guix: shell: Add '--symlink' option.

* 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.

2 files changed, 55 insertions, 27 deletions

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 @@
   #: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 @@ shell'."
       --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 @@ COMMAND or an interactive shell in that environment.\n"))
 (define %default-options
   `((system . ,(%current-system))
     (substitutes? . #t)
+    (symlinks . ())
     (offload? . #t)
     (graft? . #t)
     (print-build-trace? . #t)
@@ -256,6 +262,7 @@ use '--preserve' instead~%"))
                    (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 @@ regexps in WHITE-LIST."
 (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 @@ with the EMULATE-FHS? option.
 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 @@ WHILE-LIST."
             (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 @@ command-line option processing with 'parse-command-line'."
     (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 @@ command-line option processing with 'parse-command-line'."
 
       (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 @@ when using '--container'; doing nothing~%"))
                                                     #: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 @@
   #: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 @@ its source property."
           ((_) 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.
@@ -226,8 +243,9 @@ its source property."
                `(,@(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 @@ last resort for relocation."
                  (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)))