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.

2 files changed, 139 insertions, 10 deletions

diff --git a/gnu/system.scm b/gnu/system.scm
index ea6e9c13ea..cee5f37bcb 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -83,6 +83,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
@@ -689,7 +694,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."
@@ -763,12 +768,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'.
@@ -777,11 +785,13 @@ 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."
+we're running in the final root.  When CONTAINER? is true, skip all
+hardware-related operations as necessary when booting a Linux container."
   (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 0000000000..fdf7460872
--- /dev/null
+++ b/gnu/system/linux-container.scm
@@ -0,0 +1,119 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;;
+;;; 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 (srfi srfi-1)
+  #: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
+            containerized-operating-system
+            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)
+  "Return a derivation that builds OS as a Linux container."
+  (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 (containerized-operating-system os mappings)
+  "Return an operating system based on OS for use in a Linux container
+environment.  MAPPINGS is a list of <file-system-mapping> to realize in the
+containerized OS."
+  (define user-file-systems
+    (remove (lambda (fs)
+              (let ((target (file-system-mount-point fs))
+                    (source (file-system-device fs)))
+                (or (string=? target (%store-prefix))
+                    (string=? target "/")
+                    (string-prefix? "/dev/" source)
+                    (string-prefix? "/dev" target)
+                    (string-prefix? "/sys" target))))
+            (operating-system-file-systems os)))
+
+  (define (mapping->fs fs)
+    (file-system (inherit (mapping->file-system fs))
+      (needed-for-boot? #t)))
+
+  (operating-system (inherit os)
+    (swap-devices '()) ; disable swap
+    (file-systems (append (map mapping->fs (cons %store-mapping mappings))
+                          %container-file-systems
+                          user-file-systems))))
+
+(define* (container-script os #:key (mappings '()))
+  "Return a derivation of a script that runs OS as a Linux container.
+MAPPINGS is a list of <file-system> objects that specify the files/directories
+that will be shared with the host system."
+  (let* ((os           (containerized-operating-system os mappings))
+         (file-systems (filter file-system-needed-for-boot?
+                               (operating-system-file-systems os)))
+         (specs        (map file-system->spec file-systems)))
+
+    (mlet* %store-monad ((os-drv (system-container os)))
+
+      (define script
+        #~(begin
+            (use-modules (gnu build linux-container)
+                         (guix build utils))
+
+            (call-with-container '#$specs
+              (lambda ()
+                (setenv "HOME" "/root")
+                (setenv "TMPDIR" "/tmp")
+                (setenv "GUIX_NEW_SYSTEM" #$os-drv)
+                (for-each mkdir-p '("/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 file-systems)
+                                (gnu build linux-container))))))