file-systems: Add 'file-system-mapping->bind-mount'.

* gnu/system/file-systems.scm (file-system-mapping->bind-mount): New
procedure.
* gnu/system/linux-container.scm (mapping->file-system): Remove.
(containerized-operating-system)[mapping->fs]: Use
'file-system-mapping->bind-mount' instead of 'mapping->file-system'.
* guix/scripts/environment.scm (launch-environment/container): Likewise.
This commit is contained in:
Ludovic Courtès 2017-02-03 00:20:40 +01:00
parent 0f31d4f07f
commit d2a5e6982d
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
3 changed files with 22 additions and 19 deletions

View File

@ -63,6 +63,8 @@
file-system-mapping-target file-system-mapping-target
file-system-mapping-writable? file-system-mapping-writable?
file-system-mapping->bind-mount
%store-mapping)) %store-mapping))
;;; Commentary: ;;; Commentary:
@ -352,6 +354,21 @@ TARGET in the other system."
(writable? file-system-mapping-writable? ;Boolean (writable? file-system-mapping-writable? ;Boolean
(default #f))) (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 (define %store-mapping
;; Mapping of the host's store into the guest. ;; Mapping of the host's store into the guest.
(file-system-mapping (file-system-mapping

View File

@ -1,6 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -30,25 +30,10 @@
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu system) #:use-module (gnu system)
#:use-module (gnu system file-systems) #:use-module (gnu system file-systems)
#:export (mapping->file-system #:export (system-container
system-container
containerized-operating-system containerized-operating-system
container-script)) 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) (define (containerized-operating-system os mappings)
"Return an operating system based on OS for use in a Linux container "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 environment. MAPPINGS is a list of <file-system-mapping> to realize in the
@ -66,7 +51,7 @@ containerized OS."
(operating-system-file-systems os))) (operating-system-file-systems os)))
(define (mapping->fs fs) (define (mapping->fs fs)
(file-system (inherit (mapping->file-system fs)) (file-system (inherit (file-system-mapping->bind-mount fs))
(needed-for-boot? #t))) (needed-for-boot? #t)))
(operating-system (inherit os) (operating-system (inherit os)

View File

@ -433,7 +433,8 @@ host file systems to mount inside the container."
(writable? #f))) (writable? #f)))
reqs))) reqs)))
(file-systems (append %container-file-systems (file-systems (append %container-file-systems
(map mapping->file-system mappings)))) (map file-system-mapping->bind-mount
mappings))))
(exit/status (exit/status
(call-with-container file-systems (call-with-container file-systems
(lambda () (lambda ()