03/03: container: Pass a list of <file-system> objects as things to mount.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 5970e8e248f6327c41c83b86bb2c89be7c3b1b4e
Author: Ludovic Courtès <address@hidden>
Date:   Thu Nov 10 17:45:54 2016 +0100

    container: Pass a list of <file-system> objects as things to mount.
    
    * gnu/build/linux-container.scm (mount-file-systems): 'mounts' is now a
    list of <file-system> objects instead of a list of lists ("specs").
    Add call to 'file-system->spec' as the argument to 'mount-file-system'.
    (run-container, call-with-container): Adjust docstring accordingly.
    * gnu/system/file-systems.scm (spec->file-system): New procedure.
    * gnu/system/linux-container.scm (container-script)[script]: Call
    'spec->file-system' inside gexp.
    * guix/scripts/environment.scm (launch-environment/container): Remove
    call to 'file-system->spec'.
    * tests/containers.scm ("call-with-container, mnt namespace")
    ("call-with-container, mnt namespace, wrong bind mount"): Pass a list of
    <file-system> objects.
---
 gnu/build/linux-container.scm  |   19 +++++++++++--------
 gnu/system/file-systems.scm    |   11 +++++++++++
 gnu/system/linux-container.scm |    3 ++-
 guix/scripts/environment.scm   |    2 +-
 tests/containers.scm           |   13 ++++++++++---
 5 files changed, 35 insertions(+), 13 deletions(-)

diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
index 3fccc9a..b71d6a5 100644
--- a/gnu/build/linux-container.scm
+++ b/gnu/build/linux-container.scm
@@ -24,6 +24,7 @@
   #:use-module (guix utils)
   #:use-module (guix build utils)
   #:use-module (guix build syscalls)
+  #:use-module (gnu system file-systems)          ;<file-system>
   #:use-module ((gnu build file-systems) #:select (mount-file-system))
   #:export (user-namespace-supported?
             unprivileged-user-namespace-supported?
@@ -72,8 +73,9 @@ exists."
 ;; specification:
 ;; https://raw.githubusercontent.com/docker/libcontainer/master/SPEC.md
 (define* (mount-file-systems root mounts #:key mount-/sys? mount-/proc?)
-  "Mount the essential file systems and the those in the MOUNTS list relative
-to ROOT, then make ROOT the new root directory for the process."
+  "Mount the essential file systems and the those in MOUNTS, a list of
+<file-system> objects, relative to ROOT; then make ROOT the new root directory
+for the process."
   (define (scope dir)
     (string-append root dir))
 
@@ -141,8 +143,9 @@ to ROOT, then make ROOT the new root directory for the 
process."
   (symlink "/proc/self/fd/2" (scope "/dev/stderr"))
 
   ;; Mount user-specified file systems.
-  (for-each (lambda (spec)
-              (mount-file-system spec #:root root))
+  (for-each (lambda (file-system)
+              (mount-file-system (file-system->spec file-system)
+                                 #:root root))
             mounts)
 
   ;; Jail the process inside the container's root file system.
@@ -197,8 +200,8 @@ corresponds to the symbols in NAMESPACES."
 
 (define (run-container root mounts namespaces host-uids thunk)
   "Run THUNK in a new container process and return its PID.  ROOT specifies
-the root directory for the container.  MOUNTS is a list of file system specs
-that specify the mapping of host file systems into the container.  NAMESPACES
+the root directory for the container.  MOUNTS is a list of <file-system>
+objects that specify file systems to mount inside the container.  NAMESPACES
 is a list of symbols that correspond to the possible Linux namespaces: mnt,
 ipc, uts, user, and net.  HOST-UIDS specifies the number of
 host user identifiers to map into the user namespace."
@@ -256,8 +259,8 @@ host user identifiers to map into the user namespace."
 (define* (call-with-container mounts thunk #:key (namespaces %namespaces)
                               (host-uids 1))
   "Run THUNK in a new container process and return its exit status.
-MOUNTS is a list of file system specs that specify the mapping of host file
-systems into the container.  NAMESPACES is a list of symbols corresponding to
+MOUNTS is a list of <file-system> objects that specify file systems to mount
+inside the container.  NAMESPACES is a list of symbols corresponding to
 the identifiers for Linux namespaces: mnt, ipc, uts, pid, user, and net.  By
 default, all namespaces are used.  HOST-UIDS is the number of host user
 identifiers to map into the container's user namespace, if there is one.  By
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index b51d57f..4cc1221 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -40,6 +40,7 @@
             file-system-dependencies
 
             file-system->spec
+            spec->file-system
             specification->file-system-mapping
             uuid
 
@@ -107,6 +108,16 @@ initrd code."
     (($ <file-system> device title mount-point type flags options _ _ check?)
      (list device title mount-point type flags options check?))))
 
+(define (spec->file-system sexp)
+  "Deserialize SEXP, a list, to the corresponding <file-system> object."
+  (match sexp
+    ((device title mount-point type flags options check?)
+     (file-system
+       (device device) (title title)
+       (mount-point mount-point) (type type)
+       (flags flags) (options options)
+       (check? check?)))))
+
 (define (specification->file-system-mapping spec writable?)
   "Read the SPEC and return the corresponding <file-system-mapping>.  SPEC is
 a string of the form \"SOURCE\" or \"SOURCE=TARGET\".  The former specifies
diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm
index 189f9ef..24e61c3 100644
--- a/gnu/system/linux-container.scm
+++ b/gnu/system/linux-container.scm
@@ -94,9 +94,10 @@ that will be shared with the host system."
                                   (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
+              (call-with-container (map spec->file-system '#$specs)
                 (lambda ()
                   (setenv "HOME" "/root")
                   (setenv "TMPDIR" "/tmp")
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 0c69bfc..6dea67c 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -427,7 +427,7 @@ host file systems to mount inside the container."
             (file-systems (append %container-file-systems
                                   (map mapping->file-system mappings))))
        (exit/status
-        (call-with-container (map file-system->spec file-systems)
+        (call-with-container file-systems
           (lambda ()
             ;; Setup global shell.
             (mkdir-p "/bin")
diff --git a/tests/containers.scm b/tests/containers.scm
index 698bef3..ccd122a 100644
--- a/tests/containers.scm
+++ b/tests/containers.scm
@@ -20,6 +20,7 @@
   #:use-module (guix utils)
   #:use-module (guix build syscalls)
   #:use-module (gnu build linux-container)
+  #:use-module (gnu system file-systems)
   #:use-module (srfi srfi-64)
   #:use-module (ice-9 match))
 
@@ -80,7 +81,10 @@
 (skip-if-unsupported)
 (test-assert "call-with-container, mnt namespace"
   (zero?
-   (call-with-container '(("none" device "/testing" "tmpfs" () #f #f))
+   (call-with-container (list (file-system
+                                (device "none")
+                                (mount-point "/testing")
+                                (type "tmpfs")))
      (lambda ()
        (assert-exit (file-exists? "/testing")))
      #:namespaces '(user mnt))))
@@ -91,8 +95,11 @@
   ;; An exception should be raised; see <http://bugs.gnu.org/23306>.
   (catch 'system-error
     (lambda ()
-      (call-with-container '(("/does-not-exist" device "/foo"
-                              "none" (bind-mount) #f #f))
+      (call-with-container (list (file-system
+                                   (device "/does-not-exist")
+                                   (mount-point "/foo")
+                                   (type "none")
+                                   (flags '(bind-mount))))
         (const #t)
         #:namespaces '(user mnt)))
     (lambda args