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.
This commit is contained in:
Ludovic Courtès
parent
5e7eaccb14
commit
5970e8e248
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
|
|
@ -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")
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue