me/guix
Archived
1
0
Fork 0
Code 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 ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -55,6 +55,7 @@
(define MS_NOSUID 2) (define MS_NOSUID 2)
(define MS_NODEV 4) (define MS_NODEV 4)
(define MS_NOEXEC 8) (define MS_NOEXEC 8)
(define MS_REMOUNT 32)
(define MS_BIND 4096) (define MS_BIND 4096)
(define MS_MOVE 8192) (define MS_MOVE 8192)
@ -280,13 +281,21 @@ run a file system check."
(match spec (match spec
((source title mount-point type (flags ...) options check?) ((source title mount-point type (flags ...) options check?)
(let ((source (canonicalize-device-spec source title)) (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? (when check?
(check-file-system source type)) (check-file-system source type))
(mkdir-p mount-point) (mkdir-p mount-point)
(mount source mount-point type (mount-flags->bit-mask flags) (mount source mount-point type flags
(if options (if options
(string->pointer 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 ;;; 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)) (requirement `(root-file-system ,@requirements))
(documentation "Check, mount, and unmount the given file system.") (documentation "Check, mount, and unmount the given file system.")
(start #~(lambda args (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? #$(if create-mount-point?
#~(mkdir-p #$target) #~(mkdir-p #$target)
#~#t) #~#t)
@ -145,9 +147,16 @@ names such as device-mapping services."
(getenv "PATH"))) (getenv "PATH")))
(check-file-system device #$type)) (check-file-system device #$type))
#~#t) #~#t)
(mount device #$target #$type
#$(mount-flags->bit-mask flags) (mount device #$target #$type flags #$options)
#$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)) #t))
(stop #~(lambda args (stop #~(lambda args
;; Normally there are no processes left at this point, so ;; Normally there are no processes left at this point, so