system: Recognize more file system flags.

* guix/build/linux-initrd.scm (MS_NOSUID, MS_NODEV, MS_NOEXEC): New
  variables.
  (mount-flags->bit-mask): New procedure.
  (mount-file-system)[flags->bit-mask]: Remove.
  Use 'mount-flags->bit-mask' instead.
  In /etc/mtab, use the empty string when OPTIONS is false.
* gnu/services/base.scm (file-system-service): Add #:flags parameter and
  honor it.
* gnu/system.scm (other-file-system-services): Pass FLAGS to
  'file-system-service'.
This commit is contained in:
Ludovic Courtès 2014-07-23 00:44:27 +02:00
parent a85b83d227
commit 2c071ce96e
4 changed files with 38 additions and 17 deletions

View File

@ -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.

View File

@ -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

View File

@ -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)

View File

@ -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)