From 40f56176c517d9b5e0d3da8cc06d3ccde6b58cc2 Mon Sep 17 00:00:00 2001
From: Andy Patterson <ajpatter@uwaterloo.ca>
Date: Mon, 3 Apr 2017 09:01:30 -0400
Subject: build-system/asdf: Handle unusually-named systems.

* guix/build/lisp-utils.scm (valid-char-set): New variable.
(normalize-string): New procedure.
(compiled-system): Truncate the name of a system which contains slashes.
(generate-system-definition, make-asd-file): Use `normalize-string' to alter
the names of the created system and its dependencies.
* guix/build/asdf-build-system.scm (create-asd-file): Normalize the name of
the asd file being created.
---
 guix/build/asdf-build-system.scm |  6 ++++--
 guix/build/lisp-utils.scm        | 36 ++++++++++++++++++++++++------------
 2 files changed, 28 insertions(+), 14 deletions(-)

(limited to 'guix/build')

diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm
index 4f3fc162ff..fd4d84dfa0 100644
--- a/guix/build/asdf-build-system.scm
+++ b/guix/build/asdf-build-system.scm
@@ -153,8 +153,10 @@ valid."
   (let*-values (((out) (library-output outputs))
                 ((_ version) (package-name->name+version
                               (strip-store-file-name out)))
-                ((new-asd-file) (string-append (library-directory out)
-                                               "/" asd-system-name ".asd")))
+                ((new-asd-file) (string-append
+                                 (library-directory out)
+                                 "/" (normalize-string asd-system-name)
+                                 ".asd")))
 
     (make-asd-file new-asd-file
                    #:system asd-system-name
diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm
index 3f7a6f77c1..c48f51c982 100644
--- a/guix/build/lisp-utils.scm
+++ b/guix/build/lisp-utils.scm
@@ -40,7 +40,9 @@
             prepend-to-source-registry
             build-program
             build-image
-            make-asd-file))
+            make-asd-file
+            valid-char-set
+            normalize-string))
 
 ;;; Commentary:
 ;;;
@@ -65,6 +67,15 @@
 (define (%bundle-install-prefix)
   (string-append %source-install-prefix "/" (%lisp-type) "-bundle-systems"))
 
+;; See nix/libstore/store-api.cc#checkStoreName.
+(define valid-char-set
+  (string->char-set
+   "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+-._?="))
+
+(define (normalize-string str)
+  "Replace invalid characters in STR with a hyphen."
+  (string-join (string-tokenize str valid-char-set) "-"))
+
 (define (inputs->asd-file-map inputs)
   "Produce a hash table of the form (system . asd-file), where system is the
 name of an ASD system, and asd-file is the full path to its definition."
@@ -161,14 +172,15 @@ asdf:system-depends-on.  First load the system's ASD-FILE."
         (delete-file deps-file)))))
 
 (define (compiled-system system)
-  (match (%lisp-type)
-    ("sbcl" (string-append system "--system"))
-    (_ system)))
+  (let ((system (basename system))) ; this is how asdf handles slashes
+    (match (%lisp-type)
+      ("sbcl" (string-append system "--system"))
+      (_ system))))
 
 (define* (generate-system-definition system
                                      #:key version dependencies)
   `(asdf:defsystem
-    ,system
+    ,(normalize-string system)
     :class asdf/bundle:prebuilt-system
     :version ,version
     :depends-on ,dependencies
@@ -261,20 +273,20 @@ to locate its dependent systems."
   "Create an ASD-FILE for SYSTEM@VERSION, appending a program to allow the
 system to find its dependencies, as described by GENERATE-DEPENDENCY-LINKS."
   (define dependencies
-    (system-dependencies system system-asd-file))
+    (let ((deps
+           (system-dependencies system system-asd-file)))
+      (if (eq? 'NIL deps)
+          '()
+          (map normalize-string deps))))
 
   (define lisp-input-map
     (inputs->asd-file-map inputs))
 
   (define registry
     (filter-map hash-get-handle
-                (make-list (if (eq? 'NIL dependencies)
-                               0
-                               (length dependencies))
+                (make-list (length dependencies)
                            lisp-input-map)
-                (if (eq? 'NIL dependencies)
-                    '()
-                    dependencies)))
+                dependencies))
 
   (call-with-output-file asd-file
     (lambda (port)
-- 
cgit v1.2.3