[bug#58812] [PATCH v3 3/4] guix: shell: Add '--symlink' option.

[Maxim Cournoyer <maxim.cournoyer@gmail.com>]

* guix/scripts/pack.scm (%options): Extract symlink parsing logic to...
(symlink-spec-option-parser): ... here.
(self-contained-tarball/builder): Add a comment mentioning why a relative file
name is used for the link target.
* guix/scripts/environment.scm (show-environment-options-help): Document new
--symlink option.
(%default-options): Add default value for symlinks.
(%options): Register new symlink option.
(launch-environment/container): Add #:symlinks argument and extend doc, and
create symlinks using evaluate-populate-directive.
(guix-environment*): Pass symlinks arguments to launch-environment/container.
* doc/guix.texi (Invoking guix shell): Document it.
* tests/guix-shell.sh: Add a --symlink (negative) test.
* tests/guix-environment-container.sh: Add tests.
---
 doc/guix.texi                       |  9 +++++-
 guix/scripts/environment.scm        | 43 ++++++++++++++++++++++-------
 guix/scripts/pack.scm               | 39 ++++++++++++++------------
 tests/guix-environment-container.sh |  9 ++++++
 tests/guix-shell.sh                 |  3 ++
 5 files changed, 75 insertions(+), 28 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 3f76184495..94c3f29790 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -49,7 +49,7 @@ Copyright @copyright{} 2017 humanitiesNerd@*
 Copyright @copyright{} 2017, 2021 Christine Lemmer-Webber@*
 Copyright @copyright{} 2017, 2018, 2019, 2020, 2021, 2022 Marius Bakke@*
 Copyright @copyright{} 2017, 2019, 2020, 2022 Hartmut Goebel@*
-Copyright @copyright{} 2017, 2019, 2020, 2021 Maxim Cournoyer@*
+Copyright @copyright{} 2017, 2019, 2020, 2021, 2022 Maxim Cournoyer@*
 Copyright @copyright{} 2017–2022 Tobias Geerinckx-Rice@*
 Copyright @copyright{} 2017 George Clemmer@*
 Copyright @copyright{} 2017 Andy Wingo@*
@@ -6242,6 +6242,12 @@ directory:
 guix shell --container --expose=$HOME=/exchange guile -- guile
 @end example
 
+@cindex symbolic links, guix shell
+@item --symlink=@var{spec}
+@itemx -S @var{spec}
+For containers, create the symbolic links specified by @var{spec}, as
+documented in @ref{pack-symlink-option}.
+
 @cindex file system hierarchy standard (FHS)
 @cindex FHS (file system hierarchy standard)
 @item --emulate-fhs
@@ -7034,6 +7040,7 @@ Compress the resulting tarball using @var{tool}---one of @code{gzip},
 @code{zstd}, @code{bzip2}, @code{xz}, @code{lzip}, or @code{none} for no
 compression.
 
+@anchor{pack-symlink-option}
 @item --symlink=@var{spec}
 @itemx -S @var{spec}
 Add the symlinks specified by @var{spec} to the pack.  This option can
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index de9bc8f98d..13c6f6cb5c 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -33,8 +33,10 @@ (define-module (guix scripts environment)
   #:use-module ((guix gexp) #:select (lower-object))
   #:use-module (guix scripts)
   #:use-module (guix scripts build)
+  #:autoload   (guix scripts pack) (symlink-spec-option-parser)
   #:use-module (guix transformations)
   #:autoload   (ice-9 ftw) (scandir)
+  #:use-module (gnu build install)
   #:autoload   (gnu build linux-container) (call-with-container %namespaces
                                             user-namespace-supported?
                                             unprivileged-user-namespace-supported?
@@ -120,6 +122,9 @@ (define (show-environment-options-help)
       --expose=SPEC      for containers, expose read-only host file system
                          according to SPEC"))
   (display (G_ "
+  -S, --symlink=SPEC     for containers, add symlinks to the profile according
+                         to SPEC, e.g. \"/usr/bin/env=bin/env\"."))
+  (display (G_ "
   -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
   (display (G_ "
       --bootstrap        use bootstrap binaries to build the environment")))
@@ -157,6 +162,7 @@ (define (show-help)
 (define %default-options
   `((system . ,(%current-system))
     (substitutes? . #t)
+    (symlinks . ())
     (offload? . #t)
     (graft? . #t)
     (print-build-trace? . #t)
@@ -256,6 +262,7 @@ (define %options
                    (alist-cons 'file-system-mapping
                                (specification->file-system-mapping arg #f)
                                result)))
+         (option '(#\S "symlink") #t #f symlink-spec-option-parser)
          (option '(#\r "root") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'gc-root arg result)))
@@ -672,7 +679,7 @@ (define* (launch-environment/fork command profile manifest
 (define* (launch-environment/container #:key command bash user user-mappings
                                        profile manifest link-profile? network?
                                        map-cwd? emulate-fhs? (setup-hook #f)
-                                       (white-list '()))
+                                       (symlinks '()) (white-list '()))
   "Run COMMAND within a container that features the software in PROFILE.
 Environment variables are set according to the search paths of MANIFEST.  The
 global shell is BASH, a file name for a GNU Bash binary in the store.  When
@@ -690,6 +697,9 @@ (define* (launch-environment/container #:key command bash user user-mappings
 LINK-PROFILE? creates a symbolic link from ~/.guix-profile to the
 environment profile.
 
+SYMLINKS must be a list of (SOURCE -> TARGET) tuples denoting symlinks to be
+added to the container.
+
 Preserve environment variables whose name matches the one of the regexps in
 WHILE-LIST."
   (define (optional-mapping->fs mapping)
@@ -797,6 +807,15 @@ (define fhs-mappings
             (mkdir-p home-dir)
             (setenv "HOME" home-dir)
 
+            ;; Create symlinks.
+            (let ((symlink->directives
+                   (match-lambda
+                     ((source '-> target)
+                      `((directory ,(dirname source))
+                        (,source -> ,(string-append profile "/" target)))))))
+              (for-each (cut evaluate-populate-directive <> ".")
+                        (append-map symlink->directives symlinks)))
+
             ;; Call an additional setup procedure, if provided.
             (when setup-hook
               (setup-hook profile))
@@ -970,6 +989,7 @@ (define (guix-environment* opts)
     (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?))
@@ -1010,15 +1030,17 @@ (define-syntax-rule (with-store/maybe store exp ...)
 
       (when container? (assert-container-features))
 
-      (when (and (not container?) link-prof?)
-        (leave (G_ "'--link-profile' cannot be used without '--container'~%")))
-      (when (and (not container?) user)
-        (leave (G_ "'--user' cannot be used without '--container'~%")))
-      (when (and (not container?) no-cwd?)
-        (leave (G_ "--no-cwd cannot be used without '--container'~%")))
-      (when (and (not container?) emulate-fhs?)
-        (leave (G_ "'--emulate-fhs' cannot be used without '--container~%'")))
-
+      (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)
@@ -1099,6 +1121,7 @@ (define manifest
                                                     #:network? network?
                                                     #:map-cwd? (not no-cwd?)
                                                     #:emulate-fhs? emulate-fhs?
+                                                    #:symlinks symlinks
                                                     #:setup-hook
                                                     (and emulate-fhs?
                                                          setup-fhs))))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 06849e4761..a611922db3 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -61,7 +61,9 @@ (define-module (guix scripts pack)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
-  #:export (self-contained-tarball
+  #:export (symlink-spec-option-parser
+
+            self-contained-tarball
             debian-archive
             docker-image
             squashfs-image
@@ -160,6 +162,21 @@ (define str (string-join names "-"))
           ((_) str)
           ((names ... _) (loop names))))))
 
+(define (symlink-spec-option-parser opt name arg result)
+  "A SRFI-37 option parser for the --symlink option."
+  ;; 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 #\=))
+    ((source target)
+     (let ((symlinks (assoc-ref result 'symlinks)))
+       (alist-cons 'symlinks
+                   `((,source -> ,target) ,@symlinks)
+                   (alist-delete 'symlinks result eq?))))
+    (x
+     (leave (G_ "~a: invalid symlink specification~%")
+            arg))))
+
 \f
 ;;;
 ;;; Tarball format.
@@ -226,8 +243,9 @@ (define symlink->directives
                `(,@(if (string=? parent "/")
                        '()
                        `((directory ,parent)))
-                 (,source
-                  -> ,(relative-file-name parent target)))))))
+                 ;; Use a relative file name for compatibility with
+                 ;; relocatable packs.
+                 (,source -> ,(relative-file-name parent target)))))))
 
         (define directives
           ;; Fully-qualified symlinks.
@@ -1208,20 +1226,7 @@ (define %options
                  (lambda (opt name arg result)
                    (alist-cons 'compressor (lookup-compressor arg)
                                result)))
-         (option '(#\S "symlink") #t #f
-                 (lambda (opt name arg result)
-                   ;; 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 #\=))
-                     ((source target)
-                      (let ((symlinks (assoc-ref result 'symlinks)))
-                        (alist-cons 'symlinks
-                                    `((,source -> ,target) ,@symlinks)
-                                    (alist-delete 'symlinks result eq?))))
-                     (x
-                      (leave (G_ "~a: invalid symlink specification~%")
-                             arg)))))
+         (option '(#\S "symlink") #t #f symlink-spec-option-parser)
          (option '("save-provenance") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'save-provenance? #t result)))
diff --git a/tests/guix-environment-container.sh b/tests/guix-environment-container.sh
index fb2c19b193..82192375c7 100644
--- a/tests/guix-environment-container.sh
+++ b/tests/guix-environment-container.sh
@@ -241,3 +241,12 @@ guix shell -CF --bootstrap guile-bootstrap glibc \
                             "glibc-for-fhs")
                            0
                            1))'
+
+# '--symlink' works.
+echo "TESTING SYMLINK IN CONTAINER"
+guix shell --bootstrap guile-bootstrap --container \
+     --symlink=/usr/bin/guile=bin/guile -- \
+     /usr/bin/guile --version
+
+# A dangling symlink causes the command to fail.
+! guix shell --bootstrap -CS /usr/bin/python=bin/python guile-bootstrap -- exit
diff --git a/tests/guix-shell.sh b/tests/guix-shell.sh
index 9a6b055264..cb2b53466d 100644
--- a/tests/guix-shell.sh
+++ b/tests/guix-shell.sh
@@ -32,6 +32,9 @@ export XDG_CONFIG_HOME
 
 guix shell --bootstrap --pure guile-bootstrap -- guile --version
 
+# '--symlink' can only be used with --container.
+! guix shell --bootstrap guile-bootstrap -S /dummy=bin/guile
+
 # '--ad-hoc' is a thing of the past.
 ! guix shell --ad-hoc guile-bootstrap
 
-- 
2.37.3