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:
parent
0f31d4f07f
commit
d2a5e6982d
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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 ()
|
||||||
|
|
Loading…
Reference in New Issue