[PATCH v2 4/4] shell: Detect --symlink spec problems early.
(address . guix-patches@gnu.org)(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)
20221110042351.829-4-maxim.cournoyer@gmail.com
* 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-shell.sh: Add test.
* tests/guix-pack.sh: Adjust symlink spec.
---
guix/scripts/environment.scm | 294 +++++++++++++++++------------------
guix/scripts/pack.scm | 155 ++++++++++--------
guix/scripts/shell.scm | 77 ++++-----
tests/guix-pack.sh | 2 +-
4 files changed, 273 insertions(+), 255 deletions(-)
Toggle diff (398 lines)
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 7174dd72d2..ce299c4533 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -975,158 +975,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)))
-
- (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 (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))
-
- (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 (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)))
-
- ;; 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 \
+ (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-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 (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))
+
+ (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 (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)))
+
+ ;; 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 \
when using '--container'; doing nothing~%"))
- (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))))
-
- (else
- (return
- (exit/status
- (launch-environment/fork command profile manifest
- #:white-list white-list
- #:pure? pure?))))))))))))))
+ (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))))
+
+ (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)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index e3bddc4274..a101900736 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -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)
@@ -1310,74 +1327,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 (man
This message was truncated. Download the full message here.