all messages for Guix-related lists mirrored at yhetil.org
 help / color / mirror / code / Atom feed
* [bug#36846] [PATCH] machine: Implement safety checks.
@ 2019-07-29 22:37 Jakob L. Kreuze
  2019-07-30 17:49 ` [bug#36846] [PATCH v2] " Jakob L. Kreuze
  2019-08-06 20:41 ` [bug#36846] [PATCH] " Christopher Lemmer Webber
  0 siblings, 2 replies; 5+ messages in thread
From: Jakob L. Kreuze @ 2019-07-29 22:37 UTC (permalink / raw)
  To: 36846

[-- Attachment #1: Type: text/plain, Size: 7118 bytes --]

* gnu/machine/ssh.scm (machine-check-file-system-availability)
(machine-check-initrd-modules, check-deployment-sanity): New variable.
(deploy-managed-host): Perform safety checks before deploying.
---
 gnu/machine/ssh.scm | 128 +++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 127 insertions(+), 1 deletion(-)

diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index 552eafa9de..1f44783a6c 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -20,6 +20,9 @@
   #:use-module (gnu machine)
   #:autoload   (gnu packages gnupg) (guile-gcrypt)
   #:use-module (gnu system)
+  #:use-module (gnu system file-systems)
+  #:use-module (gnu system uuid)
+  #:use-module (guix diagnostics)
   #:use-module (guix gexp)
   #:use-module (guix i18n)
   #:use-module (guix modules)
@@ -29,6 +32,7 @@
   #:use-module (guix scripts system reconfigure)
   #:use-module (guix ssh)
   #:use-module (guix store)
+  #:use-module (guix utils)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
@@ -98,6 +102,127 @@ an environment type of 'managed-host."
   (maybe-raise-unsupported-configuration-error machine)
   (remote-eval exp (machine-ssh-session machine)))
 
+\f
+;;;
+;;; Safety checks.
+;;;
+
+(define (machine-check-file-system-availability machine)
+  "Raise a '&message' error condition if any of the file-systems specified in
+MACHINE's 'system' declaration do not exist on the machine."
+  (define file-systems
+    (filter (lambda (fs)
+              (and (file-system-mount? fs)
+                   (not (member (file-system-type fs)
+                                %pseudo-file-system-types))
+                   (not (memq 'bind-mount (file-system-flags fs)))))
+            (operating-system-file-systems (machine-system machine))))
+
+  (define (check-literal-file-system fs)
+    (define remote-exp
+      #~(catch 'system-error
+          (lambda ()
+            (stat #$(file-system-device fs))
+            #t)
+          (lambda args
+            (system-error-errno args))))
+
+    (mlet %store-monad ((errno (machine-remote-eval machine remote-exp)))
+      (when (number? errno)
+        (raise (condition
+                (&message (message (format #f (G_ "device '~a' not found: ~a")
+                                           (file-system-device fs)
+                                           (strerror errno)))))))
+      (return #t)))
+
+  (define (check-labeled-file-system fs)
+    (define remote-exp
+      (with-imported-modules '((gnu build file-systems))
+        #~(begin
+            (use-modules (gnu build file-systems))
+            (find-partition-by-label #$(file-system-label->string
+                                        (file-system-device fs))))))
+
+    (mlet %store-monad ((result (machine-remote-eval machine remote-exp)))
+      (unless result
+        (raise (condition (&message
+                           (message (format #f (G_ "no file system with label '~a'")
+                                            (file-system-label->string
+                                             (file-system-device fs))))))))
+      (return #t)))
+
+  (define (check-uuid-file-system fs)
+    (define remote-exp
+      (with-imported-modules '((gnu build file-systems))
+        #~(begin
+            (use-modules (gnu build file-systems))
+            (find-partition-by-uuid #$(file-system-device fs)))))
+
+    (mlet %store-monad ((result (machine-remote-eval machine remote-exp)))
+      (unless result
+        (raise (condition (&message
+                           (message (format #f (G_ "no file system with UUID '~a'")
+                                            (uuid->string (file-system-device fs))))))))
+      (return #t)))
+
+  (mbegin %store-monad
+    (mapm %store-monad check-literal-file-system
+          (filter (lambda (fs)
+                    (string? (file-system-device fs)))
+                  file-systems))
+    (mapm %store-monad check-labeled-file-system
+          (filter (lambda (fs)
+                    (file-system-label? (file-system-device fs)))
+                  file-systems))
+    (mapm %store-monad check-uuid-file-system
+          (filter (lambda (fs)
+              (uuid? (file-system-device fs)))
+                  file-systems))))
+
+(define (machine-check-initrd-modules machine)
+  "Raise a '&message' error condition if any of the modules needed by
+'needed-for-boot' file systems in MACHINE are not available in the initrd."
+  (define file-systems
+    (filter file-system-needed-for-boot?
+            (operating-system-file-systems (machine-system machine))))
+
+  (define (missing-modules fs)
+    (define remote-exp
+      (let ((device (file-system-device fs)))
+        (with-imported-modules (source-module-closure
+                                '((gnu build linux-modules)))
+          #~(begin
+              (use-modules (gnu build linux-modules))
+
+              (define dev
+                #$(cond ((string? device) device)
+                        ((uuid? device) #~(find-partition-by-uuid #$device))
+                        ((file-system-label? device)
+                         #~(find-partition-by-label
+                            (file-system-label->string #$device)))))
+
+              (missing-modules dev '#$(operating-system-initrd-modules
+                                       (machine-system machine)))))))
+    (mlet %store-monad ((missing (machine-remote-eval machine remote-exp)))
+      (return (list fs missing))))
+
+  (mlet %store-monad ((missing (mapm %store-monad missing-modules file-systems)))
+    (for-each (match-lambda
+                ((fs missing)
+                 (unless (null? missing)
+                   (raise (condition (&message
+                                      (message (format #f (G_ "~a missing modules ~{ ~a~}~%")
+                                                       (file-system-device fs) missing))))))))
+              missing)
+    (return #t)))
+
+(define (check-deployment-sanity machine)
+  "Raise a '&message' error condition if it is clear that deploying MACHINE's
+'system' declaration would fail."
+  (mbegin %store-monad
+    (machine-check-file-system-availability machine)
+    (machine-check-initrd-modules machine)))
+
 \f
 ;;;
 ;;; System deployment.
@@ -165,7 +290,8 @@ of MACHINE's system profile, ordered from most recent to oldest."
   "Internal implementation of 'deploy-machine' for MACHINE instances with an
 environment type of 'managed-host."
   (maybe-raise-unsupported-configuration-error machine)
-  (mlet %store-monad ((boot-parameters (machine-boot-parameters machine)))
+  (mlet %store-monad ((_ (check-deployment-sanity machine))
+                      (boot-parameters (machine-boot-parameters machine)))
     (let* ((os (machine-system machine))
            (eval (cut machine-remote-eval machine <>))
            (menu-entries (map boot-parameters->menu-entry boot-parameters))
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

^ permalink raw reply related	[flat|nested] 5+ messages in thread

* [bug#36846] [PATCH v2] machine: Implement safety checks.
  2019-07-29 22:37 [bug#36846] [PATCH] machine: Implement safety checks Jakob L. Kreuze
@ 2019-07-30 17:49 ` Jakob L. Kreuze
  2019-07-30 17:58   ` [bug#36846] [PATCH v3] " Jakob L. Kreuze
  2019-08-06 20:41 ` [bug#36846] [PATCH] " Christopher Lemmer Webber
  1 sibling, 1 reply; 5+ messages in thread
From: Jakob L. Kreuze @ 2019-07-30 17:49 UTC (permalink / raw)
  To: 36846

* gnu/machine/ssh.scm (machine-check-file-system-availability)
(machine-check-initrd-modules, check-deployment-sanity): New variable.
(deploy-managed-host): Perform safety checks before deploying.
---
 gnu/machine/ssh.scm | 130 +++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 128 insertions(+), 2 deletions(-)

diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index 552eafa9de..5773ce8e37 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -20,6 +20,9 @@
   #:use-module (gnu machine)
   #:autoload   (gnu packages gnupg) (guile-gcrypt)
   #:use-module (gnu system)
+  #:use-module (gnu system file-systems)
+  #:use-module (gnu system uuid)
+  #:use-module (guix diagnostics)
   #:use-module (guix gexp)
   #:use-module (guix i18n)
   #:use-module (guix modules)
@@ -29,6 +32,7 @@
   #:use-module (guix scripts system reconfigure)
   #:use-module (guix ssh)
   #:use-module (guix store)
+  #:use-module (guix utils)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
@@ -98,6 +102,127 @@ an environment type of 'managed-host."
   (maybe-raise-unsupported-configuration-error machine)
   (remote-eval exp (machine-ssh-session machine)))
 
+\f
+;;;
+;;; Safety checks.
+;;;
+
+(define (machine-check-file-system-availability machine)
+  "Raise a '&message' error condition if any of the file-systems specified in
+MACHINE's 'system' declaration do not exist on the machine."
+  (define file-systems
+    (filter (lambda (fs)
+              (and (file-system-mount? fs)
+                   (not (member (file-system-type fs)
+                                %pseudo-file-system-types))
+                   (not (memq 'bind-mount (file-system-flags fs)))))
+            (operating-system-file-systems (machine-system machine))))
+
+  (define (check-literal-file-system fs)
+    (define remote-exp
+      #~(catch 'system-error
+          (lambda ()
+            (stat #$(file-system-device fs))
+            #t)
+          (lambda args
+            (system-error-errno args))))
+
+    (mlet %store-monad ((errno (machine-remote-eval machine remote-exp)))
+      (when (number? errno)
+        (raise (condition
+                (&message (message (format #f (G_ "device '~a' not found: ~a")
+                                           (file-system-device fs)
+                                           (strerror errno)))))))
+      (return #t)))
+
+  (define (check-labeled-file-system fs)
+    (define remote-exp
+      (with-imported-modules '((gnu build file-systems))
+        #~(begin
+            (use-modules (gnu build file-systems))
+            (find-partition-by-label #$(file-system-label->string
+                                        (file-system-device fs))))))
+
+    (mlet %store-monad ((result (machine-remote-eval machine remote-exp)))
+      (unless result
+        (raise (condition (&message
+                           (message (format #f (G_ "no file system with label '~a'")
+                                            (file-system-label->string
+                                             (file-system-device fs))))))))
+      (return #t)))
+
+  (define (check-uuid-file-system fs)
+    (define remote-exp
+      (with-imported-modules '((gnu build file-systems))
+        #~(begin
+            (use-modules (gnu build file-systems))
+            (find-partition-by-uuid #$(file-system-device fs)))))
+
+    (mlet %store-monad ((result (machine-remote-eval machine remote-exp)))
+      (unless result
+        (raise (condition (&message
+                           (message (format #f (G_ "no file system with UUID '~a'")
+                                            (uuid->string (file-system-device fs))))))))
+      (return #t)))
+
+  (mbegin %store-monad
+    (mapm %store-monad check-literal-file-system
+          (filter (lambda (fs)
+                    (string? (file-system-device fs)))
+                  file-systems))
+    (mapm %store-monad check-labeled-file-system
+          (filter (lambda (fs)
+                    (file-system-label? (file-system-device fs)))
+                  file-systems))
+    (mapm %store-monad check-uuid-file-system
+          (filter (lambda (fs)
+              (uuid? (file-system-device fs)))
+                  file-systems))))
+
+(define (machine-check-initrd-modules machine)
+  "Raise a '&message' error condition if any of the modules needed by
+'needed-for-boot' file systems in MACHINE are not available in the initrd."
+  (define file-systems
+    (filter file-system-needed-for-boot?
+            (operating-system-file-systems (machine-system machine))))
+
+  (define (missing-modules fs)
+    (define remote-exp
+      (let ((device (file-system-device fs)))
+        (with-imported-modules (source-module-closure
+                                '((gnu build linux-modules)))
+          #~(begin
+              (use-modules (gnu build linux-modules))
+
+              (define dev
+                #$(cond ((string? device) device)
+                        ((uuid? device) #~(find-partition-by-uuid #$device))
+                        ((file-system-label? device)
+                         #~(find-partition-by-label
+                            (file-system-label->string #$device)))))
+
+              (missing-modules dev '#$(operating-system-initrd-modules
+                                       (machine-system machine)))))))
+    (mlet %store-monad ((missing (machine-remote-eval machine remote-exp)))
+      (return (list fs missing))))
+
+  (mlet %store-monad ((missing (mapm %store-monad missing-modules file-systems)))
+    (for-each (match-lambda
+                ((fs missing)
+                 (unless (null? missing)
+                   (raise (condition (&message
+                                      (message (format #f (G_ "~a missing modules ~{ ~a~}~%")
+                                                       (file-system-device fs) missing))))))))
+              missing)
+    (return #t)))
+
+(define (check-deployment-sanity machine)
+  "Raise a '&message' error condition if it is clear that deploying MACHINE's
+'system' declaration would fail."
+  (mbegin %store-monad
+    (machine-check-file-system-availability machine)
+    (machine-check-initrd-modules machine)))
+
 \f
 ;;;
 ;;; System deployment.
@@ -165,8 +290,9 @@ of MACHINE's system profile, ordered from most recent to oldest."
   "Internal implementation of 'deploy-machine' for MACHINE instances with an
 environment type of 'managed-host."
   (maybe-raise-unsupported-configuration-error machine)
-  (mlet %store-monad ((boot-parameters (machine-boot-parameters machine)))
-    (let* ((os (machine-system machine))
+  (mlet %store-monad ((_ (check-deployment-sanity machine))
+                      (boot-parameters (machine-boot-parameters machine)))
+    (let* ((os (machine-operating-system machine))
            (eval (cut machine-remote-eval machine <>))
            (menu-entries (map boot-parameters->menu-entry boot-parameters))
            (bootloader-configuration (operating-system-bootloader os))
-- 
2.22.0

^ permalink raw reply related	[flat|nested] 5+ messages in thread

* [bug#36846] [PATCH v3] machine: Implement safety checks.
  2019-07-30 17:49 ` [bug#36846] [PATCH v2] " Jakob L. Kreuze
@ 2019-07-30 17:58   ` Jakob L. Kreuze
  2019-07-31 14:38     ` [bug#36846] [PATCH v4] " Jakob L. Kreuze
  0 siblings, 1 reply; 5+ messages in thread
From: Jakob L. Kreuze @ 2019-07-30 17:58 UTC (permalink / raw)
  To: 36846

[-- Attachment #1: Type: text/plain, Size: 7056 bytes --]

* gnu/machine/ssh.scm (machine-check-file-system-availability)
(machine-check-initrd-modules, check-deployment-sanity): New variable.
(deploy-managed-host): Perform safety checks before deploying.
---
 gnu/machine/ssh.scm | 127 +++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 126 insertions(+), 1 deletion(-)

diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index 552eafa9de..d60adccf67 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -20,6 +20,9 @@
   #:use-module (gnu machine)
   #:autoload   (gnu packages gnupg) (guile-gcrypt)
   #:use-module (gnu system)
+  #:use-module (gnu system file-systems)
+  #:use-module (gnu system uuid)
+  #:use-module (guix diagnostics)
   #:use-module (guix gexp)
   #:use-module (guix i18n)
   #:use-module (guix modules)
@@ -29,6 +32,7 @@
   #:use-module (guix scripts system reconfigure)
   #:use-module (guix ssh)
   #:use-module (guix store)
+  #:use-module (guix utils)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
@@ -98,6 +102,127 @@ an environment type of 'managed-host."
   (maybe-raise-unsupported-configuration-error machine)
   (remote-eval exp (machine-ssh-session machine)))
 
+\f
+;;;
+;;; Safety checks.
+;;;
+
+(define (machine-check-file-system-availability machine)
+  "Raise a '&message' error condition if any of the file-systems specified in
+MACHINE's 'system' declaration do not exist on the machine."
+  (define file-systems
+    (filter (lambda (fs)
+              (and (file-system-mount? fs)
+                   (not (member (file-system-type fs)
+                                %pseudo-file-system-types))
+                   (not (memq 'bind-mount (file-system-flags fs)))))
+            (operating-system-file-systems (machine-operating-system machine))))
+
+  (define (check-literal-file-system fs)
+    (define remote-exp
+      #~(catch 'system-error
+          (lambda ()
+            (stat #$(file-system-device fs))
+            #t)
+          (lambda args
+            (system-error-errno args))))
+
+    (mlet %store-monad ((errno (machine-remote-eval machine remote-exp)))
+      (when (number? errno)
+        (raise (condition
+                (&message (message (format #f (G_ "device '~a' not found: ~a")
+                                           (file-system-device fs)
+                                           (strerror errno)))))))
+      (return #t)))
+
+  (define (check-labeled-file-system fs)
+    (define remote-exp
+      (with-imported-modules '((gnu build file-systems))
+        #~(begin
+            (use-modules (gnu build file-systems))
+            (find-partition-by-label #$(file-system-label->string
+                                        (file-system-device fs))))))
+
+    (mlet %store-monad ((result (machine-remote-eval machine remote-exp)))
+      (unless result
+        (raise (condition (&message
+                           (message (format #f (G_ "no file system with label '~a'")
+                                            (file-system-label->string
+                                             (file-system-device fs))))))))
+      (return #t)))
+
+  (define (check-uuid-file-system fs)
+    (define remote-exp
+      (with-imported-modules '((gnu build file-systems))
+        #~(begin
+            (use-modules (gnu build file-systems))
+            (find-partition-by-uuid #$(file-system-device fs)))))
+
+    (mlet %store-monad ((result (machine-remote-eval machine remote-exp)))
+      (unless result
+        (raise (condition (&message
+                           (message (format #f (G_ "no file system with UUID '~a'")
+                                            (uuid->string (file-system-device fs))))))))
+      (return #t)))
+
+  (mbegin %store-monad
+    (mapm %store-monad check-literal-file-system
+          (filter (lambda (fs)
+                    (string? (file-system-device fs)))
+                  file-systems))
+    (mapm %store-monad check-labeled-file-system
+          (filter (lambda (fs)
+                    (file-system-label? (file-system-device fs)))
+                  file-systems))
+    (mapm %store-monad check-uuid-file-system
+          (filter (lambda (fs)
+              (uuid? (file-system-device fs)))
+                  file-systems))))
+
+(define (machine-check-initrd-modules machine)
+  "Raise a '&message' error condition if any of the modules needed by
+'needed-for-boot' file systems in MACHINE are not available in the initrd."
+  (define file-systems
+    (filter file-system-needed-for-boot?
+            (operating-system-file-systems (machine-operating-system machine))))
+
+  (define (missing-modules fs)
+    (define remote-exp
+      (let ((device (file-system-device fs)))
+        (with-imported-modules (source-module-closure
+                                '((gnu build linux-modules)))
+          #~(begin
+              (use-modules (gnu build linux-modules))
+
+              (define dev
+                #$(cond ((string? device) device)
+                        ((uuid? device) #~(find-partition-by-uuid #$device))
+                        ((file-system-label? device)
+                         #~(find-partition-by-label
+                            (file-system-label->string #$device)))))
+
+              (missing-modules dev '#$(operating-system-initrd-modules
+                                       (machine-operating-system machine)))))))
+    (mlet %store-monad ((missing (machine-remote-eval machine remote-exp)))
+      (return (list fs missing))))
+
+  (mlet %store-monad ((missing (mapm %store-monad missing-modules file-systems)))
+    (for-each (match-lambda
+                ((fs missing)
+                 (unless (null? missing)
+                   (raise (condition (&message
+                                      (message (format #f (G_ "~a missing modules ~{ ~a~}~%")
+                                                       (file-system-device fs) missing))))))))
+              missing)
+    (return #t)))
+
+(define (check-deployment-sanity machine)
+  "Raise a '&message' error condition if it is clear that deploying MACHINE's
+'system' declaration would fail."
+  (mbegin %store-monad
+    (machine-check-file-system-availability machine)
+    (machine-check-initrd-modules machine)))
+
 \f
 ;;;
 ;;; System deployment.
@@ -166,7 +291,7 @@ of MACHINE's system profile, ordered from most recent to oldest."
 environment type of 'managed-host."
   (maybe-raise-unsupported-configuration-error machine)
   (mlet %store-monad ((boot-parameters (machine-boot-parameters machine)))
-    (let* ((os (machine-system machine))
+    (let* ((os (machine-operating-system machine))
            (eval (cut machine-remote-eval machine <>))
            (menu-entries (map boot-parameters->menu-entry boot-parameters))
            (bootloader-configuration (operating-system-bootloader os))
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

^ permalink raw reply related	[flat|nested] 5+ messages in thread

* [bug#36846] [PATCH v4] machine: Implement safety checks.
  2019-07-30 17:58   ` [bug#36846] [PATCH v3] " Jakob L. Kreuze
@ 2019-07-31 14:38     ` Jakob L. Kreuze
  0 siblings, 0 replies; 5+ messages in thread
From: Jakob L. Kreuze @ 2019-07-31 14:38 UTC (permalink / raw)
  To: 36846

[-- Attachment #1: Type: text/plain, Size: 7891 bytes --]

* gnu/machine/ssh.scm (machine-check-file-system-availability)
(machine-check-initrd-modules, check-deployment-sanity): New variable.
(deploy-managed-host): Perform safety checks before deploying.
---
 gnu/machine/ssh.scm | 148 +++++++++++++++++++++++++++++++++++++++++++-
 1 file changed, 146 insertions(+), 2 deletions(-)

diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index 552eafa9de..274d56db26 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -20,6 +20,9 @@
   #:use-module (gnu machine)
   #:autoload   (gnu packages gnupg) (guile-gcrypt)
   #:use-module (gnu system)
+  #:use-module (gnu system file-systems)
+  #:use-module (gnu system uuid)
+  #:use-module (guix diagnostics)
   #:use-module (guix gexp)
   #:use-module (guix i18n)
   #:use-module (guix modules)
@@ -29,6 +32,7 @@
   #:use-module (guix scripts system reconfigure)
   #:use-module (guix ssh)
   #:use-module (guix store)
+  #:use-module (guix utils)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
@@ -98,6 +102,145 @@ an environment type of 'managed-host."
   (maybe-raise-unsupported-configuration-error machine)
   (remote-eval exp (machine-ssh-session machine)))
 
+\f
+;;;
+;;; Safety checks.
+;;;
+
+(define (machine-check-file-system-availability machine)
+  "Raise a '&message' error condition if any of the file-systems specified in
+MACHINE's 'system' declaration do not exist on the machine."
+  (define file-systems
+    (filter (lambda (fs)
+              (and (file-system-mount? fs)
+                   (not (member (file-system-type fs)
+                                %pseudo-file-system-types))
+                   (not (memq 'bind-mount (file-system-flags fs)))))
+            (operating-system-file-systems (machine-operating-system machine))))
+
+  (define (check-literal-file-system fs)
+    (define remote-exp
+      #~(catch 'system-error
+          (lambda ()
+            (stat #$(file-system-device fs))
+            #t)
+          (lambda args
+            (system-error-errno args))))
+
+    (mlet %store-monad ((errno (machine-remote-eval machine remote-exp)))
+      (when (number? errno)
+        (raise (condition
+                (&message
+                 (message (format #f (G_ "device '~a' not found: ~a")
+                                  (file-system-device fs)
+                                  (strerror errno)))))))
+      (return #t)))
+
+  (define (check-labeled-file-system fs)
+    (define remote-exp
+      (with-imported-modules '((gnu build file-systems))
+        #~(begin
+            (use-modules (gnu build file-systems))
+            (find-partition-by-label #$(file-system-label->string
+                                        (file-system-device fs))))))
+
+    (mlet %store-monad ((result (machine-remote-eval machine remote-exp)))
+      (unless result
+        (raise (condition
+                (&message
+                 (message (format #f (G_ "no file system with label '~a'")
+                                  (file-system-label->string
+                                   (file-system-device fs))))))))
+      (return #t)))
+
+  (define (check-uuid-file-system fs)
+    (define remote-exp
+      (with-imported-modules (source-module-closure
+                              '((gnu build file-systems)
+                                (gnu system uuid)))
+        #~(begin
+            (use-modules (gnu build file-systems)
+                         (gnu system uuid))
+
+            (define uuid
+              (string->uuid #$(uuid->string (file-system-device fs))))
+
+            (find-partition-by-uuid uuid))))
+
+    (mlet %store-monad ((result (machine-remote-eval machine remote-exp)))
+      (unless result
+        (raise (condition
+                (&message
+                 (message (format #f (G_ "no file system with UUID '~a'")
+                                  (uuid->string (file-system-device fs))))))))
+      (return #t)))
+
+  (mbegin %store-monad
+    (mapm %store-monad check-literal-file-system
+          (filter (lambda (fs)
+                    (string? (file-system-device fs)))
+                  file-systems))
+    (mapm %store-monad check-labeled-file-system
+          (filter (lambda (fs)
+                    (file-system-label? (file-system-device fs)))
+                  file-systems))
+    (mapm %store-monad check-uuid-file-system
+          (filter (lambda (fs)
+              (uuid? (file-system-device fs)))
+                  file-systems))))
+
+(define (machine-check-initrd-modules machine)
+  "Raise a '&message' error condition if any of the modules needed by
+'needed-for-boot' file systems in MACHINE are not available in the initrd."
+  (define file-systems
+    (filter file-system-needed-for-boot?
+            (operating-system-file-systems (machine-operating-system machine))))
+
+  (define (missing-modules fs)
+    (define remote-exp
+      (let ((device (file-system-device fs)))
+        (with-imported-modules (source-module-closure
+                                '((gnu build file-systems)
+                                  (gnu build linux-modules)
+                                  (gnu system uuid)))
+          #~(begin
+              (use-modules (gnu build file-systems)
+                           (gnu build linux-modules)
+                           (gnu system uuid))
+
+              (define dev
+                #$(cond ((string? device) device)
+                        ((uuid? device) #~(find-partition-by-uuid
+                                           (string->uuid
+                                            #$(uuid->string device))))
+                        ((file-system-label? device)
+                         #~(find-partition-by-label
+                            (file-system-label->string #$device)))))
+
+              (missing-modules dev '#$(operating-system-initrd-modules
+                                       (machine-operating-system machine)))))))
+    (mlet %store-monad ((missing (machine-remote-eval machine remote-exp)))
+      (return (list fs missing))))
+
+  (mlet %store-monad ((device (mapm %store-monad missing-modules file-systems)))
+    (for-each (match-lambda
+                ((fs missing)
+                 (unless (null? missing)
+                   (raise (condition
+                           (&message
+                            (message (format #f (G_ "~a missing modules ~{ ~a~}~%")
+                                             (file-system-device fs)
+                                             missing))))))))
+              device)
+    (return #t)))
+
+(define (check-deployment-sanity machine)
+  "Raise a '&message' error condition if it is clear that deploying MACHINE's
+'system' declaration would fail."
+  (mbegin %store-monad
+    (machine-check-file-system-availability machine)
+    (machine-check-initrd-modules machine)))
+
 \f
 ;;;
 ;;; System deployment.
@@ -165,8 +308,9 @@ of MACHINE's system profile, ordered from most recent to oldest."
   "Internal implementation of 'deploy-machine' for MACHINE instances with an
 environment type of 'managed-host."
   (maybe-raise-unsupported-configuration-error machine)
-  (mlet %store-monad ((boot-parameters (machine-boot-parameters machine)))
-    (let* ((os (machine-system machine))
+  (mlet %store-monad ((_ (check-deployment-sanity machine))
+                      (boot-parameters (machine-boot-parameters machine)))
+    (let* ((os (machine-operating-system machine))
            (eval (cut machine-remote-eval machine <>))
            (menu-entries (map boot-parameters->menu-entry boot-parameters))
            (bootloader-configuration (operating-system-bootloader os))
-- 
2.22.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

^ permalink raw reply related	[flat|nested] 5+ messages in thread

* [bug#36846] [PATCH] machine: Implement safety checks.
  2019-07-29 22:37 [bug#36846] [PATCH] machine: Implement safety checks Jakob L. Kreuze
  2019-07-30 17:49 ` [bug#36846] [PATCH v2] " Jakob L. Kreuze
@ 2019-08-06 20:41 ` Christopher Lemmer Webber
  1 sibling, 0 replies; 5+ messages in thread
From: Christopher Lemmer Webber @ 2019-08-06 20:41 UTC (permalink / raw)
  To: 36846; +Cc: 36846-done

Merged and pushed!

^ permalink raw reply	[flat|nested] 5+ messages in thread

end of thread, other threads:[~2019-08-06 20:42 UTC | newest]

Thread overview: 5+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2019-07-29 22:37 [bug#36846] [PATCH] machine: Implement safety checks Jakob L. Kreuze
2019-07-30 17:49 ` [bug#36846] [PATCH v2] " Jakob L. Kreuze
2019-07-30 17:58   ` [bug#36846] [PATCH v3] " Jakob L. Kreuze
2019-07-31 14:38     ` [bug#36846] [PATCH v4] " Jakob L. Kreuze
2019-08-06 20:41 ` [bug#36846] [PATCH] " Christopher Lemmer Webber

Code repositories for project(s) associated with this external index

	https://git.savannah.gnu.org/cgit/guix.git

This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.