From f5d9d6ec68f78f5651bd5a698f489ab57bf77d5d Mon Sep 17 00:00:00 2001
From: Mathieu Othacehe <othacehe@gnu.org>
Date: Fri, 11 Jun 2021 19:19:59 +0200
Subject: installer: Check partitions UUIDs.

* gnu/installer/parted.scm (&cannot-read-uuid): New condition.
(cannot-read-uuid?, cannot-read-uuid-partition): New procedures.
(check-user-partitions): Check that all user-partitions have a valid UUID,
raide the above condition otherwise.
* gnu/installer/newt/partition.scm (run-disk-page): Run an error page if the
&cannot-read-uuid condition is raised.
---
 gnu/installer/newt/partition.scm |  7 ++++++
 gnu/installer/parted.scm         | 52 +++++++++++++++++++++++++++++++++-------
 2 files changed, 51 insertions(+), 8 deletions(-)

(limited to 'gnu/installer')

diff --git a/gnu/installer/newt/partition.scm b/gnu/installer/newt/partition.scm
index 1f920f5903..1c0444b67f 100644
--- a/gnu/installer/newt/partition.scm
+++ b/gnu/installer/newt/partition.scm
@@ -709,6 +709,13 @@ by pressing the Exit button.~%~%")))
                        (run-error-page
                         (G_ "No root mount point found.")
                         (G_ "Missing mount point"))
+                       #f)
+                      ((cannot-read-uuid? c)
+                       (run-error-page
+                        (format #f (G_ "Cannot read the ~a partition UUID.\
+ You may need to format it.")
+                                (cannot-read-uuid-partition c))
+                        (G_ "Wrong partition format"))
                        #f))
                  (check-user-partitions user-partitions))))
           (if user-partitions-ok?
diff --git a/gnu/installer/parted.scm b/gnu/installer/parted.scm
index 6d6e500d71..930f45ae1c 100644
--- a/gnu/installer/parted.scm
+++ b/gnu/installer/parted.scm
@@ -107,6 +107,9 @@
 
             &no-root-mount-point
             no-root-mount-point?
+            &cannot-read-uuid
+            cannot-read-uuid?
+            cannot-read-uuid-partition
 
             check-user-partitions
             set-user-partitions-file-name
@@ -1006,15 +1009,48 @@ exists."
 (define-condition-type &no-root-mount-point &condition
   no-root-mount-point?)
 
+;; Cannot not read the partition UUID.
+(define-condition-type &cannot-read-uuid &condition
+  cannot-read-uuid?
+  (partition cannot-read-uuid-partition))
+
 (define (check-user-partitions user-partitions)
-  "Return #t if the USER-PARTITIONS lists contains one <user-partition> record
-with a mount-point set to '/', raise &no-root-mount-point condition
-otherwise."
-  (let ((mount-points
-         (map user-partition-mount-point user-partitions)))
-    (or (member "/" mount-points)
-        (raise
-         (condition (&no-root-mount-point))))))
+  "Check the following statements:
+
+The USER-PARTITIONS list contains one <user-partition> record with a
+mount-point set to '/'.  Raise &no-root-mount-point condition otherwise.
+
+All the USER-PARTITIONS with a mount point and that will not be formatted have
+a valid UUID.  Raise a &cannot-read-uuid condition specifying the faulty
+partition otherwise.
+
+Return #t if all the statements are valid."
+  (define (check-root)
+    (let ((mount-points
+           (map user-partition-mount-point user-partitions)))
+      (or (member "/" mount-points)
+          (raise
+           (condition (&no-root-mount-point))))))
+
+  (define (check-uuid)
+    (let ((mount-partitions
+           (filter user-partition-mount-point user-partitions)))
+      (every
+       (lambda (user-partition)
+         (let ((file-name (user-partition-file-name user-partition))
+               (need-formatting?
+                (user-partition-need-formatting? user-partition)))
+           (or need-formatting?
+               (read-partition-uuid file-name)
+               (raise
+                (condition
+                 (&cannot-read-uuid
+                  (partition file-name)))))))
+       mount-partitions)))
+
+  (and (check-root)
+       (check-uuid)
+       #t))
 
 (define (set-user-partitions-file-name user-partitions)
   "Set the partition file-name of <user-partition> records in USER-PARTITIONS
-- 
cgit v1.2.3