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.

12 files changed, 347 insertions, 73 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index d3ab9676ee..fbf5bac9b4 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -2569,6 +2569,10 @@ candidates:
 guix build guile --with-source=../guile-2.0.9.219-e1bb7.tar.xz
 @end example
 
+@item --no-grafts
+Do not ``graft'' packages.  In practice, this means that package updates
+available as grafts are not applied.  @xref{Security Updates}, for more
+information on grafts.
 
 @item --derivations
 @itemx -d
@@ -3003,6 +3007,7 @@ For information on porting to other architectures or kernels,
 * System Installation::         Installing the whole operating system.
 * System Configuration::        Configuring a GNU system.
 * Installing Debugging Files::  Feeding the debugger.
+* Security Updates::            Deploying security fixes quickly.
 * Package Modules::             Packages from the programmer's viewpoint.
 * Packaging Guidelines::        Growing the distribution.
 * Bootstrapping::               GNU/Linux built from scratch.
@@ -4280,6 +4285,64 @@ the load.  To check whether a package has a @code{debug} output, use
 @command{guix package --list-available} (@pxref{Invoking guix package}).
 
 
+@node Security Updates
+@section Security Updates
+
+@indentedblock
+Note: As of version @value{VERSION}, the feature described in this
+section is experimental.
+@end indentedblock
+
+@cindex security updates
+Occasionally, important security vulnerabilities are discovered in core
+software packages and must be patched.  Guix follows a functional
+package management discipline (@pxref{Introduction}), which implies
+that, when a package is changed, @emph{every package that depends on it}
+must be rebuilt.  This can significantly slow down the deployment of
+fixes in core packages such as libc or Bash, since basically the whole
+distribution would need to be rebuilt.  Using pre-built binaries helps
+(@pxref{Substitutes}), but deployment may still take more time than
+desired.
+
+@cindex grafts
+To address that, Guix implements @dfn{grafts}, a mechanism that allows
+for fast deployment of critical updates without the costs associated
+with a whole-distribution rebuild.  The idea is to rebuild only the
+package that needs to be patched, and then to ``graft'' it onto packages
+explicitly installed by the user and that were previously referring to
+the original package.  The cost of grafting is typically very low, and
+order of magnitudes lower than a full rebuild of the dependency chain.
+
+@cindex replacements of packages, for grafts
+For instance, suppose a security update needs to be applied to Bash.
+Guix developers will provide a package definition for the ``fixed''
+Bash, say @var{bash-fixed}, in the usual way (@pxref{Defining
+Packages}).  Then, the original package definition is augmented with a
+@code{replacement} field pointing to the package containing the bug fix:
+
+@example
+(define bash
+  (package
+    (name "bash")
+    ;; @dots{}
+    (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
+@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.
+
+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}
+and @code{version} fields.  This restriction mostly comes from the fact
+that grafting works by patching files, including binary files, directly.
+Other restrictions may apply: for instance, when adding a graft to a
+package providing a shared library, the original shared library and its
+replacement must have the same @code{SONAME} and be binary-compatible.
+
+
 @node Package Modules
 @section Package Modules
 
diff --git a/gnu/packages/bootstrap.scm b/gnu/packages/bootstrap.scm
index e617093fb3..33b61aa0be 100644
--- a/gnu/packages/bootstrap.scm
+++ b/gnu/packages/bootstrap.scm
@@ -146,7 +146,9 @@ check whether everything is alright."
       (native-inputs (map rewritten-input
                           (package-native-inputs p)))
       (propagated-inputs (map rewritten-input
-                              (package-propagated-inputs p)))))))
+                              (package-propagated-inputs p)))
+      (replacement (and=> (package-replacement p)
+                          package-with-bootstrap-guile))))))
 
 (define* (glibc-dynamic-linker
           #:optional (system (or (and=> (%current-target-system)
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
diff --git a/tests/packages.scm b/tests/packages.scm
index 44cdb35c4b..4f700b712f 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -33,8 +33,9 @@
   #:use-module (guix build-system gnu)
   #:use-module (gnu packages)
   #:use-module (gnu packages base)
+  #:use-module (gnu packages guile)
   #:use-module (gnu packages bootstrap)
-  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-64)
@@ -47,10 +48,6 @@
 (define %store
   (open-connection-for-tests))
 
-
-
-(test-begin "packages")
-
 (define-syntax-rule (dummy-package name* extra-fields ...)
   (package (name name*) (version "0") (source #f)
            (build-system gnu-build-system)
@@ -58,6 +55,9 @@
            (home-page #f) (license #f)
            extra-fields ...))
 
+
+(test-begin "packages")
+
 (test-assert "printer with location"
   (string-match "^#<package foo-0 foo.scm:42 [[:xdigit:]]+>$"
                 (with-output-to-string
@@ -375,6 +375,80 @@
       (package-cross-derivation %store p "mips64el-linux-gnu")
       #f)))
 
+(test-equal "package-derivation, direct graft"
+  (package-derivation %store gnu-make)
+  (let ((p (package (inherit coreutils)
+             (replacement gnu-make))))
+    (package-derivation %store p)))
+
+(test-equal "package-cross-derivation, direct graft"
+  (package-cross-derivation %store gnu-make "mips64el-linux-gnu")
+  (let ((p (package (inherit coreutils)
+             (replacement gnu-make))))
+    (package-cross-derivation %store p "mips64el-linux-gnu")))
+
+(test-assert "package-grafts, 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*))))))
+    (equal? (package-grafts %store dummy)
+            (list (graft
+                    (origin (package-derivation %store dep))
+                    (replacement (package-derivation %store new)))))))
+
+(test-assert "package-grafts, indirect grafts, cross"
+  (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*)))))
+         (target "mips64el-linux-gnu"))
+    (equal? (package-grafts %store dummy #:target target)
+            (list (graft
+                    (origin (package-cross-derivation %store dep target))
+                    (replacement
+                     (package-cross-derivation %store new target)))))))
+
+(test-assert "package-grafts, indirect grafts, propagated inputs"
+  (let* ((new   (dummy-package "dep"
+                  (arguments '(#:implicit-inputs? #f))))
+         (dep   (package (inherit new) (version "0.0")))
+         (dep*  (package (inherit dep) (replacement new)))
+         (prop  (dummy-package "propagated"
+                  (propagated-inputs `(("dep" ,dep*)))
+                  (arguments '(#:implicit-inputs? #f))))
+         (dummy (dummy-package "dummy"
+                  (arguments '(#:implicit-inputs? #f))
+                  (inputs `(("prop" ,prop))))))
+    (equal? (package-grafts %store dummy)
+            (list (graft
+                    (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 "dummy-0"
+                              (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))
     (,(canonical-package glibc)) (,(canonical-package coreutils)))
@@ -406,17 +480,20 @@
        (eq? package dep)))))
 
 (test-assert "bag->derivation"
-  (let ((bag (package->bag gnu-make))
-        (drv (package-derivation %store gnu-make)))
-    (parameterize ((%current-system "foox86-hurd")) ;should have no effect
-      (equal? drv (bag->derivation %store bag)))))
+  (parameterize ((%graft? #f))
+    (let ((bag (package->bag gnu-make))
+          (drv (package-derivation %store gnu-make)))
+      (parameterize ((%current-system "foox86-hurd")) ;should have no effect
+        (equal? drv (bag->derivation %store bag))))))
 
 (test-assert "bag->derivation, cross-compilation"
-  (let ((bag (package->bag gnu-make (%current-system) "mips64el-linux-gnu"))
-        (drv (package-cross-derivation %store gnu-make "mips64el-linux-gnu")))
-    (parameterize ((%current-system "foox86-hurd") ;should have no effect
-                   (%current-target-system "foo64-linux-gnu"))
-      (equal? drv (bag->derivation %store bag)))))
+  (parameterize ((%graft? #f))
+    (let* ((target "mips64el-linux-gnu")
+           (bag    (package->bag gnu-make (%current-system) target))
+           (drv    (package-cross-derivation %store gnu-make target)))
+      (parameterize ((%current-system "foox86-hurd") ;should have no effect
+                     (%current-target-system "foo64-linux-gnu"))
+        (equal? drv (bag->derivation %store bag))))))
 
 (unless (false-if-exception (getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV))
   (test-skip 1))