01/02: grafts: Graft recursively.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit c22a1324e64d6906be5e9a8e64b8716ad763434a
Author: Ludovic Courtès <address@hidden>
Date:   Sat Feb 27 23:06:50 2016 +0100

    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.
---
 doc/guix.texi          |    9 ++-
 guix/grafts.scm        |  104 +++++++++++++++++++++++++++++++++++++--
 guix/packages.scm      |  126 +++++++++++++++++++++++++++++++----------------
 guix/scripts/graph.scm |    5 ++-
 tests/grafts.scm       |   93 +++++++++++++++++++++++++++++------
 tests/packages.scm     |   38 ++++++++-------
 6 files changed, 290 insertions(+), 85 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 4c9a91b..5e62703 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -10244,11 +10244,14 @@ Packages}).  Then, the original package definition is 
augmented with a
     (replacement bash-fixed)))
 @end example
 
-From there on, any package depending directly or indirectly on Bash that
-is installed will automatically be ``rewritten'' to refer to
+From there on, any package depending directly or indirectly on Bash---as
+reported by @command{guix gc --requisites} (@pxref{Invoking guix
+gc})---that is installed is automatically ``rewritten'' to refer to
 @var{bash-fixed} instead of @var{bash}.  This grafting process takes
 time proportional to the size of the package, but expect less than a
-minute for an ``average'' package on a recent machine.
+minute for an ``average'' package on a recent machine.  Grafting is
+recursive: when an indirect dependency requires grafting, then grafting
+``propagates'' up to the package that the user is installing.
 
 Currently, the graft and the package it replaces (@var{bash-fixed} and
 @var{bash} in the example above) must have the exact same @code{name}
diff --git a/guix/grafts.scm b/guix/grafts.scm
index ea53959..9bcc5e2 100644
--- a/guix/grafts.scm
+++ b/guix/grafts.scm
@@ -17,11 +17,14 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix grafts)
+  #:use-module (guix store)
+  #:use-module (guix monads)
   #:use-module (guix records)
   #:use-module (guix derivations)
   #:use-module ((guix utils) #:select (%current-system))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (ice-9 match)
   #:export (graft?
@@ -32,6 +35,7 @@
             graft-replacement-output
 
             graft-derivation
+            graft-derivation/shallow
 
             %graft?
             set-grafting))
@@ -61,13 +65,22 @@
 
 (set-record-type-printer! <graft> write-graft)
 
