02/04: scripts: system: Add 'container' action.

[David Thompson]

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

commit 4af27453b8e925e947a4e3b89fb68cadcc76b84e
Author: David Thompson <address@hidden>
Date:   Mon Jun 8 09:04:38 2015 -0400

    scripts: system: Add 'container' action.
    
    * guix/scripts/system.scm (show-help): Display 'container' action.
      (system-derivation-for-action, guix-system): Add 'container' case.
      (perform-action): Skip GRUB config generation when building a container.
    * doc/guix.texi (Invoking guix system): Document it.
---
 doc/guix.texi           |   21 +++++++++++++++++++++
 guix/scripts/system.scm |   19 +++++++++++++------
 2 files changed, 34 insertions(+), 6 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index b4003d8..1a56913 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -6436,6 +6436,27 @@ using the following command:
 # dd if=$(guix system disk-image my-os.scm) of=/dev/sdc
 @end example
 
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}:
+
address@hidden
+guix system container my-config.scm \
+   --expose=$HOME --share=$HOME/tmp=/exchange
address@hidden example
+
 @end table
 
 @var{options} can contain any of the common build options provided by
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 45f5982..1bd3e65 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -31,6 +31,7 @@
   #:use-module (gnu build install)
   #:use-module (gnu system)
   #:use-module (gnu system file-systems)
+  #:use-module (gnu system linux-container)
   #:use-module (gnu system vm)
   #:use-module (gnu system grub)
   #:use-module (gnu packages grub)
@@ -288,6 +289,8 @@ it atomically, and then run OS's activation script."
   (case action
     ((build init reconfigure)
      (operating-system-derivation os))
+    ((container)
+     (container-script os #:mappings mappings))
     ((vm-image)
      (system-qemu-image os #:disk-image-size image-size))
     ((vm)
@@ -327,10 +330,12 @@ boot directly to the kernel or to the bootloader."
                                                 #:full-boot? full-boot?
                                                 #:mappings mappings))
        (grub      (package->derivation grub))
-       (grub.cfg  (operating-system-grub.cfg os
-                                             (if (eq? 'init action)
-                                                 '()
-                                                 (previous-grub-entries))))
+       (grub.cfg  (if (eq? 'container action)
+                      (return #f)
+                      (operating-system-grub.cfg os
+                                                 (if (eq? 'init action)
+                                                     '()
+                                                     
(previous-grub-entries)))))
        (drvs   -> (if (and grub? (memq action '(init reconfigure)))
                       (list sys grub grub.cfg)
                       (list sys)))
@@ -385,6 +390,8 @@ Build the operating system declared in FILE according to 
ACTION.\n"))
   (display (_ "\
    build            build the operating system without installing anything\n"))
   (display (_ "\
+  container         build a Linux container that shares the host's store\n"))
+  (display (_ "\
    vm               build a virtual machine image that shares the host's 
store\n"))
   (display (_ "\
    vm-image         build a freestanding virtual machine image\n"))
@@ -494,7 +501,7 @@ Build the operating system declared in FILE according to 
ACTION.\n"))
         (alist-cons 'argument arg result)
         (let ((action (string->symbol arg)))
           (case action
-            ((build vm vm-image disk-image reconfigure init)
+            ((build container vm vm-image disk-image reconfigure init)
              (alist-cons 'action action result))
             (else (leave (_ "~a: unknown action~%") action))))))
 
@@ -515,7 +522,7 @@ Build the operating system declared in FILE according to 
ACTION.\n"))
                action))
 
       (case action
-        ((build vm vm-image disk-image reconfigure)
+        ((build container vm vm-image disk-image reconfigure)
          (unless (= count 1)
            (fail)))
         ((init)