From b86fee7848f964da4d5e695dc8027d95d40a1c77 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Mon, 20 Apr 2015 22:16:13 +0200
Subject: file-systems: Use a second 'mount' call for read-only bind mounts.

* 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.
---
 gnu/build/file-systems.scm | 17 +++++++++++++----
 gnu/services/base.scm      | 17 +++++++++++++----
 2 files changed, 26 insertions(+), 8 deletions(-)

(limited to 'gnu')

diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index 38e4851515..dc99d60d3d 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -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
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 956fa7efa0..d0a2e8c848 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -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
-- 
cgit 1.4.1