packages: Implement grafts.

Thanks to Mark H. Weaver <mhw@netris.org> for insightful discussions
and suggestions.

* guix/packages.scm (<package>)[graft]: New field.
  (patch-and-repack): Invoke 'package-derivation' with #:graft? #f.
  (package-source-derivation): Likewise.  Do not use (%guile-for-build)
  in call to 'patch-and-repack', and we could end up using a grafted
  Guile.
  (expand-input): Likewise, also for 'package-cross-derivation' call.
  (package->bag): Add #:graft? parameter.  Honor it.  Use 'strip-append'
  instead of 'package-full-name'.
  (input-graft, input-cross-graft, bag-grafts, package-grafts): New
  procedures.
  (package-derivation, package-cross-derivation): Add #:graft? parameter
  and honor it.
* gnu/packages/bootstrap.scm (package-with-bootstrap-guile): Add
  recursive call on 'graft'.
* guix/build-system/gnu.scm (package-with-explicit-inputs,
  package-with-extra-configure-variable, static-package): Likewise.
  (gnu-build): Use the ungrafted Guile to avoid full rebuilds.
  (gnu-cross-build): Likewise.
* guix/build-system/cmake.scm (cmake-build): Likewise.
* guix/build-system/glib-or-gtk.scm (glib-or-gtk-build): Likewise.
* guix/build-system/perl.scm (perl-build): Likewise.
* guix/build-system/python.scm (python-build): Likewise.
* guix/build-system/ruby.scm (ruby-build): Likewise.
* guix/build-system/trivial.scm (guile-for-build): Likewise.
* tests/packages.scm ("package-derivation, direct graft",
  "package-cross-derivation, direct graft", "package-grafts,
  indirect grafts", "package-grafts, indirect grafts, cross",
  "package-grafts, indirect grafts, propagated inputs",
  "package-derivation, indirect grafts"): New tests.
  ("bag->derivation", "bag->derivation, cross-compilation"): Wrap in
  'parameterize'.
* doc/guix.texi (Security Updates): New node.
  (Invoking guix build): Document --no-graft.

9 files changed, 190 insertions, 58 deletions

