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

[jackhill/guix/guix.git] / gnu / services / base.scm

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index a912603..d0a2e8c 100644 (file)
--- 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
@@ -499,7 +508,7 @@ the ``message of the day''."
   "Return a service that runs libc's name service cache daemon (nscd) with the
 given @var{config}---an @code{<nscd-configuration>} object.  Optionally,
 @code{#:name-services} is a list of packages that provide name service switch
- (NSS) modules needed by nscd."
+ (NSS) modules needed by nscd.  @xref{Name Service Switch}, for an example."
   (mlet %store-monad ((nscd.conf (nscd.conf-file config)))
     (return (service
              (documentation "Run libc's name service cache daemon (nscd).")
@@ -526,8 +535,10 @@ given @var{config}---an @code{<nscd-configuration>} object.  Optionally,
 
              (respawn? #f)))))
 
-(define (syslog-service)
-  "Return a service that runs @code{syslogd} with reasonable default settings."
+(define* (syslog-service #:key config-file)
+  "Return a service that runs @code{syslogd}.
+If configuration file name @var{config-file} is not specified, use some
+reasonable default settings."
 
   ;; Snippet adapted from the GNU inetutils manual.
   (define contents "
@@ -561,7 +572,7 @@ given @var{config}---an @code{<nscd-configuration>} object.  Optionally,
       (start
        #~(make-forkexec-constructor
           (list (string-append #$inetutils "/libexec/syslogd")
-                "--no-detach" "--rcfile" #$syslog.conf)))
+                "--no-detach" "--rcfile" #$(or config-file syslog.conf))))
       (stop #~(make-kill-destructor))))))
 
 (define* (guix-build-accounts count #:key
@@ -640,6 +651,7 @@ passed to @command{guix-daemon}."
 
   (with-monad %store-monad
     (return (service
+             (documentation "Run the Guix daemon.")
              (provision '(guix-daemon))
              (requirement '(user-processes))
              (start