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.
---
 doc/guix.texi       | 10 ++++++++++
 gnu/machine/ssh.scm | 34 +++++++++++++++++++++-------------
 2 files changed, 31 insertions(+), 13 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 5d18e44f91..ea603ab56a 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -35682,6 +35682,16 @@ returned by @command{guix describe}) to determine whether commits
 currently in use are descendants of those deployed.  When this is not
 the case and @code{allow-downgrades?} is false, it raises an error.
 This ensures you do not accidentally downgrade remote machines.
+
+@item @code{safety-checks?} (default: @code{#t})
+Whether to perform ``safety checks'' before deployment.  This includes
+verifying that devices and file systems referred to in the operating
+system configuration actually exist on the target machine, and making
+sure that Linux modules required to access storage devices at boot time
+are listed in the @code{initrd-modules} field of the operating system.
+
+These safety checks ensure that you do not inadvertently deploy a system
+that would fail to boot.  Be careful before turning them off!
 @end table
 @end deftp
 
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 @@
                   (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 @@ exist on the machine."
         (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 @@ not available in the initrd."
                                   (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