gnu: Add JSON-XS.
[jackhill/guix/guix.git] / tests / derivations.scm
index 4756fb9..72d253c 100644 (file)
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
 ;;; You should have received a copy of the GNU General Public License
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
-
 (define-module (test-derivations)
   #:use-module (guix derivations)
   #:use-module (guix store)
   #:use-module (guix utils)
   #:use-module (guix hash)
   #:use-module (guix base32)
-  #:use-module ((guix packages) #:select (package-derivation))
+  #:use-module (guix tests)
+  #: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))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match))
 
 (define %store
-  (false-if-exception (open-connection)))
-
-(when %store
-  ;; Make sure we build everything by ourselves.
-  (set-build-options %store #:use-substitutes? #f)
-
-  ;; By default, use %BOOTSTRAP-GUILE for the current system.
-  (let ((drv (package-derivation %store %bootstrap-guile)))
-    (%guile-for-build drv)))
+  (open-connection-for-tests))
 
 (define (bootstrap-binary name)
   (let ((bin (search-bootstrap-binary name (%current-system))))
                               #:env-vars '(("HOME" . "/homeless")
                                            ("zzz"  . "Z!")
                                            ("AAA"  . "A!"))
-                              #:inputs `((,builder))))
+                              #:inputs `((,%bash) (,builder))))
          (succeeded?
           (build-derivations %store (list drv))))
     (and succeeded?
                                  ;; builder.
                                  #:env-vars `(("in" . ,input*))
 
-                                 #:inputs `((,builder)
+                                 #:inputs `((,%bash)
+                                            (,builder)
                                             (,input))))) ; ← local file name
     (and (build-derivations %store (list drv))
          ;; Note: we can't compare the files because the above trick alters
          ;; the contents.
          (valid-path? %store (derivation->output-path drv)))))
 
