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.
Maxim Cournoyer
parent
0bb872b379
commit
b31ea797ed
|
|
@ -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@*
|
||||
|
|
@ -6246,6 +6246,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
|
||||
|
|
@ -7038,6 +7044,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
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
Reference in New Issue