From 7c27bd115b14afd142da7684cc349369965f9eab Mon Sep 17 00:00:00 2001 From: Mathieu Othacehe Date: Fri, 31 Jul 2020 13:43:20 +0200 Subject: 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 | 49 ++++++++++++++++++++++++++-------------------- 1 file changed, 28 insertions(+), 21 deletions(-) (limited to 'gnu/build') 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 - ;; , 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 + ;; , 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 -- cgit v1.2.3