summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-09-06 15:45:32 +0200
committerLudovic Courtès <ludo@gnu.org>2014-09-06 23:42:56 +0200
commitb53833b2ef36cf139f65193bec688396a734b0d0 (patch)
tree36869e74c9147a95fb7ad3e8dea9bc65216dc093
parent108293c5ea65502e351cb2f6682668d5d345dd1f (diff)
downloadpatches-b53833b2ef36cf139f65193bec688396a734b0d0.tar
patches-b53833b2ef36cf139f65193bec688396a734b0d0.tar.gz
gexp: Allow use of high-level objects in #:references-graphs.
* guix/gexp.scm (lower-reference-graphs): New procedure. (gexp->derivation)[graphs-file-names]: New procedure. Use 'lower-reference-graphs', and augment #:inputs argument as a function of #:references-graphs. * doc/guix.texi (G-Expressions): Adjust 'gexp->derivation' documentation accordingly. * tests/gexp.scm ("gexp->derivation, store copy"): Remove reference to TWO in BUILD-DRV. Use TWO directly in #:references-graphs argument. ("gexp->derivation #:references-graphs"): New test. * gnu/system/vm.scm (qemu-image): Remove variable 'graph'; use INPUTS as the #:references-graphs argument to 'expression->derivation-in-linux-vm'.
-rw-r--r--doc/guix.texi16
-rw-r--r--gnu/system/vm.scm82
-rw-r--r--guix/gexp.scm51
-rw-r--r--tests/gexp.scm52
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"))