Add `imported-files'.

* guix/derivations.scm (imported-files): New procedure.
  (build-expression->derivation): Correctly handle inputs that are
  sources and not derivation paths.

* tests/derivations.scm ("imported-files"): New test.

2 files changed, 70 insertions, 4 deletions

diff --git a/guix/derivations.scm b/guix/derivations.scm
index b5e3db2d21..c35595fd1e 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -52,7 +52,8 @@
             derivation
 
             %guile-for-build
-            build-expression->derivation))
+            build-expression->derivation
+            imported-files))
 
 ;;;
 ;;; Nix derivations, as implemented in Nix's `derivations.cc'.
@@ -372,6 +373,51 @@ known in advance, such as a file download."
   ;; when using `build-expression->derivation'.
   (make-parameter (false-if-exception (nixpkgs-derivation "guile"))))
 
+(define* (imported-files store files
+                         #:key (name "file-import") (system (%current-system)))
+  "Return a derivation that imports FILES into STORE.  FILES must be a list
+of (FINAL-PATH . FILE-NAME) pairs; each FILE-NAME is read from the file
+system, imported, and appears under FINAL-PATH in the resulting store path."
+  (define (parent-dirs file-name)
+    ;; Return the list of parent dirs of FILE-NAME, in the order in which an
+    ;; `mkdir -p' implementation would make them.
+    (let ((not-slash (char-set-complement (char-set #\/))))
+      (reverse
+       (fold (lambda (dir result)
+               (match result
+                 (()
+                  (list dir))
+                 ((prev _ ...)
+                  (cons (string-append prev "/" dir)
+                        result))))
+             '()
+             (remove (cut string=? <> ".")
+                     (string-tokenize (dirname file-name) not-slash))))))
+
+  (let* ((files   (map (match-lambda
+                        ((final-path . file-name)
+                         (cons final-path
+                               (add-to-store store (basename final-path) #t #f
+                                             "sha256" file-name))))
+                       files))
+         (builder
+          `(begin
+             (mkdir %output) (chdir %output)
+             ,@(append-map (match-lambda
+                            ((final-path . store-path)
+                             (append (match (parent-dirs final-path)
+                                       (() '())
+                                       ((head ... tail)
+                                        (append (map (lambda (d)
+                                                       `(false-if-exception
+                                                         (mkdir ,d)))
+                                                     head)
+                                                `((mkdir ,tail)))))
+                                     `((symlink ,store-path ,final-path)))))
+                           files))))
+    (build-expression->derivation store name (%current-system)
+                                  builder files)))
+
 (define* (build-expression->derivation store name system exp inputs
                                        #:key (outputs '("out"))
                                        hash hash-algo)
@@ -395,7 +441,9 @@ INPUTS."
                         ',(map (match-lambda
                                 ((name . drv)
                                  (cons name
-                                       (derivation-path->output-path drv))))
+                                       (if (derivation-path? drv)
+                                           (derivation-path->output-path drv)
+                                           drv))))
                                inputs))) )
          (builder  (add-text-to-store store
                                       (string-append name "-guile-builder")
diff --git a/tests/derivations.scm b/tests/derivations.scm
index ec48f44420..1a85639930 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -24,11 +24,13 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-64)
   #:use-module (rnrs io ports)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 rdelim)
-  #:use-module (ice-9 ftw))
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 match))
 
 (define %store
   (false-if-exception (open-connection)))
@@ -156,7 +158,7 @@
          (let ((p (derivation-path->output-path drv-path)))
            (file-exists? (string-append p "/good"))))))
 
-(test-skip (if (%guile-for-build) 0 2))
+(test-skip (if (%guile-for-build) 0 4))
 
 (test-assert "build-expression->derivation without inputs"
   (let* ((builder    '(begin
@@ -208,6 +210,22 @@
          (let ((p (derivation-path->output-path drv-path)))
            (string-contains (call-with-input-file p read-line) "GNU")))))
 
+(test-assert "imported-files"
+  (let* ((files    `(("x"     . ,(search-path %load-path "ice-9/q.scm"))
+                     ("a/b/c" . ,(search-path %load-path
+                                              "guix/derivations.scm"))
+                     ("p/q"   . ,(search-path %load-path "guix.scm"))))
+         (drv-path (imported-files %store files)))
+    (and (build-derivations %store (list drv-path))
+         (let ((dir (derivation-path->output-path drv-path)))
+           (every (match-lambda
+                   ((path . source)
+                    (equal? (call-with-input-file (string-append dir "/" path)
+                              get-bytevector-all)
+                            (call-with-input-file source
+                              get-bytevector-all))))
+                  files)))))
+
 (test-skip (if (false-if-exception (getaddrinfo "ftp.gnu.org" "http"))
                0
                1))