self: Apply grafts to the outputs of the guix derivation.channel-graft-control

Rather than having grafts apply to the derivation itself. This moves grafting
here to work like grafting for packages, where you can think of the grafted
outputs as a transformed variant of the ungrafted outputs.

I'm looking at this as it'll allow the Guix Data Service to compute the
derivations without grafts, and for these to be useful for substitutes
regardless of whether users are using grafts.

* guix/self.scm (compiled-guix, guix-derivation): Add a #:graft? keyword
argument, to control grafting when computing the guix derivation.
* build-aux/build-self.scm (build-program): Call guix-derivation with
 #:graft? (%graft?) to make the compute-guix-derivation script use or not use
grafts as desired.

2 files changed, 84 insertions, 21 deletions

diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm
index 02822a2ee8..6d0037f20c 100644
--- a/build-aux/build-self.scm
+++ b/build-aux/build-self.scm
@@ -353,7 +353,9 @@ interface (FFI) of Guile.")
                                                   #:channel-metadata
                                                   '#$channel-metadata
                                                   #:pull-version
-                                                  #$pull-version)
+                                                  #$pull-version
+                                                  #:graft?
+                                                  #$(%graft?))
                                  #:system system))
                              derivation-file-name))))))
                   #:module-path (list source))))
diff --git a/guix/self.scm b/guix/self.scm
index c5de3ab8fc..8842275ff8 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -22,6 +22,7 @@
   #:use-module (guix i18n)
   #:use-module (guix modules)
   #:use-module (guix gexp)
+  #:use-module (guix grafts)
   #:use-module (guix store)
   #:use-module (guix monads)
   #:use-module (guix discovery)
@@ -32,6 +33,7 @@
   #:use-module ((guix build utils) #:select (find-files))
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-35)
   #:use-module (ice-9 match)
   #:export (make-config.scm
@@ -244,6 +246,50 @@ record with the new file name."
      ;; which isn't great.
      (file-append item "/" file))))
 
+(define graft-derivation*
+  (store-lift graft-derivation))
+
+(define package-grafts*
+  (store-lift package-grafts))
+
+;; Apply grafts explicitly
+(define-immutable-record-type <explicit-grafting>
+  (%explicit-grafting obj packages)
+  explicit-grafting?
+  (obj      explicit-grafting-obj)       ;obj
+  (packages explicit-grafting-packages)) ;list of <package>s
+
+(define (write-explicit-grafting rec port)
+  (match rec
+    (($ <explicit-grafting> obj packages)
+     (format port "#<explicit-grafting ~s ~s>" obj packages))))
+
+(define (explicit-grafting obj packages)
+  (%explicit-grafting obj packages))
+
+(define-gexp-compiler (explicit-grafting-compiler (explicit-grafting <explicit-grafting>)
+                                                  system target)
+  (match explicit-grafting
+    (($ <explicit-grafting> obj packages)
+     (mlet* %store-monad ((drv (without-grafting
+                                (lower-object obj system #:target target)))
+                          (grafts
+                           (mapm %store-monad
+                                 (lambda (pkg)
+                                   (package-grafts* pkg system #:target target))
+                                 packages)))
+       (match (delete-duplicates
+               (concatenate grafts))
+         (()
+          (return drv))
+         (grafts
+          (mlet %store-monad ((guile (package->derivation
+                                      (guile-for-grafts)
+                                      system #:graft? #f)))
+            (graft-derivation* drv grafts
+                               #:system system
+                               #:guile guile))))))))
+
 (define* (locale-data source domain
                       #:optional (directory domain))
   "Return the locale data from 'po/DIRECTORY' in SOURCE, corresponding to
@@ -754,7 +800,8 @@ itself."
                         (gzip (specification->package "gzip"))
                         (bzip2 (specification->package "bzip2"))
                         (xz (specification->package "xz"))
-                        (guix (specification->package "guix")))
+                        (guix (specification->package "guix"))
+                        (graft? #t))
   "Return a file-like object that contains a compiled Guix."
   (define guile-avahi
     (specification->package "guile-avahi"))
@@ -1024,25 +1071,34 @@ itself."
                                                guile-lzma
                                                dependencies)
                                         #:guile guile-for-build
-                                        #:guile-version guile-version)))
-           (whole-package name modules dependencies
-                          #:command command
-                          #:guile guile-for-build
-
-                          ;; Include 'guix-daemon'.  XXX: Here we inject an
-                          ;; older snapshot of guix-daemon, but that's a good
-                          ;; enough approximation for now.
-                          #:daemon (specification->package "guix-daemon")
-
-                          #:info (info-manual source)
-                          #:miscellany (miscellaneous-files source)
-                          #:guile-version guile-version)))
+                                        #:guile-version guile-version))
+                (obj
+                 (whole-package name modules dependencies
+                                #:command command
+                                #:guile guile-for-build
+
+                                ;; Include 'guix-daemon'.  XXX: Here we inject
+                                ;; an older snapshot of guix-daemon, but
+                                ;; that's a good enough approximation for now.
+                                #:daemon (specification->package "guix-daemon")
+
+                                #:info (info-manual source)
+                                #:miscellany (miscellaneous-files source)
+                                #:guile-version guile-version)))
+           (if graft?
+               (explicit-grafting obj
+                                  (map (compose force cdr) %packages))
+               obj)))
         ((= 0 pull-version)
          ;; Legacy 'guix pull': return the .scm and .go files as one
          ;; directory.
-         (built-modules (lambda (node)
-                          (list (node-source node)
-                                (node-compiled node)))))
+         (let ((obj (built-modules (lambda (node)
+                                     (list (node-source node)
+                                           (node-compiled node))))))
+           (if graft?
+               (explicit-grafting obj
+                                  (map (compose force cdr) %packages))
+               obj)))
         (else
          ;; Unsupported 'guix pull' version.
          #f)))
@@ -1272,7 +1328,8 @@ containing MODULE-FILES and possibly other files as well."
 (define* (guix-derivation source version
                           #:optional (guile-version (effective-version))
                           #:key (pull-version 0)
-                          channel-metadata)
+                          channel-metadata
+                          (graft? #t))
   "Return, as a monadic value, the derivation to build the Guix from SOURCE
 for GUILE-VERSION.  Use VERSION as the version string.  Use CHANNEL-METADATA
 as the channel metadata sexp to include in (guix config).
@@ -1309,7 +1366,11 @@ this PULL-VERSION value is not supported."
                                #:pull-version pull-version
                                #:guile-version (if (>= pull-version 1)
                                                    "3.0" guile-version)
-                               #:guile-for-build guile)))
+                               #:guile-for-build guile
+                               #:graft? graft?)))
       (if guix
-          (lower-object guix)
+          (if graft?
+              (lower-object guix)
+              (without-grafting
+               (lower-object guix)))
           (return #f)))))