Package: guix-patches;
Reported by: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze)
Date: Mon, 29 Jul 2019 22:41:02 UTC
Severity: normal
Tags: patch
Done: Christopher Lemmer Webber <cwebber <at> dustycloud.org>
Bug is archived. No further changes may be made.
To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 36846 in the body.
You can then email your comments to 36846 AT debbugs.gnu.org in the normal way.
Toggle the display of automated, internal messages from the tracker.
View this report as an mbox folder, status mbox, maintainer mbox
guix-patches <at> gnu.org:bug#36846; Package guix-patches.
(Mon, 29 Jul 2019 22:41:02 GMT) Full text and rfc822 format available.zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze):guix-patches <at> gnu.org.
(Mon, 29 Jul 2019 22:41:03 GMT) Full text and rfc822 format available.Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):
From: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) To: guix-patches <at> gnu.org Subject: [PATCH] machine: Implement safety checks. Date: Mon, 29 Jul 2019 18:37:43 -0400
[Message part 1 (text/plain, inline)]
* 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)))
+
+;;;
+;;; 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)))
+
;;;
;;; 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
[signature.asc (application/pgp-signature, inline)]
guix-patches <at> gnu.org:bug#36846; Package guix-patches.
(Tue, 30 Jul 2019 17:53:02 GMT) Full text and rfc822 format available.Message #8 received at submit <at> debbugs.gnu.org (full text, mbox):
From: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) To: guix-patches <at> gnu.org Subject: [PATCH v2] machine: Implement safety checks. Date: Tue, 30 Jul 2019 13:49:12 -0400
* 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)))
+
+;;;
+;;; 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)))
+
;;;
;;; 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
guix-patches <at> gnu.org:bug#36846; Package guix-patches.
(Tue, 30 Jul 2019 18:02:02 GMT) Full text and rfc822 format available.Message #11 received at 36846 <at> debbugs.gnu.org (full text, mbox):
From: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) To: 36846 <at> debbugs.gnu.org Subject: [PATCH v3] machine: Implement safety checks. Date: Tue, 30 Jul 2019 13:58:59 -0400
[Message part 1 (text/plain, inline)]
* 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)))
+
+;;;
+;;; 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)))
+
;;;
;;; 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
[signature.asc (application/pgp-signature, inline)]
guix-patches <at> gnu.org:bug#36846; Package guix-patches.
(Wed, 31 Jul 2019 14:42:01 GMT) Full text and rfc822 format available.Message #14 received at 36846 <at> debbugs.gnu.org (full text, mbox):
From: zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze) To: 36846 <at> debbugs.gnu.org Subject: [PATCH v4] machine: Implement safety checks. Date: Wed, 31 Jul 2019 10:38:29 -0400
[Message part 1 (text/plain, inline)]
* 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)))
+
+;;;
+;;; 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)))
+
;;;
;;; 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
[signature.asc (application/pgp-signature, inline)]
guix-patches <at> gnu.org:bug#36846; Package guix-patches.
(Tue, 06 Aug 2019 20:42:02 GMT) Full text and rfc822 format available.Message #17 received at submit <at> debbugs.gnu.org (full text, mbox):
From: Christopher Lemmer Webber <cwebber <at> dustycloud.org> To: guix-patches <at> gnu.org Cc: 36846-done <at> debbugs.gnu.org Subject: Re: [bug#36846] [PATCH] machine: Implement safety checks. Date: Tue, 06 Aug 2019 16:41:15 -0400
Merged and pushed!
Christopher Lemmer Webber <cwebber <at> dustycloud.org>:zerodaysfordays <at> sdf.lonestar.org (Jakob L. Kreuze):Debbugs Internal Request <help-debbugs <at> gnu.org>
to internal_control <at> debbugs.gnu.org.
(Wed, 04 Sep 2019 11:24:04 GMT) Full text and rfc822 format available.
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.