Allow derivations with input derivations.

* guix/derivations.scm (derivation-path->output-path): New procedure.
  (derivation-hash): Call `memoize'.  In the fixed-output case, convert
  HASH-ALGO to a string.  In the other case, sort inputs in the
  alphabetical order of their hex hash.  For inputs with no sub-drvs,
  add "out" as the sub-drv.

* guix/utils.scm (%nixpkgs-directory): New parameter.
  (nixpkgs-derivation, memoize): New procedures.

* tests/derivations.scm ("build derivation with 1 source"): Remove
  useless shebang.
  (%coreutils): New variable.
  ("build derivation with coreutils"): New test.

3 files changed, 125 insertions, 30 deletions

diff --git a/guix/derivations.scm b/guix/derivations.scm
index 151bff7215..09f58f0fb8 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -48,6 +48,7 @@
 
             read-derivation
             write-derivation
+            derivation-path->output-path
             derivation))
 
 ;;;
@@ -186,6 +187,18 @@ that form."
                       env-vars))
      (display ")" port))))
 
+(define* (derivation-path->output-path path #:optional (output "out"))
+  "Read the derivation from PATH (`/nix/store/xxx.drv'), and return the store
+path of its output OUTPUT."
+  (let* ((drv     (call-with-input-file path read-derivation))
+         (outputs (derivation-outputs drv)))
+    (and=> (assoc-ref outputs output) derivation-output-path)))
+
+
+;;;
+;;; Derivation primitive.
+;;;
+
 (define (compressed-hash bv size)                 ; `compressHash'
   "Given the hash stored in BV, return a compressed version thereof that fits
 in SIZE bytes."
@@ -200,33 +213,41 @@ in SIZE bytes."
                               (logxor o (bytevector-u8-ref bv i)))
           (loop (+ 1 i))))))
 
-(define (derivation-hash drv)      ; `hashDerivationModulo' in derivations.cc
-  "Return the hash of DRV, modulo its fixed-output inputs, as a bytevector."
-  (match drv
-    (($ <derivation> ((_ . ($ <derivation-output> path
-                              (? symbol? hash-algo) (? string? hash)))))
-     ;; A fixed-output derivation.
-     (sha256
-      (string->utf8
-       (string-append "fixed:out:" hash-algo ":" hash ":" path))))
-    (($ <derivation> outputs inputs sources
-        system builder args env-vars)
-     ;; A regular derivation: replace the path of each input with that
-     ;; input's hash; return the hash of serialization of the resulting
-     ;; derivation.
-     (let* ((inputs (map (match-lambda
-                          (($ <derivation-input> path sub-drvs)
-                           (let ((hash (call-with-input-file path
-                                         (compose bytevector->base16-string
-                                                  derivation-hash
-                                                  read-derivation))))
-                             (make-derivation-input hash sub-drvs))))
-                         inputs))
-            (drv     (make-derivation outputs inputs sources
-                                      system builder args env-vars)))
+(define derivation-hash            ; `hashDerivationModulo' in derivations.cc
+  (memoize
+   (lambda (drv)
+    "Return the hash of DRV, modulo its fixed-output inputs, as a bytevector."
+    (match drv
+      (($ <derivation> ((_ . ($ <derivation-output> path
+                                (? symbol? hash-algo) (? string? hash)))))
+       ;; A fixed-output derivation.
        (sha256
-        (string->utf8 (call-with-output-string
-                       (cut write-derivation drv <>))))))))
+        (string->utf8
+         (string-append "fixed:out:" (symbol->string hash-algo)
+                        ":" hash ":" path))))
+      (($ <derivation> outputs inputs sources
+          system builder args env-vars)
+       ;; A regular derivation: replace the path of each input with that
+       ;; input's hash; return the hash of serialization of the resulting
+       ;; derivation.  Note: inputs are sorted as in the order of their hex
+       ;; hash representation because that's what the C++ `std::map' code
+       ;; does.
+       (let* ((inputs (sort (map (match-lambda
+                                  (($ <derivation-input> path sub-drvs)
+                                   (let ((hash (call-with-input-file path
+                                                 (compose bytevector->base16-string
+                                                          derivation-hash
+                                                          read-derivation))))
+                                     (make-derivation-input hash sub-drvs))))
+                                 inputs)
+                            (lambda (i1 i2)
+                              (string<? (derivation-input-path i1)
+                                        (derivation-input-path i2)))))
+              (drv    (make-derivation outputs inputs sources
+                                       system builder args env-vars)))
+         (sha256
+          (string->utf8 (call-with-output-string
+                         (cut write-derivation drv <>))))))))))
 
 (define (store-path type hash name)               ; makeStorePath
   "Return the store path for NAME/HASH/TYPE."
@@ -300,7 +321,9 @@ known in advance, such as a file download."
                                   (make-derivation-output "" hash-algo hash)))
                           outputs))
          (inputs     (map (match-lambda
-                           (((? store-path? input) . sub-drvs)
+                           (((? store-path? input))
+                            (make-derivation-input input '("out")))
+                           (((? store-path? input) sub-drvs ...)
                             (make-derivation-input input sub-drvs))
                            ((input . _)
                             (let ((path (add-to-store store
@@ -321,6 +344,7 @@ known in advance, such as a file download."
                                                   inputs)
                                       system builder args env-vars))
          (drv        (add-output-paths drv-masked)))
+
     (values (add-text-to-store store (string-append name ".drv")
                                (call-with-output-string
                                 (cut write-derivation drv <>))
diff --git a/guix/utils.scm b/guix/utils.scm
index a5f64f97a9..2ffecbfab9 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -19,9 +19,12 @@
 (define-module (guix utils)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-39)
   #:use-module (srfi srfi-60)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 format)
+  #:autoload   (ice-9 popen)  (open-pipe*)
+  #:autoload   (ice-9 rdelim) (read-line)
   #:use-module ((chop hash)
                 #:select (bytevector-hash
                           hash-method/sha256))
@@ -29,7 +32,12 @@
             bytevector->base32-string
             bytevector->nix-base32-string
             bytevector->base16-string
-            sha256))
+            sha256
+
+            %nixpkgs-directory
+            nixpkgs-derivation
+
+            memoize))
 
 
 ;;;
@@ -198,3 +206,39 @@ the previous application or INIT."
   "Return the SHA256 of BV as a bytevector."
   (bytevector-hash hash-method/sha256 bv))
 
+
+
+;;;
+;;; Nixpkgs.
+;;;
+
+(define %nixpkgs-directory
+  (make-parameter (getenv "NIXPKGS")))
+
+(define (nixpkgs-derivation attribute)
+  "Return the derivation path of ATTRIBUTE in Nixpkgs."
+  (let* ((p (open-pipe* OPEN_READ "nix-instantiate" "-A"
+                        attribute (%nixpkgs-directory)))
+         (l (read-line p))
+         (s (close-pipe p)))
+    (and (zero? (status:exit-val s))
+         (not (eof-object? l))
+         l)))
+
+
+;;;
+;;; Miscellaneous.
+;;;
+
+(define (memoize proc)
+  "Return a memoizing version of PROC."
+  (let ((cache (make-hash-table)))
+    (lambda args
+      (let ((results (hash-ref cache args)))
+        (if results
+            (apply values results)
+            (let ((results (call-with-values (lambda ()
+                                               (apply proc args))
+                             list)))
+              (hash-set! cache args results)
+              (apply values results)))))))
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 64bc678828..f2a3bb2d55 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -20,6 +20,7 @@
 (define-module (test-derivations)
   #:use-module (guix derivations)
   #:use-module (guix store)
+  #:use-module (guix utils)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-64)
@@ -40,7 +41,7 @@
     (and (equal? b1 b2)
          (equal? d1 d2))))
 
-(test-skip (if %store 0 2))
+(test-skip (if %store 0 3))
 
 (test-assert "derivation with no inputs"
   (let ((builder (add-text-to-store %store "my-builder.sh"
@@ -52,7 +53,7 @@
 (test-assert "build derivation with 1 source"
   (let*-values (((builder)
                  (add-text-to-store %store "my-builder.sh"
-                                    "#!/bin/sh\necho hello, world > \"$out\"\n"
+                                    "echo hello, world > \"$out\"\n"
                                     '()))
                 ((drv-path drv)
                  (derivation %store "foo" "x86_64-linux"
@@ -67,6 +68,32 @@
            (string=? (call-with-input-file path read-line)
                      "hello, world")))))
 
+
+(define %coreutils
+  (false-if-exception (nixpkgs-derivation "coreutils")))
+
+(test-skip (if %coreutils 0 1))
+
+(test-assert "build derivation with coreutils"
+  (let* ((builder
+          (add-text-to-store %store "build-with-coreutils.sh"
+                             "echo $PATH ; mkdir --version ; mkdir $out ; touch $out/good"
+                             '()))
+         (drv-path
+          (derivation %store "foo" "x86_64-linux"
+                      "/bin/sh" `(,builder)
+                      `(("PATH" .
+                         ,(string-append
+                           (derivation-path->output-path %coreutils)
+                           "/bin")))
+                      `((,builder)
+                        (,%coreutils))))
+         (succeeded?
+          (build-derivations %store (list drv-path))))
+    (and succeeded?
+         (let ((p (derivation-path->output-path drv-path)))
+           (file-exists? (string-append p "/good"))))))
+
 (test-end)