diff options
| -rw-r--r-- | doc/guix.texi | 16 | ||||
| -rw-r--r-- | gnu/system/vm.scm | 82 | ||||
| -rw-r--r-- | guix/gexp.scm | 51 | ||||
| -rw-r--r-- | tests/gexp.scm | 52 |
4 files changed, 148 insertions, 53 deletions
diff --git a/doc/guix.texi b/doc/guix.texi index 1f192bf0a7..e0251f5ffd 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -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 diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm index 624f2a680a..205bf2cb19 100644 --- a/gnu/system/vm.scm +++ b/gnu/system/vm.scm @@ -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)) ;;; diff --git a/guix/gexp.scm b/guix/gexp.scm index e31324e101..5401cbf96f 100644 --- a/guix/gexp.scm +++ b/guix/gexp.scm @@ -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)) diff --git a/tests/gexp.scm b/tests/gexp.scm index a08164c484..ea4df48403 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -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")) |