futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

environment: Do not connect to the daemon when '--profile' is used.

Browse Source 
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.
This commit is contained in:
Ludovic Courtès 2021-10-01 22:09:51 +02:00
parent 648a6eb03f
commit 99499a2037
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
1 changed files with 93 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

169
guix/scripts/environment.scm
View File

@ -691,6 +691,26 @@ command-line option processing with 'parse-command-line'."
(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 @@ command-line option processing with 'parse-command-line'."
(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: