[bug#59162] [PATCH v2 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): Extract symlink->directives logic to...
* gnu/build/install.scm (make-symlink->directives): ... here.  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.
Create symlinks using evaluate-populate-directive and
make-symlink->directives.
(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 ++++-
 gnu/build/install.scm               | 18 +++++++++
 guix/scripts/environment.scm        | 38 ++++++++++++++-----
 guix/scripts/pack.scm               | 57 ++++++++++++-----------------
 tests/guix-environment-container.sh | 12 ++++++
 tests/guix-shell.sh                 |  3 ++
 6 files changed, 92 insertions(+), 45 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/gnu/build/install.scm b/gnu/build/install.scm
index 33a9616c0d..031a97e91b 100644
--- a/gnu/build/install.scm
+++ b/gnu/build/install.scm
@@ -19,6 +19,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu build install)
+  #:use-module ((guix build union) #:select (relative-file-name))
   #:use-module (guix build syscalls)
   #:use-module (guix build utils)
   #:use-module (guix build store-copy)
@@ -26,6 +27,7 @@ (define-module (gnu build install)
   #:use-module (ice-9 match)
   #:export (install-boot-config
             evaluate-populate-directive
+            make-symlink->directives
             populate-root-file-system
             install-database-and-gc-roots
             populate-single-profile-directory
@@ -124,6 +126,22 @@ (define target* (if (string-suffix? "/" target)
                 directive)
         (apply throw args)))))
 
+(define (make-symlink->directives directory)
+  "Return a procedure that turn symlinks specs into directives that target
+DIRECTORY."
+  (match-lambda
+    ((source '-> target)
+     (let ((target (string-append directory "/" target))
+           (parent (dirname source)))
+       ;; Never add a 'directory' directive for "/" so as to preserve its
+       ;; ownership and avoid adding the same entries multiple times.
+       `(,@(if (string=? parent "/")
+               '()
+               `((directory ,parent)))
+         ;; Note: a relative file name is used for compatibility with
+         ;; relocatable packs.
+         (,source -> ,(relative-file-name parent target)))))))
+
 (define (directives store)
   "Return a list of directives to populate the root file system that will host
 STORE."
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index de9bc8f98d..7174dd72d2 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,10 @@ (define fhs-mappings
             (mkdir-p home-dir)
             (setenv "HOME" home-dir)
 
+            ;; Create symlinks.
+            (for-each (cut evaluate-populate-directive <> ".")
+                      (append-map (make-symlink->directives profile) symlinks))
+
             ;; Call an additional setup procedure, if provided.
             (when setup-hook
               (setup-hook profile))
@@ -970,6 +984,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 +1025,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 +1116,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..e3bddc4274 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.
@@ -204,30 +221,15 @@ (define (import-module? module)
         (use-modules (guix build pack)
                      (guix build store-copy)
                      (guix build utils)
-                     ((guix build union) #:select (relative-file-name))
                      (gnu build install)
                      (srfi srfi-1)
-                     (srfi srfi-26)
-                     (ice-9 match))
+                     (srfi srfi-26))
 
         (define %root "root")
 
-        (define symlink->directives
-          ;; Return "populate directives" to make the given symlink and its
-          ;; parent directories.
-          (match-lambda
-            ((source '-> target)
-             (let ((target (string-append #$profile "/" target))
-                   (parent (dirname source)))
-               ;; Never add a 'directory' directive for "/" so as to
-               ;; preserve its ownership when extracting the archive (see
-               ;; below), and also because this would lead to adding the
-               ;; same entries twice in the tarball.
-               `(,@(if (string=? parent "/")
-                       '()
-                       `((directory ,parent)))
-                 (,source
-                  -> ,(relative-file-name parent target)))))))
+        ;; Return "populate directives" to make the given symlink and its
+        ;; parent directories.
+        (define symlink->directives (make-symlink->directives #$profile))
 
         (define directives
           ;; Fully-qualified symlinks.
@@ -1208,20 +1210,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..b509e52e26 100644
--- a/tests/guix-environment-container.sh
+++ b/tests/guix-environment-container.sh
@@ -241,3 +241,15 @@ 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
+
+# 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
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