derivations: Add support for recursive fixed-output derivations.

* guix/derivations.scm (<derivation-output>): Add 'recursive?' field.
  Adjust 'make-derivation-output' callers.
  (%read-derivation) <fixed-output>: When HASH-ALGO starts with 'r:',
  set the 'recursive?' field and drop 'r:' from the hash algo name.
  (write-derivation)[write-output]: Write the algo as 'r:HASH-ALGO' when
  the RECURSIVE? field is set.
  (derivation-hash) <fixed-output>: Prepend "r:" when RECURSIVE? is set.
  (fixed-output-path): New procedure.
  (derivation): Add #:recursive? parameter.  Use 'fixed-output-path' to
  compute the output file name of a fixed output derivation.
  (build-expression->derivation): Add #:recursive? parameter.  Pass it
  to 'derivation'.
* tests/derivations.scm ("fixed-output derivation, recursive",
  "build-expression->derivation produces recursive fixed-output",
  "build-expression->derivation uses recursive fixed-output"): New
  tests.
* doc/guix.texi (Derivations): Document #:recursive? for 'derivation'.
  Add #:recursive? for 'build-expression->derivation'.

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)))