diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2021-11-07 18:42:11 +0100 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2021-11-07 23:10:41 +0100 |
| commit | 5eb5c0789f34e87ee417a53ddfcfa3b6521bb337 (patch) | |
| tree | a3a5de35fca0d1b74b10ad4426a8eb0572ac12db /gnu/system/file-systems.scm | |
| parent | 4d59596a1c5f6b20870e619cbf67068ac7dd64ff (diff) | |
| download | guix-patches-5eb5c0789f34e87ee417a53ddfcfa3b6521bb337.tar guix-patches-5eb5c0789f34e87ee417a53ddfcfa3b6521bb337.tar.gz | |
file-systems: Validate the 'flags' field.
Fixes <https://issues.guix.gnu.org/51425>.
Reported by Jonathan Brielmaier <jonathan.brielmaier@web.de>.
* gnu/system/file-systems.scm (invalid-file-system-flags)
(%validate-file-system-flags): New procedures.
(validate-file-system-flags): New macro.
(<file-system>)[flags]: Add 'sanitize' property.
Diffstat (limited to 'gnu/system/file-systems.scm')
| -rw-r--r-- | gnu/system/file-systems.scm | 47 |
1 files changed, 44 insertions, 3 deletions
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index e69cfd06e6..c6c1b96d16 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2021 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2020 Google LLC ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net> ;;; Copyright © 2020, 2021 Maxim Cournoyer <maxim.cournoyer@gmail.com> @@ -30,7 +30,8 @@ #:use-module (srfi srfi-35) #:use-module (srfi srfi-9 gnu) #:use-module (guix records) - #:use-module ((guix diagnostics) #:select (&fix-hint)) + #:use-module ((guix diagnostics) + #:select (source-properties->location leave &fix-hint)) #:use-module (guix i18n) #:use-module (gnu system uuid) #:re-export (uuid ;backward compatibility @@ -107,6 +108,45 @@ ;;; ;;; Code: +(eval-when (expand load eval) + (define invalid-file-system-flags + ;; Note: Keep in sync with 'mount-flags->bit-mask'. + (let ((known-flags '(read-only + bind-mount no-suid no-dev no-exec + no-atime strict-atime lazy-time))) + (lambda (flags) + "Return the subset of FLAGS that is invalid." + (remove (cut memq <> known-flags) flags)))) + + (define (%validate-file-system-flags flags location) + "Raise an error if FLAGS contains invalid mount flags; otherwise return +FLAGS." + (match (invalid-file-system-flags flags) + (() flags) + (invalid + (leave (source-properties->location location) + (N_ "invalid file system mount flag:~{ ~s~}~%" + "invalid file system mount flags:~{ ~s~}~%" + (length invalid)) + invalid))))) + +(define-syntax validate-file-system-flags + (lambda (s) + "Validate the given file system mount flags, raising an error if invalid +flags are found." + (syntax-case s (quote) + ((_ (quote (symbols ...))) ;validate at expansion time + (begin + (%validate-file-system-flags (syntax->datum #'(symbols ...)) + (syntax-source s)) + #'(quote (symbols ...)))) + ((_ flags) + #`(%validate-file-system-flags flags + '#,(datum->syntax s (syntax-source s)))) + (id + (identifier? #'id) + #'%validate-file-system-flags)))) + ;; File system declaration. (define-record-type* <file-system> %file-system make-file-system @@ -115,7 +155,8 @@ (mount-point file-system-mount-point) ; string (type file-system-type) ; string (flags file-system-flags ; list of symbols - (default '())) + (default '()) + (sanitize validate-file-system-flags)) (options file-system-options ; string or #f (default #f)) (mount? file-system-mount? ; Boolean |