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 2022-10-26 15:56:27 -04:00
parent b31ea797ed
commit 788602b37f
No known key found for this signature in database
GPG Key ID: 1260E46482E63562
5 changed files with 258 additions and 237 deletions

View File

@ -980,158 +980,158 @@ message if any test fails."
(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)

View File

@ -42,6 +42,7 @@
#: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 @@
#: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 @@ its source property."
((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 @@ Create a bundle of PACKAGE.\n"))
(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.

View File

@ -534,43 +534,44 @@ concatenates MANIFESTS, a list of expressions."
(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))))

View File

@ -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

View File

@ -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.