derivations: Add #:dependency-graphs `derivation' parameter.

* guix/derivations.scm (derivation): Add `dependency-graphs' keyword
  parameter; honor it.
* tests/derivations.scm (bootstrap-binary): New procedure.
  (%bash): Use it.
  (%mkdir): New variable.
  (directory-contents): Add `slurp' optional parameter.
  ("derivation with #:dependency-graphs"): New test.
* doc/guix.texi (Derivations): Update accordingly.

3 files changed, 91 insertions, 12 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index c82d5f7480..86912ecabf 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -1113,13 +1113,18 @@ derivations as Scheme objects, along with procedures to create and
 otherwise manipulate derivations.  The lowest-level primitive to create
 a derivation is the @code{derivation} procedure:
 
-@deffn {Scheme Procedure} derivation @var{store} @var{name} @var{builder} @var{args} [#:outputs '("out")] [#:hash #f] [#:hash-algo #f] [#:hash-mode #f] [#:inputs '()] [#:env-vars '()] [#:system (%current-system)]
+@deffn {Scheme Procedure} derivation @var{store} @var{name} @var{builder} @var{args} [#:outputs '("out")] [#:hash #f] [#:hash-algo #f] [#:hash-mode #f] [#:inputs '()] [#:env-vars '()] [#:system (%current-system)] [#:dependency-graphs #f]
 Build a derivation with the given arguments.  Return the resulting store
 path and @code{<derivation>} object.
 
 When @var{hash}, @var{hash-algo}, and @var{hash-mode} are given, a
 @dfn{fixed-output derivation} is created---i.e., one whose result is
 known in advance, such as a file download.
+
+When @var{dependency-graphs} is true, it must be a list of file
+name/store path pairs.  In that case, the reference graph of each store
+path is exported in the build environment in the corresponding file, in
+a simple text format.
 @end deffn
 
 @noindent
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 3d7a30aaa8..fea9984370 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -501,11 +501,16 @@ the derivation called NAME with hash HASH."
                      #:key
                      (system (%current-system)) (env-vars '())
                      (inputs '()) (outputs '("out"))
-                     hash hash-algo hash-mode)
+                     hash hash-algo hash-mode
+                     dependency-graphs)
   "Build a derivation with the given arguments.  Return the resulting
 store path and <derivation> object.  When HASH, HASH-ALGO, and HASH-MODE
 are given, a fixed-output derivation is created---i.e., one whose result is
-known in advance, such as a file download."
+known in advance, such as a file download.
+
+When DEPENDENCY-GRAPHS is true, it must be a list of file name/store path
+pairs.  In that case, the reference graph of each store path is exported in
+the build environment in the corresponding file, in a simple text format."
   (define direct-store-path?
     (let ((len (+ 1 (string-length (%store-prefix)))))
       (lambda (p)
@@ -540,7 +545,22 @@ known in advance, such as a file download."
                                            value))))
                                env-vars))))))
 
