[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/04: scripts: environment: Add --container option.
|
From: |
David Thompson |
|
Subject: |
01/04: scripts: environment: Add --container option. |
|
Date: |
Wed, 21 Oct 2015 17:41:05 +0000 |
davexunit pushed a commit to branch wip-container
in repository guix.
commit 171380b992e40d1406fb6083118465f10a92c54b
Author: David Thompson <address@hidden>
Date: Fri Jun 19 08:57:44 2015 -0400
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.
(%network-configuration-files): New variable.
(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.
* tests/guix-environment-container.sh: New file.
* Makefile.am (SH_TESTS): Add it.
---
Makefile.am | 1 +
doc/guix.texi | 56 ++++++++
guix/scripts/environment.scm | 263 +++++++++++++++++++++++++++++------
guix/scripts/system.scm | 13 --
guix/ui.scm | 19 +++
tests/guix-environment-container.sh | 64 +++++++++
6 files changed, 362 insertions(+), 54 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 1427203..4f90b1d 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 99c10d8..91ef127 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:
+
address@hidden
+guix environment --ad-hoc --container guile -- guile
address@hidden example
+
The available options are summarized below.
@table @code
@@ -4741,6 +4753,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
@@ -7064,6 +7119,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 2408420..4ca31cf 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,126 @@ 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))))
+ ;; (pk 'mounts (map file-system->spec file-systems))
+ (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"))
+
+ ;; For convenience, start in the user's current working
+ ;; directory rather than the root directory.
+ (chdir cwd)
+
+ ;; (format #t "PERMS: ~o\n"
+ ;; (stat:perms
+ ;; (stat
+ ;;
"/home/dave/Code/guix/test-tmp/store/w8fsskwxr793yq6w3368x5k1p07syi3h-guile-bootstrap-2.0/bin/guile")))
+
+ (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 +411,70 @@ 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
+ ;; First build the 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)))))))))))))
+ (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?
+ (launch-environment/container #:command command
+ #:bash bash
+ #: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 b5da57a..8775267 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 fb8121c..9cc1908 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 0000000..7d16acc
--- /dev/null
+++ b/tests/guix-environment-container.sh
@@ -0,0 +1,64 @@
+# GNU Guix --- Functional package management for GNU
+# Copyright © 2015 David Thompson <address@hidden>
+#
+# 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)
+ ;; Ignore these types of file systems.
+ ((_ _ (or \"tmpfs\" \"proc\" \"sysfs\" \"devtmpfs\"
+ \"devpts\" \"cgroup\") _ _ _)
+ #f)
+ (mount mount)))
+ (string-split (call-with-input-file \"/proc/mounts\" read-string)
+ #\newline)))
+
+(display mappings)
+"
+
+guix environment --container --ad-hoc --bootstrap guile-bootstrap \
+ -- guile -c "$mount_test_code" > $tmpdir/mounts
+
+# TODO: Finish this test.