From 5970e8e248f6327c41c83b86bb2c89be7c3b1b4e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 10 Nov 2016 17:45:54 +0100 Subject: container: Pass a list of objects as things to mount. * gnu/build/linux-container.scm (mount-file-systems): 'mounts' is now a list of 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 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 3fccc9addb..b71d6a5f88 100644 --- a/gnu/build/linux-container.scm +++ b/gnu/build/linux-container.scm @@ -24,6 +24,7 @@ (define-module (gnu build linux-container) #:use-module (guix utils) #:use-module (guix build utils) #:use-module (guix build syscalls) + #:use-module (gnu system file-systems) ; #:use-module ((gnu build file-systems) #:select (mount-file-system)) #:export (user-namespace-supported? unprivileged-user-namespace-supported? @@ -72,8 +73,9 @@ (define (purify-environment) ;; 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 + 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 @@ (define* (mount* source target type #:optional (flags 0) options (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 @@ (define (namespaces->bit-mask 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 +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 @@ (define (run-container root mounts namespaces host-uids thunk) (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 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 @@ (define-module (gnu system file-systems) file-system-dependencies file-system->spec + spec->file-system specification->file-system-mapping uuid @@ -107,6 +108,16 @@ (define (file-system->spec fs) (($ 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 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 . 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 @@ (define script (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 @@ (define* (launch-environment/container #:key command bash user-mappings (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 @@ (define-module (test-containers) #: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 @@ (define (skip-if-unsupported) (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 @@ (define (skip-if-unsupported) ;; An exception should be raised; see . (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 -- cgit v1.2.3