mapped-devices: Cope with delayed appearance of LUKS source.

[jackhill/guix/guix.git] / gnu / system / linux-container.scm

diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm
index fdf7460..bceea41 100644 (file)
--- a/gnu/system/linux-container.scm
+++ b/gnu/system/linux-container.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -24,41 +25,15 @@
   #:use-module (guix gexp)
   #:use-module (guix derivations)
   #:use-module (guix monads)
+  #:use-module (guix modules)
   #:use-module (gnu build linux-container)
+  #:use-module (gnu services)
   #:use-module (gnu system)
   #:use-module (gnu system file-systems)
-  #:export (mapping->file-system
-            system-container
+  #:export (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
@@ -69,13 +44,14 @@ containerized OS."
                     (source (file-system-device fs)))
                 (or (string=? target (%store-prefix))
                     (string=? target "/")
-                    (string-prefix? "/dev/" source)
+                    (and (string? source)
+                         (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))
+    (file-system (inherit (file-system-mapping->bind-mount fs))
       (needed-for-boot? #t)))
 
   (operating-system (inherit os)
@@ -93,27 +69,30 @@ that will be shared with the host system."
                                (operating-system-file-systems os)))
          (specs        (map file-system->spec file-systems)))
 
-    (mlet* %store-monad ((os-drv (system-container os)))
+    (mlet* %store-monad ((os-drv (operating-system-derivation
+                                  os
+                                  #:container? #t)))
 
       (define script
-        #~(begin
-            (use-modules (gnu build linux-container)
-                         (guix build utils))
+        (with-imported-modules (source-module-closure
+                                '((guix build utils)
+                                  (gnu build linux-container)))
+          #~(begin
+              (use-modules (gnu build linux-container)
+                           (gnu system file-systems) ;spec->file-system
+                           (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"))))))
+              (call-with-container (map spec->file-system '#$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")))
+                ;; A range of 65536 uid/gids is used to cover 16 bits worth of
+                ;; users and groups, which is sufficient for most cases.
+                ;;
+                ;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users=
+                #:host-uids 65536))))
 
-      (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))))))
+      (gexp->script "run-container" script))))