Browse Source

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.
version-0.12.0
Ludovic Courtès 6 years ago
parent
commit
5970e8e248
No known key found for this signature in database GPG Key ID: 90B11993D9AEBB5
  1. 19
      gnu/build/linux-container.scm
  2. 11
      gnu/system/file-systems.scm
  3. 3
      gnu/system/linux-container.scm
  4. 2
      guix/scripts/environment.scm
  5. 13
      tests/containers.scm

19
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

11
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

3
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")

2
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")

13
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

Loading…
Cancel
Save