diff options
Diffstat (limited to 'guix/scripts/environment.scm')
-rw-r--r-- | guix/scripts/environment.scm | 159 |
1 files changed, 131 insertions, 28 deletions
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 67da6fc3bf..4f88c513c0 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2018 David Thompson <davet@gnu.org> ;;; Copyright © 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2018 Mike Gerwitz <mtg@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -160,6 +161,13 @@ COMMAND or an interactive shell in that environment.\n")) (display (G_ " -N, --network allow containers to access the network")) (display (G_ " + -P, --link-profile link environment profile to ~/.guix-profile within + an isolated 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")) + (display (G_ " --share=SPEC for containers, share writable host file system according to SPEC")) (display (G_ " @@ -243,6 +251,13 @@ COMMAND or an interactive shell in that environment.\n")) (option '(#\N "network") #f #f (lambda (opt name arg result) (alist-cons 'network? #t result))) + (option '(#\P "link-profile") #f #f + (lambda (opt name arg result) + (alist-cons 'link-profile? #t result))) + (option '(#\u "user") #t #f + (lambda (opt name arg result) + (alist-cons 'user arg + (alist-delete 'user result eq?)))) (option '("share") #t #f (lambda (opt name arg result) (alist-cons 'file-system-mapping @@ -403,41 +418,50 @@ environment variables are cleared before setting the new ones." (pid (match (waitpid pid) ((_ . status) status))))) -(define* (launch-environment/container #:key command bash user-mappings - profile paths network?) +(define* (launch-environment/container #:key command bash user user-mappings + profile paths link-profile? network?) "Run COMMAND within a container that features the software in PROFILE. Environment variables are set according to PATHS, a list of native search paths. 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." +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." (mlet %store-monad ((reqs (inputs->requisites (list (direct-store-path bash) profile)))) (return - (let* ((cwd (getcwd)) - (passwd (getpwuid (getuid))) + (let* ((cwd (getcwd)) + (home (getenv "HOME")) + (passwd (mock-passwd (getpwuid (getuid)) + user + bash)) + (home-dir (passwd:dir passwd)) ;; Bind-mount all requisite store items, user-specified mappings, ;; /bin/sh, the current working directory, and possibly networking ;; configuration files within the container. (mappings - (append user-mappings - ;; Current working directory. - (list (file-system-mapping - (source cwd) - (target cwd) - (writable? #t))) - ;; When in Rome, do as Nix build.cc does: Automagically - ;; map common network configuration files. - (if network? - %network-file-mappings - '()) - ;; Mappings for the union closure of all inputs. - (map (lambda (dir) - (file-system-mapping - (source dir) - (target dir) - (writable? #f))) - reqs))) + (override-user-mappings + user home + (append user-mappings + ;; Current working directory. + (list (file-system-mapping + (source cwd) + (target cwd) + (writable? #t))) + ;; When in Rome, do as Nix build.cc does: Automagically + ;; map common network configuration files. + (if network? + %network-file-mappings + '()) + ;; Mappings for the union closure of all inputs. + (map (lambda (dir) + (file-system-mapping + (source dir) + (target dir) + (writable? #f))) + reqs)))) (file-systems (append %container-file-systems (map file-system-mapping->bind-mount mappings)))) @@ -458,10 +482,14 @@ host file systems to mount inside the container." ;; The same variables as in Nix's 'build.cc'. '("TMPDIR" "TEMPDIR" "TMP" "TEMP")) - ;; Create a dummy home directory under the same name as on the - ;; host. - (mkdir-p (passwd:dir passwd)) - (setenv "HOME" (passwd:dir passwd)) + ;; Create a dummy home directory. + (mkdir-p home-dir) + (setenv "HOME" home-dir) + + ;; If requested, link $GUIX_ENVIRONMENT to $HOME/.guix-profile; + ;; this allows programs expecting that path to continue working as + ;; expected within a container. + (when link-profile? (link-environment profile home-dir)) ;; Create a dummy /etc/passwd to satisfy applications that demand ;; to read it, such as 'git clone' over SSH, a valid use-case when @@ -481,7 +509,7 @@ host file systems to mount inside the container." ;; For convenience, start in the user's current working ;; directory rather than the root directory. - (chdir cwd) + (chdir (override-user-dir user home cwd)) (primitive-exit/status ;; A container's environment is already purified, so no need to @@ -491,6 +519,72 @@ host file systems to mount inside the container." (delq 'net %namespaces) ; share host network %namespaces))))))) +(define (mock-passwd passwd user-override shell) + "Generate mock information for '/etc/passwd'. If USER-OVERRIDE is not '#f', +it is expected to be a string representing the mock username; it will produce +a user of that name, with a home directory of '/home/USER-OVERRIDE', and no +GECOS field. If USER-OVERRIDE is '#f', data will be inherited from PASSWD. +In either case, the shadow password and UID/GID are cleared, since the user +runs as root within the container. SHELL will always be used in place of the +shell in PASSWD. + +The resulting vector is suitable for use with Guile's POSIX user procedures. + +See passwd(5) for more information each of the fields." + (if user-override + (vector + user-override + "x" "0" "0" ;; no shadow, user is now root + "" ;; no personal information + (user-override-home user-override) + shell) + (vector + (passwd:name passwd) + "x" "0" "0" ;; no shadow, user is now root + (passwd:gecos passwd) + (passwd:dir passwd) + shell))) + +(define (user-override-home user) + "Return home directory for override user USER." + (string-append "/home/" user)) + +(define (override-user-mappings user home mappings) + "If a username USER is provided, rewrite each HOME prefix in file system +mappings MAPPINGS to a home directory determined by 'override-user-dir'; +otherwise, return MAPPINGS." + (if (not user) + mappings + (map (lambda (mapping) + (let ((target (file-system-mapping-target mapping))) + (if (string-prefix? home target) + (file-system-mapping + (source (file-system-mapping-source mapping)) + (target (override-user-dir user home target)) + (writable? (file-system-mapping-writable? mapping))) + mapping))) + mappings))) + +(define (override-user-dir user home dir) + "If username USER is provided, overwrite string prefix HOME in DIR with a +directory determined by 'user-override-home'; otherwise, return DIR." + (if (and user (string-prefix? home dir)) + (string-append (user-override-home user) + (substring dir (string-length home))) + dir)) + +(define (link-environment profile home-dir) + "Create a symbolic link from HOME-DIR/.guix-profile to PROFILE." + (let ((profile-dir (string-append home-dir "/.guix-profile"))) + (catch 'system-error + (lambda () + (symlink profile profile-dir)) + (lambda args + (if (= EEXIST (system-error-errno args)) + (leave (G_ "cannot link profile: '~a' already exists within container~%") + profile-dir) + (apply throw args)))))) + (define (environment-bash container? bootstrap? system) "Return a monadic value in the store monad for the version of GNU Bash needed in the environment for SYSTEM, if any. If CONTAINER? is #f, return #f. @@ -564,7 +658,9 @@ message if any test fails." (let* ((opts (parse-args args)) (pure? (assoc-ref opts 'pure)) (container? (assoc-ref opts 'container?)) + (link-prof? (assoc-ref opts 'link-profile?)) (network? (assoc-ref opts 'network?)) + (user (assoc-ref opts 'user)) (bootstrap? (assoc-ref opts 'bootstrap?)) (system (assoc-ref opts 'system)) (command (or (assoc-ref opts 'exec) @@ -597,6 +693,11 @@ message if any test fails." (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'~%"))) + (with-store store (set-build-options-from-command-line store opts) @@ -643,9 +744,11 @@ message if any test fails." "/bin/sh")))) (launch-environment/container #:command command #:bash bash-binary + #:user user #:user-mappings mappings #:profile profile #:paths paths + #:link-profile? link-prof? #:network? network?))) (else (return |