summaryrefslogtreecommitdiff
path: root/guix/scripts
diff options
context:
space:
mode:
Diffstat (limited to 'guix/scripts')
-rw-r--r--guix/scripts/environment.scm170
1 files changed, 146 insertions, 24 deletions
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 2493134470..cf99760859 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2014, 2015, 2018 David Thompson <davet@gnu.org>
;;; Copyright © 2015-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Mike Gerwitz <mtg@gnu.org>
+;;; Copyright © 2022 John Kehayias <john.kehayias@protonmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -120,6 +121,9 @@ shell'."
--expose=SPEC for containers, expose read-only host file system
according to SPEC"))
(display (G_ "
+ -F, --emulate-fhs for containers, emulate the Filesystem Hierarchy
+ Standard (FHS)"))
+ (display (G_ "
-v, --verbosity=LEVEL use the given verbosity LEVEL"))
(display (G_ "
--bootstrap use bootstrap binaries to build the environment")))
@@ -256,6 +260,9 @@ use '--preserve' instead~%"))
(alist-cons 'file-system-mapping
(specification->file-system-mapping arg #f)
result)))
+ (option '(#\F "emulate-fhs") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'emulate-fhs? #t result)))
(option '(#\r "root") #t #f
(lambda (opt name arg result)
(alist-cons 'gc-root arg result)))
@@ -375,6 +382,65 @@ requisite store items i.e. the union closure of all the inputs."
input->requisites inputs)))
(return (delete-duplicates (concatenate reqs)))))
+(define (setup-fhs profile)
+ "Setup the FHS container by creating and linking expected directories from
+PROFILE (other bind mounts are done in LAUNCH-ENVIRONMENT/CONTAINER),
+providing a symlink for CC if GCC is in the container PROFILE, and writing
+/etc/ld.so.conf."
+ ;; Additional symlinks for an FHS container.
+ (define fhs-symlinks
+ `(("/lib" . "/usr/lib")
+ ,(if (target-64bit?)
+ '("/lib" . "/lib64")
+ '("/lib" . "/lib32"))
+ ("/bin" . "/usr/bin")
+ ("/sbin" . "/usr/sbin")))
+
+ ;; A procedure to symlink the contents (at the top level) of a directory,
+ ;; excluding the directory itself and parent, along with any others provided
+ ;; in EXCLUDE.
+ (define* (link-contents dir #:key (exclude '()))
+ (for-each (lambda (file)
+ (symlink (string-append profile dir "/" file)
+ (string-append dir "/" file)))
+ (scandir (string-append profile dir)
+ (negate (cut member <>
+ (append exclude '("." ".." )))))))
+
+ ;; The FHS container sets up the expected filesystem through MAPPINGS with
+ ;; FHS-MAPPINGS (in LAUNCH-ENVIRONMENT/CONTAINER), the symlinks through
+ ;; FHS-SYMLINKS, and linking the contents of PROFILE/bin and PROFILE/etc
+ ;; using LINK-CONTENTS, as these both have or will have contents for a
+ ;; non-FHS container so must be handled separately.
+ (mkdir-p "/usr")
+ (for-each (lambda (link)
+ (if (file-exists? (car link))
+ (symlink (car link) (cdr link))))
+ fhs-symlinks)
+ (link-contents "/bin" #:exclude '("sh"))
+ (mkdir-p "/etc")
+ (link-contents "/etc")
+
+ ;; Provide a frequently expected 'cc' symlink to gcc (in case it is in
+ ;; PROFILE), though this could also be done by the user in the container,
+ ;; e.g. in $HOME/.local/bin and adding that to $PATH. Note: we do this in
+ ;; /bin since that already has the sh symlink and the other (optional) FHS
+ ;; bin directories will link to /bin.
+ (let ((gcc-path (string-append profile "/bin/gcc")))
+ (if (file-exists? gcc-path)
+ (symlink gcc-path "/bin/cc")))
+
+ ;; Guix's ldconfig doesn't search in FHS default locations, so provide a
+ ;; minimal ld.so.conf.
+ (call-with-output-file "/etc/ld.so.conf"
+ (lambda (port)
+ (for-each (lambda (directory)
+ (display directory port)
+ (newline port))
+ ;; /lib/nss is needed as Guix's nss puts libraries
+ ;; there rather than in the lib directory.
+ '("/lib" "/lib/nss")))))
+
(define (status->exit-code status)
"Compute the exit code made from STATUS, a value as returned by 'waitpid',
and suitable for 'exit'."
@@ -386,11 +452,13 @@ and suitable for 'exit'."
(define primitive-exit/status (compose primitive-exit status->exit-code))
(define* (launch-environment command profile manifest
- #:key pure? (white-list '()))
+ #:key pure? (white-list '())
+ emulate-fhs?)
"Run COMMAND in a new environment containing INPUTS, using the native search
paths defined by the list PATHS. When PURE?, pre-existing environment
variables are cleared before setting the new ones, except those matching the
-regexps in WHITE-LIST."
+regexps in WHITE-LIST. When EMULATE-FHS?, first set up an FHS environment
+with $PATH and generate the LD cache."
;; Properly handle SIGINT, so pressing C-c in an interactive terminal
;; application works.
(sigaction SIGINT SIG_DFL)
@@ -406,6 +474,12 @@ regexps in WHITE-LIST."
((program . args)
(catch 'system-error
(lambda ()
+ (when emulate-fhs?
+ ;; When running in a container with EMULATE-FHS?, override $PATH
+ ;; (optional, but to better match FHS expectations), and generate
+ ;; /etc/ld.so.cache.
+ (setenv "PATH" "/bin:/usr/bin:/sbin:/usr/sbin")
+ (invoke "ldconfig" "-X"))
(apply execlp program program args))
(lambda _
;; Report the error from here because the parent process cannot
@@ -604,16 +678,24 @@ regexps in WHITE-LIST."
(define* (launch-environment/container #:key command bash user user-mappings
profile manifest link-profile? network?
- map-cwd? (white-list '()))
+ map-cwd? emulate-fhs? (setup-hook #f)
+ (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 NETWORK?, access to the host system network is permitted.
-USER-MAPPINGS, a list of file system mappings, contains the user-specified
-host file systems to mount inside the container. If USER is not #f, each
-target of USER-MAPPINGS will be re-written relative to '/home/USER', and USER
-will be used for the passwd entry. LINK-PROFILE? creates a symbolic link from
-~/.guix-profile to the environment 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
+NETWORK?, access to the host system network is permitted. USER-MAPPINGS, a
+list of file system mappings, contains the user-specified host file systems to
+mount inside the container. If USER is not #f, each target of USER-MAPPINGS
+will be re-written relative to '/home/USER', and USER will be used for the
+passwd entry.
+
+When EMULATE-FHS?, set up the container to follow the Filesystem Hierarchy
+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.
+
+LINK-PROFILE? creates a symbolic link from ~/.guix-profile to the
+environment profile.
Preserve environment variables whose name matches the one of the regexps in
WHILE-LIST."
@@ -621,6 +703,21 @@ WHILE-LIST."
(and (file-exists? (file-system-mapping-source mapping))
(file-system-mapping->bind-mount mapping)))
+ ;; File system mappings for an FHS container, where the entire directory can
+ ;; be mapped. Others (bin and etc) will already have contents and need to
+ ;; use LINK-CONTENTS (defined in SETUP-FHS) to symlink the directory
+ ;; contents.
+ (define fhs-mappings
+ (map (lambda (mapping)
+ (file-system-mapping
+ (source (string-append profile (car mapping)))
+ (target (cdr mapping))))
+ '(("/lib" . "/lib")
+ ("/include" . "/usr/include")
+ ("/sbin" . "/sbin")
+ ("/libexec" . "/usr/libexec")
+ ("/share" . "/usr/share"))))
+
(mlet %store-monad ((reqs (inputs->requisites
(list (direct-store-path bash) profile))))
(return
@@ -675,6 +772,11 @@ 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)
+ '())
(map file-system-mapping->bind-mount
mappings))))
(exit/status
@@ -702,6 +804,10 @@ WHILE-LIST."
(mkdir-p home-dir)
(setenv "HOME" home-dir)
+ ;; Call an additional setup procedure, if provided.
+ (when setup-hook
+ (setup-hook profile))
+
;; If requested, link $GUIX_ENVIRONMENT to $HOME/.guix-profile;
;; this allows programs expecting that path to continue working as
;; expected within a container.
@@ -743,7 +849,8 @@ WHILE-LIST."
(if link-profile?
(string-append home-dir "/.guix-profile")
profile)
- manifest #:pure? #f)))
+ manifest #:pure? #f
+ #:emulate-fhs? emulate-fhs?)))
#:guest-uid uid
#:guest-gid gid
#:namespaces (if network?
@@ -867,16 +974,17 @@ message if any test fails."
"Run the 'guix environment' command on OPTS, an alist resulting for
command-line option processing with 'parse-command-line'."
(with-error-handling
- (let* ((pure? (assoc-ref opts 'pure))
- (container? (assoc-ref opts 'container?))
- (link-prof? (assoc-ref opts 'link-profile?))
- (network? (assoc-ref opts 'network?))
- (no-cwd? (assoc-ref opts 'no-cwd?))
- (user (assoc-ref opts 'user))
- (bootstrap? (assoc-ref opts 'bootstrap?))
- (system (assoc-ref opts 'system))
- (profile (assoc-ref opts 'profile))
- (command (or (assoc-ref opts 'exec)
+ (let* ((pure? (assoc-ref opts 'pure))
+ (container? (assoc-ref opts 'container?))
+ (link-prof? (assoc-ref opts 'link-profile?))
+ (network? (assoc-ref opts 'network?))
+ (no-cwd? (assoc-ref opts 'no-cwd?))
+ (emulate-fhs? (assoc-ref opts 'emulate-fhs?))
+ (user (assoc-ref opts 'user))
+ (bootstrap? (assoc-ref opts 'bootstrap?))
+ (system (assoc-ref opts 'system))
+ (profile (assoc-ref opts 'profile))
+ (command (or (assoc-ref opts 'exec)
;; Spawn a shell if the user didn't specify
;; anything in particular.
(if container?
@@ -915,12 +1023,22 @@ command-line option processing with 'parse-command-line'."
(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~'%")))
(with-store/maybe store
(with-status-verbosity (assoc-ref opts 'verbosity)
(define manifest-from-opts
- (options/resolve-packages store opts))
+ (options/resolve-packages
+ store
+ ;; For an FHS-container, add the (hidden) package glibc-for-fhs
+ ;; which uses the global cache at /etc/ld.so.cache.
+ (if emulate-fhs?
+ (alist-cons 'expression
+ '(ad-hoc-package "(@@ (gnu packages base) glibc-for-fhs)")
+ opts)
+ opts)))
(define manifest
(if profile
@@ -994,7 +1112,11 @@ when using '--container'; doing nothing~%"))
#:white-list white-list
#:link-profile? link-prof?
#:network? network?
- #:map-cwd? (not no-cwd?))))
+ #:map-cwd? (not no-cwd?)
+ #:emulate-fhs? emulate-fhs?
+ #:setup-hook
+ (and emulate-fhs?
+ setup-fhs))))
(else
(return