[bug#50960] [PATCH v2 08/11] environment: Do not connect to the daemon when '--profile' is used.

[Ludovic Courtès]

This further speeds up the 'guix environment -p PROFILE' case.

* guix/scripts/environment.scm (guix-environment*)[store-needed?]: New
variable.
[with-store/maybe]: New macro.
Use it instead of 'with-store', and remove 'with-build-handler' form.
---
 guix/scripts/environment.scm | 169 +++++++++++++++++++----------------
 1 file changed, 93 insertions(+), 76 deletions(-)

diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 32f376fdd2..e23d52df39 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -691,6 +691,26 @@ (define (guix-environment* opts)
            (mappings   (pick-all opts 'file-system-mapping))
            (white-list (pick-all opts 'inherit-regexp)))
 
+      (define store-needed?
+        ;; Whether connecting to the daemon is needed.
+        (or container? (not profile)))
+
+      (define-syntax-rule (with-store/maybe store exp ...)
+        ;; Evaluate EXP... with STORE bound to a connection, unless
+        ;; STORE-NEEDED? is false, in which case STORE is bound to #f.
+        (let ((proc (lambda (store) exp ...)))
+          (if store-needed?
+              (with-store s
+                (set-build-options-from-command-line s opts)
+                (with-build-handler (build-notifier #:use-substitutes?
+                                                    (assoc-ref opts 
'substitutes?)
+                                                    #:verbosity
+                                                    (assoc-ref opts 'verbosity)
+                                                    #:dry-run?
+                                                    (assoc-ref opts 'dry-run?))
+                  (proc s)))
+              (proc #f))))
+
       (when container? (assert-container-features))
 
       (when (and (not container?) link-prof?)
@@ -701,88 +721,85 @@ (define (guix-environment* opts)
         (leave (G_ "--no-cwd cannot be used without --container~%")))
 
 
-      (with-store store
-        (with-build-handler (build-notifier #:use-substitutes?
-                                            (assoc-ref opts 'substitutes?)
-                                            #:verbosity
-                                            (assoc-ref opts 'verbosity)
-                                            #:dry-run?
-                                            (assoc-ref opts 'dry-run?))
-          (with-status-verbosity (assoc-ref opts 'verbosity)
-            (define manifest-from-opts
-              (options/resolve-packages store opts))
+      (with-store/maybe store
+        (with-status-verbosity (assoc-ref opts 'verbosity)
+          (define manifest-from-opts
+            (options/resolve-packages store opts))
 
-            (define manifest
-              (if profile
-                  (profile-manifest profile)
-                  manifest-from-opts))
+          (define manifest
+            (if profile
+                (profile-manifest profile)
+                manifest-from-opts))
 
-            (when (and profile
-                       (> (length (manifest-entries manifest-from-opts)) 0))
-              (leave (G_ "'--profile' cannot be used with package options~%")))
+          (when (and profile
+                     (> (length (manifest-entries manifest-from-opts)) 0))
+            (leave (G_ "'--profile' cannot be used with package options~%")))
 
-            (when (null? (manifest-entries manifest))
-              (warning (G_ "no packages specified; creating an empty 
environment~%")))
+          (when (null? (manifest-entries manifest))
+            (warning (G_ "no packages specified; creating an empty 
environment~%")))
 
-            (set-build-options-from-command-line store opts)
+          ;; Use the bootstrap Guile when requested.
+          (parameterize ((%graft? (assoc-ref opts 'graft?))
+                         (%guile-for-build
+                          (and store-needed?
+                               (package-derivation
+                                store
+                                (if bootstrap?
+                                    %bootstrap-guile
+                                    (default-guile))))))
+            (run-with-store store
+              ;; Containers need a Bourne shell at /bin/sh.
+              (mlet* %store-monad ((bash       (environment-bash container?
+                                                                 bootstrap?
+                                                                 system))
+                                   (prof-drv   (if profile
+                                                   (return #f)
+                                                   (manifest->derivation
+                                                    manifest system 
bootstrap?)))
+                                   (profile -> (if profile
+                                                   (readlink* profile)
+                                                   (derivation->output-path 
prof-drv)))
+                                   (gc-root -> (assoc-ref opts 'gc-root)))
 
-            ;; Use the bootstrap Guile when requested.
-            (parameterize ((%graft? (assoc-ref opts 'graft?))
-                           (%guile-for-build
-                            (and (or container? (not profile))
-                                 (package-derivation
-                                  store
-                                  (if bootstrap?
-                                      %bootstrap-guile
-                                      (default-guile))))))
-              (run-with-store store
-                ;; Containers need a Bourne shell at /bin/sh.
-                (mlet* %store-monad ((bash       (environment-bash container?
-                                                                   bootstrap?
-                                                                   system))
-                                     (prof-drv   (if profile
-                                                     (return #f)
-                                                     (manifest->derivation
-                                                      manifest system 
bootstrap?)))
-                                     (profile -> (if profile
-                                                     (readlink* profile)
-                                                     (derivation->output-path 
prof-drv)))
-                                     (gc-root -> (assoc-ref opts 'gc-root)))
-
-                  ;; First build the inputs.  This is necessary even for
-                  ;; --search-paths.  Additionally, we might need to build 
bash for
-                  ;; a container.
-                  (mbegin %store-monad
+                ;; First build the inputs.  This is necessary even for
+                ;; --search-paths.  Additionally, we might need to build bash 
for
+                ;; a container.
+                (mbegin %store-monad
+                  (mwhen store-needed?
                     (built-derivations (append
                                            (if prof-drv (list prof-drv) '())
-                                           (if (derivation? bash) (list bash) 
'())))
-                    (mwhen gc-root
-                      (register-gc-root profile gc-root))
+                                           (if (derivation? bash) (list bash) 
'()))))
+                  (mwhen gc-root
+                    (register-gc-root profile gc-root))
 
-                    (cond
-                     ((assoc-ref opts 'search-paths)
-                      (show-search-paths profile manifest #:pure? pure?)
-                      (return #t))
-                     (container?
-                      (let ((bash-binary
-                             (if bootstrap?
-                                 (derivation->output-path bash)
-                                 (string-append (derivation->output-path bash)
-                                                "/bin/sh"))))
-                        (launch-environment/container #:command command
-                                                      #:bash bash-binary
-                                                      #:user user
-                                                      #:user-mappings mappings
-                                                      #:profile profile
-                                                      #:manifest manifest
-                                                      #:white-list white-list
-                                                      #:link-profile? 
link-prof?
-                                                      #:network? network?
-                                                      #:map-cwd? (not 
no-cwd?))))
+                  (cond
+                   ((assoc-ref opts 'search-paths)
+                    (show-search-paths profile manifest #:pure? pure?)
+                    (return #t))
+                   (container?
+                    (let ((bash-binary
+                           (if bootstrap?
+                               (derivation->output-path bash)
+                               (string-append (derivation->output-path bash)
+                                              "/bin/sh"))))
+                      (launch-environment/container #:command command
+                                                    #:bash bash-binary
+                                                    #:user user
+                                                    #:user-mappings mappings
+                                                    #:profile profile
+                                                    #:manifest manifest
+                                                    #:white-list white-list
+                                                    #:link-profile? link-prof?
+                                                    #:network? network?
+                                                    #:map-cwd? (not no-cwd?))))
 
-                     (else
-                      (return
-                       (exit/status
-                        (launch-environment/fork command profile manifest
-                                                 #:white-list white-list
-                                                 #:pure? pure?)))))))))))))))
+                   (else
+                    (return
+                     (exit/status
+                      (launch-environment/fork command profile manifest
+                                               #:white-list white-list
+                                               #:pure? pure?))))))))))))))
+
+;;; Local Variables:
+;;; (put 'with-store/maybe 'scheme-indent-function 1)
+;;; End:
-- 
2.33.0