From 36bbbbd150f75c2a6dab2473643c3723e606e41d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Fri, 21 Feb 2014 23:03:19 +0100
Subject: 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'.
---
 tests/derivations.scm | 70 +++++++++++++++++++++++++++++++++++++++++++++++++--
 1 file changed, 68 insertions(+), 2 deletions(-)

(limited to 'tests/derivations.scm')

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)))
-- 
cgit v1.2.3