-(define* (graft-derivation store drv grafts
-                           #:key
-                           (name (derivation-name drv))
-                           (guile (%guile-for-build))
-                           (system (%current-system)))
+(define (graft-origin-file-name graft)
+  "Return the output file name of the origin of GRAFT."
+  (match graft
+    (($ <graft> (? derivation? origin) output)
+     (derivation->output-path origin output))
+    (($ <graft> (? string? item))
+     item)))
+
+(define* (graft-derivation/shallow store drv grafts
+                                   #:key
+                                   (name (derivation-name drv))
+                                   (guile (%guile-for-build))
+                                   (system (%current-system)))
   "Return a derivation called NAME, based on DRV but with all the GRAFTS
-applied."
+applied.  This procedure performs \"shallow\" grafting in that GRAFTS are not
+recursively applied to dependencies of DRV."
   ;; XXX: Someday rewrite using gexps.
   (define mapping
     ;; List of store item pairs.
@@ -133,6 +146,85 @@ applied."
                                                           (map add-label 
targets)))
                                      #:outputs output-names
                                      #:local-build? #t)))))
+(define (item->deriver store item)
+  "Return two values: the derivation that led to ITEM (a store item), and the
+name of the output of that derivation ITEM corresponds to (for example
+\"out\").  When ITEM has no deriver, for instance because it is a plain file,
+#f and #f are returned."
+  (match (valid-derivers store item)
+    (()                                           ;ITEM is a plain file
+     (values #f #f))
+    ((drv-file _ ...)
+     (let ((drv (call-with-input-file drv-file read-derivation)))
+       (values drv
+               (any (match-lambda
+                      ((name . path)
+                       (and (string=? item path) name)))
+                    (derivation->output-paths drv)))))))
+
+(define (non-self-references store drv outputs)
+  "Return the list of references of the OUTPUTS of DRV, excluding self
+references."
+  (let ((refs (append-map (lambda (output)
+                            (references store
+                                        (derivation->output-path drv output)))
+                          outputs))
+        (self (match (derivation->output-paths drv)
+                (((names . items) ...)
+                 items))))
+    (remove (cut member <> self) refs)))
+
+(define* (cumulative-grafts store drv grafts
+                            #:key
+                            (outputs (derivation-output-names drv))
+                            (guile (%guile-for-build))
+                            (system (%current-system)))
+  "Augment GRAFTS with additional grafts resulting from the application of
+GRAFTS to the dependencies of DRV.  Return the resulting list of grafts."
+  (define (dependency-grafts item)
+    (let-values (((drv output) (item->deriver store item)))
+      (if drv
+          (cumulative-grafts store drv grafts
+                             #:outputs (list output)
+                             #:guile guile
+                             #:system system)
+          grafts)))
+
+  ;; TODO: Memoize.
+  (match (non-self-references store drv outputs)
+    (()                                           ;no dependencies
+     grafts)
+    (deps                                         ;one or more dependencies
+     (let* ((grafts  (delete-duplicates (append-map dependency-grafts deps)
+                                        eq?))
+            (origins (map graft-origin-file-name grafts)))
+       (if (find (cut member <> deps) origins)
+           (let ((new (graft-derivation/shallow store drv grafts
+                                                #:guile guile
+                                                #:system system)))
+             (cons (graft (origin drv) (replacement new))
+                   grafts))
+           grafts)))))
+
+(define* (graft-derivation store drv grafts
+                           #:key (guile (%guile-for-build))
+                           (system (%current-system)))
+  "Applied GRAFTS to DRV and all its dependencies, recursively.  That is, if
+GRAFTS apply only indirectly to DRV, graft the dependencies of DRV, and graft
+DRV itself to refer to those grafted dependencies."
+
+  ;; First, we need to build the ungrafted DRV so we can query its run-time
+  ;; dependencies in 'cumulative-grafts'.
+  (build-derivations store (list drv))
+
+  (match (cumulative-grafts store drv grafts
+                            #:guile guile #:system system)
+    ((first . rest)
+     ;; If FIRST is not a graft for DRV, it means that GRAFTS are not
+     ;; applicable to DRV and nothing needs to be done.
+     (if (equal? drv (graft-origin first))
+         (graft-replacement first)
+         drv))))
 
 
 ;; The following might feel more at home in (guix packages) but since (guix
diff --git a/guix/packages.scm b/guix/packages.scm
index f6afaeb..3e50260 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -30,6 +30,7 @@
   #:use-module (guix build-system)
   #:use-module (guix search-paths)
   #:use-module (guix gexp)
+  #:use-module (guix sets)
   #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
   #:use-module (srfi srfi-1)
@@ -831,30 +832,25 @@ and return it."
                         (package package))))))))))
 
 (define (input-graft store system)
-  "Return a procedure that, given an input referring to a package with a
-graft, returns a pair with the original derivation and the graft's derivation,
-and returns #f for other inputs."
+  "Return a procedure that, given a package with a graft, returns a graft, and
+#f otherwise."
   (match-lambda
-   ((label (? package? package) sub-drv ...)
-    (let ((replacement (package-replacement package)))
-      (and replacement
-           (let ((orig (package-derivation store package system
-                                           #:graft? #f))
-                 (new  (package-derivation store replacement system)))
-             (graft
-               (origin orig)
-               (replacement new)
-               (origin-output (match sub-drv
-                                (() "out")
-                                ((output) output)))
-               (replacement-output origin-output))))))
-   (x
-    #f)))
+    ((? package? package)
+     (let ((replacement (package-replacement package)))
+       (and replacement
+            (let ((orig (package-derivation store package system
+                                            #:graft? #f))
+                  (new  (package-derivation store replacement system)))
+              (graft
+                (origin orig)
+                (replacement new))))))
+    (x
+     #f)))
 
 (define (input-cross-graft store target system)
   "Same as 'input-graft', but for cross-compilation inputs."
   (match-lambda
-   ((label (? package? package) sub-drv ...)
+    ((? package? package)
     (let ((replacement (package-replacement package)))
       (and replacement
            (let ((orig (package-cross-derivation store package target system
@@ -863,34 +859,75 @@ and returns #f for other inputs."
                                                  target system)))
              (graft
                (origin orig)
-               (replacement new)
-               (origin-output (match sub-drv
-                                (() "out")
-                                ((output) output)))
-               (replacement-output origin-output))))))
+               (replacement new))))))
    (_
     #f)))
 
-(define* (bag-grafts store bag)
-  "Return the list of grafts applicable to BAG.  Each graft is a <graft>
-record."
-  (let ((target (bag-target bag))
-        (system (bag-system bag)))
-    (define native-grafts
-      (filter-map (input-graft store system)
-                  (append (bag-transitive-build-inputs bag)
-                          (bag-transitive-target-inputs bag)
-                          (if target
-                              '()
-                              (bag-transitive-host-inputs bag)))))
-
-    (define target-grafts
-      (if target
-          (filter-map (input-cross-graft store target system)
-                      (bag-transitive-host-inputs bag))
-          '()))
+(define* (fold-bag-dependencies proc seed bag
+                                #:key (native? #t))
+  "Fold PROC over the packages BAG depends on.  Each package is visited only
+once, in depth-first order.  If NATIVE? is true, restrict to native
+dependencies; otherwise, restrict to target dependencies."
+  (define nodes
+    (match (if native?
+               (append (bag-build-inputs bag)
+                       (bag-target-inputs bag)
+                       (if (bag-target bag)
+                           '()
+                           (bag-host-inputs bag)))
+               (bag-host-inputs bag))
+      (((labels things _ ...) ...)
+       things)))
+
+  (let loop ((nodes nodes)
+             (result seed)
+             (visited (setq)))
+    (match nodes
+      (()
+       result)
+      (((? package? head) . tail)
+       (if (set-contains? visited head)
+           (loop tail result visited)
+           (let ((inputs (bag-direct-inputs (package->bag head))))
+             (loop (match inputs
+                     (((labels things _ ...) ...)
+                      (append things tail)))
+                   (proc head result)
+                   (set-insert head visited)))))
+      ((head . tail)
+       (loop tail result visited)))))
 
-    (append native-grafts target-grafts)))
+(define* (bag-grafts store bag)
+  "Return the list of grafts potentially applicable to BAG.  Potentially
+applicable grafts are collected by looking at direct or indirect dependencies
+of BAG that have a 'replacement'.  Whether a graft is actually applicable
+depends on whether the outputs of BAG depend on the items the grafts refer
+to (see 'graft-derivation'.)"
+  (define system (bag-system bag))
+  (define target (bag-target bag))
+
+  (define native-grafts
+    (let ((->graft (input-graft store system)))
+      (fold-bag-dependencies (lambda (package grafts)
+                               (match (->graft package)
+                                 (#f    grafts)
+                                 (graft (cons graft grafts))))
+                             '()
+                             bag)))
+
+  (define target-grafts
+    (if target
+        (let ((->graft (input-cross-graft store target system)))
+          (fold-bag-dependencies (lambda (package grafts)
+                                   (match (->graft package)
+                                     (#f    grafts)
+                                     (graft (cons graft grafts))))
+                                 '()
+                                 bag
+                                 #:native? #f))
+        '()))
+
+  (append native-grafts target-grafts))
 
 (define* (package-grafts store package
                          #:optional (system (%current-system))
@@ -985,6 +1022,9 @@ This is an internal procedure."
                   (grafts
                    (let ((guile (package-derivation store (default-guile)
                                                     system #:graft? #f)))
+                     ;; TODO: As an optimization, we can simply graft the tip
+                     ;; of the derivation graph since 'graft-derivation'
+                     ;; recurses anyway.
                      (graft-derivation store drv grafts
                                        #:system system
                                        #:guile guile))))
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index dcc4701..2d1c1ff 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -19,6 +19,7 @@
 (define-module (guix scripts graph)
   #:use-module (guix ui)
   #:use-module (guix graph)
+  #:use-module (guix grafts)
   #:use-module (guix scripts)
   #:use-module (guix utils)
   #:use-module (guix packages)
@@ -352,7 +353,9 @@ Emit a Graphviz (dot) representation of the dependencies of 
PACKAGE...\n"))
                                  opts)))
       (with-store store
         (run-with-store store
-          (mlet %store-monad ((nodes (mapm %store-monad
+          ;; XXX: Since grafting can trigger unsolicited builds, disable it.
+          (mlet %store-monad ((_     (set-grafting #f))
+                              (nodes (mapm %store-monad
                                            (node-type-convert type)
                                            packages)))
             (export-graph (concatenate nodes)
diff --git a/tests/grafts.scm b/tests/grafts.scm
index 9fe314d..4bc3370 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 6315c22..4639178 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))