aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2014-07-23 00:44:27 +0200
committerLudovic Courtès <ludo@gnu.org>2014-07-23 02:02:07 +0200
commit2c071ce96e7e4049be3ae2eb958077566d3b4ea0 (patch)
tree0f4e3f8c84d42839064d9b8c4441642f3e9b2b9a
parenta85b83d2270673fdb00d03bbec7e3378c6adcac2 (diff)
downloadguix-2c071ce96e7e4049be3ae2eb958077566d3b4ea0.tar
guix-2c071ce96e7e4049be3ae2eb958077566d3b4ea0.tar.gz
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'.
-rw-r--r--doc/guix.texi4
-rw-r--r--gnu/services/base.scm13
-rw-r--r--gnu/system.scm3
-rw-r--r--guix/build/linux-initrd.scm35
4 files changed, 38 insertions, 17 deletions
diff --git a/doc/guix.texi b/doc/guix.texi
index f475a172fe..42e62d4648 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -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.
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 2c9054af48..342b3c1488 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -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
diff --git a/gnu/system.scm b/gnu/system.scm
index 8c6fc13059..4648d810a3 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -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)
diff --git a/guix/build/linux-initrd.scm b/guix/build/linux-initrd.scm
index 08df32ad1e..662f7967e3 100644
--- a/guix/build/linux-initrd.scm
+++ b/guix/build/linux-initrd.scm
@@ -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)