03/04: guix system: Error out when passed a wrong file system UUID/label.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 9d80d0e95c9eab042ddd8250ad9a231ed0c458dc
Author: Ludovic Courtès <address@hidden>
Date:   Wed Oct 4 21:39:20 2017 +0200

    guix system: Error out when passed a wrong file system UUID/label.
    
    * 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 567d8bb..e50f1d8 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"))
+
 
 ;;;
 ;;; Switch generations.
@@ -556,6 +559,61 @@ PATTERN, a string.  When PATTERN is #f, display all the 
system generations."
 
 
 ;;;
+;;; 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))))
+
+
+;;;
 ;;; 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