diff options
| -rw-r--r-- | doc/guix.texi | 9 | ||||
| -rw-r--r-- | guix/derivations.scm | 71 | ||||
| -rw-r--r-- | tests/derivations.scm | 70 |
3 files changed, 127 insertions, 23 deletions
diff --git a/doc/guix.texi b/doc/guix.texi index ce011959ad..b2733fbec9 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -1478,7 +1478,7 @@ 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 '()] @ + [#:recursive? #f] [#:hash-mode #f] [#:inputs '()] [#:env-vars '()] @ [#:system (%current-system)] [#:references-graphs #f] @ [#:local-build? #f] Build a derivation with the given arguments, and return the resulting @@ -1486,7 +1486,10 @@ Build a derivation with the given arguments, and return the resulting 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. +known in advance, such as a file download. If, in addition, +@var{recursive?} is true, then that fixed output may be an executable +file or a directory and @var{hash} must be the hash of an archive +containing this output. When @var{references-graphs} is true, it must be a list of file name/store path pairs. In that case, the reference graph of each store @@ -1526,7 +1529,7 @@ the caller to directly pass a Guile expression as the build script: @var{name} @var{exp} @ [#:system (%current-system)] [#:inputs '()] @ [#:outputs '("out")] [#:hash #f] [#:hash-algo #f] @ - [#:env-vars '()] [#:modules '()] @ + [#:recursive? #f] [#:env-vars '()] [#:modules '()] @ [#:references-graphs #f] [#:local-build? #f] [#:guile-for-build #f] Return a derivation that executes Scheme expression @var{exp} as a builder for derivation @var{name}. @var{inputs} must be a list of diff --git a/guix/derivations.scm b/guix/derivations.scm index cc8e37c973..4f060a6aa2 100644 --- a/guix/derivations.scm +++ b/guix/derivations.scm @@ -47,6 +47,7 @@ derivation-output-path derivation-output-hash-algo derivation-output-hash + derivation-output-recursive? <derivation-input> derivation-input? @@ -91,11 +92,12 @@ (file-name derivation-file-name)) ; the .drv file name (define-record-type <derivation-output> - (make-derivation-output path hash-algo hash) + (make-derivation-output path hash-algo hash recursive?) derivation-output? (path derivation-output-path) ; store path (hash-algo derivation-output-hash-algo) ; symbol | #f - (hash derivation-output-hash)) ; bytevector | #f + (hash derivation-output-hash) ; bytevector | #f + (recursive? derivation-output-recursive?)) ; Boolean (define-record-type <derivation-input> (make-derivation-input path sub-derivations) @@ -241,14 +243,19 @@ that second value is the empty list." (match output ((name path "" "") (alist-cons name - (make-derivation-output path #f #f) + (make-derivation-output path #f #f #f) result)) ((name path hash-algo hash) ;; fixed-output - (let ((algo (string->symbol hash-algo)) - (hash (base16-string->bytevector hash))) + (let* ((rec? (string-prefix? "r:" hash-algo)) + (algo (string->symbol + (if rec? + (string-drop hash-algo 2) + hash-algo))) + (hash (base16-string->bytevector hash))) (alist-cons name - (make-derivation-output path algo hash) + (make-derivation-output path algo + hash rec?) result))))) '() x)) @@ -368,9 +375,12 @@ that form." (define (write-output output port) (match output - ((name . ($ <derivation-output> path hash-algo hash)) + ((name . ($ <derivation-output> path hash-algo hash recursive?)) (write-tuple (list name path - (or (and=> hash-algo symbol->string) "") + (if hash-algo + (string-append (if recursive? "r:" "") + (symbol->string hash-algo)) + "") (or (and=> hash bytevector->base16-string) "")) write @@ -476,11 +486,14 @@ in SIZE bytes." "Return the hash of DRV, modulo its fixed-output inputs, as a bytevector." (match drv (($ <derivation> ((_ . ($ <derivation-output> path - (? symbol? hash-algo) (? bytevector? hash))))) + (? symbol? hash-algo) (? bytevector? hash) + (? boolean? recursive?))))) ;; A fixed-output derivation. (sha256 (string->utf8 - (string-append "fixed:out:" (symbol->string hash-algo) + (string-append "fixed:out:" + (if recursive? "r:" "") + (symbol->string hash-algo) ":" (bytevector->base16-string hash) ":" path)))) (($ <derivation> outputs inputs sources @@ -527,17 +540,33 @@ the derivation called NAME with hash HASH." name (string-append name "-" output)))) +(define (fixed-output-path output hash-algo hash recursive? name) + "Return an output path for the fixed output OUTPUT defined by HASH of type +HASH-ALGO, of the derivation NAME. RECURSIVE? has the same meaning as for +'add-to-store'." + (if (and recursive? (eq? hash-algo 'sha256)) + (store-path "source" hash name) + (let ((tag (string-append "fixed:" output ":" + (if recursive? "r:" "") + (symbol->string hash-algo) ":" + (bytevector->base16-string hash) ":"))) + (store-path (string-append "output:" output) + (sha256 (string->utf8 tag)) + name)))) + (define* (derivation store name builder args #:key (system (%current-system)) (env-vars '()) (inputs '()) (outputs '("out")) - hash hash-algo hash-mode + hash hash-algo hash-mode recursive? references-graphs local-build?) "Build a derivation with the given arguments, and return the resulting <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. +advance, such as a file download. If, in addition, RECURSIVE? is true, then +that fixed output may be an executable file or a directory and HASH must be +the hash of an archive containing this output. When REFERENCES-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 @@ -555,12 +584,16 @@ derivations where the costs of data transfers would outweigh the benefits." (let* ((drv-hash (derivation-hash drv)) (outputs (map (match-lambda ((output-name . ($ <derivation-output> - _ algo hash)) - (let ((path (output-path output-name - drv-hash name))) + _ algo hash rec?)) + (let ((path (if hash + (fixed-output-path output-name + algo hash + rec? name) + (output-path output-name + drv-hash name)))) (cons output-name (make-derivation-output path algo - hash))))) + hash rec?))))) outputs))) (make-derivation outputs inputs sources system builder args (map (match-lambda @@ -618,7 +651,8 @@ derivations where the costs of data transfers would outweigh the benefits." (let* ((outputs (map (lambda (name) ;; Return outputs with an empty path. (cons name - (make-derivation-output "" hash-algo hash))) + (make-derivation-output "" hash-algo + hash recursive?))) outputs)) (inputs (map (match-lambda (((? derivation? drv)) @@ -909,7 +943,7 @@ they can refer to each other." (system (%current-system)) (inputs '()) (outputs '("out")) - hash hash-algo + hash hash-algo recursive? (env-vars '()) (modules '()) guile-for-build @@ -1056,6 +1090,7 @@ LOCAL-BUILD?." env-vars) #:hash hash #:hash-algo hash-algo + #:recursive? recursive? #:outputs outputs #:references-graphs references-graphs #:local-build? local-build?))) diff --git a/tests/derivations.scm b/tests/derivations.scm index f7cedde505..f31b00b8a2 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -23,7 +23,8 @@ #:use-module (guix utils) #:use-module (guix hash) #:use-module (guix base32) - #:use-module ((guix packages) #:select (package-derivation)) + #:use-module ((guix packages) #:select (package-derivation base32)) + #:use-module ((guix build utils) #:select (executable-file?)) #:use-module ((gnu packages) #:select (search-bootstrap-binary)) #:use-module (gnu packages bootstrap) #:use-module ((gnu packages guile) #:select (guile-1.8)) @@ -190,6 +191,23 @@ (equal? (derivation->output-path drv1) (derivation->output-path drv2))))) +(test-assert "fixed-output derivation, recursive" + (let* ((builder (add-text-to-store %store "my-fixed-builder.sh" + "echo -n hello > $out" '())) + (hash (sha256 (string->utf8 "hello"))) + (drv (derivation %store "fixed-rec" + %bash `(,builder) + #:inputs `((,builder)) + #:hash (base32 "0sg9f58l1jj88w6pdrfdpj5x9b1zrwszk84j81zvby36q9whhhqa") + #:hash-algo 'sha256 + #:recursive? #t)) + (succeeded? (build-derivations %store (list drv)))) + (and succeeded? + (let ((p (derivation->output-path drv))) + (and (equal? (string->utf8 "hello") + (call-with-input-file p get-bytevector-all)) + (bytevector? (query-path-hash %store p))))))) + (test-assert "derivation with a fixed-output input" ;; A derivation D using a fixed-output derivation F doesn't has the same ;; output path when passed F or F', as long as F and F' have the same output @@ -637,6 +655,54 @@ Deriver: ~a~%" (derivation-file-name final1))) (build-derivations %store (list final1 final2))))) +(test-assert "build-expression->derivation produces recursive fixed-output" + (let* ((builder '(begin + (use-modules (srfi srfi-26)) + (mkdir %output) + (chdir %output) + (call-with-output-file "exe" + (cut display "executable" <>)) + (chmod "exe" #o777) + (symlink "exe" "symlink") + (mkdir "subdir"))) + (drv (build-expression->derivation %store "fixed-rec" builder + #:hash-algo 'sha256 + #:hash (base32 + "10k1lw41wyrjf9mxydi0is5nkpynlsvgslinics4ppir13g7d74p") + #:recursive? #t))) + (and (build-derivations %store (list drv)) + (let* ((dir (derivation->output-path drv)) + (exe (string-append dir "/exe")) + (link (string-append dir "/symlink")) + (subdir (string-append dir "/subdir"))) + (and (executable-file? exe) + (string=? "executable" + (call-with-input-file exe get-string-all)) + (string=? "exe" (readlink link)) + (file-is-directory? subdir)))))) + +(test-assert "build-expression->derivation uses recursive fixed-output" + (let* ((builder '(call-with-output-file %output + (lambda (port) + (display "hello" port)))) + (fixed (build-expression->derivation %store "small-fixed-rec" + builder + #:hash-algo 'sha256 + #:hash (base32 + "0sg9f58l1jj88w6pdrfdpj5x9b1zrwszk84j81zvby36q9whhhqa") + #:recursive? #t)) + (in (derivation->output-path fixed)) + (builder `(begin + (mkdir %output) + (chdir %output) + (symlink ,in "symlink"))) + (drv (build-expression->derivation %store "fixed-rec-user" + builder + #:inputs `(("fixed" ,fixed))))) + (and (build-derivations %store (list drv)) + (let ((out (derivation->output-path drv))) + (string=? (readlink (string-append out "/symlink")) in))))) + (test-assert "build-expression->derivation with #:references-graphs" (let* ((input (add-text-to-store %store "foo" "hello" (list %bash %mkdir))) |