;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 2018 David Thompson <davet@gnu.org>
-;;; Copyright © 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Mike Gerwitz <mtg@gnu.org>
;;;
;;; This file is part of GNU Guix.
#:use-module (guix search-paths)
#:use-module (guix build utils)
#:use-module (guix monads)
- #:use-module ((guix gexp) #:select (lower-inputs))
+ #:use-module ((guix gexp) #:select (lower-object))
#:use-module (guix scripts)
#:use-module (guix scripts build)
#:use-module (gnu build linux-container)
+ #:use-module (gnu build accounts)
+ #:use-module ((guix build syscalls) #:select (set-network-interface-up))
#:use-module (gnu system linux-container)
#:use-module (gnu system file-systems)
#:use-module (gnu packages)
#:use-module (gnu packages bash)
- #:use-module (gnu packages commencement)
- #:use-module (gnu packages guile)
- #:use-module ((gnu packages bootstrap) #:select (%bootstrap-guile))
+ #:use-module ((gnu packages bootstrap)
+ #:select (bootstrap-executable %bootstrap-guile))
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-37)
#:use-module (srfi srfi-98)
- #:export (guix-environment))
+ #:export (assert-container-features
+ guix-environment))
;; Protect some env vars from purification. Borrowed from nix-shell.
(define %precious-variables
(display (G_ "
--pure unset existing environment variables"))
(display (G_ "
- --inherit=REGEXP inherit environment variables that match REGEXP"))
+ -E, --preserve=REGEXP preserve environment variables that match REGEXP"))
(display (G_ "
--search-paths display needed environment variable definitions"))
(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_ "
+ --no-cwd do not share current working directory with an
+ isolated container"))
+
(display (G_ "
--share=SPEC for containers, share writable host file system
according to SPEC"))
(newline)
(show-build-options-help)
(newline)
- (show-transformation-options-help)
- (newline)
(display (G_ "
-h, --help display this help and exit"))
(display (G_ "
(define %default-options
`((system . ,(%current-system))
(substitutes? . #t)
- (build-hook? . #t)
+ (offload? . #t)
(graft? . #t)
(print-build-trace? . #t)
(print-extended-build-trace? . #t)
(multiplexed-build-output? . #t)
(debug . 0)
- (verbosity . 2)))
+ (verbosity . 1)))
(define (tag-package-arg opts arg)
"Return a two-element list with the form (TAG ARG) that tags ARG with either
(option '("pure") #f #f
(lambda (opt name arg result)
(alist-cons 'pure #t result)))
- (option '("inherit") #t #f
+ (option '(#\E "preserve") #t #f
(lambda (opt name arg result)
(alist-cons 'inherit-regexp
(make-regexp* arg)
result)))
- (option '(#\E "exec") #t #f ; deprecated
+ (option '("inherit") #t #f ;deprecated
(lambda (opt name arg result)
- (alist-cons 'exec (list %default-shell "-c" arg) result)))
+ (warning (G_ "'--inherit' is deprecated, \
+use '--preserve' instead~%"))
+ (alist-cons 'inherit-regexp
+ (make-regexp* arg)
+ result)))
(option '("search-paths") #f #f
(lambda (opt name arg result)
(alist-cons 'search-paths #t result)))
(alist-cons 'ad-hoc? #t result)))
(option '(#\n "dry-run") #f #f
(lambda (opt name arg result)
- (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
+ (alist-cons 'dry-run? #t result)))
(option '(#\s "system") #t #f
(lambda (opt name arg result)
(alist-cons 'system arg
(lambda (opt name arg result)
(alist-cons 'user arg
(alist-delete 'user result eq?))))
+ (option '("no-cwd") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'no-cwd? #t result)))
(option '("share") #t #f
(lambda (opt name arg result)
(alist-cons 'file-system-mapping
(list (package->manifest-entry* package output))))
(('package 'package (? string? spec))
(package-environment-inputs
- (specification->package+output spec)))
+ (transform (specification->package+output spec))))
(('expression mode str)
;; Add all the outputs of the package STR evaluates to.
(packages->outputs (read/eval str) mode))
opts)
manifest-entry=?)))
-(define* (build-environment derivations opts)
- "Build the DERIVATIONS required by the environment using the build options
-in OPTS."
- (let ((substitutes? (assoc-ref opts 'substitutes?))
- (dry-run? (assoc-ref opts 'dry-run?)))
- (mbegin %store-monad
- (show-what-to-build* derivations
- #:use-substitutes? substitutes?
- #:dry-run? dry-run?)
- (if dry-run?
- (return #f)
- (built-derivations derivations)))))
-
(define (manifest->derivation manifest system bootstrap?)
"Return the derivation for a profile of MANIFEST.
BOOTSTRAP? specifies whether to use the bootstrap Guile to build the profile."
((_ . status) status)))))
(define* (launch-environment/container #:key command bash user user-mappings
- profile manifest link-profile? network?)
+ profile manifest link-profile? network?
+ map-cwd? (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
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."
+~/.guix-profile to the environment profile.
+
+Preserve environment variables whose name matches the one of the regexps in
+WHILE-LIST."
+ (define (optional-mapping->fs mapping)
+ (and (file-exists? (file-system-mapping-source mapping))
+ (file-system-mapping->bind-mount mapping)))
+
(mlet %store-monad ((reqs (inputs->requisites
(list (direct-store-path bash) profile))))
(return
(let* ((cwd (getcwd))
(home (getenv "HOME"))
- (passwd (mock-passwd (getpwuid (getuid))
- user
- bash))
- (home-dir (passwd:dir passwd))
+ (uid (if user 1000 (getuid)))
+ (gid (if user 1000 (getgid)))
+ (passwd (let ((pwd (getpwuid (getuid))))
+ (password-entry
+ (name (or user (passwd:name pwd)))
+ (real-name (if user
+ ""
+ (passwd:gecos pwd)))
+ (uid uid) (gid gid) (shell bash)
+ (directory (if user
+ (string-append "/home/" user)
+ (passwd:dir pwd))))))
+ (groups (list (group-entry (name "users") (gid gid))
+ (group-entry (gid 65534) ;the overflow GID
+ (name "overflow"))))
+ (home-dir (password-entry-directory passwd))
+ (logname (password-entry-name passwd))
+ (environ (filter (match-lambda
+ ((variable . value)
+ (find (cut regexp-exec <> variable)
+ white-list)))
+ (get-environment-variables)))
;; Bind-mount all requisite store items, user-specified mappings,
;; /bin/sh, the current working directory, and possibly networking
;; configuration files within the container.
(mappings
- (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))))
+ (append
+ (override-user-mappings
+ user home
+ (append user-mappings
+ ;; Share current working directory, unless asked not to.
+ (if map-cwd?
+ (list (file-system-mapping
+ (source cwd)
+ (target cwd)
+ (writable? #t)))
+ '())))
+ ;; 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
+ (if network?
+ (filter-map optional-mapping->fs
+ %network-file-mappings)
+ '())
(map file-system-mapping->bind-mount
mappings))))
(exit/status
;; The same variables as in Nix's 'build.cc'.
'("TMPDIR" "TEMPDIR" "TMP" "TEMP"))
+ ;; Some programs expect USER and/or LOGNAME to be set.
+ (setenv "LOGNAME" logname)
+ (setenv "USER" logname)
+
;; Create a dummy home directory.
(mkdir-p home-dir)
(setenv "HOME" home-dir)
;; to read it, such as 'git clone' over SSH, a valid use-case when
;; sharing the host's network namespace.
(mkdir-p "/etc")
- (call-with-output-file "/etc/passwd"
- (lambda (port)
- (display (string-join (list (passwd:name passwd)
- "x" ; but there is no shadow
- "0" "0" ; user is now root
- (passwd:gecos passwd)
- (passwd:dir passwd)
- bash)
- ":")
- port)
- (newline port)))
+ (write-passwd (list passwd))
+ (write-group groups)
+
+ (unless network?
+ ;; When isolated from the network, provide a minimal /etc/hosts
+ ;; to resolve "localhost".
+ (call-with-output-file "/etc/hosts"
+ (lambda (port)
+ (display "127.0.0.1 localhost\n" port)))
+
+ ;; Allow local AF_INET communications.
+ (set-network-interface-up "lo"))
;; For convenience, start in the user's current working
- ;; directory rather than the root directory.
- (chdir (override-user-dir user home cwd))
+ ;; directory or, if unmapped, the home directory.
+ (chdir (if map-cwd?
+ (override-user-dir user home cwd)
+ home-dir))
+
+ ;; Set environment variables that match WHITE-LIST.
+ (for-each (match-lambda
+ ((variable . value)
+ (setenv variable value)))
+ environ)
(primitive-exit/status
;; A container's environment is already purified, so no need to
;; request it be purified again.
- (launch-environment command profile manifest #:pure? #f)))
+ (launch-environment command
+ (if link-profile?
+ (string-append home-dir "/.guix-profile")
+ profile)
+ manifest #:pure? #f)))
+ #:guest-uid uid
+ #:guest-gid gid
#:namespaces (if network?
(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))
(package->derivation bash))
;; Use the bootstrap Bash instead.
((and container? bootstrap?)
- (interned-file
- (search-bootstrap-binary "bash" system)))
+ (lower-object (bootstrap-executable "bash" system)))
(else
(return #f)))))
;;; Entry point.
;;;
-(define (guix-environment . args)
+(define-command (guix-environment . args)
+ (category development)
+ (synopsis "spawn one-off software environments")
+
(with-error-handling
(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?))
+ (no-cwd? (assoc-ref opts 'no-cwd?))
(user (assoc-ref opts 'user))
(bootstrap? (assoc-ref opts 'bootstrap?))
(system (assoc-ref opts 'system))
(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~%")))
+
(with-store store
- (with-status-verbosity (assoc-ref opts 'verbosity)
- (define manifest
- (options/resolve-packages store opts))
-
- (set-build-options-from-command-line store opts)
-
- ;; Use the bootstrap Guile when requested.
- (parameterize ((%graft? (assoc-ref opts 'graft?))
- (%guile-for-build
- (package-derivation
- store
- (if bootstrap?
- %bootstrap-guile
- (canonical-package guile-2.2)))))
- (run-with-store store
- ;; Containers need a Bourne shell at /bin/sh.
- (mlet* %store-monad ((bash (environment-bash container?
- bootstrap?
- system))
- (prof-drv (manifest->derivation
- manifest system bootstrap?))
- (profile -> (derivation->output-path prof-drv))
- (gc-root -> (assoc-ref opts 'gc-root)))
-
- ;; First build the inputs. This is necessary even for
- ;; --search-paths. Additionally, we might need to build bash for
- ;; a container.
- (mbegin %store-monad
- (build-environment (if (derivation? bash)
- (list prof-drv bash)
- (list prof-drv))
- opts)
- (mwhen gc-root
- (register-gc-root profile gc-root))
-
- (cond
- ((assoc-ref opts 'dry-run?)
- (return #t))
- ((assoc-ref opts 'search-paths)
- (show-search-paths profile manifest #:pure? pure?)
- (return #t))
- (container?
- (let ((bash-binary
- (if bootstrap?
- bash
- (string-append (derivation->output-path bash)
- "/bin/sh"))))
- (launch-environment/container #:command command
- #:bash bash-binary
- #:user user
- #:user-mappings mappings
- #:profile profile
- #:manifest manifest
- #:link-profile? link-prof?
- #:network? network?)))
- (else
- (return
- (exit/status
- (launch-environment/fork command profile manifest
- #:white-list white-list
- #:pure? pure?))))))))))))))
+ (with-build-handler (build-notifier #:use-substitutes?
+ (assoc-ref opts 'substitutes?)
+ #:verbosity
+ (assoc-ref opts 'verbosity)
+ #:dry-run?
+ (assoc-ref opts 'dry-run?))
+ (with-status-verbosity (assoc-ref opts 'verbosity)
+ (define manifest
+ (options/resolve-packages store opts))
+
+ (set-build-options-from-command-line store opts)
+
+ ;; Use the bootstrap Guile when requested.
+ (parameterize ((%graft? (assoc-ref opts 'graft?))
+ (%guile-for-build
+ (package-derivation
+ store
+ (if bootstrap?
+ %bootstrap-guile
+ (default-guile)))))
+ (run-with-store store
+ ;; Containers need a Bourne shell at /bin/sh.
+ (mlet* %store-monad ((bash (environment-bash container?
+ bootstrap?
+ system))
+ (prof-drv (manifest->derivation
+ manifest system bootstrap?))
+ (profile -> (derivation->output-path prof-drv))
+ (gc-root -> (assoc-ref opts 'gc-root)))
+
+ ;; First build the inputs. This is necessary even for
+ ;; --search-paths. Additionally, we might need to build bash for
+ ;; a container.
+ (mbegin %store-monad
+ (built-derivations (if (derivation? bash)
+ (list prof-drv bash)
+ (list prof-drv)))
+ (mwhen gc-root
+ (register-gc-root profile gc-root))
+
+ (cond
+ ((assoc-ref opts 'search-paths)
+ (show-search-paths profile manifest #:pure? pure?)
+ (return #t))
+ (container?
+ (let ((bash-binary
+ (if bootstrap?
+ (derivation->output-path bash)
+ (string-append (derivation->output-path bash)
+ "/bin/sh"))))
+ (launch-environment/container #:command command
+ #:bash bash-binary
+ #:user user
+ #:user-mappings mappings
+ #:profile profile
+ #:manifest manifest
+ #:white-list white-list
+ #:link-profile? link-prof?
+ #:network? network?
+ #:map-cwd? (not no-cwd?))))
+
+ (else
+ (return
+ (exit/status
+ (launch-environment/fork command profile manifest
+ #:white-list white-list
+ #:pure? pure?)))))))))))))))
HCoop / jackhill / guix / guix.git / blobdiff