me
/
guix
Archived
1
0
Fork 0
Code

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.
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

268
guix/scripts/environment.scm
View File

@ -980,158 +980,158 @@ message if any test fails."
(category development) (category development)
(synopsis "spawn one-off software environments (deprecated)") (synopsis "spawn one-off software environments (deprecated)")
(guix-environment* (parse-args args))) (with-error-handling
(guix-environment* (parse-args args))))
(define (guix-environment* opts) (define (guix-environment* opts)
"Run the 'guix environment' command on OPTS, an alist resulting for "Run the 'guix environment' command on OPTS, an alist resulting for
command-line option processing with 'parse-command-line'." command-line option processing with 'parse-command-line'."
(with-error-handling (let* ((pure? (assoc-ref opts 'pure))
(let* ((pure? (assoc-ref opts 'pure)) (container? (assoc-ref opts 'container?))
(container? (assoc-ref opts 'container?)) (link-prof? (assoc-ref opts 'link-profile?))
(link-prof? (assoc-ref opts 'link-profile?)) (symlinks (assoc-ref opts 'symlinks))
(symlinks (assoc-ref opts 'symlinks)) (network? (assoc-ref opts 'network?))
(network? (assoc-ref opts 'network?)) (no-cwd? (assoc-ref opts 'no-cwd?))
(no-cwd? (assoc-ref opts 'no-cwd?)) (emulate-fhs? (assoc-ref opts 'emulate-fhs?))
(emulate-fhs? (assoc-ref opts 'emulate-fhs?)) (user (assoc-ref opts 'user))
(user (assoc-ref opts 'user)) (bootstrap? (assoc-ref opts 'bootstrap?))
(bootstrap? (assoc-ref opts 'bootstrap?)) (system (assoc-ref opts 'system))
(system (assoc-ref opts 'system)) (profile (assoc-ref opts 'profile))
(profile (assoc-ref opts 'profile)) (command (or (assoc-ref opts 'exec)
(command (or (assoc-ref opts 'exec) ;; Spawn a shell if the user didn't specify
;; Spawn a shell if the user didn't specify ;; anything in particular.
;; anything in particular. (if container?
(if container? ;; The user's shell is likely not available
;; The user's shell is likely not available ;; within the container.
;; within the container. '("/bin/sh")
'("/bin/sh") (list %default-shell))))
(list %default-shell)))) (mappings (pick-all opts 'file-system-mapping))
(mappings (pick-all opts 'file-system-mapping)) (white-list (pick-all opts 'inherit-regexp)))
(white-list (pick-all opts 'inherit-regexp)))
(define store-needed? (define store-needed?
;; Whether connecting to the daemon is needed. ;; Whether connecting to the daemon is needed.
(or container? (not profile))) (or container? (not profile)))
(define-syntax-rule (with-store/maybe store exp ...) (define-syntax-rule (with-store/maybe store exp ...)
;; Evaluate EXP... with STORE bound to a connection, unless ;; Evaluate EXP... with STORE bound to a connection, unless
;; STORE-NEEDED? is false, in which case STORE is bound to #f. ;; STORE-NEEDED? is false, in which case STORE is bound to #f.
(let ((proc (lambda (store) exp ...))) (let ((proc (lambda (store) exp ...)))
(if store-needed? (if store-needed?
(with-store s (with-store s
(set-build-options-from-command-line s opts) (set-build-options-from-command-line s opts)
(with-build-handler (build-notifier #:use-substitutes? (with-build-handler (build-notifier #:use-substitutes?
(assoc-ref opts 'substitutes?) (assoc-ref opts 'substitutes?)
#:verbosity #:verbosity
(assoc-ref opts 'verbosity) (assoc-ref opts 'verbosity)
#:dry-run? #:dry-run?
(assoc-ref opts 'dry-run?)) (assoc-ref opts 'dry-run?))
(proc s))) (proc s)))
(proc #f)))) (proc #f))))
(when container? (assert-container-features)) (when container? (assert-container-features))
(when (not container?) (when (not container?)
(when link-prof? (when link-prof?
(leave (G_ "'--link-profile' cannot be used without '--container'~%"))) (leave (G_ "'--link-profile' cannot be used without '--container'~%")))
(when user (when user
(leave (G_ "'--user' cannot be used without '--container'~%"))) (leave (G_ "'--user' cannot be used without '--container'~%")))
(when no-cwd? (when no-cwd?
(leave (G_ "--no-cwd cannot be used without '--container'~%"))) (leave (G_ "--no-cwd cannot be used without '--container'~%")))
(when emulate-fhs? (when emulate-fhs?
(leave (G_ "'--emulate-fhs' cannot be used without '--container~%'"))) (leave (G_ "'--emulate-fhs' cannot be used without '--container~%'")))
(when (pair? symlinks) (when (pair? symlinks)
(leave (G_ "'--symlink' cannot be used without '--container~%'")))) (leave (G_ "'--symlink' cannot be used without '--container~%'"))))
(with-store/maybe store (with-store/maybe store
(with-status-verbosity (assoc-ref opts 'verbosity) (with-status-verbosity (assoc-ref opts 'verbosity)
(define manifest-from-opts (define manifest-from-opts
(options/resolve-packages store opts)) (options/resolve-packages store opts))
(define manifest (define manifest
(if profile (if profile
(profile-manifest profile) (profile-manifest profile)
manifest-from-opts)) manifest-from-opts))
(when (and profile (when (and profile
(> (length (manifest-entries manifest-from-opts)) 0)) (> (length (manifest-entries manifest-from-opts)) 0))
(leave (G_ "'--profile' cannot be used with package options~%"))) (leave (G_ "'--profile' cannot be used with package options~%")))
(when (null? (manifest-entries manifest)) (when (null? (manifest-entries manifest))
(warning (G_ "no packages specified; creating an empty environment~%"))) (warning (G_ "no packages specified; creating an empty environment~%")))
;; Use the bootstrap Guile when requested. ;; Use the bootstrap Guile when requested.
(parameterize ((%graft? (assoc-ref opts 'graft?)) (parameterize ((%graft? (assoc-ref opts 'graft?))
(%guile-for-build (%guile-for-build
(and store-needed? (and store-needed?
(package-derivation (package-derivation
store store
(if bootstrap? (if bootstrap?
%bootstrap-guile %bootstrap-guile
(default-guile)))))) (default-guile))))))
(run-with-store store (run-with-store store
;; Containers need a Bourne shell at /bin/sh. ;; Containers need a Bourne shell at /bin/sh.
(mlet* %store-monad ((bash (environment-bash container? (mlet* %store-monad ((bash (environment-bash container?
bootstrap? bootstrap?
system)) system))
(prof-drv (if profile (prof-drv (if profile
(return #f) (return #f)
(manifest->derivation (manifest->derivation
manifest system bootstrap?))) manifest system bootstrap?)))
(profile -> (if profile (profile -> (if profile
(readlink* profile) (readlink* profile)
(derivation->output-path prof-drv))) (derivation->output-path prof-drv)))
(gc-root -> (assoc-ref opts 'gc-root))) (gc-root -> (assoc-ref opts 'gc-root)))
;; First build the inputs. This is necessary even for ;; First build the inputs. This is necessary even for
;; --search-paths. Additionally, we might need to build bash for ;; --search-paths. Additionally, we might need to build bash for
;; a container. ;; a container.
(mbegin %store-monad (mbegin %store-monad
(mwhen store-needed? (mwhen store-needed?
(built-derivations (append (built-derivations (append
(if prof-drv (list prof-drv) '()) (if prof-drv (list prof-drv) '())
(if (derivation? bash) (list bash) '())))) (if (derivation? bash) (list bash) '()))))
(mwhen gc-root (mwhen gc-root
(register-gc-root profile gc-root)) (register-gc-root profile gc-root))
(mwhen (assoc-ref opts 'check?) (mwhen (assoc-ref opts 'check?)
(return (return
(if container? (if container?
(warning (G_ "'--check' is unnecessary \ (warning (G_ "'--check' is unnecessary \
when using '--container'; doing nothing~%")) when using '--container'; doing nothing~%"))
(validate-child-shell-environment profile manifest)))) (validate-child-shell-environment profile manifest))))
(cond (cond
((assoc-ref opts 'search-paths) ((assoc-ref opts 'search-paths)
(show-search-paths profile manifest #:pure? pure?) (show-search-paths profile manifest #:pure? pure?)
(return #t)) (return #t))
(container? (container?
(let ((bash-binary (let ((bash-binary
(if bootstrap? (if bootstrap?
(derivation->output-path bash) (derivation->output-path bash)
(string-append (derivation->output-path bash) (string-append (derivation->output-path bash)
"/bin/sh")))) "/bin/sh"))))
(launch-environment/container #:command command (launch-environment/container #:command command
#:bash bash-binary #:bash bash-binary
#:user user #:user user
#:user-mappings mappings #:user-mappings mappings
#:profile profile #:profile profile
#:manifest manifest #:manifest manifest
#:white-list white-list #:white-list white-list
#:link-profile? link-prof? #:link-profile? link-prof?
#:network? network? #:network? network?
#:map-cwd? (not no-cwd?) #:map-cwd? (not no-cwd?)
#:emulate-fhs? emulate-fhs? #:emulate-fhs? emulate-fhs?
#:symlinks symlinks #:symlinks symlinks
#:setup-hook #:setup-hook
(and emulate-fhs? (and emulate-fhs?
setup-fhs)))) setup-fhs))))
(else (else
(return (return
(exit/status (exit/status
(launch-environment/fork command profile manifest (launch-environment/fork command profile manifest
#:white-list white-list #:white-list white-list
#:pure? pure?)))))))))))))) #:pure? pure?)))))))))))))
;;; Local Variables: ;;; Local Variables:
;;; eval: (put 'with-store/maybe 'scheme-indent-function 1) ;;; eval: (put 'with-store/maybe 'scheme-indent-function 1)

155
guix/scripts/pack.scm
View File

@ -42,6 +42,7 @@
#:use-module (guix profiles) #:use-module (guix profiles)
#:use-module (guix describe) #:use-module (guix describe)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix diagnostics)
#:use-module (guix search-paths) #:use-module (guix search-paths)
#:use-module (guix build-system gnu) #:use-module (guix build-system gnu)
#:use-module (guix scripts build) #:use-module (guix scripts build)
@ -59,6 +60,7 @@
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9) #:use-module (srfi srfi-9)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-37) #:use-module (srfi srfi-37)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:export (symlink-spec-option-parser #:export (symlink-spec-option-parser
@ -163,12 +165,27 @@ its source property."
((names ... _) (loop names)))))) ((names ... _) (loop names))))))
(define (symlink-spec-option-parser opt name arg result) (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 ;; Note: Using 'string-split' allows us to handle empty
;; TARGET (as in "/opt/guile=", meaning that /opt/guile is ;; TARGET (as in "/opt/guile=", meaning that /opt/guile is
;; a symlink to the profile) correctly. ;; a symlink to the profile) correctly.
(match (string-split arg (char-set #\=)) (match (string-split arg #\=)
((source target) ((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))) (let ((symlinks (assoc-ref result 'symlinks)))
(alist-cons 'symlinks (alist-cons 'symlinks
`((,source -> ,target) ,@symlinks) `((,source -> ,target) ,@symlinks)
@ -1326,74 +1343,74 @@ Create a bundle of PACKAGE.\n"))
(category development) (category development)
(synopsis "create application bundles") (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 (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-store store
(with-status-verbosity (assoc-ref opts 'verbosity) (with-status-verbosity (assoc-ref opts 'verbosity)
;; Set the build options before we do anything else. ;; Set the build options before we do anything else.

67
guix/scripts/shell.scm
View File

@ -534,43 +534,44 @@ concatenates MANIFESTS, a list of expressions."
(category development) (category development)
(synopsis "spawn one-off software environments") (synopsis "spawn one-off software environments")
(define (cache-entries directory) (with-error-handling
(filter-map (match-lambda (define (cache-entries directory)
((or "." "..") #f) (filter-map (match-lambda
(file (string-append directory "/" file))) ((or "." "..") #f)
(or (scandir directory) '()))) (file (string-append directory "/" file)))
(or (scandir directory) '())))
(define* (entry-expiration file) (define* (entry-expiration file)
;; Return the time at which FILE, a cached profile, is considered expired. ;; Return the time at which FILE, a cached profile, is considered expired.
(match (false-if-exception (lstat file)) (match (false-if-exception (lstat file))
(#f 0) ;FILE may have been deleted in the meantime (#f 0) ;FILE may have been deleted in the meantime
(st (+ (stat:atime st) (* 60 60 24 7))))) (st (+ (stat:atime st) (* 60 60 24 7)))))
(define opts (define opts
(parse-args args)) (parse-args args))
(define interactive? (define interactive?
(not (assoc-ref opts 'exec))) (not (assoc-ref opts 'exec)))
(if (assoc-ref opts 'check?) (if (assoc-ref opts 'check?)
(record-hint 'shell-check) (record-hint 'shell-check)
(when (and interactive? (when (and interactive?
(not (hint-given? 'shell-check)) (not (hint-given? 'shell-check))
(not (assoc-ref opts 'container?)) (not (assoc-ref opts 'container?))
(not (assoc-ref opts 'search-paths))) (not (assoc-ref opts 'search-paths)))
(display-hint (G_ "Consider passing the @option{--check} option once (display-hint (G_ "Consider passing the @option{--check} option once
to make sure your shell does not clobber environment variables."))) ) to make sure your shell does not clobber environment variables."))) )
;; Clean the cache in EXIT-HOOK so that (1) it happens after potential use ;; Clean the cache in EXIT-HOOK so that (1) it happens after potential use
;; of cached profiles, and (2) cleanup actually happens, even when ;; of cached profiles, and (2) cleanup actually happens, even when
;; 'guix-environment*' calls 'exit'. ;; 'guix-environment*' calls 'exit'.
(add-hook! exit-hook (add-hook! exit-hook
(lambda _ (lambda _
(maybe-remove-expired-cache-entries (maybe-remove-expired-cache-entries
(%profile-cache-directory) (%profile-cache-directory)
cache-entries cache-entries
#:entry-expiration entry-expiration))) #:entry-expiration entry-expiration)))
(if (assoc-ref opts 'export-manifest?) (if (assoc-ref opts 'export-manifest?)
(export-manifest opts (current-output-port)) (export-manifest opts (current-output-port))
(guix-environment* opts))) (guix-environment* opts))))

3
tests/guix-environment-container.sh
View File

@ -250,3 +250,6 @@ guix shell --bootstrap guile-bootstrap --container \
# A dangling symlink causes the command to fail. # A dangling symlink causes the command to fail.
! guix shell --bootstrap -CS /usr/bin/python=bin/python guile-bootstrap -- exit ! 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

2
tests/guix-pack.sh
View File

@ -103,7 +103,7 @@ fi
guix pack --dry-run --bootstrap -f docker guile-bootstrap guix pack --dry-run --bootstrap -f docker guile-bootstrap
# Build a Docker image with a symlink. # 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 # Build a tarball pack of cross-compiled software. Use coreutils because
# guile-bootstrap is not intended to be cross-compiled. # guile-bootstrap is not intended to be cross-compiled.