diff options
| -rw-r--r-- | gnu/system/file-systems.scm | 17 | ||||
| -rw-r--r-- | gnu/system/linux-container.scm | 21 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 3 |
3 files changed, 22 insertions, 19 deletions
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index fa56853fd1..b2721f2389 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -63,6 +63,8 @@ file-system-mapping-target file-system-mapping-writable? + file-system-mapping->bind-mount + %store-mapping)) ;;; Commentary: @@ -352,6 +354,21 @@ TARGET in the other system." (writable? file-system-mapping-writable? ;Boolean (default #f))) +(define (file-system-mapping->bind-mount mapping) + "Return a file system that realizes MAPPING, a <file-system-mapping>, using +a bind mount." + (match mapping + (($ <file-system-mapping> source target writable?) + (file-system + (mount-point target) + (device source) + (type "none") + (flags (if writable? + '(bind-mount) + '(bind-mount read-only))) + (check? #f) + (create-mount-point? #t))))) + (define %store-mapping ;; Mapping of the host's store into the guest. (file-system-mapping diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm index 24e61c3ead..bceea41332 100644 --- a/gnu/system/linux-container.scm +++ b/gnu/system/linux-container.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 David Thompson <davet@gnu.org> -;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -30,25 +30,10 @@ #:use-module (gnu services) #:use-module (gnu system) #:use-module (gnu system file-systems) - #:export (mapping->file-system - system-container + #:export (system-container containerized-operating-system container-script)) -(define (mapping->file-system mapping) - "Return a file system that realizes MAPPING." - (match mapping - (($ <file-system-mapping> source target writable?) - (file-system - (mount-point target) - (device source) - (type "none") - (flags (if writable? - '(bind-mount) - '(bind-mount read-only))) - (check? #f) - (create-mount-point? #t))))) - (define (containerized-operating-system os mappings) "Return an operating system based on OS for use in a Linux container environment. MAPPINGS is a list of <file-system-mapping> to realize in the @@ -66,7 +51,7 @@ containerized OS." (operating-system-file-systems os))) (define (mapping->fs fs) - (file-system (inherit (mapping->file-system fs)) + (file-system (inherit (file-system-mapping->bind-mount fs)) (needed-for-boot? #t))) (operating-system (inherit os) diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 8a3a935a10..0a1205d087 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -433,7 +433,8 @@ host file systems to mount inside the container." (writable? #f))) reqs))) (file-systems (append %container-file-systems - (map mapping->file-system mappings)))) + (map file-system-mapping->bind-mount + mappings)))) (exit/status (call-with-container file-systems (lambda () |