4 files changed, 148 insertions(+), 53 deletions(-)

M doc/guix.texi
M gnu/system/vm.scm
M guix/gexp.scm
M tests/gexp.scm

@@ 2278,6 2278,22 @@ search path to be copied in the store, compiled, and made available in
 the load path during the execution of @var{exp}---e.g., @code{((guix
 build utils) (guix build gnu-build-system))}.
 
+When @var{references-graphs} is true, it must be a list of tuples of one of the
+following forms:
+
+@example
+(@var{file-name} @var{package})
+(@var{file-name} @var{package} @var{output})
+(@var{file-name} @var{derivation})
+(@var{file-name} @var{derivation} @var{output})
+(@var{file-name} @var{store-item})
+@end example
+
+The right-hand-side of each element of @var{references-graphs} is automatically made
+an input of the build process of @var{exp}.  In the build environment, each
+@var{file-name} contains the reference graph of the corresponding item, in a simple
+text format.
+
 The other arguments are as for @code{derivation} (@pxref{Derivations}).
 @end deffn
 

@@ 219,48 219,46 @@ INPUTS is a list of inputs (as for packages).  When COPY-INPUTS? is true, copy
 all of INPUTS into the image being built.  When REGISTER-CLOSURES? is true,
 register INPUTS in the store database of the image so that Guix can be used in
 the image."
-  (mlet %store-monad
-      ((graph (sequence %store-monad (map input->name+output inputs))))
-   (expression->derivation-in-linux-vm
-    name
-    #~(begin
-        (use-modules (gnu build vm)
-                     (guix build utils))
-
-        (let ((inputs
-               '#$(append (list qemu parted grub e2fsprogs util-linux)
-                          (map canonical-package
-                               (list sed grep coreutils findutils gawk))
-                          (if register-closures? (list guix) '())))
-
-              ;; This variable is unused but allows us to add INPUTS-TO-COPY
-              ;; as inputs.
-              (to-register
-                '#$(map (match-lambda
-                         ((name thing) thing)
-                         ((name thing output) `(,thing ,output)))
-                        inputs)))
-
-          (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
-
-          (let ((graphs '#$(match inputs
-                             (((names . _) ...)
-                              names))))
-            (initialize-hard-disk "/dev/vda"
-                                  #:system-directory #$os-derivation
-                                  #:grub.cfg #$grub-configuration
-                                  #:closures graphs
-                                  #:copy-closures? #$copy-inputs?
-                                  #:register-closures? #$register-closures?
-                                  #:disk-image-size #$disk-image-size
-                                  #:file-system-type #$file-system-type
-                                  #:file-system-label #$file-system-label)
-            (reboot))))
-    #:system system
-    #:make-disk-image? #t
-    #:disk-image-size disk-image-size
-    #:disk-image-format disk-image-format
-    #:references-graphs graph)))
+  (expression->derivation-in-linux-vm
+   name
+   #~(begin
+       (use-modules (gnu build vm)
+                    (guix build utils))
+
+       (let ((inputs
+              '#$(append (list qemu parted grub e2fsprogs util-linux)
+                         (map canonical-package
+                              (list sed grep coreutils findutils gawk))
+                         (if register-closures? (list guix) '())))
+
+             ;; This variable is unused but allows us to add INPUTS-TO-COPY
+             ;; as inputs.
+             (to-register
+              '#$(map (match-lambda
+                       ((name thing) thing)
+                       ((name thing output) `(,thing ,output)))
+                      inputs)))
+
+         (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
+
+         (let ((graphs '#$(match inputs
+                            (((names . _) ...)
+                             names))))
+           (initialize-hard-disk "/dev/vda"
+                                 #:system-directory #$os-derivation
+                                 #:grub.cfg #$grub-configuration
+                                 #:closures graphs
+                                 #:copy-closures? #$copy-inputs?
+                                 #:register-closures? #$register-closures?
+                                 #:disk-image-size #$disk-image-size
+                                 #:file-system-type #$file-system-type
+                                 #:file-system-label #$file-system-label)
+           (reboot))))
+   #:system system
+   #:make-disk-image? #t
+   #:disk-image-size disk-image-size
+   #:disk-image-format disk-image-format
+   #:references-graphs inputs))
 
 
 ;;;

@@ 109,6 109,17 @@ the cross-compilation target triplet."
                      (return input)))
                    inputs))))
 
