From 7c27bd115b14afd142da7684cc349369965f9eab Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Fri, 31 Jul 2020 13:43:20 +0200 Subject: [PATCH] file-system: Add mount-may-fail? option. * gnu/system/file-systems.scm (): Add a mount-may-fail? field. (file-system->spec): adapt accordingly, (spec->file-system): ditto. * gnu/build/file-systems.scm (mount-file-system): If 'system-error is raised and mount-may-fail? is true, ignore it. Otherwise, re-raise the exception. Signed-off-by: Mathieu Othacehe --- gnu/build/file-systems.scm | 45 +++++++++++++++++++++---------------- gnu/system/file-systems.scm | 11 ++++++--- 2 files changed, 34 insertions(+), 22 deletions(-) diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index 478c71a4e1..4ba1503b9f 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -814,26 +814,33 @@ corresponds to the symbols listed in FLAGS." (when (file-system-check? fs) (check-file-system source type)) - ;; Create the mount point. Most of the time this is a directory, but - ;; in the case of a bind mount, a regular file or socket may be needed. - (if (and (= MS_BIND (logand flags MS_BIND)) - (not (file-is-directory? source))) - (unless (file-exists? mount-point) - (mkdir-p (dirname mount-point)) - (call-with-output-file mount-point (const #t))) - (mkdir-p mount-point)) + (catch 'system-error + (lambda () + ;; Create the mount point. Most of the time this is a directory, but + ;; in the case of a bind mount, a regular file or socket may be + ;; needed. + (if (and (= MS_BIND (logand flags MS_BIND)) + (not (file-is-directory? source))) + (unless (file-exists? mount-point) + (mkdir-p (dirname mount-point)) + (call-with-output-file mount-point (const #t))) + (mkdir-p mount-point)) - (cond - ((string-prefix? "nfs" type) - (mount-nfs source mount-point type flags options)) - (else - (mount source mount-point type flags options))) + (cond + ((string-prefix? "nfs" type) + (mount-nfs source mount-point type flags options)) + (else + (mount source mount-point type flags options))) - ;; For read-only bind mounts, an extra remount is needed, as per - ;; , which still applies to Linux 4.0. - (when (and (= MS_BIND (logand flags MS_BIND)) - (= MS_RDONLY (logand flags MS_RDONLY))) - (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY))) - (mount source mount-point type flags #f))))) + ;; For read-only bind mounts, an extra remount is needed, as per + ;; , which still applies to Linux + ;; 4.0. + (when (and (= MS_BIND (logand flags MS_BIND)) + (= MS_RDONLY (logand flags MS_RDONLY))) + (let ((flags (logior MS_BIND MS_REMOUNT MS_RDONLY))) + (mount source mount-point type flags #f)))) + (lambda args + (or (file-system-mount-may-fail? fs) + (apply throw args)))))) ;;; file-systems.scm ends here diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index 660f9942b0..9c5cbc9b4e 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -48,6 +48,7 @@ alist->file-system-options file-system-mount? + file-system-mount-may-fail? file-system-check? file-system-create-mount-point? file-system-dependencies @@ -114,6 +115,8 @@ (default #f)) (mount? file-system-mount? ; Boolean (default #t)) + (mount-may-fail? file-system-mount-may-fail? ; Boolean + (default #f)) (needed-for-boot? %file-system-needed-for-boot? ; Boolean (default #f)) (check? file-system-check? ; Boolean @@ -301,18 +304,19 @@ store--e.g., if FS is the root file system." "Return a list corresponding to file-system FS that can be passed to the initrd code." (match fs - (($ device mount-point type flags options _ _ check?) + (($ device mount-point type flags options mount? + mount-may-fail? needed-for-boot? check?) (list (cond ((uuid? device) `(uuid ,(uuid-type device) ,(uuid-bytevector device))) ((file-system-label? device) `(file-system-label ,(file-system-label->string device))) (else device)) - mount-point type flags options check?)))) + mount-point type flags options mount-may-fail? check?)))) (define (spec->file-system sexp) "Deserialize SEXP, a list, to the corresponding object." (match sexp - ((device mount-point type flags options check?) + ((device mount-point type flags options mount-may-fail? check?) (file-system (device (match device (('uuid (? symbol? type) (? bytevector? bv)) @@ -323,6 +327,7 @@ initrd code." device))) (mount-point mount-point) (type type) (flags flags) (options options) + (mount-may-fail? mount-may-fail?) (check? check?))))) (define (specification->file-system-mapping spec writable?)