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

[David Thompson]

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

commit 5d0f9d5960d9021a832a84a786c9f152b6456b37
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.
      (guix-environment): Spawn new process in a container when requested.
---
 guix/scripts/environment.scm |   34 ++++++++++++++++++++++++----------
 1 files changed, 24 insertions(+), 10 deletions(-)

diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 007fde1..07efb82 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -27,6 +27,7 @@
   #:use-module (guix utils)
   #:use-module (guix monads)
   #:use-module (guix scripts build)
+  #:use-module (gnu build linux-container)
   #:use-module (gnu packages)
   #:use-module (ice-9 format)
   #:use-module (ice-9 match)
@@ -109,6 +110,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 +159,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)
@@ -232,15 +238,16 @@ packages."
     (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?      (or (assoc-ref opts 'pure) container?))
+           (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
@@ -254,4 +261,11 @@ packages."
                (show-search-paths inputs drvs pure?))
               (else
                (create-environment inputs drvs pure?)
-               (system command)))))))
+               (if container?
+                   (call-with-container "/tmp/container"
+                       `(("/gnu/store" "/gnu/store")
+                         (,(getcwd)    "/env"))
+                     (lambda ()
+                       (chdir "/env")
+                       (system command)))
+                   (system command))))))))