diff --git a/guix/build-system/cmake.scm b/guix/build-system/cmake.scm
index 85acc2d0b3..0425e9fb39 100644
--- a/guix/build-system/cmake.scm
+++ b/guix/build-system/cmake.scm
@@ -125,11 +125,11 @@ provides a 'CMakeLists.txt' file as its build system."
   (define guile-for-build
     (match guile
       ((? package?)
-       (package-derivation store guile system))
+       (package-derivation store guile system #:graft? #f))
       (#f                                         ; the default
        (let* ((distro (resolve-interface '(gnu packages commencement)))
               (guile  (module-ref distro 'guile-final)))
-         (package-derivation store guile system)))))
+         (package-derivation store guile system #:graft? #f)))))
 
   (build-expression->derivation store name builder
                                 #:system system
diff --git a/guix/build-system/glib-or-gtk.scm b/guix/build-system/glib-or-gtk.scm
index 078d5f6e8a..51e0c419e3 100644
--- a/guix/build-system/glib-or-gtk.scm
+++ b/guix/build-system/glib-or-gtk.scm
@@ -168,11 +168,11 @@
   (define guile-for-build
     (match guile
       ((? package?)
-       (package-derivation store guile system))
+       (package-derivation store guile system #:graft? #f))
       (#f                                         ; the default
        (let* ((distro (resolve-interface '(gnu packages commencement)))
               (guile  (module-ref distro 'guile-final)))
-         (package-derivation store guile system)))))
+         (package-derivation store guile system #:graft? #f)))))
 
   (build-expression->derivation store name builder
                                 #:system system
diff --git a/guix/build-system/gnu.scm b/guix/build-system/gnu.scm
index 3cb9f6ae94..c675155a6a 100644
--- a/guix/build-system/gnu.scm
+++ b/guix/build-system/gnu.scm
@@ -91,6 +91,13 @@ builder, or the distro's final Guile when GUILE is #f."
          `(#:guile ,guile
            #:implicit-inputs? #f
            ,@args)))
+      (replacement
+       (let ((replacement (package-replacement p)))
+         (and replacement
+              (package-with-explicit-inputs replacement inputs loc
+                                            #:native-inputs
+                                            native-inputs
+                                            #:guile guile))))
       (native-inputs
        (let ((filtered (duplicate-filter native-inputs*)))
         `(,@(call native-inputs*)
@@ -132,6 +139,11 @@ flags for VARIABLE, the associated value is augmented."
                                  (substring flag ,len))
                                 flag))
                           ,flags)))))))
+      (replacement
+       (let ((replacement (package-replacement p)))
+         (and replacement
+              (package-with-extra-configure-variable replacement
+                                                     variable value))))
       (inputs (rewritten-inputs (package-inputs p)))
       (propagated-inputs (rewritten-inputs (package-propagated-inputs p))))))
 
@@ -155,7 +167,8 @@ use `--strip-all' as the arguments to `strip'."
          ((#:strip-flags flags)
           (if strip-all?
               ''("--strip-all")
-              flags)))))))
+              flags)))))
+    (replacement (and=> (package-replacement p) static-package))))
 
 (define* (dist-package p source)
   "Return a package that runs takes source files from the SOURCE directory,
@@ -290,9 +303,11 @@ are allowed to refer to."
   (define canonicalize-reference
     (match-lambda
      ((? package? p)
-      (derivation->output-path (package-derivation store p system)))
+      (derivation->output-path (package-derivation store p system
+                                                   #:graft? #f)))
      (((? package? p) output)
-      (derivation->output-path (package-derivation store p system)
+      (derivation->output-path (package-derivation store p system
+                                                   #:graft? #f)
                                output))
      ((? string? output)
       output)))
@@ -328,11 +343,12 @@ are allowed to refer to."
   (define guile-for-build
     (match guile
       ((? package?)
-       (package-derivation store guile system))
+       (package-derivation store guile system #:graft? #f))
       (#f                                         ; the default
        (let* ((distro (resolve-interface '(gnu packages commencement)))
               (guile  (module-ref distro 'guile-final)))
-         (package-derivation store guile system)))))
+         (package-derivation store guile system
+                             #:graft? #f)))))
 
   (build-expression->derivation store name builder
                                 #:system system
@@ -472,11 +488,11 @@ platform."
   (define guile-for-build
     (match guile
       ((? package?)
-       (package-derivation store guile system))
+       (package-derivation store guile system #:graft? #f))
       (#f                                         ; the default
        (let* ((distro (resolve-interface '(gnu packages commencement)))
               (guile  (module-ref distro 'guile-final)))
-         (package-derivation store guile system)))))
+         (package-derivation store guile system #:graft? #f)))))
 
   (build-expression->derivation store name builder
                                 #:system system
diff --git a/guix/build-system/perl.scm b/guix/build-system/perl.scm
index 1a968f4150..c488adb500 100644
--- a/guix/build-system/perl.scm
+++ b/guix/build-system/perl.scm
@@ -114,11 +114,11 @@ provides a `Makefile.PL' file as its build system."
   (define guile-for-build
     (match guile
       ((? package?)
-       (package-derivation store guile system))
+       (package-derivation store guile system #:graft? #f))
       (#f                                         ; the default
        (let* ((distro (resolve-interface '(gnu packages commencement)))
               (guile  (module-ref distro 'guile-final)))
-         (package-derivation store guile system)))))
+         (package-derivation store guile system #:graft? #f)))))
 
   (build-expression->derivation store name builder
                                 #:system system
diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm
index 3cd537c752..78348e9cf7 100644
--- a/guix/build-system/python.scm
+++ b/guix/build-system/python.scm
@@ -160,11 +160,11 @@ provides a 'setup.py' file as its build system."
   (define guile-for-build
     (match guile
       ((? package?)
-       (package-derivation store guile system))
+       (package-derivation store guile system #:graft? #f))
       (#f                                         ; the default
        (let* ((distro (resolve-interface '(gnu packages commencement)))
               (guile  (module-ref distro 'guile-final)))
-         (package-derivation store guile system)))))
+         (package-derivation store guile system #:graft? #f)))))
 
   (build-expression->derivation store name builder
                                 #:inputs inputs
diff --git a/guix/build-system/ruby.scm b/guix/build-system/ruby.scm
index e4e115f657..d2dd6a48cc 100644
--- a/guix/build-system/ruby.scm
+++ b/guix/build-system/ruby.scm
@@ -99,11 +99,11 @@
   (define guile-for-build
     (match guile
       ((? package?)
-       (package-derivation store guile system))
+       (package-derivation store guile system #:graft? #f))
       (#f
        (let* ((distro (resolve-interface '(gnu packages commencement)))
               (guile  (module-ref distro 'guile-final)))
-         (package-derivation store guile system)))))
+         (package-derivation store guile system #:graft? #f)))))
 
   (build-expression->derivation store name builder
                                 #:inputs inputs
diff --git a/guix/build-system/trivial.scm b/guix/build-system/trivial.scm
index 07adbe75fa..350b1df553 100644
--- a/guix/build-system/trivial.scm
+++ b/guix/build-system/trivial.scm
@@ -28,11 +28,11 @@
 (define (guile-for-build store guile system)
   (match guile
     ((? package?)
-     (package-derivation store guile system))
+     (package-derivation store guile system #:graft? #f))
     (#f                                         ; the default
      (let* ((distro (resolve-interface '(gnu packages commencement)))
             (guile  (module-ref distro 'guile-final)))
-       (package-derivation store guile system)))))
+       (package-derivation store guile system #:graft? #f)))))
 
 (define* (lower name
                 #:key source inputs native-inputs outputs system target
diff --git a/guix/packages.scm b/guix/packages.scm
index 97a82a4682..698a4c8097 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -26,6 +26,7 @@
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
@@ -65,6 +66,7 @@
             package-outputs
             package-native-search-paths
             package-search-paths
+            package-replacement
             package-synopsis
             package-description
             package-license
@@ -85,6 +87,7 @@
             package-derivation
             package-cross-derivation
             package-output
+            package-grafts
 
             %supported-systems
 
@@ -97,6 +100,7 @@
             &package-cross-build-system-error
             package-cross-build-system-error?
 
+            %graft?
             package->bag
             bag->derivation
             bag-transitive-inputs
@@ -211,6 +215,8 @@ corresponds to the arguments expected by `set-path-environment-variable'."
                                                   ; inputs
   (native-search-paths package-native-search-paths (default '()))
   (search-paths package-search-paths (default '()))
+  (replacement package-replacement                ; package | #f
+               (default #f) (thunked))
 
   (synopsis package-synopsis)                    ; one-line description
   (description package-description)              ; one or two paragraphs
@@ -445,8 +451,8 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET."
                                (and (member name (cons decompression-type
                                                        '("tar" "xz" "patch")))
                                     (list name
-                                          (package-derivation store p
-                                                              system)))))
+                                          (package-derivation store p system
+                                                              #:graft? #f)))))
                              (or inputs (%standard-patch-inputs))))
         (modules (delete-duplicates (cons '(guix build utils) modules))))
 
@@ -472,12 +478,10 @@ IMPORTED-MODULES specify modules to use/import for use by SNIPPET."
      ;; Patches and/or a snippet.
      (let ((source (method store uri 'sha256 sha256 name
                            #:system system))
-           (guile  (match (or guile-for-build (%guile-for-build)
-                              (default-guile))
+           (guile  (match (or guile-for-build (default-guile))
                      ((? package? p)
-                      (package-derivation store p system))
-                     ((? derivation? drv)
-                      drv))))
+                      (package-derivation store p system
+                                          #:graft? #f)))))
        (patch-and-repack store source patches
                          #:inputs inputs
                          #:snippet snippet
@@ -617,8 +621,9 @@ information in exceptions."
 
   (define derivation
     (if cross-system
-        (cut package-cross-derivation store <> cross-system system)
-        (cut package-derivation store <> system)))
+        (cut package-cross-derivation store <> cross-system system
+             #:graft? #f)
+        (cut package-derivation store <> system #:graft? #f)))
 
   (match input
     (((? string? name) (? package? package))
@@ -643,20 +648,27 @@ information in exceptions."
                         (package package)
                         (input   x)))))))
 
+(define %graft?
+  ;; Whether to honor package grafts by default.
+  (make-parameter #t))
+
 (define* (package->bag package #:optional
                        (system (%current-system))
-                       (target (%current-target-system)))
+                       (target (%current-target-system))
+                       #:key (graft? (%graft?)))
   "Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET,
 and return it."
   ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked field
   ;; values can refer to it.
   (parameterize ((%current-system system)
                  (%current-target-system target))
-    (match package
+    (match (if graft?
+               (or (package-replacement package) package)
+               package)
       (($ <package> name version source build-system
                     args inputs propagated-inputs native-inputs self-native-input?
                     outputs)
-       (or (make-bag build-system (package-full-name package)
+       (or (make-bag build-system (string-append name "-" version)
                      #:system system
                      #:target target
                      #:source source
@@ -676,6 +688,77 @@ and return it."
                        (&package-error
                         (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."
+  (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)))
+
+(define (input-cross-graft store target system)
+  "Same as 'input-graft', but for cross-compilation inputs."
+  (match-lambda
+   ((label (? package? package) sub-drv ...)
+    (let ((replacement (package-replacement package)))
+      (and replacement
+           (let ((orig (package-cross-derivation store package target system
+                                                 #:graft? #f))
+                 (new  (package-cross-derivation store replacement
+                                                 target system)))
+             (graft
+               (origin orig)
+               (replacement new)
+               (origin-output (match sub-drv
+                                (() "out")
+                                ((output) output)))
+               (replacement-output origin-output))))))
+   (_
+    #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))
+          '()))
+
+    (append native-grafts target-grafts)))
+
+(define* (package-grafts store package
+                         #:optional (system (%current-system))
+                         #:key target)
+  "Return the list of grafts applicable to PACKAGE as built for SYSTEM and
+TARGET."
+  (let* ((package (or (package-replacement package) package))
+         (bag     (package->bag package system target)))
+    (bag-grafts store bag)))
+
 (define* (bag->derivation store bag
                           #:optional context)
   "Return the derivation to build BAG for SYSTEM.  Optionally, CONTEXT can be
@@ -743,23 +826,47 @@ This is an internal procedure."
            (bag-arguments bag))))
 
 (define* (package-derivation store package
-                             #:optional (system (%current-system)))
+                             #:optional (system (%current-system))
+                             #:key (graft? (%graft?)))
   "Return the <derivation> object of PACKAGE for SYSTEM."
 
   ;; Compute the derivation and cache the result.  Caching is important
   ;; because some derivations, such as the implicit inputs of the GNU build
   ;; system, will be queried many, many times in a row.
-  (cached package system
-          (bag->derivation store (package->bag package system #f)
-                           package)))
+  (cached package (cons system graft?)
+          (let* ((bag (package->bag package system #f #:graft? graft?))
+                 (drv (bag->derivation store bag package)))
+            (if graft?
+                (match (bag-grafts store bag)
+                  (()
+                   drv)
+                  (grafts
+                   (let ((guile (package-derivation store (default-guile)
+                                                    system #:graft? #f)))
+                     (graft-derivation store (bag-name bag) drv grafts
+                                       #:system system
+                                       #:guile guile))))
+                drv))))
 
 (define* (package-cross-derivation store package target
-                                   #:optional (system (%current-system)))
+                                   #:optional (system (%current-system))
+                                   #:key (graft? (%graft?)))
   "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
 system identifying string)."
-  (cached package (cons system target)
-          (bag->derivation store (package->bag package system target)
-                           package)))
+  (cached package (list system target graft?)
+          (let* ((bag (package->bag package system target #:graft? graft?))
+                 (drv (bag->derivation store bag package)))
+            (if graft?
+                (match (bag-grafts store bag)
+                  (()
+                   drv)
+                  (grafts
+                   (graft-derivation store (bag-name bag) drv grafts
+                                     #:system system
+                                     #:guile
+                                     (package-derivation store (default-guile)
+                                                         system #:graft? #f))))
+                drv))))
 
 (define* (package-output store package
                          #:optional (output "out") (system (%current-system)))
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index cde2a25613..7b7f419f3a 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -202,6 +202,7 @@ options handled by 'set-build-options-from-command-line', and listed in
 (define %default-options
   ;; Alist of default option values.
   `((system . ,(%current-system))
+    (graft? . #t)
     (substitutes? . #t)
     (build-hook? . #t)
     (print-build-trace? . #t)
@@ -223,6 +224,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
       --with-source=SOURCE
                          use SOURCE when building the corresponding package"))
   (display (_ "
+      --no-grafts        do not graft packages"))
+  (display (_ "
   -d, --derivations      return the derivation paths of the given packages"))
   (display (_ "
   -r, --root=FILE        make FILE a symlink to the result, and register it
@@ -278,6 +281,10 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
          (option '("with-source") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'with-source arg result)))
+         (option '("no-grafts") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'graft? #f
+                               (alist-delete 'graft? result eq?))))
 
          %standard-build-options))
 
@@ -290,26 +297,28 @@ build."
       (triplet
        (cut package-cross-derivation <> <> triplet <>))))
 
-  (define src? (assoc-ref opts 'source?))
-  (define sys  (assoc-ref opts 'system))
+  (define src?   (assoc-ref opts 'source?))
+  (define sys    (assoc-ref opts 'system))
+  (define graft? (assoc-ref opts 'graft?))
 
-  (let ((opts (options/with-source store
-                                   (options/resolve-packages store opts))))
-    (filter-map (match-lambda
-                 (('argument . (? package? p))
-                  (if src?
-                      (let ((s (package-source p)))
-                        (package-source-derivation store s))
-                      (package->derivation store p sys)))
-                 (('argument . (? derivation? drv))
-                  drv)
-                 (('argument . (? derivation-path? drv))
-                  (call-with-input-file drv read-derivation))
-                 (('argument . (? store-path?))
-                  ;; Nothing to do; maybe for --log-file.
-                  #f)
-                 (_ #f))
-                opts)))
+  (parameterize ((%graft? graft?))
+    (let ((opts (options/with-source store
+                                     (options/resolve-packages store opts))))
+      (filter-map (match-lambda
+                   (('argument . (? package? p))
+                    (if src?
+                        (let ((s (package-source p)))
+                          (package-source-derivation store s))
+                        (package->derivation store p sys)))
+                   (('argument . (? derivation? drv))
+                    drv)
+                   (('argument . (? derivation-path? drv))
+                    (call-with-input-file drv read-derivation))
+                   (('argument . (? store-path?))
+                    ;; Nothing to do; maybe for --log-file.
+                    #f)
+                   (_ #f))
+                  opts))))
 
 (define (options/resolve-packages store opts)
   "Return OPTS with package specification strings replaced by actual