11/15: gnu: system: Add Linux container module.

[David Thompson]

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

commit 0858982a984c9016895dfa1eb87e23e4c0594d34
Author: David Thompson <address@hidden>
Date:   Mon Jun 8 08:59:00 2015 -0400

    gnu: system: Add Linux container module.
    
    * gnu/system/linux-container.scm: New file.
    * gnu-system.am (GNU_SYSTEM_MODULES): Add it.
    * gnu/system.scm: Export 'operating-system-etc-directory',
      'operating-system-boot-script', 'operating-system-locale-directory', and
      'file-union'.
      (operating-system-boot-script): Add #:container? keyword argument.
      (operating-system-activation-script): Add #:container?  keyword argument.
      Don't call 'activate-firmware' or 'activate-ptrace-attach' when 
activating a
      container.
---
 gnu-system.am                  |    1 +
 gnu/system.scm                 |   27 ++++++++----
 gnu/system/linux-container.scm |   90 ++++++++++++++++++++++++++++++++++++++++
 3 files changed, 109 insertions(+), 9 deletions(-)

diff --git a/gnu-system.am b/gnu-system.am
index d625d9c..24d218f 100644
--- a/gnu-system.am
+++ b/gnu-system.am
@@ -347,6 +347,7 @@ GNU_SYSTEM_MODULES =                                \
   gnu/system/grub.scm                          \
   gnu/system/install.scm                       \
   gnu/system/linux.scm                         \
+  gnu/system/linux-container.scm               \
   gnu/system/linux-initrd.scm                  \
   gnu/system/locale.scm                                \
   gnu/system/nss.scm                           \
diff --git a/gnu/system.scm b/gnu/system.scm
index 82b7fbc..476d901 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -82,6 +82,11 @@
             operating-system-derivation
             operating-system-profile
             operating-system-grub.cfg
+            operating-system-etc-directory
+            operating-system-locale-directory
+            operating-system-boot-script
+
+            file-union
 
             local-host-aliases
             %setuid-programs
@@ -679,7 +684,7 @@ variable is not set---hence the need for this wrapper."
                       (apply execl #$modprobe
                              (cons #$modprobe (cdr (command-line))))))))
 
-(define (operating-system-activation-script os)
+(define* (operating-system-activation-script os #:key container?)
   "Return the activation script for OS---i.e., the code that \"activates\" the
 stateful part of OS, including user accounts and groups, special directories,
 etc."
@@ -752,12 +757,15 @@ etc."
                     ;; Tell the kernel to use our 'modprobe' command.
                     (activate-modprobe #$modprobe)
 
-                    ;; Tell the kernel where firmware is.
-                    (activate-firmware
-                     (string-append #$firmware "/lib/firmware"))
-
-                    ;; Let users debug their own processes!
-                    (activate-ptrace-attach)
+                    ;; Tell the kernel where firmware is, unless we are
+                    ;; activating a container.
+                    #$@(if container?
+                           #~()
+                           ;; Tell the kernel where firmware is.
+                           #~((activate-firmware
+                               (string-append #$firmware "/lib/firmware"))
+                              ;; Let users debug their own processes!
+                              (activate-ptrace-attach)))
 
                     ;; Run the services' activation snippets.
                     ;; TODO: Use 'load-compiled'.
@@ -766,11 +774,12 @@ etc."
                     ;; Set up /run/current-system.
                     (activate-current-system)))))
 
-(define (operating-system-boot-script os)
+(define* (operating-system-boot-script os #:key container?)
   "Return the boot script for OS---i.e., the code started by the initrd once
 we're running in the final root."
   (mlet* %store-monad ((services (operating-system-services os))
-                       (activate (operating-system-activation-script os))
+                       (activate (operating-system-activation-script
+                                  os #:container? container?))
                        (dmd-conf (dmd-configuration-file services)))
     (gexp->file "boot"
                 #~(begin
diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm
new file mode 100644
index 0000000..5368dec
--- /dev/null
+++ b/gnu/system/linux-container.scm
@@ -0,0 +1,90 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 David Thompson <address@hidden>
+;;;
+;;; 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/>.
+
+(define-module (gnu system linux-container)
+  #:use-module (ice-9 match)
+  #:use-module (guix config)
+  #:use-module (guix store)
+  #:use-module (guix gexp)
+  #:use-module (guix derivations)
+  #:use-module (guix monads)
+  #:use-module (gnu build linux-container)
+  #:use-module (gnu system)
+  #:use-module (gnu system file-systems)
+  #:export (mapping->file-system
+            system-container
+            container-script))
+
+(define (mapping->file-system mapping)
+  "Return a file system that realizes MAPPING."
+  (match mapping
+    (($ <file-system-mapping> source target writable?)
+     (file-system
+       (mount-point target)
+       (device source)
+       (type "none")
+       (flags (if writable?
+                  '(bind-mount)
+                  '(bind-mount read-only)))
+       (check? #f)
+       (create-mount-point? #t)))))
+
+(define (system-container os)
+  (mlet* %store-monad
+      ((profile (operating-system-profile os))
+       (etc     (operating-system-etc-directory os))
+       (boot    (operating-system-boot-script os #:container? #t))
+       (locale  (operating-system-locale-directory os)))
+    (file-union "system-container"
+                `(("boot" ,#~#$boot)
+                  ("profile" ,#~#$profile)
+                  ("locale" ,#~#$locale)
+                  ("etc" ,#~#$etc)))))
+
+(define* (container-script os #:key (mappings '()))
+  (let* ((mappings     (map mapping->file-system
+                            ;; Bind-mount the store in addition to
+                            ;; user-specified mappings.
+                            (cons %store-mapping mappings)))
+         (file-systems (filter file-system-needed-for-boot?
+                               (operating-system-file-systems os)))
+         (specs        (map file-system->spec
+                            (append file-systems mappings))))
+
+    (mlet* %store-monad ((os-drv (system-container os)))
+
+      (define script
+        #~(begin
+            (use-modules (gnu build linux-container))
+
+            (call-with-container '#$specs
+              (lambda ()
+                (setenv "HOME" "/root")
+                (setenv "TMPDIR" "/tmp")
+                (setenv "GUIX_NEW_SYSTEM" #$os-drv)
+                (for-each mkdir '("/run" "/bin" "/etc" "/home" "/var"))
+                (primitive-load (string-append #$os-drv "/boot"))))))
+
+      (gexp->script "run-container" script
+                    #:modules '((ice-9 match)
+                                (srfi srfi-98)
+                                (guix config)
+                                (guix utils)
+                                (guix build utils)
+                                (guix build syscalls)
+                                (gnu build linux-container))))))