grafts: Graft recursively.

Fixes <http://bugs.gnu.org/22139>.

* guix/grafts.scm (graft-derivation): Rename to...
(graft-derivation/shallow): ... this.
(graft-origin-file-name, item->deriver, non-self-references)
(cumulative-grafts, graft-derivation): New procedures
* tests/grafts.scm ("graft-derivation, grafted item is a direct
dependency"): Clarify title.  Use 'grafted' instead of 'graft' to refer
to the grafted derivation.
("graft-derivation, grafted item is an indirect dependency")
("graft-derivation, no dependencies on grafted output"): New tests.
* guix/packages.scm (input-graft): Change to take a package instead of
an input.
(input-cross-graft): Likewise.
(fold-bag-dependencies): New procedure.
(bag-grafts): Rewrite in terms of 'fold-bag-dependencies'.
* tests/packages.scm ("package-derivation, indirect grafts"): Comment out.
* doc/guix.texi (Security Updates): Mention run-time dependencies and
recursive grafting.

2 files changed, 99 insertions, 32 deletions

diff --git a/tests/grafts.scm b/tests/grafts.scm
index 9fe314d183..4bc33709d6 100644
--- a/tests/grafts.scm
+++ b/tests/grafts.scm
@@ -17,12 +17,16 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (test-grafts)
+  #:use-module (guix gexp)
+  #:use-module (guix monads)
   #:use-module (guix derivations)
   #:use-module (guix store)
   #:use-module (guix utils)
   #:use-module (guix grafts)
   #:use-module (guix tests)
   #:use-module ((gnu packages) #:select (search-bootstrap-binary))
+  #:use-module (gnu packages bootstrap)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-64)
   #:use-module (rnrs io ports))
 
@@ -42,7 +46,7 @@
 
 (test-begin "grafts")
 
-(test-assert "graft-derivation"
+(test-assert "graft-derivation, grafted item is a direct dependency"
   (let* ((build `(begin
                    (mkdir %output)
                    (chdir %output)
@@ -51,7 +55,7 @@
                      (lambda (output)
                        (format output "foo/~a/bar" ,%mkdir)))
                    (symlink ,%bash "sh")))
-         (orig  (build-expression->derivation %store "graft" build
+         (orig  (build-expression->derivation %store "grafted" build
                                               #:inputs `(("a" ,%bash)
                                                          ("b" ,%mkdir))))
          (one   (add-text-to-store %store "bash" "fake bash"))
@@ -59,21 +63,80 @@
                                               '(call-with-output-file %output
                                                  (lambda (port)
                                                    (display "fake mkdir" port)))))
-         (graft (graft-derivation %store 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)))
+         (grafted (graft-derivation %store orig
+                                    (list (graft
+                                            (origin %bash)
+                                            (replacement one))
+                                          (graft
+                                            (origin %mkdir)
+                                            (replacement two))))))
+    (and (build-derivations %store (list grafted))
+         (let ((two     (derivation->output-path two))
+               (grafted (derivation->output-path grafted)))
            (and (string=? (format #f "foo/~a/bar" two)
-                          (call-with-input-file (string-append graft "/text")
+                          (call-with-input-file (string-append grafted "/text")
                             get-string-all))
-                (string=? (readlink (string-append graft "/sh")) one)
-                (string=? (readlink (string-append graft "/self")) graft))))))
+                (string=? (readlink (string-append grafted "/sh")) one)
+                (string=? (readlink (string-append grafted "/self"))
+                          grafted))))))
+
+;; Make sure 'derivation-file-name' always gets to see an absolute file name.
+(fluid-set! %file-port-name-canonicalization 'absolute)
+
+(test-assert "graft-derivation, grafted item is an indirect dependency"
+  (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")))
+         (dep   (build-expression->derivation %store "dep" build
+                                              #:inputs `(("a" ,%bash)
+                                                         ("b" ,%mkdir))))
+         (orig  (build-expression->derivation %store "thing"
+                                              '(symlink
+                                                (assoc-ref %build-inputs
+                                                           "dep")
+                                                %output)
+                                              #:inputs `(("dep" ,dep))))
+         (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)))))
+         (grafted (graft-derivation %store orig
+                                    (list (graft
+                                            (origin %bash)
+                                            (replacement one))
+                                          (graft
+                                            (origin %mkdir)
+                                            (replacement two))))))
+    (and (build-derivations %store (list grafted))
+         (let* ((two     (derivation->output-path two))
+                (grafted (derivation->output-path grafted))
+                (dep     (readlink grafted)))
+           (and (string=? (format #f "foo/~a/bar" two)
+                          (call-with-input-file (string-append dep "/text")
+                            get-string-all))
+                (string=? (readlink (string-append dep "/sh")) one)
+                (string=? (readlink (string-append dep "/self")) dep)
+                (equal? (references %store grafted) (list dep))
+                (lset= string=?
+                       (list one two dep)
+                       (references %store dep)))))))
+
+(test-assert "graft-derivation, no dependencies on grafted output"
+  (run-with-store %store
+    (mlet* %store-monad ((fake    (text-file "bash" "Fake bash."))
+                         (graft -> (graft
+                                     (origin %bash)
+                                     (replacement fake)))
+                         (drv     (gexp->derivation "foo" #~(mkdir #$output)))
+                         (grafted ((store-lift graft-derivation) drv
+                                   (list graft))))
+      (return (eq? grafted drv)))))
 
 (test-assert "graft-derivation, multiple outputs"
   (let* ((build `(begin
diff --git a/tests/packages.scm b/tests/packages.scm
index 6315c2204f..46391783b0 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -605,23 +605,27 @@
                     (origin (package-derivation %store dep))
                     (replacement (package-derivation %store new)))))))
 
-(test-assert "package-derivation, indirect grafts"
-  (let* ((new   (dummy-package "dep"
-                  (arguments '(#:implicit-inputs? #f))))
-         (dep   (package (inherit new) (version "0.0")))
-         (dep*  (package (inherit dep) (replacement new)))
-         (dummy (dummy-package "dummy"
-                  (arguments '(#:implicit-inputs? #f))
-                  (inputs `(("dep" ,dep*)))))
-         (guile (package-derivation %store (canonical-package guile-2.0)
-                                    #:graft? #f)))
-    (equal? (package-derivation %store dummy)
-            (graft-derivation %store
-                              (package-derivation %store dummy #:graft? #f)
-                              (package-grafts %store dummy)
-
-                              ;; Use the same Guile as 'package-derivation'.
-                              #:guile guile))))
+;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to
+;;; find out about their run-time dependencies, so this test is no longer
+;;; applicable since it would trigger a full rebuild.
+;;
+;; (test-assert "package-derivation, indirect grafts"
+;;   (let* ((new   (dummy-package "dep"
+;;                   (arguments '(#:implicit-inputs? #f))))
+;;          (dep   (package (inherit new) (version "0.0")))
+;;          (dep*  (package (inherit dep) (replacement new)))
+;;          (dummy (dummy-package "dummy"
+;;                   (arguments '(#:implicit-inputs? #f))
+;;                   (inputs `(("dep" ,dep*)))))
+;;          (guile (package-derivation %store (canonical-package guile-2.0)
+;;                                     #:graft? #f)))
+;;     (equal? (package-derivation %store dummy)
+;;             (graft-derivation %store
+;;                               (package-derivation %store dummy #:graft? #f)
+;;                               (package-grafts %store dummy)
+
+;;                               ;; Use the same Guile as 'package-derivation'.
+;;                               #:guile guile))))
 
 (test-equal "package->bag"
   `("foo86-hurd" #f (,(package-source gnu-make))