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 @@ (define-module (gnu services base) #: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 @@ (define (root-file-system-service) (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 @@ (define* (file-system-service device target type (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 @@ (define file-systems #: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 @@ (define-module (guix build linux-initrd) find-partition-by-label canonicalize-device-spec + mount-flags->bit-mask check-file-system mount-file-system bind-mount @@ -393,6 +394,9 @@ (define* (configure-qemu-networking #:optional (interface "eth0")) ;; Linux mount flags, from libc's . (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 @@ (define fsck 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 @@ (define* (mount-file-system spec #:key (root "/root")) 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 @@ (define flags->bit-mask (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 @@ (define flags->bit-mask (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)