diff options
| -rw-r--r-- | gnu/build/file-systems.scm | 49 | ||||
| -rw-r--r-- | gnu/system/file-systems.scm | 11 |
2 files changed, 36 insertions, 24 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 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 - (($ <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)) @@ -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?) |