+(define* (lower-reference-graphs graphs #:key system target)
+  "Given GRAPHS, a list of (FILE-NAME INPUT ...) lists for use as a
+#:reference-graphs argument, lower it such that each INPUT is replaced by the
+corresponding derivation."
+  (match graphs
+    (((file-names . inputs) ...)
+     (mlet %store-monad ((inputs (lower-inputs inputs
+                                               #:system system
+                                               #:target target)))
+       (return (map cons file-names inputs))))))
+
 (define* (gexp->derivation name exp
                            #:key
                            system (target 'current)


@@ 127,10 138,38 @@ names of Guile modules from the current search path to be copied in the store,
 compiled, and made available in the load path during the execution of
 EXP---e.g., '((guix build utils) (guix build gnu-build-system)).
 
+When REFERENCES-GRAPHS is true, it must be a list of tuples of one of the
+following forms:
+
+  (FILE-NAME PACKAGE)
+  (FILE-NAME PACKAGE OUTPUT)
+  (FILE-NAME DERIVATION)
+  (FILE-NAME DERIVATION OUTPUT)
+  (FILE-NAME STORE-ITEM)
+
+The right-hand-side of each element of REFERENCES-GRAPHS is automatically made
+an input of the build process of EXP.  In the build environment, each
+FILE-NAME contains the reference graph of the corresponding item, in a simple
+text format.
+
+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.
+
 The other arguments are as for 'derivation'."
   (define %modules modules)
   (define outputs (gexp-outputs exp))
 
+  (define (graphs-file-names graphs)
+    ;; Return a list of (FILE-NAME . STORE-PATH) pairs made from GRAPHS.
+    (map (match-lambda
+           ((file-name (? derivation? drv))
+            (cons file-name (derivation->output-path drv)))
+           ((file-name (? derivation? drv) sub-drv)
+            (cons file-name (derivation->output-path drv sub-drv)))
+           ((file-name thing)
+            (cons file-name thing)))
+         graphs))
+
   (mlet* %store-monad (;; The following binding is here to force
                        ;; '%current-system' and '%current-target-system' to be
                        ;; looked up at >>= time.


@@ 162,6 201,11 @@ The other arguments are as for 'derivation'."
                                                        #:system system
                                                        #:guile guile-for-build)
                                      (return #f)))
+                       (graphs   (if references-graphs
+                                     (lower-reference-graphs references-graphs
+                                                             #:system system
+                                                             #:target target)
+                                     (return #f)))
                        (guile    (if guile-for-build
                                      (return guile-for-build)
                                      (package->derivation (default-guile)


@@ 182,9 226,12 @@ The other arguments are as for 'derivation'."
                                (,builder)
                                ,@(if modules
                                      `((,modules) (,compiled) ,@inputs)
-                                     inputs))
+                                     inputs)
+                               ,@(match graphs
+                                   (((_ . inputs) ...) inputs)
+                                   (_ '())))
                     #:hash hash #:hash-algo hash-algo #:recursive? recursive?
-                    #:references-graphs references-graphs
+                    #:references-graphs (and=> graphs graphs-file-names)
                     #:local-build? local-build?)))
 
 (define* (gexp-inputs exp #:optional (references gexp-references))

@@ 335,19 335,16 @@
                          (call-with-output-file (string-append #$output "/two")
                            (lambda (port)
                              (display "This is the second one." port))))))
-        (build-drv (lambda (two)
-                     #~(begin
-                         (use-modules (guix build store-copy))
+        (build-drv #~(begin
+                       (use-modules (guix build store-copy))
 
-                         (mkdir #$output)
-                         '#$two                   ;make it an input
-                         (populate-store '("graph") #$output)))))
+                       (mkdir #$output)
+                       (populate-store '("graph") #$output))))
     (mlet* %store-monad ((one (gexp->derivation "one" build-one))
                          (two (gexp->derivation "two" (build-two one)))
-                         (dir -> (derivation->output-path two))
-                         (drv (gexp->derivation "store-copy" (build-drv two)
+                         (drv (gexp->derivation "store-copy" build-drv
                                                 #:references-graphs
-                                                `(("graph" . ,dir))
+                                                `(("graph" ,two))
                                                 #:modules
                                                 '((guix build store-copy)
                                                   (guix build utils))))


@@ 362,6 359,43 @@
                      (string=? (readlink (string-append out "/" two "/one"))
                                one)))))))
 
+(test-assertm "gexp->derivation #:references-graphs"
+  (mlet* %store-monad
+      ((one (text-file "one" "hello, world"))
+       (two (gexp->derivation "two"
+                              #~(symlink #$one #$output:chbouib)))
+       (drv (gexp->derivation "ref-graphs"
+                              #~(begin
+                                  (use-modules (guix build store-copy))
+                                  (with-output-to-file #$output
+                                    (lambda ()
+                                      (write (call-with-input-file "guile"
+                                               read-reference-graph))))
+                                  (with-output-to-file #$output:one
+                                    (lambda ()
+                                      (write (call-with-input-file "one"
+                                               read-reference-graph))))
+                                  (with-output-to-file #$output:two
+                                    (lambda ()
+                                      (write (call-with-input-file "two"
+                                               read-reference-graph)))))
+                              #:references-graphs `(("one" ,one)
+                                                    ("two" ,two "chbouib")
+                                                    ("guile" ,%bootstrap-guile))
+                              #:modules '((guix build store-copy)
+                                          (guix build utils))))
+       (ok? (built-derivations (list drv)))
+       (guile-drv  (package->derivation %bootstrap-guile))
+       (g-one   -> (derivation->output-path drv "one"))
+       (g-two   -> (derivation->output-path drv "two"))
+       (g-guile -> (derivation->output-path drv)))
+    (return (and ok?
+                 (equal? (call-with-input-file g-one read) (list one))
+                 (equal? (call-with-input-file g-two read)
+                         (list one (derivation->output-path two "chbouib")))
+                 (equal? (call-with-input-file g-guile read)
+                         (list (derivation->output-path guile-drv)))))))
+
 (define shebang
   (string-append "#!" (derivation->output-path (%guile-for-build))
                  "/bin/guile --no-auto-compile"))