[bug#28706] [PATCH 0/3] Detect wrong UUIDs/labels in 'guix system init/reconfigure'

[bug#28706] [PATCH 0/3] Detect wrong UUIDs/labels in 'guix system init/reconfigure'

[Ludovic Courtès]

Hello Guix!

At the GHM we were discussing that a common mistake when installing
GuixSD is to specify a wrong file system UUID or label in the config.
You would run the whole install to completion, reboot into the new
system, just to find that it fails to boot because you passed the wrong
UUID or label.  And then you have to reinstall again.  Roel’s report at
<https://lists.gnu.org/archive/html/help-guix/2017-09/msg00068.html> is
another instance of that (though Roel could easily roll back in that
case.)

With this patch such mistakes are detected early on, upon ‘guix system
init’ or ‘guix system reconfigure’:

  configuration.scm:32:23: error: file system with UUID 'c78e0703-373f-4c4d-9652-5633f072eae6' not found
  configuration.scm:42:23: error: file system with UUID '1234-ABCD' not found

The behavior is to stop altogether when such a problem is found.  I
wondered whether it should be a warning instead, on the grounds that it
could be annoying if the mistake-prevention logic wrongfully raised an
error for some reason.  However, I figured that a warning would be much
less efficient (people wouldn’t notice), and I think
‘check-file-system-availability’ avoids the obvious pitfalls by
filtering out irrelevant file systems.

Thoughts?

Thanks,
Ludo’.

Ludovic Courtès (3):
  uuid: Add 'uuid=?' and use it.
  file-systems: Add a 'location' field to <file-system>.
  guix system: Error out when passed a wrong file system UUID/label.

 gnu/build/file-systems.scm  |  4 +--
 gnu/system/file-systems.scm |  6 ++++-
 gnu/system/uuid.scm         | 13 +++++++++
 guix/scripts/system.scm     | 65 +++++++++++++++++++++++++++++++++++++++++++++
 tests/uuid.scm              |  6 +++++
 5 files changed, 91 insertions(+), 3 deletions(-)

-- 
2.14.2

[bug#28706] [PATCH 1/3] uuid: Add 'uuid=?' and use it.

[Ludovic Courtès]

* gnu/system/uuid.scm (uuid=?): New procedure.
* tests/uuid.scm ("uuid=?"): New test.
* gnu/build/file-systems.scm (partition-uuid-predicate)
(luks-partition-uuid-predicate): Use it instead of 'bytevector=?'.
---
 gnu/build/file-systems.scm |  4 ++--
 gnu/system/uuid.scm        | 13 +++++++++++++
 tests/uuid.scm             |  6 ++++++
 3 files changed, 21 insertions(+), 2 deletions(-)

diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm
index 32885f1d2..140bcb414 100644
--- a/gnu/build/file-systems.scm
+++ b/gnu/build/file-systems.scm
@@ -415,12 +415,12 @@ was READ is = to the given value."
   (partition-predicate read-partition-label string=?))
 
 (define partition-uuid-predicate
-  (partition-predicate read-partition-uuid bytevector=?))
+  (partition-predicate read-partition-uuid uuid=?))
 
 (define luks-partition-uuid-predicate
   (partition-predicate
    (partition-field-reader read-luks-header luks-header-uuid)
-   bytevector=?))
+   uuid=?))
 
 (define (find-partition predicate)
   "Return the first partition found that matches PREDICATE, or #f if none
diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm
index 6470abb8c..e422e06a6 100644
--- a/gnu/system/uuid.scm
+++ b/gnu/system/uuid.scm
@@ -29,6 +29,7 @@
             uuid?
             uuid-type
             uuid-bytevector
+            uuid=?
 
             bytevector->uuid
 
@@ -281,3 +282,15 @@ corresponding bytevector; otherwise return #f."
        ((_ . (? procedure? unparse)) (unparse bv))))
     (((? uuid? uuid))
      (uuid->string (uuid-bytevector uuid) (uuid-type uuid)))))
