[Top][All Lists]

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

04/06: scripts: environment: Add --container option.

From: David Thompson
Subject: 04/06: scripts: environment: Add --container option.
Date: Sat, 05 Sep 2015 03:09:06 +0000

davexunit pushed a commit to branch wip-container
in repository guix.

commit f63edfff23e1073eb313f4b5755de8198b622d85
Author: David Thompson <address@hidden>
Date:   Fri Jun 19 08:57:44 2015 -0400

    scripts: environment: Add --container option.
    * guix/scripts/enviroment.scm (show-help): Show help for new option.
      (%options): Add --container and --network 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                |   49 +++++++++---
 guix/scripts/environment.scm |  174 ++++++++++++++++++++++++++++++++++--------
 2 files changed, 179 insertions(+), 44 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 190558a..9ef5b5a 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:
+guix environment --ad-hoc --container guile --exec=guile
address@hidden example
 The available options are summarized below.
 @table @code
@@ -4573,6 +4585,15 @@ 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
 @end table
 It also supports all of the common build options that @command{guix
@@ -6749,6 +6770,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.
@@ -6798,20 +6820,21 @@ using the following command:
 @end example
 @item container
address@hidden container
 Return a script to run the operating system declared in @var{file}
-within a container.  Currently, the script must be run as root in order
-to support more than a single user and group.
-The container shares its store with the host system.
-Additional file systems can be shared between the host and the container
-using the @code{--share} and @code{--expose} command-line options: the
-former specifies a directory to be shared with write access, while the
-latter provides read-only access to the shared directory.
-The example below creates a container in which the user's home directory
-is accessible read-only, and where the @file{/exchange} directory is a
-read-write mapping of the host's @file{$HOME/tmp}:
+within a @dfn{container}.  Containers are a set of lightweight isolation
+mechanisms provided by the kernel Linux-libre.  Containers are
+substantially less resource-demanding than full virtual machines since
+the kernel, shared objects, and other resources can be shared with the
+host system; this also means they provide thinner isolation.  Currently,
address@hidden system container} must be run as root in order to support
+more than a single user and group.
+Containers share their store with the host system.
+As with the @code{vm} action (@pxref{guix system vm}), additional file
+systems to be shared between the host and container can be specified
+using the @option{--share} and @option{--expose} options:
 guix system container my-config.scm \
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index ecdbc7a..9c1c41f 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -28,7 +28,11 @@
   #: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 +126,10 @@ 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"))
@@ -174,6 +182,12 @@ 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)))
 (define (pick-all alist key)
@@ -229,56 +243,154 @@ OUTPUT) tuples, using the build options in OPTS."
                (built-derivations derivations)
                (return derivations))))))))
+(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 command bash requisites inputs
+                                      paths network?)
+  "Run COMMAND within a Linux container whose global shell (/bin/sh) is BASH,
+that includes the closure of INPUTS, and that sets the environment variables
+defined by PATHS, a list of native search paths.  When NETWORK?, access to the
+host system network is permitted."
+  ;; Bind-mount all requisite store items, /bin/sh, the current working
+  ;; directory, and possibly networking configuration files within the
+  ;; container.
+  (let* ((cwd (getcwd))
+         (mappings (append
+                    (list (file-system-mapping
+                           (source cwd)
+                           (target cwd)
+                           (writable? #t))
+                          (file-system-mapping
+                           (source (string-append (derivation->output-path 
+                                                  "/bin/sh"))
+                           (target "/bin/sh")
+                           (writable? #f)))
+                    ;; When in Nix, do as does.
+                    (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"))
+                        '())
+                    (map (lambda (dir)
+                           (file-system-mapping
+                            (source dir)
+                            (target dir)
+                            (writable? #f)))
+                         requisites)))
+         (file-systems (append %container-file-systems
+                               (map mapping->file-system mappings)))
+         (status
+          (call-with-container (map file-system->spec file-systems)
+            (lambda ()
+              ;; Setup directory for temporary files.
+              (mkdir "/tmp")
+              (for-each (lambda (var)
+                          (setenv var "/tmp"))
+                        ;; The same variables as in Nix's ''.
+                        '("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)
+                             %namespaces))))
+    (status:exit-val status)))
+(define requisites* (store-lift requisites))
+(define (inputs->requisites inputs)
+  "Convert INPUTS, a list of derivations, into a set of requisite store items 
+the union closure of all the inputs."
+  (define input->requisites
+    (match-lambda
+     ((drv output)
+      (requisites* (derivation->output-path drv output)))))
+  (mlet %store-monad ((reqs (sequence %store-monad
+                                      (map input->requisites inputs))))
+    (return (delete-duplicates (concatenate reqs)))))
 ;; Entry point.
 (define (guix-environment . args)
   (define (handle-argument arg result)
     (alist-cons 'package arg result))
-    (let* ((opts     (parse-command-line args %options (list %default-options)
+    (let* ((opts       (parse-command-line args %options (list 
                                          #: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))
+           (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?
+                     (mlet %store-monad ((reqs (inputs->requisites 
+                       (return
+                        (launch-environment/container command bash reqs
+                                                      inputs paths network?))))
-                     (create-environment inputs paths pure?)
-                     (return (exit (status:exit-val (system 
+                     (return
+                      (launch-environment command inputs paths pure?)))))))))))

reply via email to

[Prev in Thread] Current Thread [Next in Thread]