+(test-assert "identical files are deduplicated"
+  (let* ((build1  (add-text-to-store %store "one.sh"
+                                     "echo hello, world > \"$out\"\n"
+                                     '()))
+         (build2  (add-text-to-store %store "two.sh"
+                                     "# Hey!\necho hello, world > \"$out\"\n"
+                                     '()))
+         (drv1    (derivation %store "foo"
+                              %bash `(,build1)
+                              #:inputs `((,%bash) (,build1))))
+         (drv2    (derivation %store "bar"
+                              %bash `(,build2)
+                              #:inputs `((,%bash) (,build2)))))
+    (and (build-derivations %store (list drv1 drv2))
+         (let ((file1 (derivation->output-path drv1))
+               (file2 (derivation->output-path drv2)))
+           (and (valid-path? %store file1) (valid-path? %store file2)
+                (string=? (call-with-input-file file1 get-string-all)
+                          "hello, world\n")
+                (= (stat:ino (lstat file1))
+                   (stat:ino (lstat file2))))))))
+
+(test-equal "derivation-name"
+  "foo-0.0"
+  (let ((drv (derivation %store "foo-0.0" %bash '())))
+    (derivation-name drv)))
+
+(test-equal "derivation-output-names"
+  '(("out") ("bar" "chbouib"))
+  (let ((drv1 (derivation %store "foo-0.0" %bash '()))
+        (drv2 (derivation %store "foo-0.0" %bash '()
+                          #:outputs '("bar" "chbouib"))))
+    (list (derivation-output-names drv1)
+          (derivation-output-names drv2))))
+
+(test-assert "offloadable-derivation?"
+  (and (offloadable-derivation? (derivation %store "foo" %bash '()))
+       (not (offloadable-derivation?
+             (derivation %store "foo" %bash '()
+                         #:local-build? #t)))))
+
+(test-assert "fixed-output-derivation?"
+  (let* ((builder    (add-text-to-store %store "my-fixed-builder.sh"
+                                        "echo -n hello > $out" '()))
+         (hash       (sha256 (string->utf8 "hello")))
+         (drv        (derivation %store "fixed"
+                                 %bash `(,builder)
+                                 #:inputs `((,builder))
+                                 #:hash hash #:hash-algo 'sha256)))
+    (fixed-output-derivation? drv)))
+
 (test-assert "fixed-output derivation"
   (let* ((builder    (add-text-to-store %store "my-fixed-builder.sh"
                                         "echo -n hello > $out" '()))
          (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
          (final1     (derivation %store "final"
                                  %bash `(,builder3)
                                  #:env-vars `(("in" . ,fixed-out))
-                                 #:inputs `((,builder3) (,fixed1))))
+                                 #:inputs `((,%bash) (,builder3) (,fixed1))))
          (final2     (derivation %store "final"
                                  %bash `(,builder3)
                                  #:env-vars `(("in" . ,fixed-out))
-                                 #:inputs `((,builder3) (,fixed2))))
+                                 #:inputs `((,%bash) (,builder3) (,fixed2))))
          (succeeded? (build-derivations %store
                                         (list final1 final2))))
     (and succeeded?
                                  #:env-vars '(("HOME" . "/homeless")
                                               ("zzz"  . "Z!")
                                               ("AAA"  . "A!"))
-                                 #:inputs `((,builder))
+                                 #:inputs `((,%bash) (,builder))
                                  #:outputs '("out" "second")))
          (succeeded? (build-derivations %store (list drv))))
     (and succeeded?
                                         '()))
          (drv        (derivation %store "fixed"
                                  %bash `(,builder)
-                                 #:inputs `((,builder))
+                                 #:inputs `((,%bash) (,builder))
                                  #:outputs '("out" "AAA")))
          (succeeded? (build-derivations %store (list drv))))
     (and succeeded?
            (and (eq? 'one (call-with-input-file one read))
                 (eq? 'two (call-with-input-file two read)))))))
 
+(test-assert "multiple-output derivation, derivation-path->output-path"
+  (let* ((builder    (add-text-to-store %store "builder.sh"
+                                        "echo one > $out ; echo two > $second"
+                                        '()))
+         (drv        (derivation %store "multiple"
+                                 %bash `(,builder)
+                                 #:outputs '("out" "second")))
+         (drv-file   (derivation-file-name drv))
+         (one        (derivation->output-path drv "out"))
+         (two        (derivation->output-path drv "second"))
+         (first      (derivation-path->output-path drv-file "out"))
+         (second     (derivation-path->output-path drv-file "second")))
+    (and (not (string=? one two))
+         (string-suffix? "-second" two)
+         (string=? first one)
+         (string=? second two))))
+
 (test-assert "user of multiple-output derivation"
   ;; Check whether specifying several inputs coming from the same
   ;; multiple-output derivation works.
                                         '()))
          (mdrv       (derivation %store "multiple-output"
                                  %bash `(,builder1)
-                                 #:inputs `((,builder1))
+                                 #:inputs `((,%bash) (,builder1))
                                  #:outputs '("out" "two")))
          (builder2   (add-text-to-store %store "my-mo-user-builder.sh"
                                         "read x < $one;
                                               ("two"
                                                . ,(derivation->output-path
                                                    mdrv "two")))
-                                 #:inputs `((,builder2)
+                                 #:inputs `((,%bash)
+                                            (,builder2)
                                             ;; two occurrences of MDRV:
                                             (,mdrv)
                                             (,mdrv "two")))))
                                                ((p2 . _)
                                                 (string<? p1 p2)))))))))))))))
 
+(test-assert "derivation #:allowed-references, ok"
+  (let ((drv (derivation %store "allowed" %bash
+                         '("-c" "echo hello > $out")
+                         #:inputs `((,%bash))
+                         #:allowed-references '())))
+    (build-derivations %store (list drv))))
+
+(test-assert "derivation #:allowed-references, not allowed"
+  (let* ((txt (add-text-to-store %store "foo" "Hello, world."))
+         (drv (derivation %store "disallowed" %bash
+                          `("-c" ,(string-append "echo " txt "> $out"))
+                          #:inputs `((,%bash) (,txt))
+                          #:allowed-references '())))
+    (guard (c ((nix-protocol-error? c)
+               ;; There's no specific error message to check for.
+               #t))
+      (build-derivations %store (list drv))
+      #f)))
+
+(test-assert "derivation #:allowed-references, self allowed"
+  (let ((drv (derivation %store "allowed" %bash
+                         '("-c" "echo $out > $out")
+                         #:inputs `((,%bash))
+                         #:allowed-references '("out"))))
+    (build-derivations %store (list drv))))
+
+(test-assert "derivation #:allowed-references, self not allowed"
+  (let ((drv (derivation %store "disallowed" %bash
+                         `("-c" ,"echo $out > $out")
+                         #:inputs `((,%bash))
+                         #:allowed-references '())))
+    (guard (c ((nix-protocol-error? c)
+               ;; There's no specific error message to check for.
+               #t))
+      (build-derivations %store (list drv))
+      #f)))
+
 \f
 (define %coreutils
   (false-if-exception
-   (and (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)
+   (and (network-reachable?)
         (or (package-derivation %store %bootstrap-coreutils&co)
             (nixpkgs-derivation "coreutils")))))
 
 (test-skip (if (%guile-for-build) 0 8))
 
 (test-assert "build-expression->derivation and derivation-prerequisites"
-  (let ((drv (build-expression->derivation %store "fail" (%current-system)
-                                           #f '())))
+  (let ((drv (build-expression->derivation %store "fail" #f)))
     (any (match-lambda
           (($ <derivation-input> path)
            (string=? path (derivation-file-name (%guile-for-build)))))
                         (call-with-output-file (string-append %output "/test")
                           (lambda (p)
                             (display '(hello guix) p)))))
-         (drv       (build-expression->derivation %store "goo" (%current-system)
-                                                   builder '()))
+         (drv        (build-expression->derivation %store "goo" builder))
          (succeeded? (build-derivations %store (list drv))))
     (and succeeded?
          (let ((p (derivation->output-path drv)))
   (let* ((store      (let ((s (open-connection)))
                        (set-build-options s #:max-silent-time 1)
                        s))
-         (builder    '(sleep 100))
-         (drv        (build-expression->derivation %store "silent"
-                                                   (%current-system)
-                                                   builder '()))
+         (builder    '(begin (sleep 100) (mkdir %output) #t))
+         (drv        (build-expression->derivation store "silent" builder))
          (out-path   (derivation->output-path drv)))
     (guard (c ((nix-protocol-error? c)
                (and (string-contains (nix-protocol-error-message c)
                                      "failed")
                     (not (valid-path? store out-path)))))
-      (build-derivations %store (list drv)))))
+      (build-derivations store (list drv))
+      #f)))
+
+(test-assert "build-expression->derivation and timeout"
+  (let* ((store      (let ((s (open-connection)))
+                       (set-build-options s #:timeout 1)
+                       s))
+         (builder    '(begin (sleep 100) (mkdir %output) #t))
+         (drv        (build-expression->derivation store "slow" builder))
+         (out-path   (derivation->output-path drv)))
+    (guard (c ((nix-protocol-error? c)
+               (and (string-contains (nix-protocol-error-message c)
+                                     "failed")
+                    (not (valid-path? store out-path)))))
+      (build-derivations store (list drv))
+      #f)))
 
 (test-assert "build-expression->derivation and derivation-prerequisites-to-build"
-  (let ((drv (build-expression->derivation %store "fail" (%current-system)
-                                           #f '())))
+  (let ((drv (build-expression->derivation %store "fail" #f)))
     ;; The only direct dependency is (%guile-for-build) and it's already
     ;; built.
     (null? (derivation-prerequisites-to-build %store drv))))
 
 (test-assert "derivation-prerequisites-to-build when outputs already present"
   (let* ((builder    '(begin (mkdir %output) #t))
-         (input-drv  (build-expression->derivation %store "input"
-                                                   (%current-system)
-                                                   builder '()))
+         (input-drv  (build-expression->derivation %store "input" builder))
          (input-path (derivation-output-path
                       (assoc-ref (derivation-outputs input-drv)
                                  "out")))
-         (drv        (build-expression->derivation %store "something"
-                                                   (%current-system) builder
+         (drv        (build-expression->derivation %store "something" builder
+                                                   #:inputs
                                                    `(("i" ,input-drv))))
          (output     (derivation->output-path drv)))
     ;; Make sure these things are not already built.
          ;; prerequisite to build because DRV itself is already built.
          (null? (derivation-prerequisites-to-build %store drv)))))
 
-(test-skip (if (getenv "GUIX_BINARY_SUBSTITUTE_URL") 0 1))
 (test-assert "derivation-prerequisites-to-build and substitutes"
   (let* ((store  (open-connection))
          (drv    (build-expression->derivation store "prereq-subst"
-                                               (%current-system)
-                                               (random 1000) '()))
-         (output (derivation->output-path drv))
-         (dir    (and=> (getenv "GUIX_BINARY_SUBSTITUTE_URL")
-                        (compose uri-path string->uri))))
-    ;; Create fake substituter data, to be read by `substitute-binary'.
-    (call-with-output-file (string-append dir "/nix-cache-info")
-      (lambda (p)
-        (format p "StoreDir: ~a\nWantMassQuery: 0\n"
-                (%store-prefix))))
-    (call-with-output-file (string-append dir "/" (store-path-hash-part output)
-                                          ".narinfo")
-      (lambda (p)
-        (format p "StorePath: ~a
-URL: ~a
-Compression: none
-NarSize: 1234
-References: 
-System: ~a
-Deriver: ~a~%"
-                output                              ; StorePath
-                (string-append dir "/example.nar")  ; URL
-                (%current-system)                   ; System
-                (basename
-                 (derivation-file-name drv)))))     ; Deriver
-
-    (let-values (((build download)
-                  (derivation-prerequisites-to-build store drv))
-                 ((build* download*)
-                  (derivation-prerequisites-to-build store drv
-                                                     #:use-substitutes? #f)))
-      (pk build download build* download*)
-      (and (null? build)
-           (equal? download (list output))
-           (null? download*)
-           (null? build*)))))
+                                               (random 1000)))
+         (output (derivation->output-path drv)))
+
+    ;; Make sure substitutes are usable.
+    (set-build-options store #:use-substitutes? #t)
+
+    (with-derivation-narinfo drv
+      (let-values (((build download)
+                    (derivation-prerequisites-to-build store drv))
+                   ((build* download*)
+                    (derivation-prerequisites-to-build store drv
+                                                       #:substitutable?
+                                                       (const #f))))
+        (and (null? build)
+             (equal? download (list output))
+             (null? download*)
+             (null? build*))))))
+
+(test-assert "derivation-prerequisites-to-build and substitutes, local build"
+  (let* ((store  (open-connection))
+         (drv    (build-expression->derivation store "prereq-subst-local"
+                                               (random 1000)
+                                               ;; XXX: Adjust once
+                                               ;; <http://bugs.gnu.org/18747>
+                                               ;; is fixed.
+                                               #:local-build? #t))
+         (output (derivation->output-path drv)))
+
+    ;; Make sure substitutes are usable.
+    (set-build-options store #:use-substitutes? #t)
+
+    (with-derivation-narinfo drv
+      (let-values (((build download)
+                    (derivation-prerequisites-to-build store drv)))
+        ;; Despite being available as a substitute, DRV will be built locally
+        ;; due to #:local-build?.
+        (and (null? download)
+             (match build
+               (((? derivation-input? input))
+                (string=? (derivation-input-path input)
+                          (derivation-file-name drv)))))))))
 
 (test-assert "build-expression->derivation with expression returning #f"
   (let* ((builder  '(begin
                       (mkdir %output)
                       #f))                        ; fail!
-         (drv      (build-expression->derivation %store "fail" (%current-system)
-                                                 builder '()))
+         (drv      (build-expression->derivation %store "fail" builder))
          (out-path (derivation->output-path drv)))
     (guard (c ((nix-protocol-error? c)
                ;; Note that the output path may exist at this point, but it
@@ -514,9 +643,7 @@ Deriver: ~a~%"
                         (call-with-output-file (assoc-ref %outputs "second")
                           (lambda (p)
                             (display '(world) p)))))
-         (drv        (build-expression->derivation %store "double"
-                                                   (%current-system)
-                                                   builder '()
+         (drv        (build-expression->derivation %store "double" builder
                                                    #:outputs '("out"
                                                                "second")))
          (succeeded? (build-derivations %store (list drv))))
@@ -535,31 +662,14 @@ Deriver: ~a~%"
                             (dup2 (port->fdes p) 1)
                             (execl (string-append cu "/bin/uname")
                                    "uname" "-a")))))
-         (drv        (build-expression->derivation %store "uname" (%current-system)
-                                                   builder
+         (drv        (build-expression->derivation %store "uname" builder
+                                                   #:inputs
                                                    `(("cu" ,%coreutils))))
          (succeeded? (build-derivations %store (list drv))))
     (and succeeded?
          (let ((p (derivation->output-path drv)))
            (string-contains (call-with-input-file p read-line) "GNU")))))
 
-(test-assert "imported-files"
-  (let* ((files    `(("x"     . ,(search-path %load-path "ice-9/q.scm"))
-                     ("a/b/c" . ,(search-path %load-path
-                                              "guix/derivations.scm"))
-                     ("p/q"   . ,(search-path %load-path "guix.scm"))
-                     ("p/z"   . ,(search-path %load-path "guix/store.scm"))))
-         (drv      (imported-files %store files)))
-    (and (build-derivations %store (list drv))
-         (let ((dir (derivation->output-path drv)))
-           (every (match-lambda
-                   ((path . source)
-                    (equal? (call-with-input-file (string-append dir "/" path)
-                              get-bytevector-all)
-                            (call-with-input-file source
-                              get-bytevector-all))))
-                  files)))))
-
 (test-assert "build-expression->derivation with modules"
   (let* ((builder  `(begin
                       (use-modules (guix build utils))
@@ -567,8 +677,7 @@ Deriver: ~a~%"
                         (mkdir-p (string-append out "/guile/guix/nix"))
                         #t)))
          (drv      (build-expression->derivation %store "test-with-modules"
-                                                 (%current-system)
-                                                 builder '()
+                                                 builder
                                                  #:modules
                                                  '((guix build utils)))))
     (and (build-derivations %store (list drv))
@@ -584,14 +693,10 @@ Deriver: ~a~%"
                         (lambda (p)
                           (write "hello" p))))
          (hash       (sha256 (string->utf8 "hello")))
-         (input1     (build-expression->derivation %store "fixed"
-                                                   (%current-system)
-                                                   builder1 '()
+         (input1     (build-expression->derivation %store "fixed" builder1
                                                    #:hash hash
                                                    #:hash-algo 'sha256))
-         (input2     (build-expression->derivation %store "fixed"
-                                                   (%current-system)
-                                                   builder2 '()
+         (input2     (build-expression->derivation %store "fixed" builder2
                                                    #:hash hash
                                                    #:hash-algo 'sha256))
          (succeeded? (build-derivations %store (list input1 input2))))
@@ -609,27 +714,21 @@ Deriver: ~a~%"
                         (lambda (p)
                           (write "hello" p))))
          (hash       (sha256 (string->utf8 "hello")))
-         (input1     (build-expression->derivation %store "fixed"
-                                                   (%current-system)
-                                                   builder1 '()
+         (input1     (build-expression->derivation %store "fixed" builder1
                                                    #:hash hash
                                                    #:hash-algo 'sha256))
-         (input2     (build-expression->derivation %store "fixed"
-                                                   (%current-system)
-                                                   builder2 '()
+         (input2     (build-expression->derivation %store "fixed" builder2
                                                    #:hash hash
                                                    #:hash-algo 'sha256))
          (builder3  '(let ((input (assoc-ref %build-inputs "input")))
                        (call-with-output-file %output
                          (lambda (out)
                            (format #f "My input is ~a.~%" input)))))
-         (final1    (build-expression->derivation %store "final"
-                                                  (%current-system)
-                                                  builder3
+         (final1    (build-expression->derivation %store "final" builder3
+                                                  #:inputs
                                                   `(("input" ,input1))))
-         (final2    (build-expression->derivation %store "final"
-                                                  (%current-system)
-                                                  builder3
+         (final2    (build-expression->derivation %store "final" builder3
+                                                  #:inputs
                                                   `(("input" ,input2)))))
     (and (string=? (derivation->output-path final1)
                    (derivation->output-path final2))
@@ -638,13 +737,60 @@ 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)))
          (builder '(copy-file "input" %output))
          (drv     (build-expression->derivation %store "references-graphs"
-                                                (%current-system)
-                                                builder '()
+                                                builder
                                                 #:references-graphs
                                                 `(("input" . ,input))))
          (out     (derivation->output-path drv)))
@@ -670,6 +816,85 @@ Deriver: ~a~%"
                                     ((p2 . _)
                                      (string<? p1 p2)))))))))))))
 
+
+(test-assert "graft-derivation"
+  (let* ((build `(begin
+                   (mkdir %output)
+                   (chdir %output)
+                   (symlink %output "self")
+                   (call-with-output-file "text"
+                     (lambda (output)
+                       (format output "foo/~a/bar" ,%mkdir)))
+                   (symlink ,%bash "sh")))
+         (orig  (build-expression->derivation %store "graft" build
+                                              #:inputs `(("a" ,%bash)
+                                                         ("b" ,%mkdir))))
+         (one   (add-text-to-store %store "bash" "fake bash"))
+         (two   (build-expression->derivation %store "mkdir"
+                                              '(call-with-output-file %output
+                                                 (lambda (port)
+                                                   (display "fake mkdir" port)))))
+         (graft (graft-derivation %store "graft" orig
+                                  (list (graft
+                                          (origin %bash)
+                                          (replacement one))
+                                        (graft
+                                          (origin %mkdir)
+                                          (replacement two))))))
+    (and (build-derivations %store (list graft))
+         (let ((two   (derivation->output-path two))
+               (graft (derivation->output-path graft)))
+           (and (string=? (format #f "foo/~a/bar" two)
+                          (call-with-input-file (string-append graft "/text")
+                            get-string-all))
+                (string=? (readlink (string-append graft "/sh")) one)
+                (string=? (readlink (string-append graft "/self")) graft))))))
+
+(test-equal "map-derivation"
+  "hello"
+  (let* ((joke (package-derivation %store guile-1.8))
+         (good (package-derivation %store %bootstrap-guile))
+         (drv1 (build-expression->derivation %store "original-drv1"
+                                             #f   ; systematically fail
+                                             #:guile-for-build joke))
+         (drv2 (build-expression->derivation %store "original-drv2"
+                                             '(call-with-output-file %output
+                                                (lambda (p)
+                                                  (display "hello" p)))))
+         (drv3 (build-expression->derivation %store "drv-to-remap"
+                                             '(let ((in (assoc-ref
+                                                         %build-inputs "in")))
+                                                (copy-file in %output))
+                                             #:inputs `(("in" ,drv1))
+                                             #:guile-for-build joke))
+         (drv4 (map-derivation %store drv3 `((,drv1 . ,drv2)
+                                             (,joke . ,good))))
+         (out  (derivation->output-path drv4)))
+    (and (build-derivations %store (list (pk 'remapped drv4)))
+         (call-with-input-file out get-string-all))))
+
+(test-equal "map-derivation, sources"
+  "hello"
+  (let* ((script1   (add-text-to-store %store "fail.sh" "exit 1"))
+         (script2   (add-text-to-store %store "hi.sh" "echo -n hello > $out"))
+         (bash-full (package-derivation %store (@ (gnu packages bash) bash)))
+         (drv1      (derivation %store "drv-to-remap"
+
+                                ;; XXX: This wouldn't work in practice, but if
+                                ;; we append "/bin/bash" then we can't replace
+                                ;; it with the bootstrap bash, which is a
+                                ;; single file.
+                                (derivation->output-path bash-full)
+
+                                `("-e" ,script1)
+                                #:inputs `((,bash-full) (,script1))))
+         (drv2      (map-derivation %store drv1
+                                    `((,bash-full . ,%bash)
+                                      (,script1 . ,script2))))
+         (out       (derivation->output-path drv2)))
+    (and (build-derivations %store (list (pk 'remapped* drv2)))
+         (call-with-input-file out get-string-all))))
+
 (test-end)
 
 \f