GNU bug report logs - #59162
[PATCH] Add '--symlink' to 'guix shell'

Previous Next

To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 59162 in the body.
You can then email your comments to 59162 AT debbugs.gnu.org in the normal way.

Toggle the display of automated, internal messages from the tracker.

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 3/4] guix: shell: Add '--symlink' option.
Date: Wed,  9 Nov 2022 23:23:50 -0500

* 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))))
+
 
 ;;;
 ;;; 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

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.