[PATCH v2 3/4] guix: shell: Add '--symlink' option.
(address . guix-patches@gnu.org)(name . Maxim Cournoyer)(address . maxim.cournoyer@gmail.com)
20221110042351.829-3-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(-)
Toggle diff (321 lines)
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