[bug#58812] [PATCH 5/5] shell: Detect --symlink spec problems early.

[Maxim Cournoyer <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 +-
 tests/guix-shell.sh          |   6 +-
 5 files changed, 278 insertions(+), 256 deletions(-)

diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index bd95329c5c..0906b48508 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 a2836629ad..7708ce62a9 100644
--- a/guix/scripts/shell.scm
+++ b/guix/scripts/shell.scm
@@ -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))))
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.
diff --git a/tests/guix-shell.sh b/tests/guix-shell.sh
index 32dd997fe7..70dd852009 100644
--- a/tests/guix-shell.sh
+++ b/tests/guix-shell.sh
@@ -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.
-- 
2.37.3