-  (define (env-vars-with-empty-outputs)
+  (define (user+system-env-vars)
+    ;; Some options are passed to the build daemon via the env. vars of
+    ;; derivations (urgh!).  We hide that from our API, but here is the place
+    ;; where we kludgify those options.
+    (match dependency-graphs
+      (((file . path) ...)
+       (let ((value (map (cut string-append <> " " <>)
+                         file path)))
+         ;; XXX: This all breaks down if an element of FILE or PATH contains
+         ;; white space.
+         `(("exportReferencesGraph" . ,(string-join value " "))
+           ,@env-vars)))
+      (#f
+       env-vars)))
+
+  (define (env-vars-with-empty-outputs env-vars)
     ;; Return a variant of ENV-VARS where each OUTPUTS is associated with an
     ;; empty string, even outputs that do not appear in ENV-VARS.
     (let ((e (map (match-lambda
@@ -572,7 +592,7 @@ known in advance, such as a file download."
                                                       #t "sha256" input)))
                               (make-derivation-input path '()))))
                           (delete-duplicates inputs)))
-         (env-vars   (env-vars-with-empty-outputs))
+         (env-vars   (env-vars-with-empty-outputs (user+system-env-vars)))
          (drv-masked (make-derivation outputs
                                       (filter (compose derivation-path?
                                                        derivation-input-path)
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 9833e15112..9b3d92a7bf 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -50,19 +50,23 @@
   (let ((drv (package-derivation %store %bootstrap-guile)))
     (%guile-for-build drv)))
 
-(define %bash
-  (let ((bash (search-bootstrap-binary "bash" (%current-system))))
+(define (bootstrap-binary name)
+  (let ((bin (search-bootstrap-binary name (%current-system))))
     (and %store
-         (add-to-store %store "bash" #t "sha256" bash))))
+         (add-to-store %store name #t "sha256" bin))))
+
+(define %bash
+  (bootstrap-binary "bash"))
+(define %mkdir
+  (bootstrap-binary "mkdir"))
 
-(define (directory-contents dir)
+(define* (directory-contents dir #:optional (slurp get-bytevector-all))
   "Return an alist representing the contents of DIR."
   (define prefix-len (string-length dir))
   (sort (file-system-fold (const #t)                   ; enter?
                           (lambda (path stat result)   ; leaf
                             (alist-cons (string-drop path prefix-len)
-                                        (call-with-input-file path
-                                          get-bytevector-all)
+                                        (call-with-input-file path slurp)
                                         result))
                           (lambda (path stat result) result)      ; down
                           (lambda (path stat result) result)      ; up
@@ -84,7 +88,7 @@
     (and (equal? b1 b2)
          (equal? d1 d2))))
 
-(test-skip (if %store 0 11))
+(test-skip (if %store 0 12))
 
 (test-assert "add-to-store, flat"
   (let* ((file (search-path %load-path "language/tree-il/spec.scm"))
@@ -292,6 +296,56 @@
            (and (valid-path? %store p)
                 (equal? '(one two) (call-with-input-file p read)))))))
 
+(test-assert "derivation with #:dependency-graphs"
+  (let* ((input1  (add-text-to-store %store "foo" "hello"
+                                     (list %bash)))
+         (input2  (add-text-to-store %store "bar"
+                                     (number->string (random 7777))
+                                     (list input1)))
+         (builder (add-text-to-store %store "build-graph"
+                                     (format #f "
+~a $out
+ (while read l ; do echo $l ; done) < bash > $out/bash
+ (while read l ; do echo $l ; done) < input1 > $out/input1
+ (while read l ; do echo $l ; done) < input2 > $out/input2"
+                                             %mkdir)
+                                     (list %mkdir)))
+         (drv     (derivation %store "closure-graphs"
+                              %bash `(,builder)
+                              #:dependency-graphs
+                              `(("bash" . ,%bash)
+                                ("input1" . ,input1)
+                                ("input2" . ,input2))
+                              #:inputs `((,%bash) (,builder))))
+         (out     (derivation-path->output-path drv)))
+    (define (deps path . deps)
+      (let ((count (length deps)))
+        (string-append path "\n\n" (number->string count) "\n"
+                       (string-join (sort deps string<?) "\n")
+                       (if (zero? count) "" "\n"))))
+
+    (and (build-derivations %store (list drv))
+         (equal? (directory-contents out get-string-all)
+                 `(("/bash"   . ,(string-append %bash "\n\n0\n"))
+                   ("/input1" . ,(if (string>? input1 %bash)
+                                     (string-append (deps %bash)
+                                                    (deps input1 %bash))
+                                     (string-append (deps input1 %bash)
+                                                    (deps %bash))))
+                   ("/input2" . ,(string-concatenate
+                                  (map cdr
+                                       (sort
+                                        (map (lambda (p d)
+                                               (cons p (apply deps p d)))
+                                             (list %bash input1 input2)
+                                             (list '() (list %bash) (list input1)))
+                                        (lambda (x y)
+                                          (match x
+                                            ((p1 . _)
+                                             (match y
+                                               ((p2 . _)
+                                                (string<? p1 p2)))))))))))))))
+
 
 (define %coreutils
   (false-if-exception