01/02: file-system: Add mount-may-fail? option.

[guix-commits]

mothacehe pushed a commit to branch master
in repository guix.

commit 7c27bd115b14afd142da7684cc349369965f9eab
Author: Mathieu Othacehe <othacehe@gnu.org>
AuthorDate: Fri Jul 31 13:43:20 2020 +0200

    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>
---
 gnu/build/file-systems.scm  | 49 ++++++++++++++++++++++++++-------------------
 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 478c71a..4ba1503 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 660f994..9c5cbc9 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?)