4 files changed, 38 insertions(+), 17 deletions(-)

M doc/guix.texi
M gnu/services/base.scm
M gnu/system.scm
M guix/build/linux-initrd.scm

@@ 3039,7 3039,9 @@ partitions without having to hard-code their actual device name.
 
 @item @code{flags} (default: @code{'()})
 This is a list of symbols denoting mount flags.  Recognized flags
-include @code{read-only} and @code{bind-mount}.
+include @code{read-only}, @code{bind-mount}, @code{no-dev} (disallow
+access to special files), @code{no-suid} (ignore setuid and setgid
+bits), and @code{no-exec} (disallow program execution.)
 
 @item @code{options} (default: @code{#f})
 This is either @code{#f}, or a string denoting mount options.

@@ 29,6 29,8 @@
   #:use-module ((gnu packages base)
                 #:select (glibc-final))
   #:use-module (gnu packages package-management)
+  #:use-module ((guix build linux-initrd)
+                #:select (mount-flags->bit-mask))
   #:use-module (guix gexp)
   #:use-module (guix monads)
   #:use-module (srfi srfi-1)


@@ 96,13 98,14 @@ This service must be the root of the service dependency graph so that its
       (respawn? #f)))))
 
 (define* (file-system-service device target type
-                              #:key (check? #t) create-mount-point?
-                              options (title 'any))
+                              #:key (flags '()) (check? #t)
+                              create-mount-point? options (title 'any))
   "Return a service that mounts DEVICE on TARGET as a file system TYPE with
 OPTIONS.  TITLE is a symbol specifying what kind of name DEVICE is: 'label for
 a partition label, 'device for a device file name, or 'any.  When CHECK? is
 true, check the file system before mounting it.  When CREATE-MOUNT-POINT? is
-true, create TARGET if it does not exist yet."
+true, create TARGET if it does not exist yet.  FLAGS is a list of symbols,
+such as 'read-only' etc."
   (with-monad %store-monad
     (return
      (service


@@ 124,7 127,9 @@ true, create TARGET if it does not exist yet."
                                       (getenv "PATH")))
                              (check-file-system device #$type))
                          #~#t)
-                   (mount device #$target #$type 0 #$options))
+                   (mount device #$target #$type
+                          #$(mount-flags->bit-mask flags)
+                          #$options))
                  #t))
       (stop #~(lambda args
                 ;; Normally there are no processes left at this point, so

@@ 186,7 186,8 @@ as 'needed-for-boot'."
                                         #:title title
                                         #:check? check?
                                         #:create-mount-point? create?
-                                        #:options opts)))
+                                        #:options opts
+                                        #:flags flags)))
                  file-systems)))
 
 (define (essential-services os)

@@ 40,6 40,7 @@
             find-partition-by-label
             canonicalize-device-spec
 
+            mount-flags->bit-mask
             check-file-system
             mount-file-system
             bind-mount


@@ 393,6 394,9 @@ networking values.)  Return #t if INTERFACE is up, #f otherwise."
 
 ;; Linux mount flags, from libc's <sys/mount.h>.
 (define MS_RDONLY 1)
+(define MS_NOSUID 2)
+(define MS_NODEV  4)
+(define MS_NOEXEC 8)
 (define MS_BIND 4096)
 (define MS_MOVE 8192)
 


@@ 494,6 498,24 @@ UNIONFS."
                fsck code device)
        (start-repl)))))
 
+(define (mount-flags->bit-mask flags)
+  "Return the number suitable for the 'flags' argument of 'mount' that
+corresponds to the symbols listed in FLAGS."
+  (let loop ((flags flags))
+    (match flags
+      (('read-only rest ...)
+       (logior MS_RDONLY (loop rest)))
+      (('bind-mount rest ...)
+       (logior MS_BIND (loop rest)))
+      (('no-suid rest ...)
+       (logior MS_NOSUID (loop rest)))
+      (('no-dev rest ...)
+       (logior MS_NODEV (loop rest)))
+      (('no-exec rest ...)
+       (logior MS_NOEXEC (loop rest)))
+      (()
+       0))))
+
 (define* (mount-file-system spec #:key (root "/root"))
   "Mount the file system described by SPEC under ROOT.  SPEC must have the
 form:


@@ 503,15 525,6 @@ form:
 DEVICE, MOUNT-POINT, and TYPE must be strings; OPTIONS can be a string or #f;
 FLAGS must be a list of symbols.  CHECK? is a Boolean indicating whether to
 run a file system check."
-  (define flags->bit-mask
-    (match-lambda
-     (('read-only rest ...)
-      (or MS_RDONLY (flags->bit-mask rest)))
-     (('bind-mount rest ...)
-      (or MS_BIND (flags->bit-mask rest)))
-     (()
-      0)))
-
   (match spec
     ((source title mount-point type (flags ...) options check?)
      (let ((source      (canonicalize-device-spec source title))


@@ 519,7 532,7 @@ run a file system check."
        (when check?
          (check-file-system source type))
        (mkdir-p mount-point)
-       (mount source mount-point type (flags->bit-mask flags)
+       (mount source mount-point type (mount-flags->bit-mask flags)
               (if options
                   (string->pointer options)
                   %null-pointer))


@@ 528,7 541,7 @@ run a file system check."
        (mkdir-p (string-append root "/etc"))
        (let ((port (open-file (string-append root "/etc/mtab") "a")))
          (format port "~a ~a ~a ~a 0 0~%"
-                 source mount-point type options)
+                 source mount-point type (or options ""))
          (close-port port))))))
 
 (define (switch-root root)