* gnu/system/file-systems.scm (<file-system>): 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.
---
gnu/build/file-systems.scm | 49 +++++++++++++++++++++----------------
gnu/system/file-systems.scm | 11 ++++++---
2 files changed, 36 insertions(+), 24 deletions(-)
Toggle diff (113 lines)
diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index 902563b219..2f7987f334 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -673,26 +673,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))
-
- (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
- ;; <http://lwn.net/Articles/281157/>, 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)))))
+ (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)))
+
+ ;; For read-only bind mounts, an extra remount is needed, as per
+ ;; <http://lwn.net/Articles/281157/>, 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 3b599efa8e..5180eca8d9 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -38,6 +38,7 @@
file-system-flags
file-system-options
file-system-mount?
+ file-system-mount-may-fail?
file-system-check?
file-system-create-mount-point?
file-system-dependencies
@@ -101,6 +102,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
@@ -261,18 +264,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
- (($ <file-system> device mount-point type flags options _ _ check?)
+ (($ <file-system> 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 <file-system> 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))
@@ -283,6 +287,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?)
--
2.26.0
