mirror of
https://codeberg.org/guix/guix.git
synced 2025-10-02 02:15:12 +00:00
environment: Add '--nesting'.
* guix/scripts/environment.scm (show-environment-options-help) (%options): Add '--nesting'. (options/resolve-packages): Handle it. (launch-environment/container): Add #:nesting? and honor it. [nesting-mappings]: New procedure. (guix-environment*): Add support for '--nesting'. * guix/scripts/shell.scm (profile-cached-gc-root): Special-case 'nesting?'. * tests/guix-environment-container.sh: Test it. * doc/guix.texi (Invoking guix shell): Document it.
This commit is contained in:
Ludovic Courtès
Ludovic Courtès
parent
58769f9273
commit
57db09aae7
4 changed files with 124 additions and 4 deletions
|
|
@ -31,6 +31,8 @@
|
|||
#:use-module (guix build utils)
|
||||
#:use-module (guix monads)
|
||||
#:use-module ((guix gexp) #:select (lower-object))
|
||||
#:autoload (guix describe) (current-profile current-channels)
|
||||
#:autoload (guix channels) (guix-channel? channel-commit)
|
||||
#:use-module (guix scripts)
|
||||
#:use-module (guix scripts build)
|
||||
#:autoload (guix scripts pack) (symlink-spec-option-parser)
|
||||
|
|
@ -49,9 +51,11 @@
|
|||
#:autoload (gnu packages) (specification->package+output)
|
||||
#:autoload (gnu packages bash) (bash)
|
||||
#:autoload (gnu packages bootstrap) (bootstrap-executable %bootstrap-guile)
|
||||
#:autoload (gnu packages package-management) (guix)
|
||||
#:use-module (ice-9 match)
|
||||
#:autoload (ice-9 rdelim) (read-line)
|
||||
#:use-module (ice-9 vlist)
|
||||
#:autoload (web uri) (string->uri uri-scheme)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-11)
|
||||
#:use-module (srfi srfi-26)
|
||||
|
|
@ -108,6 +112,8 @@ shell'."
|
|||
-P, --link-profile link environment profile to ~/.guix-profile within
|
||||
an isolated container"))
|
||||
(display (G_ "
|
||||
-W, --nesting make Guix available within the container"))
|
||||
(display (G_ "
|
||||
-u, --user=USER instead of copying the name and home of the current
|
||||
user into an isolated container, use the name USER
|
||||
with home directory /home/USER"))
|
||||
|
|
@ -238,6 +244,9 @@ use '--preserve' instead~%"))
|
|||
(option '(#\N "network") #f #f
|
||||
(lambda (opt name arg result)
|
||||
(alist-cons 'network? #t result)))
|
||||
(option '(#\W "nesting") #f #f
|
||||
(lambda (opt name arg result)
|
||||
(alist-cons 'nesting? #t result)))
|
||||
(option '(#\P "link-profile") #f #f
|
||||
(lambda (opt name arg result)
|
||||
(alist-cons 'link-profile? #t result)))
|
||||
|
|
@ -342,6 +351,26 @@ for the corresponding packages."
|
|||
(packages->outputs (load* file module) mode)))
|
||||
(('manifest . file)
|
||||
(manifest-entries (load-manifest file)))
|
||||
(('nesting? . #t)
|
||||
(if (assoc-ref opts 'profile)
|
||||
'()
|
||||
(let ((profile (and=> (current-profile) readlink*)))
|
||||
(if (or (not profile) (not (store-path? profile)))
|
||||
(begin
|
||||
(warning (G_ "\
|
||||
could not add current Guix to the profile~%"))
|
||||
'())
|
||||
(list (manifest-entry
|
||||
(name "guix")
|
||||
(version
|
||||
(or (any (lambda (channel)
|
||||
(and (guix-channel? channel)
|
||||
(channel-commit channel)))
|
||||
(current-channels))
|
||||
"0"))
|
||||
(item profile)
|
||||
(search-paths
|
||||
(package-native-search-paths guix))))))))
|
||||
(_ '()))
|
||||
opts)
|
||||
manifest-entry=?)))
|
||||
|
|
@ -688,7 +717,8 @@ 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)
|
||||
map-cwd? emulate-fhs? nesting?
|
||||
(setup-hook #f)
|
||||
(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
|
||||
|
|
@ -704,6 +734,9 @@ Standard and provide a glibc that reads the cache from /etc/ld.so.cache.
|
|||
SETUP-HOOK is an additional setup procedure to be called, currently only used
|
||||
with the EMULATE-FHS? option.
|
||||
|
||||
When NESTING? is true, share all the store with the container and add Guix to
|
||||
its profile, allowing its use from within the container.
|
||||
|
||||
LINK-PROFILE? creates a symbolic link from ~/.guix-profile to the
|
||||
environment profile.
|
||||
|
||||
|
|
@ -731,8 +764,26 @@ WHILE-LIST."
|
|||
("/libexec" . "/usr/libexec")
|
||||
("/share" . "/usr/share"))))
|
||||
|
||||
(mlet %store-monad ((reqs (inputs->requisites
|
||||
(list (direct-store-path bash) profile))))
|
||||
(define (nesting-mappings)
|
||||
;; Files shared with the host when enabling nesting.
|
||||
(cons* (file-system-mapping
|
||||
(source (%store-prefix))
|
||||
(target source))
|
||||
(file-system-mapping
|
||||
(source (cache-directory))
|
||||
(target source)
|
||||
(writable? #t))
|
||||
(let ((uri (string->uri (%daemon-socket-uri))))
|
||||
(if (or (not uri) (eq? 'file (uri-scheme uri)))
|
||||
(list (file-system-mapping
|
||||
(source (%daemon-socket-uri))
|
||||
(target source)))
|
||||
'()))))
|
||||
|
||||
(mlet %store-monad ((reqs (if nesting?
|
||||
(return '())
|
||||
(inputs->requisites
|
||||
(list (direct-store-path bash) profile)))))
|
||||
(return
|
||||
(let* ((cwd (getcwd))
|
||||
(home (getenv "HOME"))
|
||||
|
|
@ -795,11 +846,14 @@ WHILE-LIST."
|
|||
(filter-map optional-mapping->fs
|
||||
%network-file-mappings)
|
||||
'())
|
||||
;; Mappings for an FHS container.
|
||||
(if emulate-fhs?
|
||||
(filter-map optional-mapping->fs
|
||||
fhs-mappings)
|
||||
'())
|
||||
(if nesting?
|
||||
(filter-map optional-mapping->fs
|
||||
(nesting-mappings))
|
||||
'())
|
||||
(map file-system-mapping->bind-mount
|
||||
mappings))))
|
||||
(exit/status
|
||||
|
|
@ -1013,6 +1067,7 @@ command-line option processing with 'parse-command-line'."
|
|||
(network? (assoc-ref opts 'network?))
|
||||
(no-cwd? (assoc-ref opts 'no-cwd?))
|
||||
(emulate-fhs? (assoc-ref opts 'emulate-fhs?))
|
||||
(nesting? (assoc-ref opts 'nesting?))
|
||||
(user (assoc-ref opts 'user))
|
||||
(bootstrap? (assoc-ref opts 'bootstrap?))
|
||||
(system (assoc-ref opts 'system))
|
||||
|
|
@ -1059,6 +1114,8 @@ command-line option processing with 'parse-command-line'."
|
|||
(leave (G_ "--no-cwd cannot be used without '--container'~%")))
|
||||
(when emulate-fhs?
|
||||
(leave (G_ "'--emulate-fhs' cannot be used without '--container~%'")))
|
||||
(when nesting?
|
||||
(leave (G_ "'--nesting' cannot be used without '--container~%'")))
|
||||
(when (pair? symlinks)
|
||||
(leave (G_ "'--symlink' cannot be used without '--container~%'"))))
|
||||
|
||||
|
|
@ -1141,6 +1198,7 @@ when using '--container'; doing nothing~%"))
|
|||
#:network? network?
|
||||
#:map-cwd? (not no-cwd?)
|
||||
#:emulate-fhs? emulate-fhs?
|
||||
#:nesting? nesting?
|
||||
#:symlinks symlinks
|
||||
#:setup-hook
|
||||
(and emulate-fhs?
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue