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.

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