channels: Allow disabling grafts when computing derivations.channel-instances-manifest-graft-control

2 files changed, 26 insertions, 16 deletions

diff --git a/build-aux/build-self.scm b/build-aux/build-self.scm
index 02822a2ee8..0e7fc2907d 100644
--- a/build-aux/build-self.scm
+++ b/build-aux/build-self.scm
@@ -241,7 +241,8 @@ interface (FFI) of Guile.")
 
 (define* (build-program source version
                         #:optional (guile-version (effective-version))
-                        #:key (pull-version 0) (channel-metadata #f))
+                        #:key (pull-version 0) (channel-metadata #f)
+                        (graft? #t))
   "Return a program that computes the derivation to build Guix from SOURCE."
   (define select?
     ;; Select every module but (guix config) and non-Guix modules.
@@ -316,6 +317,8 @@ interface (FFI) of Guile.")
                         (read-disable 'positions))
 
                       (use-modules (guix store)
+                                   (guix grafts)
+                                   (guix monads)
                                    (guix self)
                                    (guix derivations)
                                    (srfi srfi-1))
@@ -348,12 +351,14 @@ interface (FFI) of Guile.")
                                              (%make-void-port "w"))
                                             (current-build-output-port sock))
                                (run-with-store store
-                                 (guix-derivation source version
-                                                  #$guile-version
-                                                  #:channel-metadata
-                                                  '#$channel-metadata
-                                                  #:pull-version
-                                                  #$pull-version)
+                                 (mbegin %store-monad
+                                   (set-grafting #$graft?)
+                                   (guix-derivation source version
+                                                    #$guile-version
+                                                    #:channel-metadata
+                                                    '#$channel-metadata
+                                                    #:pull-version
+                                                    #$pull-version))
                                  #:system system))
                              derivation-file-name))))))
                   #:module-path (list source))))
@@ -398,6 +403,7 @@ Display a spinner when nothing happens."
                 #:key verbose?
                 (version (date-version-string)) channel-metadata
                 system
+                (graft? #t)
                 (pull-version 0)
 
                 ;; For the standalone Guix, default to Guile 3.0.  For old
@@ -415,7 +421,8 @@ files."
   ;; SOURCE.
   (mlet %store-monad ((build  (build-program source version guile-version
                                              #:channel-metadata channel-metadata
-                                             #:pull-version pull-version))
+                                             #:pull-version pull-version
+                                             #:graft? graft?))
                       (system (if system (return system) (current-system)))
                       (home -> (getenv "HOME"))
 
diff --git a/guix/channels.scm b/guix/channels.scm
index 5f47834c10..3aba677534 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -658,7 +658,7 @@ that unconditionally resumes the continuation."
               store))))
 
 (define* (build-from-source instance
-                            #:key core verbose? (dependencies '()) system)
+                            #:key core verbose? (dependencies '()) system graft?)
   "Return a derivation to build Guix from INSTANCE, using the self-build
 script contained therein.  When CORE is true, build package modules under
 SOURCE using CORE, an instance of Guix.  By default, build for the current
@@ -703,13 +703,14 @@ system, or SYSTEM if specified."
            (build source
                   #:verbose? verbose? #:version commit
                   #:system system
+                  #:graft? graft?
                   #:channel-metadata (channel-instance->sexp instance)
                   #:pull-version %pull-version))))
 
       ;; Build a set of modules that extend Guix using the standard method.
       (standard-module-derivation name source core dependencies)))
 
-(define* (build-channel-instance instance system
+(define* (build-channel-instance instance system graft?
                                  #:optional core (dependencies '()))
   "Return, as a monadic value, the derivation for INSTANCE, a channel
 instance, for SYSTEM.  DEPENDENCIES is a list of extensions providing Guile
@@ -717,7 +718,8 @@ modules that INSTANCE depends on."
   (build-from-source instance
                      #:core core
                      #:dependencies dependencies
-                     #:system system))
+                     #:system system
+                     #:graft? graft?))
 
 (define (resolve-dependencies instances)
   "Return a procedure that, given one of the elements of INSTANCES, returns
@@ -747,7 +749,7 @@ list of instances it depends on."
   (lambda (instance)
     (vhash-foldq* cons '() instance edges)))
 
-(define* (channel-instance-derivations instances #:key system)
+(define* (channel-instance-derivations instances #:key system graft?)
   "Return the list of derivations to build INSTANCES, in the same order as
 INSTANCES.  Build for the current system by default, or SYSTEM if specified."
   (define core-instance
@@ -763,11 +765,11 @@ INSTANCES.  Build for the current system by default, or SYSTEM if specified."
   (define (instance->derivation instance)
     (mlet %store-monad ((system (if system (return system) (current-system))))
       (mcached (if (eq? instance core-instance)
-                   (build-channel-instance instance system)
+                   (build-channel-instance instance system graft?)
                    (mlet %store-monad ((core (instance->derivation core-instance))
                                        (deps (mapm %store-monad instance->derivation
                                                    (edges instance))))
-                     (build-channel-instance instance system core deps)))
+                     (build-channel-instance instance system graft? core deps)))
                instance
                system)))
 
@@ -869,7 +871,7 @@ derivation."
                     intro))))))
             '()))))
 
-(define* (channel-instances->manifest instances #:key system)
+(define* (channel-instances->manifest instances #:key system (graft? #t))
   "Return a profile manifest with entries for all of INSTANCES, a list of
 channel instances.  By default, build for the current system, or SYSTEM if
 specified."
@@ -889,7 +891,8 @@ specified."
          `((source ,(channel-instance->sexp instance)))))))
 
   (mlet* %store-monad ((derivations (channel-instance-derivations instances
-                                                                  #:system system))
+                                                                  #:system system
+                                                                  #:graft? graft?))
                        (entries ->  (map instance->entry instances derivations)))
     (return (manifest entries))))