+
+(define uuid=?
+  ;; Return true if A is equal to B, comparing only the actual bits.
+  (match-lambda*
+    (((? bytevector? a) (? bytevector? b))
+     (bytevector=? a b))
+    (((? uuid? a) (? bytevector? b))
+     (bytevector=? (uuid-bytevector a) b))
+    (((? uuid? a) (? uuid? b))
+     (bytevector=? (uuid-bytevector a) (uuid-bytevector b)))
+    ((a b)
+     (uuid=? b a))))
diff --git a/tests/uuid.scm b/tests/uuid.scm
index aacce7723..68676f775 100644
--- a/tests/uuid.scm
+++ b/tests/uuid.scm
@@ -57,4 +57,10 @@
   "1234-ABCD"
   (uuid->string (uuid "1234-abcd" 'fat32)))
 
+(test-equal "uuid=?"
+  (and (uuid=? (uuid-bytevector (uuid "1234-abcd" 'fat32))
+               (uuid "1234-abcd" 'fat32))
+       (uuid=? (uuid "1234-abcd" 'fat32)
+               (uuid "1234-abcd" 'fat))))
+
 (test-end)
-- 
2.14.2

[bug#28706] [PATCH 2/3] file-systems: Add a 'location' field to <file-system>.

[Ludovic Courtès]

* gnu/system/file-systems.scm (<file-system>)[location]: New field.
---
 gnu/system/file-systems.scm | 6 +++++-
 1 file changed, 5 insertions(+), 1 deletion(-)

diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index 52f16676f..92f040425 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -38,6 +38,7 @@
             file-system-check?
             file-system-create-mount-point?
             file-system-dependencies
+            file-system-location
 
             file-system-type-predicate
 
@@ -101,7 +102,10 @@
   (create-mount-point? file-system-create-mount-point? ; Boolean
                        (default #f))
   (dependencies     file-system-dependencies      ; list of <file-system>
-                    (default '())))               ; or <mapped-device>
+                    (default '()))                ; or <mapped-device>
+  (location         file-system-location
+                    (default (current-source-location))
+                    (innate)))
 
 ;; Note: This module is used both on the build side and on the host side.
 ;; Arrange not to pull (guix store) and (guix config) because the latter
-- 
2.14.2

[bug#28706] [PATCH 3/3] guix system: Error out when passed a wrong file system UUID/label.

[Ludovic Courtès]

* guix/scripts/system.scm (check-file-system-availability): New
procedure.
(perform-action): Use it.
---
 guix/scripts/system.scm | 65 +++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 65 insertions(+)

diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 567d8bb64..e50f1d8ac 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -37,6 +37,8 @@
   #:use-module (guix scripts graph)
   #:use-module (guix build utils)
   #:use-module (gnu build install)
+  #:autoload   (gnu build file-systems)
+                 (find-partition-by-label find-partition-by-uuid)
   #:use-module (gnu system)
   #:use-module (gnu bootloader)
   #:use-module (gnu system file-systems)
@@ -404,6 +406,7 @@ NUMBERS, which is a list of generation numbers."
   "Roll back the system profile to its previous generation.  STORE is an open
 connection to the store."
   (switch-to-system-generation store "-1"))
+
 \f
 ;;;
 ;;; Switch generations.
@@ -555,6 +558,61 @@ PATTERN, a string.  When PATTERN is #f, display all the system generations."
          (leave (G_ "invalid syntax: ~a~%") pattern))))
 
 \f
+;;;
+;;; File system declaration checks.
+;;;
+
+(define (check-file-system-availability file-systems)
+  "Check whether the UUIDs or partition labels that FILE-SYSTEMS refer to, if
+any, are available.  Raise an error if they're not."
+  (define relevant
+    (filter (lambda (fs)
+              (and (file-system-mount? fs)
+                   (not (string=? "tmpfs" (file-system-type fs)))
+                   (not (memq 'bind-mount (file-system-flags fs)))))
+            file-systems))
+
+  (define labeled
+    (filter (lambda (fs)
+              (eq? (file-system-title fs) 'label))
+            relevant))
+
+  (define uuid
+    (filter (lambda (fs)
+              (eq? (file-system-title fs) 'uuid))
+            relevant))
+
+  (define fail? #f)
+
+  (define (file-system-location* fs)
+    (location->string
+     (source-properties->location
+      (file-system-location fs))))
+
+  (let-syntax ((error (syntax-rules ()
+                        ((_ args ...)
+                         (begin
+                           (set! fail? #t)
+                           (format (current-error-port)
+                                   args ...))))))
+    (for-each (lambda (fs)
+                (unless (find-partition-by-label (file-system-device fs))
+                  (error (G_ "~a: error: file system with label '~a' not found~%")
+                         (file-system-location* fs)
+                         (file-system-device fs))))
+              labeled)
+    (for-each (lambda (fs)
+                (unless (find-partition-by-uuid (file-system-device fs))
+                  (error (G_ "~a: error: file system with UUID '~a' not found~%")
+                         (file-system-location* fs)
+                         (uuid->string (file-system-device fs)))))
+              uuid)
+
+    (when fail?
+      ;; Better be safe than sorry.
+      (exit 1))))
+
+\f
 ;;;
 ;;; Action.
 ;;;
@@ -637,6 +695,13 @@ output when building a system derivation, such as a disk image."
   (when (eq? action 'reconfigure)
     (maybe-suggest-running-guix-pull))
 
+  ;; Check whether the declared file systems exist.  This is better than
+  ;; instantiating a broken configuration.  Assume that we can only check if
+  ;; running as root.
+  (when (and (memq action '(init reconfigure))
+             (zero? (getuid)))
+    (check-file-system-availability (operating-system-file-systems os)))
+
   (mlet* %store-monad
       ((sys       (system-derivation-for-action os action
                                                 #:file-system-type file-system-type
-- 
2.14.2

[bug#28706] [PATCH 1/3] uuid: Add 'uuid=?' and use it.

[Danny Milosavljevic]

LGTM!

[bug#28706] [PATCH 2/3] file-systems: Add a 'location' field to <file-system>.

[Danny Milosavljevic]

LGTM!

[bug#28706] [PATCH 3/3] guix system: Error out when passed a wrong file system UUID/label.

[Danny Milosavljevic]

LGTM!

bug#28706: [PATCH 3/3] guix system: Error out when passed a wrong file system UUID/label.

[Ludovic Courtès]

Danny Milosavljevic <dannym@scratchpost.org> skribis:

> LGTM!

Thanks for checking.  Pushed as
9d80d0e95c9eab042ddd8250ad9a231ed0c458dc.

Note that the <file-system> change breaks the ABI, so “make clean-go”
is needed!

Ludo’.