mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
shell: Detect --symlink spec problems early.
* guix/scripts/pack.scm (symlink-spec-option-parser): Remove extraneous char-set. Raise an exception when the target is an absolute file name. (guix-pack): Move with-error-handler earlier. * guix/scripts/shell.scm (guix-shell): Likewise. * guix/scripts/environment.scm (guix-environment): Wrap the whole guix-environment* call with the with-error-handling handler. * tests/guix-environment-container.sh: Add tests. * tests/guix-pack.sh: Adjust symlink spec.
This commit is contained in:
Maxim Cournoyer
parent
b31ea797ed
commit
788602b37f
5 changed files with 258 additions and 237 deletions
|
|
@ -980,158 +980,158 @@ (define-command (guix-environment . args)
|
|||
(category development)
|
||||
(synopsis "spawn one-off software environments (deprecated)")
|
||||
|
||||
(guix-environment* (parse-args args)))
|
||||
(with-error-handling
|
||||
(guix-environment* (parse-args args))))
|
||||
|
||||
(define (guix-environment* opts)
|
||||
"Run the 'guix environment' command on OPTS, an alist resulting for
|
||||
command-line option processing with 'parse-command-line'."
|
||||
(with-error-handling
|
||||
(let* ((pure? (assoc-ref opts 'pure))
|
||||
(container? (assoc-ref opts 'container?))
|
||||
(link-prof? (assoc-ref opts 'link-profile?))
|
||||
(symlinks (assoc-ref opts 'symlinks))
|
||||
(network? (assoc-ref opts 'network?))
|
||||
(no-cwd? (assoc-ref opts 'no-cwd?))
|
||||
(emulate-fhs? (assoc-ref opts 'emulate-fhs?))
|
||||
(user (assoc-ref opts 'user))
|
||||
(bootstrap? (assoc-ref opts 'bootstrap?))
|
||||
(system (assoc-ref opts 'system))
|
||||
(profile (assoc-ref opts 'profile))
|
||||
(command (or (assoc-ref opts 'exec)
|
||||
;; Spawn a shell if the user didn't specify
|
||||
;; anything in particular.
|
||||
(if container?
|
||||
;; The user's shell is likely not available
|
||||
;; within the container.
|
||||
'("/bin/sh")
|
||||
(list %default-shell))))
|
||||
(mappings (pick-all opts 'file-system-mapping))
|
||||
(white-list (pick-all opts 'inherit-regexp)))
|
||||
(let* ((pure? (assoc-ref opts 'pure))
|
||||
(container? (assoc-ref opts 'container?))
|
||||
(link-prof? (assoc-ref opts 'link-profile?))
|
||||
(symlinks (assoc-ref opts 'symlinks))
|
||||
(network? (assoc-ref opts 'network?))
|
||||
(no-cwd? (assoc-ref opts 'no-cwd?))
|
||||
(emulate-fhs? (assoc-ref opts 'emulate-fhs?))
|
||||
(user (assoc-ref opts 'user))
|
||||
(bootstrap? (assoc-ref opts 'bootstrap?))
|
||||
(system (assoc-ref opts 'system))
|
||||
(profile (assoc-ref opts 'profile))
|
||||
(command (or (assoc-ref opts 'exec)
|
||||
;; Spawn a shell if the user didn't specify
|
||||
;; anything in particular.
|
||||
(if container?
|
||||
;; The user's shell is likely not available
|
||||
;; within the container.
|
||||
'("/bin/sh")
|
||||
(list %default-shell))))
|
||||
(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 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))))
|
||||
(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 container? (assert-container-features))
|
||||
|
||||
(when (not container?)
|
||||
(when link-prof?
|
||||
(leave (G_ "'--link-profile' cannot be used without '--container'~%")))
|
||||
(when user
|
||||
(leave (G_ "'--user' cannot be used without '--container'~%")))
|
||||
(when no-cwd?
|
||||
(leave (G_ "--no-cwd cannot be used without '--container'~%")))
|
||||
(when emulate-fhs?
|
||||
(leave (G_ "'--emulate-fhs' cannot be used without '--container~%'")))
|
||||
(when (pair? symlinks)
|
||||
(leave (G_ "'--symlink' cannot be used without '--container~%'"))))
|
||||
(when (not container?)
|
||||
(when link-prof?
|
||||
(leave (G_ "'--link-profile' cannot be used without '--container'~%")))
|
||||
(when user
|
||||
(leave (G_ "'--user' cannot be used without '--container'~%")))
|
||||
(when no-cwd?
|
||||
(leave (G_ "--no-cwd cannot be used without '--container'~%")))
|
||||
(when emulate-fhs?
|
||||
(leave (G_ "'--emulate-fhs' cannot be used without '--container~%'")))
|
||||
(when (pair? symlinks)
|
||||
(leave (G_ "'--symlink' cannot be used without '--container~%'"))))
|
||||
|
||||
(with-store/maybe store
|
||||
(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~%")))
|
||||
|
||||
;; 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 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)))
|
||||
|
||||
;; 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))
|
||||
;; 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))
|
||||
|
||||
(mwhen (assoc-ref opts 'check?)
|
||||
(return
|
||||
(if container?
|
||||
(warning (G_ "'--check' is unnecessary \
|
||||
(mwhen (assoc-ref opts 'check?)
|
||||
(return
|
||||
(if container?
|
||||
(warning (G_ "'--check' is unnecessary \
|
||||
when using '--container'; doing nothing~%"))
|
||||
(validate-child-shell-environment profile manifest))))
|
||||
(validate-child-shell-environment profile manifest))))
|
||||
|
||||
(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?)
|
||||
#:emulate-fhs? emulate-fhs?
|
||||
#:symlinks symlinks
|
||||
#:setup-hook
|
||||
(and emulate-fhs?
|
||||
setup-fhs))))
|
||||
(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?)
|
||||
#:emulate-fhs? emulate-fhs?
|
||||
#:symlinks symlinks
|
||||
#:setup-hook
|
||||
(and emulate-fhs?
|
||||
setup-fhs))))
|
||||
|
||||
(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:
|
||||
;;; eval: (put 'with-store/maybe 'scheme-indent-function 1)
|
||||
|
|
|
|||
|
|
@ -42,6 +42,7 @@ (define-module (guix scripts pack)
|
|||
#:use-module (guix profiles)
|
||||
#:use-module (guix describe)
|
||||
#:use-module (guix derivations)
|
||||
#:use-module (guix diagnostics)
|
||||
#:use-module (guix search-paths)
|
||||
#:use-module (guix build-system gnu)
|
||||
#:use-module (guix scripts build)
|
||||
|
|
@ -59,6 +60,7 @@ (define-module (guix scripts pack)
|
|||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-9)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (srfi srfi-35)
|
||||
#:use-module (srfi srfi-37)
|
||||
#:use-module (ice-9 match)
|
||||
#:export (symlink-spec-option-parser
|
||||
|
|
@ -163,12 +165,27 @@ (define str (string-join names "-"))
|
|||
((names ... _) (loop names))))))
|
||||
|
||||
(define (symlink-spec-option-parser opt name arg result)
|
||||
"A SRFI-37 option parser for the --symlink option."
|
||||
"A SRFI-37 option parser for the --symlink option. The symlink spec accepts
|
||||
the link file name as its left-hand side value and its target as its
|
||||
right-hand side value. The target must be a relative link."
|
||||
;; Note: Using 'string-split' allows us to handle empty
|
||||
;; TARGET (as in "/opt/guile=", meaning that /opt/guile is
|
||||
;; a symlink to the profile) correctly.
|
||||
(match (string-split arg (char-set #\=))
|
||||
(match (string-split arg #\=)
|
||||
((source target)
|
||||
(when (string-prefix? "/" target)
|
||||
(raise-exception
|
||||
(make-compound-condition
|
||||
(formatted-message (G_ "symlink target is absolute: '~a'~%") target)
|
||||
(condition
|
||||
(&fix-hint (hint (format #f (G_ "The target of the symlink must be
|
||||
relative rather than absolute, as it is relative to the profile created.
|
||||
Perhaps the source and target components of the symlink spec were inverted?
|
||||
Below is a valid example, where the @file{/usr/bin/env} symbolic link is to
|
||||
target the profile's @file{bin/env} file:
|
||||
@example
|
||||
--symlink=/usr/bin/env=bin/env
|
||||
@end example"))))))))
|
||||
(let ((symlinks (assoc-ref result 'symlinks)))
|
||||
(alist-cons 'symlinks
|
||||
`((,source -> ,target) ,@symlinks)
|
||||
|
|
@ -1326,74 +1343,74 @@ (define-command (guix-pack . args)
|
|||
(category development)
|
||||
(synopsis "create application bundles")
|
||||
|
||||
(define opts
|
||||
(parse-command-line args %options (list %default-options)))
|
||||
|
||||
(define maybe-package-argument
|
||||
;; Given an option pair, return a package, a package/output tuple, or #f.
|
||||
(match-lambda
|
||||
(('argument . spec)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(specification->package+output spec))
|
||||
list))
|
||||
(('expression . exp)
|
||||
(read/eval-package-expression exp))
|
||||
(x #f)))
|
||||
|
||||
(define (manifest-from-args store opts)
|
||||
(let* ((transform (options->transformation opts))
|
||||
(packages (map (match-lambda
|
||||
(((? package? package) output)
|
||||
(list (transform package) output))
|
||||
((? package? package)
|
||||
(list (transform package) "out")))
|
||||
(reverse
|
||||
(filter-map maybe-package-argument opts))))
|
||||
(manifests (filter-map (match-lambda
|
||||
(('manifest . file) file)
|
||||
(_ #f))
|
||||
opts)))
|
||||
(define with-provenance
|
||||
(if (assoc-ref opts 'save-provenance?)
|
||||
(lambda (manifest)
|
||||
(map-manifest-entries
|
||||
(lambda (entry)
|
||||
(let ((entry (manifest-entry-with-provenance entry)))
|
||||
(unless (assq 'provenance (manifest-entry-properties entry))
|
||||
(warning (G_ "could not determine provenance of package ~a~%")
|
||||
(manifest-entry-name entry)))
|
||||
entry))
|
||||
manifest))
|
||||
identity))
|
||||
|
||||
(with-provenance
|
||||
(cond
|
||||
((and (not (null? manifests)) (not (null? packages)))
|
||||
(leave (G_ "both a manifest and a package list were given~%")))
|
||||
((not (null? manifests))
|
||||
(concatenate-manifests
|
||||
(map (lambda (file)
|
||||
(let ((user-module (make-user-module
|
||||
'((guix profiles) (gnu)))))
|
||||
(load* file user-module)))
|
||||
manifests)))
|
||||
(else
|
||||
(packages->manifest packages))))))
|
||||
|
||||
(define (process-file-arg opts name)
|
||||
;; Validate that the file exists and return it as a <local-file> object,
|
||||
;; else #f.
|
||||
(let ((value (assoc-ref opts name)))
|
||||
(match value
|
||||
((and (? string?) (not (? file-exists?)))
|
||||
(leave (G_ "file provided with option ~a does not exist: ~a~%")
|
||||
(string-append "--" (symbol->string name)) value))
|
||||
((? string?)
|
||||
(local-file value))
|
||||
(#f #f))))
|
||||
|
||||
(with-error-handling
|
||||
(define opts
|
||||
(parse-command-line args %options (list %default-options)))
|
||||
|
||||
(define maybe-package-argument
|
||||
;; Given an option pair, return a package, a package/output tuple, or #f.
|
||||
(match-lambda
|
||||
(('argument . spec)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(specification->package+output spec))
|
||||
list))
|
||||
(('expression . exp)
|
||||
(read/eval-package-expression exp))
|
||||
(x #f)))
|
||||
|
||||
(define (manifest-from-args store opts)
|
||||
(let* ((transform (options->transformation opts))
|
||||
(packages (map (match-lambda
|
||||
(((? package? package) output)
|
||||
(list (transform package) output))
|
||||
((? package? package)
|
||||
(list (transform package) "out")))
|
||||
(reverse
|
||||
(filter-map maybe-package-argument opts))))
|
||||
(manifests (filter-map (match-lambda
|
||||
(('manifest . file) file)
|
||||
(_ #f))
|
||||
opts)))
|
||||
(define with-provenance
|
||||
(if (assoc-ref opts 'save-provenance?)
|
||||
(lambda (manifest)
|
||||
(map-manifest-entries
|
||||
(lambda (entry)
|
||||
(let ((entry (manifest-entry-with-provenance entry)))
|
||||
(unless (assq 'provenance (manifest-entry-properties entry))
|
||||
(warning (G_ "could not determine provenance of package ~a~%")
|
||||
(manifest-entry-name entry)))
|
||||
entry))
|
||||
manifest))
|
||||
identity))
|
||||
|
||||
(with-provenance
|
||||
(cond
|
||||
((and (not (null? manifests)) (not (null? packages)))
|
||||
(leave (G_ "both a manifest and a package list were given~%")))
|
||||
((not (null? manifests))
|
||||
(concatenate-manifests
|
||||
(map (lambda (file)
|
||||
(let ((user-module (make-user-module
|
||||
'((guix profiles) (gnu)))))
|
||||
(load* file user-module)))
|
||||
manifests)))
|
||||
(else
|
||||
(packages->manifest packages))))))
|
||||
|
||||
(define (process-file-arg opts name)
|
||||
;; Validate that the file exists and return it as a <local-file> object,
|
||||
;; else #f.
|
||||
(let ((value (assoc-ref opts name)))
|
||||
(match value
|
||||
((and (? string?) (not (? file-exists?)))
|
||||
(leave (G_ "file provided with option ~a does not exist: ~a~%")
|
||||
(string-append "--" (symbol->string name)) value))
|
||||
((? string?)
|
||||
(local-file value))
|
||||
(#f #f))))
|
||||
|
||||
(with-store store
|
||||
(with-status-verbosity (assoc-ref opts 'verbosity)
|
||||
;; Set the build options before we do anything else.
|
||||
|
|
|
|||
|
|
@ -534,43 +534,44 @@ (define-command (guix-shell . args)
|
|||
(category development)
|
||||
(synopsis "spawn one-off software environments")
|
||||
|
||||
(define (cache-entries directory)
|
||||
(filter-map (match-lambda
|
||||
((or "." "..") #f)
|
||||
(file (string-append directory "/" file)))
|
||||
(or (scandir directory) '())))
|
||||
(with-error-handling
|
||||
(define (cache-entries directory)
|
||||
(filter-map (match-lambda
|
||||
((or "." "..") #f)
|
||||
(file (string-append directory "/" file)))
|
||||
(or (scandir directory) '())))
|
||||
|
||||
(define* (entry-expiration file)
|
||||
;; Return the time at which FILE, a cached profile, is considered expired.
|
||||
(match (false-if-exception (lstat file))
|
||||
(#f 0) ;FILE may have been deleted in the meantime
|
||||
(st (+ (stat:atime st) (* 60 60 24 7)))))
|
||||
(define* (entry-expiration file)
|
||||
;; Return the time at which FILE, a cached profile, is considered expired.
|
||||
(match (false-if-exception (lstat file))
|
||||
(#f 0) ;FILE may have been deleted in the meantime
|
||||
(st (+ (stat:atime st) (* 60 60 24 7)))))
|
||||
|
||||
(define opts
|
||||
(parse-args args))
|
||||
(define opts
|
||||
(parse-args args))
|
||||
|
||||
(define interactive?
|
||||
(not (assoc-ref opts 'exec)))
|
||||
(define interactive?
|
||||
(not (assoc-ref opts 'exec)))
|
||||
|
||||
(if (assoc-ref opts 'check?)
|
||||
(record-hint 'shell-check)
|
||||
(when (and interactive?
|
||||
(not (hint-given? 'shell-check))
|
||||
(not (assoc-ref opts 'container?))
|
||||
(not (assoc-ref opts 'search-paths)))
|
||||
(display-hint (G_ "Consider passing the @option{--check} option once
|
||||
(if (assoc-ref opts 'check?)
|
||||
(record-hint 'shell-check)
|
||||
(when (and interactive?
|
||||
(not (hint-given? 'shell-check))
|
||||
(not (assoc-ref opts 'container?))
|
||||
(not (assoc-ref opts 'search-paths)))
|
||||
(display-hint (G_ "Consider passing the @option{--check} option once
|
||||
to make sure your shell does not clobber environment variables."))) )
|
||||
|
||||
;; Clean the cache in EXIT-HOOK so that (1) it happens after potential use
|
||||
;; of cached profiles, and (2) cleanup actually happens, even when
|
||||
;; 'guix-environment*' calls 'exit'.
|
||||
(add-hook! exit-hook
|
||||
(lambda _
|
||||
(maybe-remove-expired-cache-entries
|
||||
(%profile-cache-directory)
|
||||
cache-entries
|
||||
#:entry-expiration entry-expiration)))
|
||||
;; Clean the cache in EXIT-HOOK so that (1) it happens after potential use
|
||||
;; of cached profiles, and (2) cleanup actually happens, even when
|
||||
;; 'guix-environment*' calls 'exit'.
|
||||
(add-hook! exit-hook
|
||||
(lambda _
|
||||
(maybe-remove-expired-cache-entries
|
||||
(%profile-cache-directory)
|
||||
cache-entries
|
||||
#:entry-expiration entry-expiration)))
|
||||
|
||||
(if (assoc-ref opts 'export-manifest?)
|
||||
(export-manifest opts (current-output-port))
|
||||
(guix-environment* opts)))
|
||||
(if (assoc-ref opts 'export-manifest?)
|
||||
(export-manifest opts (current-output-port))
|
||||
(guix-environment* opts))))
|
||||
|
|
|
|||
|
|
@ -250,3 +250,6 @@ guix shell --bootstrap guile-bootstrap --container \
|
|||
|
||||
# A dangling symlink causes the command to fail.
|
||||
! guix shell --bootstrap -CS /usr/bin/python=bin/python guile-bootstrap -- exit
|
||||
|
||||
# An invalid symlink spec causes the command to fail.
|
||||
! guix shell --bootstrap -CS bin/guile=/usr/bin/guile guile-bootstrap -- exit
|
||||
|
|
|
|||
|
|
@ -103,7 +103,7 @@ fi
|
|||
guix pack --dry-run --bootstrap -f docker guile-bootstrap
|
||||
|
||||
# Build a Docker image with a symlink.
|
||||
guix pack --dry-run --bootstrap -f docker -S /opt/gnu=/ guile-bootstrap
|
||||
guix pack --dry-run --bootstrap -f docker -S /opt/gnu= guile-bootstrap
|
||||
|
||||
# Build a tarball pack of cross-compiled software. Use coreutils because
|
||||
# guile-bootstrap is not intended to be cross-compiled.
|
||||
|
|
|
|||
Loading…
Reference in a new issue