diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | doc/guix.texi | 56 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 276 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 13 | ||||
| -rw-r--r-- | guix/ui.scm | 19 | ||||
| -rw-r--r-- | tests/guix-environment-container.sh | 75 |
6 files changed, 385 insertions, 55 deletions
diff --git a/Makefile.am b/Makefile.am index 1427203fb2..4f90b1d15b 100644 --- a/Makefile.am +++ b/Makefile.am @@ -253,6 +253,7 @@ SH_TESTS = \ tests/guix-archive.sh \ tests/guix-authenticate.sh \ tests/guix-environment.sh \ + tests/guix-environment-container.sh \ tests/guix-graph.sh \ tests/guix-lint.sh diff --git a/doc/guix.texi b/doc/guix.texi index 99c10d8dc7..7715b72818 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4681,6 +4681,18 @@ NumPy: guix environment --ad-hoc python2-numpy python-2.7 -- python @end example +Sometimes it is desirable to isolate the environment as much as +possible, for maximal purity and reproducibility. In particular, when +using Guix on a host distro that is not GuixSD, it is desirable to +prevent access to @file{/usr/bin} and other system-wide resources from +the development environment. For example, the following command spawns +a Guile REPL in a ``container'' where only the store and the current +working directory are mounted: + +@example +guix environment --ad-hoc --container guile -- guile +@end example + The available options are summarized below. @table @code @@ -4741,6 +4753,49 @@ environment. @item --system=@var{system} @itemx -s @var{system} Attempt to build for @var{system}---e.g., @code{i686-linux}. + +@item --container +@itemx -C +@cindex container +Run @var{command} within an isolated container. The current working +directory outside the container is mapped to @file{/env} inside the +container. Additionally, the spawned process runs as the current user +outside the container, but has root privileges in the context of the +container. + +@item --network +@itemx -N +For containers, share the network namespace with the host system. +Containers created without this flag only have access to the loopback +device. + +@item --expose=@var{source}[=@var{target}] +For containers, expose the file system @var{source} from the host system +as the read-only file system @var{target} within the container. If +@var{target} is not specified, @var{source} is used as the target mount +point in the container. + +The example below spawns a Guile REPL in a container in which the user's +home directory is accessible read-only via the @file{/exchange} +directory: + +@example +guix environment --container --expose=$HOME=/exchange guile -- guile +@end example + +@item --share +For containers, share the file system @var{source} from the host system +as the writable file system @var{target} within the container. If +@var{target} is not specified, @var{source} is used as the target mount +point in the container. + +The example below spawns a Guile REPL in a container in which the user's +home directory is accessible for both reading and writing via the +@file{/exchange} directory: + +@example +guix environment --container --share=$HOME=/exchange guile -- guile +@end example @end table It also supports all of the common build options that @command{guix @@ -7064,6 +7119,7 @@ This command also installs GRUB on the device specified in @item vm @cindex virtual machine @cindex VM +@anchor{guix system vm} Build a virtual machine that contain the operating system declared in @var{file}, and return a script to run that virtual machine (VM). Arguments given to the script are passed as is to QEMU. diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 2408420e18..1d21a768dc 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -25,13 +25,19 @@ #:use-module (guix profiles) #:use-module (guix search-paths) #:use-module (guix utils) + #:use-module (guix build utils) #:use-module (guix monads) #:use-module ((guix gexp) #:select (lower-inputs)) #:use-module (guix scripts) #:use-module (guix scripts build) + #:use-module (gnu build linux-container) + #:use-module (gnu system linux-container) + #:use-module (gnu system file-systems) #:use-module (gnu packages) + #:use-module (gnu packages bash) #:use-module (ice-9 format) #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) @@ -60,6 +66,12 @@ OUTPUT) tuples." (define %default-shell (or (getenv "SHELL") "/bin/sh")) +(define %network-configuration-files + '("/etc/resolv.conf" + "/etc/nsswitch.conf" + "/etc/services" + "/etc/hosts")) + (define (purify-environment) "Unset almost all environment variables. A small number of variables such as 'HOME' and 'USER' are left untouched." @@ -124,6 +136,18 @@ COMMAND or an interactive shell in that environment.\n")) --search-paths display needed environment variable definitions")) (display (_ " -s, --system=SYSTEM attempt to build for SYSTEM--e.g., \"i686-linux\"")) + (display (_ " + -C, --container run command within an isolated container")) + (display (_ " + -N, --network allow containers to access the network")) + (display (_ " + --share=SPEC for containers, share writable host file system + according to SPEC")) + (display (_ " + --expose=SPEC for containers, expose read-only host file system + according to SPEC")) + (display (_ " + --bootstrap use bootstrap binaries to build the environment")) (newline) (show-build-options-help) (newline) @@ -176,6 +200,25 @@ COMMAND or an interactive shell in that environment.\n")) (lambda (opt name arg result) (alist-cons 'system arg (alist-delete 'system result eq?)))) + (option '(#\C "container") #f #f + (lambda (opt name arg result) + (alist-cons 'container? #t result))) + (option '(#\N "network") #f #f + (lambda (opt name arg result) + (alist-cons 'network? #t result))) + (option '("share") #t #f + (lambda (opt name arg result) + (alist-cons 'file-system-mapping + (specification->file-system-mapping arg #t) + result))) + (option '("expose") #t #f + (lambda (opt name arg result) + (alist-cons 'file-system-mapping + (specification->file-system-mapping arg #f) + result))) + (option '("bootstrap") #f #f + (lambda (opt name arg result) + (alist-cons 'bootstrap? #t result))) %standard-build-options)) (define (pick-all alist key) @@ -231,6 +274,131 @@ OUTPUT) tuples, using the build options in OPTS." (built-derivations derivations) (return derivations)))))))) +(define requisites* (store-lift requisites)) + +(define (inputs->requisites inputs) + "Convert INPUTS, a list of input tuples or store path strings, into a set of +requisite store items i.e. the union closure of all the inputs." + (define (input->requisites input) + (requisites* + (match input + ((drv output) + (derivation->output-path drv output)) + ((drv) + (derivation->output-path drv)) + ((? direct-store-path? path) + path)))) + + (mlet %store-monad ((reqs (sequence %store-monad + (map input->requisites inputs)))) + (return (delete-duplicates (concatenate reqs))))) + +(define exit/status (compose exit status:exit-val)) +(define primitive-exit/status (compose primitive-exit status:exit-val)) + +(define (launch-environment command inputs paths pure?) + "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." + (create-environment inputs paths pure?) + (apply system* command)) + +(define* (launch-environment/container #:key command bash user-mappings + inputs paths network?) + "Run COMMAND within a Linux container. The environment features INPUTS, a +list of derivations to be shared from the host system. 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." + (mlet %store-monad ((reqs (inputs->requisites + (cons (direct-store-path bash) inputs)))) + (return + (let* ((cwd (getcwd)) + ;; 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? + (filter-map (lambda (file) + (and (file-exists? file) + (file-system-mapping + (source file) + (target file) + (writable? #f)))) + %network-configuration-files) + '()) + ;; 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 mapping->file-system mappings)))) + (exit/status + (call-with-container (map file-system->spec file-systems) + (lambda () + ;; Setup global shell. + (mkdir-p "/bin") + (symlink bash "/bin/sh") + + ;; Setup directory for temporary files. + (mkdir-p "/tmp") + (for-each (lambda (var) + (setenv var "/tmp")) + ;; The same variables as in Nix's 'build.cc'. + '("TMPDIR" "TEMPDIR" "TMP" "TEMP")) + + ;; From Nix build.cc: + ;; + ;; Set HOME to a non-existing path to prevent certain + ;; programs from using /etc/passwd (or NIS, or whatever) + ;; to locate the home directory (for example, wget looks + ;; for ~/.wgetrc). I.e., these tools use /etc/passwd if + ;; HOME is not set, but they will just assume that the + ;; settings file they are looking for does not exist if + ;; HOME is set but points to some non-existing path. + (setenv "HOME" "/homeless-shelter") + + ;; For convenience, start in the user's current working + ;; directory rather than the root directory. + (chdir cwd) + + (primitive-exit/status + ;; A container's environment is already purified, so no need to + ;; request it be purified again. + (launch-environment command inputs paths #f))) + #:namespaces (if network? + (delq 'net %namespaces) ; share host network + %namespaces))))))) + +(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. +If CONTAINER? and BOOTSTRAP?, return the store path for the bootstrap Bash. +Otherwise, return the derivation for the Bash package." + (with-monad %store-monad + (cond + ((and container? (not bootstrap?)) + (package->derivation bash)) + ;; Use the bootstrap Bash instead. + ((and container? bootstrap?) + (interned-file + (search-bootstrap-binary "bash" system))) + (else + (return #f))))) + (define (parse-args args) "Parse the list of command line arguments ARGS." (define (handle-argument arg result) @@ -248,52 +416,76 @@ OUTPUT) tuples, using the build options in OPTS." ;; Entry point. (define (guix-environment . args) (with-error-handling - (let* ((opts (parse-args args)) - (pure? (assoc-ref opts 'pure)) - (ad-hoc? (assoc-ref opts 'ad-hoc?)) - (command (assoc-ref opts 'exec)) - (packages (pick-all (options/resolve-packages opts) 'package)) - (inputs (if ad-hoc? - (append-map (match-lambda - ((package output) - (package+propagated-inputs package - output))) - packages) - (append-map (compose bag-transitive-inputs - package->bag - first) - packages))) - (paths (delete-duplicates - (cons $PATH - (append-map (match-lambda - ((label (? package? p) _ ...) - (package-native-search-paths p)) - (_ - '())) - inputs)) - eq?))) + (let* ((opts (parse-args args)) + (pure? (assoc-ref opts 'pure)) + (container? (assoc-ref opts 'container?)) + (network? (assoc-ref opts 'network?)) + (ad-hoc? (assoc-ref opts 'ad-hoc?)) + (bootstrap? (assoc-ref opts 'bootstrap?)) + (system (assoc-ref opts 'system)) + (command (assoc-ref opts 'exec)) + (packages (pick-all (options/resolve-packages opts) 'package)) + (mappings (pick-all opts 'file-system-mapping)) + (inputs (if ad-hoc? + (append-map (match-lambda + ((package output) + (package+propagated-inputs package + output))) + packages) + (append-map (compose bag-transitive-inputs + package->bag + first) + packages))) + (paths (delete-duplicates + (cons $PATH + (append-map (match-lambda + ((label (? package? p) _ ...) + (package-native-search-paths p)) + (_ + '())) + inputs)) + eq?))) (with-store store (run-with-store store - (mlet %store-monad ((inputs (lower-inputs - (map (match-lambda + (mlet* %store-monad ((inputs (lower-inputs + (map (match-lambda ((label item) (list item)) ((label item output) (list item output))) - inputs) - #:system (assoc-ref opts 'system)))) + inputs) + #:system system)) + ;; Containers need a Bourne shell at /bin/sh. + (bash (environment-bash container? + bootstrap? + system))) (mbegin %store-monad - ;; First build INPUTS. This is necessary even for - ;; --search-paths. - (build-inputs inputs opts) - (cond ((assoc-ref opts 'dry-run?) - (return #t)) - ((assoc-ref opts 'search-paths) - (show-search-paths inputs paths pure?) - (return #t)) - (else - (create-environment inputs paths pure?) - (return - (exit - (status:exit-val - (apply system* command))))))))))))) + ;; First build the inputs. This is necessary even for + ;; --search-paths. Additionally, we might need to build bash + ;; for a container. + (build-inputs (if (derivation? bash) + `((,bash "out") ,@inputs) + inputs) + opts) + (cond + ((assoc-ref opts 'dry-run?) + (return #t)) + ((assoc-ref opts 'search-paths) + (show-search-paths inputs paths 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-mappings mappings + #:inputs inputs + #:paths paths + #:network? network?))) + (else + (return + (exit/status + (launch-environment command inputs paths pure?)))))))))))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index b5da57a9ce..8775267f80 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -488,19 +488,6 @@ Build the operating system declared in FILE according to ACTION.\n")) (newline) (show-bug-report-information)) -(define (specification->file-system-mapping spec writable?) - "Read the SPEC and return the corresponding <file-system-mapping>." - (let ((index (string-index spec #\=))) - (if index - (file-system-mapping - (source (substring spec 0 index)) - (target (substring spec (+ 1 index))) - (writable? writable?)) - (file-system-mapping - (source spec) - (target spec) - (writable? writable?))))) - (define %options ;; Specifications of the command-line options. (cons* (option '(#\h "help") #f #f diff --git a/guix/ui.scm b/guix/ui.scm index fb8121c213..9cc1908e6e 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -34,6 +34,7 @@ #:use-module (guix serialization) #:use-module ((guix build utils) #:select (mkdir-p)) #:use-module ((guix licenses) #:select (license? license-name)) + #:use-module (gnu system file-systems) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) @@ -80,6 +81,7 @@ string->recutils package->recutils package-specification->name+version+output + specification->file-system-mapping string->generations string->duration run-guix-command @@ -966,6 +968,23 @@ optionally contain a version number and an output name, as in these examples: (package-name->name+version name))) (values name version sub-drv))) +(define (specification->file-system-mapping spec writable?) + "Read the SPEC and return the corresponding <file-system-mapping>. SPEC is +a string of the form \"SOURCE\" or \"SOURCE=TARGET\". The former specifies +that SOURCE from the host should be mounted at SOURCE in the other system. +The latter format specifies that SOURCE from the host should be mounted at +TARGET in the other system." + (let ((index (string-index spec #\=))) + (if index + (file-system-mapping + (source (substring spec 0 index)) + (target (substring spec (+ 1 index))) + (writable? writable?)) + (file-system-mapping + (source spec) + (target spec) + (writable? writable?))))) + ;;; ;;; Command-line option processing. diff --git a/tests/guix-environment-container.sh b/tests/guix-environment-container.sh new file mode 100644 index 0000000000..9c3e93dd8c --- /dev/null +++ b/tests/guix-environment-container.sh @@ -0,0 +1,75 @@ +# GNU Guix --- Functional package management for GNU +# Copyright © 2015 David Thompson <davet@gnu.org> +# +# This file is part of GNU Guix. +# +# GNU Guix is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or (at +# your option) any later version. +# +# GNU Guix is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +# +# Test 'guix environment'. +# + +set -e + +guix environment --version + +tmpdir="t-guix-environment-$$" +trap 'rm -r "$tmpdir"' EXIT + +mkdir "$tmpdir" + +# Make sure the exit value is preserved. +if guix environment --container --ad-hoc --bootstrap guile-bootstrap \ + -- guile -c '(exit 42)' +then + false +else + test $? = 42 +fi + +# Make sure that the right directories are mapped. +mount_test_code=" +(use-modules (ice-9 rdelim) + (ice-9 match) + (srfi srfi-1)) + +(define mappings + (filter-map (lambda (line) + (match (string-split line #\space) + ;; Empty line. + ((\"\") #f) + ;; Ignore these types of file systems. + ((_ _ (or \"tmpfs\" \"proc\" \"sysfs\" \"devtmpfs\" + \"devpts\" \"cgroup\" \"mqueue\") _ _ _) + #f) + ((_ mount _ _ _ _) + mount))) + (string-split (call-with-input-file \"/proc/mounts\" read-string) + #\newline))) + +(for-each (lambda (mount) + (display mount) + (newline)) + mappings)" + +guix environment --container --ad-hoc --bootstrap guile-bootstrap \ + -- guile -c "$mount_test_code" > $tmpdir/mounts + +test `wc -l < $tmpdir/mounts` -eq 3 + +grep -e "$PWD$" $tmpdir/mounts # current directory +grep $(guix build guile-bootstrap) $tmpdir/mounts +grep -e "$NIX_STORE_DIR/.*-bash" $tmpdir/mounts # bootstrap bash + +rm $tmpdir/mounts |