kreyren/guix-kreyren
1
0
Fork 0
Code Issues 1 Pull Requests 1 Releases Activity

file-systems: Use a second 'mount' call for read-only bind mounts.

Browse Source 
* gnu/build/file-systems.scm (MS_REMOUNT): New constant.
  (mount-file-system): Add 'flags' local variable.   When FLAGS has
  MS_BIND & MS_RDONLY, call 'mount' with MS_REMOUNT.
* gnu/services/base.scm (file-system-service) <start>: Likewise.
This commit is contained in:
Ludovic Courtès 2015-04-20 22:16:13 +02:00
parent 38cf2ba084
commit b86fee7848
2 changed files with 26 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
gnu/build/file-systems.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -55,6 +55,7 @@
(define MS_NOSUID 2)
(define MS_NODEV 4)
(define MS_NOEXEC 8)
(define MS_REMOUNT 32)
(define MS_BIND 4096)
(define MS_MOVE 8192)
@ -280,13 +281,21 @@ run a file system check."
(match spec
((source title mount-point type (flags ...) options check?)
(let ((source (canonicalize-device-spec source title))
(mount-point (string-append root "/" mount-point)))
(mount-point (string-append root "/" mount-point))
(flags (mount-flags->bit-mask flags)))
(when check?
(check-file-system source type))
(mkdir-p mount-point)
(mount source mount-point type (mount-flags->bit-mask flags)
(mount source mount-point type flags
(if options
(string->pointer options)
%null-pointer))))))
%null-pointer))
;; For read-only bind mounts, an extra remount is needed, as per
;; <http://lwn.net/Articles/281157/>, which still applies to Linux 4.0.
(when (and (= MS_BIND (logand flags MS_BIND))
(= MS_RDONLY (logand flags MS_RDONLY)))
(mount source mount-point type (logior MS_BIND MS_REMOUNT MS_RDONLY)
%null-pointer))))))
;;; file-systems.scm ends here

17
gnu/services/base.scm
View File

@ -131,7 +131,9 @@ names such as device-mapping services."
(requirement `(root-file-system ,@requirements))
(documentation "Check, mount, and unmount the given file system.")
(start #~(lambda args
(let ((device (canonicalize-device-spec #$device '#$title)))
;; FIXME: Use or factorize with 'mount-file-system'.
(let ((device (canonicalize-device-spec #$device '#$title))
(flags #$(mount-flags->bit-mask flags)))
#$(if create-mount-point?
#~(mkdir-p #$target)
#~#t)
@ -145,9 +147,16 @@ names such as device-mapping services."
(getenv "PATH")))
(check-file-system device #$type))
#~#t)
(mount device #$target #$type
#$(mount-flags->bit-mask flags)
#$options))
(mount device #$target #$type flags #$options)
;; For read-only bind mounts, an extra remount is needed,
;; as per <http://lwn.net/Articles/281157/>, which still
;; applies to Linux 4.0.
(when (and (= MS_BIND (logand flags MS_BIND))
(= MS_RDONLY (logand flags MS_RDONLY)))
(mount device #$target #$type
(logior MS_BIND MS_REMOUNT MS_RDONLY))))
#t))
(stop #~(lambda args
;; Normally there are no processes left at this point, so