summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--gnu/build/linux-container.scm19
-rw-r--r--gnu/system/file-systems.scm11
-rw-r--r--gnu/system/linux-container.scm3
-rw-r--r--guix/scripts/environment.scm2
-rw-r--r--tests/containers.scm13
5 files changed, 35 insertions, 13 deletions
diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
index 3fccc9addb..b71d6a5f88 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 b51d57f079..4cc1221eb8 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 189f9efa79..24e61c3ead 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 0c69bfc9d3..6dea67ca22 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 698bef3e47..ccd122ac79 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