Package: guix-patches;
Reported by: Maxim Cournoyer <maxim.cournoyer <at> gmail.com>
Date: Thu, 10 Nov 2022 04:25:03 UTC
Severity: normal
Tags: patch
Merged with 58812, 59161, 59162, 59164
Done: Maxim Cournoyer <maxim.cournoyer <at> gmail.com>
Bug is archived. No further changes may be made.
To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 59163 in the body.
You can then email your comments to 59163 AT debbugs.gnu.org in the normal way.
Toggle the display of automated, internal messages from the tracker.
View this report as an mbox folder, status mbox, maintainer mbox
guix-patches <at> gnu.org:bug#59163; Package guix-patches.
(Thu, 10 Nov 2022 04:25:04 GMT) Full text and rfc822 format available.Maxim Cournoyer <maxim.cournoyer <at> gmail.com>:guix-patches <at> gnu.org.
(Thu, 10 Nov 2022 04:25:04 GMT) Full text and rfc822 format available.Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):
From: Maxim Cournoyer <maxim.cournoyer <at> gmail.com> To: guix-patches <at> gnu.org Cc: Maxim Cournoyer <maxim.cournoyer <at> gmail.com> Subject: [PATCH v2 4/4] shell: Detect --symlink spec problems early. Date: Wed, 9 Nov 2022 23:23:51 -0500
* 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(-)
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 (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.
diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm
index 7a379122ae..2fc1dc942a 100644
--- a/guix/scripts/shell.scm
+++ b/guix/scripts/shell.scm
@@ -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) '())))
-
- (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 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
+ (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 opts
+ (parse-args args))
+
+ (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
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)))
-
- (if (assoc-ref opts 'export-manifest?)
- (export-manifest opts (current-output-port))
- (guix-environment* opts)))
+ ;; 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))))
diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh
index f19a0f754e..6fc9e3723b 100644
--- a/tests/guix-pack.sh
+++ b/tests/guix-pack.sh
@@ -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.
--
2.37.3
Maxim Cournoyer <maxim.cournoyer <at> gmail.com>
to control <at> debbugs.gnu.org.
(Thu, 10 Nov 2022 13:44:02 GMT) Full text and rfc822 format available.Maxim Cournoyer <maxim.cournoyer <at> gmail.com>
to control <at> debbugs.gnu.org.
(Thu, 10 Nov 2022 13:44:03 GMT) Full text and rfc822 format available.Ludovic Courtès <ludo <at> gnu.org>
to control <at> debbugs.gnu.org.
(Thu, 17 Nov 2022 17:32:02 GMT) Full text and rfc822 format available.Debbugs Internal Request <help-debbugs <at> gnu.org>
to internal_control <at> debbugs.gnu.org.
(Sun, 25 Dec 2022 12:24:06 GMT) Full text and rfc822 format available.
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.