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.

1 files changed, 98 insertions, 6 deletions

diff --git a/guix/grafts.scm b/guix/grafts.scm
index ea53959b37..9bcc5e2ef8 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