summaryrefslogtreecommitdiff
path: root/gnu/build
diff options
context:
space:
mode:
authorMathieu Othacehe <othacehe@gnu.org>2020-07-31 13:43:20 +0200
committerMathieu Othacehe <othacehe@gnu.org>2020-07-31 13:43:20 +0200
commit7c27bd115b14afd142da7684cc349369965f9eab (patch)
treebd8ee8a4e6ec582481f926820fc4bfe0b8740f23 /gnu/build
parent6bb07e91e1ab9367f636a3a5e9d52a9e0772aa89 (diff)
file-system: Add mount-may-fail? option.
* 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. Signed-off-by: Mathieu Othacehe <othacehe@gnu.org>
Diffstat (limited to 'gnu/build')
-rw-r--r--gnu/build/file-systems.scm49
1 files changed, 28 insertions, 21 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))
-
- (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