From 8e2d0fca75feeaacaf6a401a3c13d614f9c3720b Mon Sep 17 00:00:00 2001 From: David Thompson Date: Fri, 19 Jun 2015 08:57:44 -0400 Subject: [PATCH] scripts: environment: Add --container option. * guix/scripts/system.scm (specification->file-system-mapping): Move from here... * guix/ui.scm (specification->file-system-mapping): ... to here. * guix/scripts/enviroment.scm (show-help): Show help for new options. (%options): Add --container --network, --expose, and --share options. (launch-environment, launch-environment/container, requisites*, inputs->requisites): New procedures. (guix-environment): Spawn new process in a container when requested. * doc/guix.texi (Invoking guix environment): Document it. --- doc/guix.texi | 56 ++++++++++++ guix/scripts/environment.scm | 206 ++++++++++++++++++++++++++++++++++++------- guix/scripts/system.scm | 13 --- guix/ui.scm | 15 ++++ 4 files changed, 246 insertions(+), 44 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index f943540..676c07c 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -4508,6 +4508,18 @@ NumPy: guix environment --ad-hoc python2-numpy python-2.7 -E 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: + address@hidden +guix environment --ad-hoc --container guile --exec=guile address@hidden example + The available options are summarized below. @table @code @@ -4573,6 +4585,49 @@ environment. @item address@hidden @itemx -s @var{system} Attempt to build for @var{system}---e.g., @code{i686-linux}. + address@hidden --container address@hidden -C address@hidden 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. + address@hidden --network address@hidden -N +For containers, share the network namespace with the host system. +Containers created without this flag only have access to the loopback +device. + address@hidden address@hidden@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 address@hidden 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: + address@hidden +guix environment --container --expose=$HOME=/exchange guile -E guile address@hidden example + address@hidden --share +For containers, share the file system @var{source} from the host system +as the writable file system @var{target} within the container. If address@hidden 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 address@hidden/exchange} directory: + address@hidden +guix environment --container --share=$HOME=/exchange guile -E guile address@hidden example @end table It also supports all of the common build options that @command{guix @@ -6749,6 +6804,7 @@ This command also installs GRUB on the device specified in @item vm @cindex virtual machine @cindex VM address@hidden 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 ecdbc7a..7f17cb4 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -25,10 +25,15 @@ #: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 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 (srfi srfi-1) @@ -122,6 +127,16 @@ shell command 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")) (newline) (show-build-options-help) (newline) @@ -174,6 +189,22 @@ shell command 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))) %standard-build-options)) (define (pick-all alist key) @@ -229,56 +260,169 @@ 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 derivations, into a set of requisite store items i.e. +the union closure of all the inputs." + (define (input->requisites inputs) + (requisites* + (match inputs + ((drv output) + (derivation->output-path drv output)) + ((drv) + (derivation->output-path drv))))) + + (mlet %store-monad ((reqs (sequence %store-monad + (map input->requisites inputs)))) + (return (delete-duplicates (concatenate reqs))))) + +(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?) + (system command)) + +(define* (launch-environment/container #:key command bash requisites + 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 derivation of Bash. 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 `((,bash "out") ,@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)))) + '("/etc/resolv.conf" + "/etc/nsswitch.conf" + "/etc/services" + "/etc/hosts")) + '()) + ;; 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))) + (status + (call-with-container (map file-system->spec file-systems) + (lambda () + ;; Setup global shell. + (mkdir-p "/bin") + (symlink (string-append (derivation->output-path bash) + "/bin/sh") + "/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")) + + ;; For convenience, start in the user's current working + ;; directory rather than the root directory. + (chdir cwd) + + ;; 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)))) + (status:exit-val status))))) + ;; Entry point. (define (guix-environment . args) (define (handle-argument arg result) (alist-cons 'package arg result)) (with-error-handling - (let* ((opts (parse-command-line args %options (list %default-options) + (let* ((opts (parse-command-line args %options (list %default-options) #:argument-handler handle-argument)) - (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?))) + (pure? (assoc-ref opts 'pure)) + (container? (assoc-ref opts 'container?)) + (network? (assoc-ref opts 'network?)) + (ad-hoc? (assoc-ref opts 'ad-hoc?)) + (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 (assoc-ref opts 'system))) + ;; Containers need a Bourne shell at /bin/sh. + (bash (if container? + (package->derivation bash) + (return #f))) + (all-inputs -> (if container? + `((,bash "out") ,@inputs) + inputs))) (mbegin %store-monad ;; First build INPUTS. This is necessary even for ;; --search-paths. - (build-inputs inputs opts) + (build-inputs all-inputs opts) (cond ((assoc-ref opts 'dry-run?) (return #t)) ((assoc-ref opts 'search-paths) (show-search-paths inputs paths pure?) (return #t)) + (container? + (launch-environment/container #:command command + #:bash bash + #:user-mappings mappings + #:inputs inputs + #:paths paths + #:network? network?)) (else - (create-environment inputs paths pure?) - (return (exit (status:exit-val (system command))))))))))))) + (return + (launch-environment command inputs paths pure?))))))))))) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 45f5982..4245925 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -415,19 +415,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 ." - (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 8de8e3c..43afd8f 100644 --- a/guix/ui.scm +++ b/guix/ui.scm @@ -31,6 +31,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) @@ -72,6 +73,7 @@ string->recutils package->recutils package-specification->name+version+output + specification->file-system-mapping string->generations string->duration args-fold* @@ -922,6 +924,19 @@ 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 ." + (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. -- 2.5.0