Merge branch 'master' into core-updates

3 files changed, 121 insertions, 14 deletions

diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index b177f93398..8155b273e3 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -47,7 +47,6 @@
             %binary-format-file-system
             %shared-memory-file-system
             %pseudo-terminal-file-system
-            %devtmpfs-file-system
             %immutable-store
             %control-groups
             %elogind-file-systems
@@ -186,17 +185,6 @@ UUID representation."
     (type "binfmt_misc")
     (check? #f)))
 
-(define %devtmpfs-file-system
-  ;; /dev as a 'devtmpfs' file system, needed for udev.
-  (file-system
-    (device "none")
-    (mount-point "/dev")
-    (type "devtmpfs")
-    (check? #f)
-
-    ;; Mount it from the initrd so /dev/pts & co. can then be mounted over it.
-    (needed-for-boot? #t)))
-
 (define %tty-gid
   ;; ID of the 'tty' group.  Allocate it statically to make it easy to refer
   ;; to it from here and from the 'tty' group definitions.
@@ -282,8 +270,7 @@ UUID representation."
 (define %base-file-systems
   ;; List of basic file systems to be mounted.  Note that /proc and /sys are
   ;; currently mounted by the initrd.
-  (append (list %devtmpfs-file-system
-                %pseudo-terminal-file-system
+  (append (list %pseudo-terminal-file-system
                 %shared-memory-file-system
                 %immutable-store)
           %elogind-file-systems
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))))))
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index 48b855b567..519373fe34 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -182,6 +182,7 @@ loaded at boot time in the order in which they appear."
       "isci"                              ;for SAS controllers like Intel C602
       "usb-storage" "uas"                     ;for the installation image etc.
       "usbkbd" "usbhid"                       ;USB keyboards, for debugging
+      "dm-crypt" "xts"                        ;for encrypted root partitions
       ,@(if (or virtio? qemu-networking?)
             virtio-modules
             '())