From 084b76a70a6b302529f3450e6d07f1d105a10f7d Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sun, 16 Jan 2022 15:51:13 +0100
Subject: machine: ssh: Add 'safety-checks?' field.

Fixes <https://issues.guix.gnu.org/52766>.
Reported by Michael Rohleder <mike@rohleder.de>.

* gnu/machine/ssh.scm (<machine-ssh-configuration>)[safety-checks?]: New
field.
(machine-check-file-system-availability): Return the empty list when
'safety-checks?' is false.
(machine-check-initrd-modules): Likewise.
* doc/guix.texi (Invoking guix deploy): Document it.
---
 gnu/machine/ssh.scm | 34 +++++++++++++++++++++-------------
 1 file changed, 21 insertions(+), 13 deletions(-)

(limited to 'gnu/machine')

diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index 22688f46f4..0dc8933c82 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -93,6 +93,8 @@ (define-record-type* <machine-ssh-configuration> machine-ssh-configuration
                   (default #t))
   (allow-downgrades? machine-ssh-configuration-allow-downgrades? ; boolean
                      (default #f))
+  (safety-checks?    machine-ssh-configuration-safety-checks? ;boolean
+                     (default #t))
   (port           machine-ssh-configuration-port           ; integer
                   (default 22))
   (user           machine-ssh-configuration-user           ; string
@@ -240,18 +242,21 @@ (define remote-exp
         (raise (formatted-message (G_ "no file system with UUID '~a'")
                                   (uuid->string (file-system-device fs)))))))
 
-  (append (map check-literal-file-system
-               (filter (lambda (fs)
-                         (string? (file-system-device fs)))
-                       file-systems))
-          (map check-labeled-file-system
-               (filter (lambda (fs)
-                         (file-system-label? (file-system-device fs)))
-                       file-systems))
-          (map check-uuid-file-system
-               (filter (lambda (fs)
-                         (uuid? (file-system-device fs)))
-                       file-systems))))
+  (if (machine-ssh-configuration-safety-checks?
+       (machine-configuration machine))
+      (append (map check-literal-file-system
+                   (filter (lambda (fs)
+                             (string? (file-system-device fs)))
+                           file-systems))
+              (map check-labeled-file-system
+                   (filter (lambda (fs)
+                             (file-system-label? (file-system-device fs)))
+                           file-systems))
+              (map check-uuid-file-system
+                   (filter (lambda (fs)
+                             (uuid? (file-system-device fs)))
+                           file-systems)))
+      '()))
 
 (define (machine-check-initrd-modules machine)
   "Return a list of <remote-assertion> that raise a '&message' error condition
@@ -291,7 +296,10 @@ (define dev
                                   (file-system-device fs)
                                   missing)))))
 
-  (map missing-modules file-systems))
+  (if (machine-ssh-configuration-safety-checks?
+       (machine-configuration machine))
+      (map missing-modules file-systems)
+      '()))
 
 (define* (machine-check-forward-update machine)
   "Check whether we are making a forward update for MACHINE.  Depending on its
-- 
cgit v1.2.3