ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

scripts: environment: Add --container option.

Browse source 
* 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.
This commit is contained in:
David Thompson 2015-06-19 08:57:44 -04:00 committed by David Thompson
parent 581176c00b
commit f535dcbe19
6 changed files with 385 additions and 55 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
Makefile.am
View file

@ -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

56
doc/guix.texi
View file

@ -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.

276
guix/scripts/environment.scm
View file

@ -25,13 +25,19 @@ (define-module (guix scripts environment)
#: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 @@ (define %precious-variables
(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 @@ (define (show-help)
--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 @@ (define %options
(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 @@ (define (build-inputs inputs 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 @@ (define (handle-argument arg result)
;; 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?))))))))))))

13
guix/scripts/system.scm
View file

@ -488,19 +488,6 @@ (define (show-help)
(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

19
guix/ui.scm
View file

@ -34,6 +34,7 @@ (define-module (guix ui)
#: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 @@ (define-module (guix ui)
string->recutils
package->recutils
package-specification->name+version+output
specification->file-system-mapping
string->generations
string->duration
run-guix-command
@ -966,6 +968,23 @@ (define* (package-specification->name+version+output spec
(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.

75
tests/guix-environment-container.sh Normal file
View file

@ -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