14/14: scripts: environment: Add --container option.

[David Thompson]

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

commit 53c036cc7407561dde65523210afdc6e4413e787
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 option.
      (launch-environment, launch-environment/container): New procedures.
      (guix-environment): Spawn new process in a container when requested.
---
 guix/scripts/environment.scm |   62 ++++++++++++++++++++++++++++++++++-------
 1 files changed, 51 insertions(+), 11 deletions(-)

diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 007fde1..662f518 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -27,6 +27,9 @@
   #:use-module (guix utils)
   #:use-module (guix monads)
   #: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 (ice-9 format)
   #:use-module (ice-9 match)
@@ -109,6 +112,8 @@ shell command in that environment.\n"))
       --pure             unset existing environment variables"))
   (display (_ "
       --search-paths     display needed environment variable definitions"))
+  (display (_ "
+  -C, --container        run command within an isolated container"))
   (newline)
   (show-build-options-help)
   (newline)
@@ -156,6 +161,9 @@ shell command in that environment.\n"))
          (option '(#\n "dry-run") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'dry-run? #t result)))
+         (option '(#\C "container") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'container? #t result)))
          %standard-build-options))
 
 (define (pick-all alist key)
@@ -226,21 +234,52 @@ packages."
               (built-derivations drvs)
               (return drvs)))))))
 
+(define (launch-environment command inputs derivations pure?)
+  "Run COMMAND in a new environment containing DERIVATIONS, using the native
+search paths defined by INPUTS.  When PURE?, pre-existing environment
+variables are cleared before setting the new ones."
+  (create-environment inputs derivations pure?)
+  (system command))
+
+(define (launch-environment/container command inputs derivations)
+  "Run COMMAND within a Linux container that includes DERIVATIONS and the
+environment variables defined by the native search paths of INPUTS."
+  ;; Bind-mount the store and the current working directory within the
+  ;; container.
+  (let* ((mappings
+          (list (file-system-mapping
+                 (source (%store-prefix))
+                 (target (%store-prefix))
+                 (writable? #f))
+                (file-system-mapping
+                 (source (getcwd))
+                 (target "/env")
+                 (writable? #t))))
+         (file-systems
+          (append %container-file-systems
+                  (map mapping->file-system mappings))))
+    (call-with-container (map file-system->spec file-systems)
+      (lambda ()
+        (chdir "/env")
+        ;; A container's environment is already purified.
+        (launch-environment command inputs derivations #f)))))
+
 ;; 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)
-                                         #: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?
-                         (packages+propagated-inputs packages)
-                         (packages->transitive-inputs packages))))
+    (let* ((opts       (parse-command-line args %options (list 
%default-options)
+                                           #:argument-handler handle-argument))
+           (container? (assoc-ref opts 'container?))
+           (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?
+                           (packages+propagated-inputs packages)
+                           (packages->transitive-inputs packages))))
       (with-store store
         (define drvs
           (run-with-store store
@@ -253,5 +292,6 @@ packages."
               ((assoc-ref opts 'search-paths)
                (show-search-paths inputs drvs pure?))
               (else
-               (create-environment inputs drvs pure?)
-               (system command)))))))
+               (if container?
+                   (launch-environment/container command inputs drvs)
+                   (launch-environment command inputs drvs pure?))))))))