environment: Do not connect to the daemon when '--profile' is used.
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:
parent
648a6eb03f
commit
99499a2037
|
@ -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:
|
||||
|
|
Loading…
Reference in a new issue