From 645b9df858683dc05ffa04c9eb2fdc45ccef4a65 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Mon, 17 Oct 2016 23:40:03 +0200
Subject: [PATCH] guix build: Add '--with-graft'.

* guix/scripts/build.scm (transform-package-inputs/graft): New procedure.
(%transformations): Add 'with-graft'.
(%transformation-options): Likewise.
(show-transformation-options-help): Document it.
* tests/scripts-build.scm ("options->transformation, with-graft"): New
test.
* doc/guix.texi (Package Transformation Options): Document it.
---
 doc/guix.texi           | 24 ++++++++++++++++++++++++
 guix/scripts/build.scm  | 29 ++++++++++++++++++++++++++---
 tests/scripts-build.scm | 19 +++++++++++++++++++
 3 files changed, 69 insertions(+), 3 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 47fc199c6c..0c5d641b48 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -4513,6 +4513,30 @@ This is a recursive, deep replacement.  So in this example, both
 
 This is implemented using the @code{package-input-rewriting} Scheme
 procedure (@pxref{Defining Packages, @code{package-input-rewriting}}).
+
+@item --with-graft=@var{package}=@var{replacement}
+This is similar to @code{--with-input} but with an important difference:
+instead of rebuilding all the dependency chain, @var{replacement} is
+built and then @dfn{grafted} onto the binaries that were initially
+referring to @var{package}.  @xref{Security Updates}, for more
+information on grafts.
+
+For example, the command below grafts version 3.5.4 of GnuTLS onto Wget
+and all its dependencies, replacing references to the version of GnuTLS
+they currently refer to:
+
+@example
+guix build --with-graft=gnutls=gnutls@@3.5.4 wget
+@end example
+
+This has the advantage of being much faster than rebuilding everything.
+But there is a caveat: it works if and only if @var{package} and
+@var{replacement} are strictly compatible---for example, if they provide
+a library, the application binary interface (ABI) of those libraries
+must be compatible.  If @var{replacement} is somehow incompatible with
+@var{package}, then the resulting package may be unusable.  Use with
+care!
+
 @end table
 
 @node Additional Build Options
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index bd97d56dce..8c2c4902fc 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -209,13 +209,31 @@ called \"guile\" must be replaced with a dependency on a version 2.1 of
           (rewrite obj)
           obj))))
 
+(define (transform-package-inputs/graft replacement-specs)
+  "Return a procedure that, when passed a package, replaces its direct
+dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
+strings like \"gnutls=gnutls@3.5.4\" meaning that packages are built using the
+current 'gnutls' package, after which version 3.5.4 is grafted onto them."
+  (define (replacement-pair old new)
+    (cons old
+          (package (inherit old) (replacement new))))
+
+  (let* ((replacements (evaluate-replacement-specs replacement-specs
+                                                   replacement-pair))
+         (rewrite      (package-input-rewriting replacements)))
+    (lambda (store obj)
+      (if (package? obj)
+          (rewrite obj)
+          obj))))
+
 (define %transformations
   ;; Transformations that can be applied to things to build.  The car is the
   ;; key used in the option alist, and the cdr is the transformation
   ;; procedure; it is called with two arguments: the store, and a list of
   ;; things to build.
   `((with-source . ,transform-package-source)
-    (with-input  . ,transform-package-inputs)))
+    (with-input  . ,transform-package-inputs)
+    (with-graft  . ,transform-package-inputs/graft)))
 
 (define %transformation-options
   ;; The command-line interface to the above transformations.
@@ -227,7 +245,9 @@ called \"guile\" must be replaced with a dependency on a version 2.1 of
     (list (option '("with-source") #t #f
                   (parser 'with-source))
           (option '("with-input") #t #f
-                  (parser 'with-input)))))
+                  (parser 'with-input))
+          (option '("with-graft") #t #f
+                  (parser 'with-graft)))))
 
 (define (show-transformation-options-help)
   (display (_ "
@@ -235,7 +255,10 @@ called \"guile\" must be replaced with a dependency on a version 2.1 of
                          use SOURCE when building the corresponding package"))
   (display (_ "
       --with-input=PACKAGE=REPLACEMENT
-                         replace dependency PACKAGE by REPLACEMENT")))
+                         replace dependency PACKAGE by REPLACEMENT"))
+  (display (_ "
+      --with-graft=PACKAGE=REPLACEMENT
+                         graft REPLACEMENT on packages that refer to PACKAGE")))
 
 
 (define (options->transformation opts)
diff --git a/tests/scripts-build.scm b/tests/scripts-build.scm
index e48c8da264..e2610904e2 100644
--- a/tests/scripts-build.scm
+++ b/tests/scripts-build.scm
@@ -102,4 +102,23 @@
                        ((("x" dep))
                         (eq? dep findutils)))))))))))
 
+(test-assert "options->transformation, with-graft"
+  (let* ((p (dummy-package "guix.scm"
+              (inputs `(("foo" ,grep)
+                        ("bar" ,(dummy-package "chbouib"
+                                  (native-inputs `(("x" ,grep)))))))))
+         (t (options->transformation '((with-input . "grep=findutils")))))
+    (with-store store
+      (let ((new (t store p)))
+        (and (not (eq? new p))
+             (match (package-inputs new)
+               ((("foo" dep1) ("bar" dep2))
+                (and (string=? (package-full-name dep1)
+                               (package-full-name grep))
+                     (eq? (package-replacement dep1) findutils)
+                     (string=? (package-name dep2) "chbouib")
+                     (match (package-native-inputs dep2)
+                       ((("x" dep))
+                        (eq? (package-replacement dep) findutils)))))))))))
+
 (test-end)