diff options
| -rw-r--r-- | gnu/build/linux-container.scm | 19 | ||||
| -rw-r--r-- | gnu/system/file-systems.scm | 11 | ||||
| -rw-r--r-- | gnu/system/linux-container.scm | 3 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 2 | ||||
| -rw-r--r-- | 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 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 |