@@ -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)
@@ -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.
@@ -533,43 +533,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))))
@@ -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.
@@ -44,9 +44,13 @@ if has_container_support; then
--symlink=/usr/bin/guile=bin/guile -- \
/usr/bin/guile --version
- # A bad symlink spec causes the command to fail.
+ # An invalid symlink spec causes the command to fail.
! guix shell --bootstrap -CS bin/guile=/usr/bin/guile guile-bootstrap \
-- exit
+
+ # A dangling symlink causes the command to fail.
+ ! guix shell --bootstrap -CS /usr/bin/python=bin/python guile-bootstrap \
+ -- exit
fi
# '--ad-hoc' is a thing of the past.