[bug#68733] [PATCH] machine: ssh: Add 'graft?' field.

[Herman Rimm]

* gnu/machine/ssh.scm (<machine-ssh-configuration>)[graft?]: New field.
* gnu/scripts/deploy.scm (deploy-machine*): Reparameterize %graft?.
* doc/guix.texi (Invoking guix deploy): Document it.

Change-Id: Ide83bb465c9f30165f4ddc64e48c1b89484e3e69
---
Hi,

This patch allows disabling grafts per machine by way of a new graft?
field for machine-ssh-configuration. I don't know what happens when a
digital-ocean-configuration is used. But that won't matter if %graft?
can be parameterized in (deploy-managed-host machine) in /gnu/machine/
ssh.scm. However if %graft? is parameterized alongside %current-system,
it does not affect grafting. Where should %graft? be parameterized?

Cheers,
Herman
 doc/guix.texi           |  5 ++++
 gnu/machine/ssh.scm     | 10 ++++---
 guix/scripts/deploy.scm | 58 ++++++++++++++++++++++-------------------
 3 files changed, 42 insertions(+), 31 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index db0c751ded..2e316ae709 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -124,6 +124,7 @@
 Copyright @copyright{} 2023 Saku Laesvuori@*
 Copyright @copyright{} 2023 Graham James Addis@*
 Copyright @copyright{} 2023 Tomas Volf@*
+Copyright @copyright{} 2024 Herman Rimm@*
 
 Permission is granted to copy, distribute and/or modify this document
 under the terms of the GNU Free Documentation License, Version 1.3 or
@@ -42359,6 +42360,10 @@ Invoking guix deploy
 @item @code{authorize?} (default: @code{#t})
 If true, the coordinator's signing key will be added to the remote's ACL
 keyring.
+@item @code{graft?} (default: @code{#t})
+If false, system derivations will be built without applying any grafts onto
+packages. Grafting should be disabled for deployment to machines with a
+differing architecture.
 @item @code{port} (default: @code{22})
 @item @code{user} (default: @code{"root"})
 @item @code{identity} (default: @code{#f})
diff --git a/gnu/machine/ssh.scm b/gnu/machine/ssh.scm
index b5984dc732..881576ff74 100644
--- a/gnu/machine/ssh.scm
+++ b/gnu/machine/ssh.scm
@@ -63,6 +63,7 @@ (define-module (gnu machine ssh)
             machine-ssh-configuration-build-locally?
             machine-ssh-configuration-authorize?
             machine-ssh-configuration-allow-downgrades?
+            machine-ssh-configuration-graft?
             machine-ssh-configuration-port
             machine-ssh-configuration-user
             machine-ssh-configuration-host-key
@@ -95,6 +96,8 @@ (define-record-type* <machine-ssh-configuration> 
machine-ssh-configuration
                   (default #t))
   (allow-downgrades? machine-ssh-configuration-allow-downgrades? ; boolean
                      (default #f))
+  (graft?         machine-ssh-configuration-graft?         ; boolean
+                  (default #t))
   (safety-checks?    machine-ssh-configuration-safety-checks? ;boolean
                      (default #t))
   (port           machine-ssh-configuration-port           ; integer
@@ -489,12 +492,10 @@ (define (deploy-managed-host machine)
   "Internal implementation of 'deploy-machine' for MACHINE instances with an
 environment type of 'managed-host."
   (define config (machine-configuration machine))
-  (define host   (machine-ssh-configuration-host-name config))
   (define system (machine-ssh-configuration-system config))
 
   (maybe-raise-unsupported-configuration-error machine)
-  (when (machine-ssh-configuration-authorize?
-         (machine-configuration machine))
+  (when (machine-ssh-configuration-authorize? config)
     (unless (file-exists? %public-key-file)
       (raise (formatted-message (G_ "no signing key '~a'. \
 Have you run 'guix archive --generate-key'?")
@@ -512,7 +513,8 @@ (define (deploy-managed-host machine)
     ;; %BASE-INITRD-MODULES, gets to see the right value.
     (parameterize ((%current-system system)
                    (%current-target-system #f))
-      (let* ((os (machine-operating-system machine))
+      (let* ((host (machine-ssh-configuration-host-name config))
+             (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))
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index 4b1a603049..8ffc45e8c3 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -20,6 +20,7 @@
 
 (define-module (guix scripts deploy)
   #:use-module (gnu machine)
+  #:use-module (gnu machine ssh)
   #:use-module (guix discovery)
   #:use-module (guix scripts)
   #:use-module (guix scripts build)
@@ -138,35 +139,38 @@ (define (deploy-machine* store machine)
   (info (G_ "deploying to ~a...~%")
         (machine-display-name machine))
 
-  (guard* (c
-           ;; On Guile 3.0, exceptions such as 'unbound-variable' are compound
-           ;; and include a '&message'.  However, that message only contains
-           ;; the format string.  Thus, special-case it here to avoid
-           ;; displaying a bare format string.
-           (((exception-predicate &exception-with-kind-and-args) c)
-            (raise c))
+  (define config (machine-configuration machine))
+  (define graft? (machine-ssh-configuration-graft? config))
+  (parameterize ((%graft? (and (%graft?) graft?)))
+    (guard* (c
+             ;; On Guile 3.0, exceptions such as 'unbound-variable' are 
compound
+             ;; and include a '&message'.  However, that message only contains
+             ;; the format string.  Thus, special-case it here to avoid
+             ;; displaying a bare format string.
+             (((exception-predicate &exception-with-kind-and-args) c)
+              (raise c))
 
-           ((message-condition? c)
-            (leave (G_ "failed to deploy ~a: ~a~%")
-                   (machine-display-name machine)
-                   (condition-message c)))
-           ((formatted-message? c)
-            (leave (G_ "failed to deploy ~a: ~a~%")
-                   (machine-display-name machine)
-                   (apply format #f
-                          (gettext (formatted-message-string c)
-                                   %gettext-domain)
-                          (formatted-message-arguments c))))
-           ((deploy-error? c)
-            (when (deploy-error-should-roll-back c)
-              (info (G_ "rolling back ~a...~%")
-                    (machine-display-name machine))
-              (run-with-store store (roll-back-machine machine)))
-            (apply throw (deploy-error-captured-args c))))
-      (run-with-store store (deploy-machine machine))
+             ((message-condition? c)
+              (leave (G_ "failed to deploy ~a: ~a~%")
+                     (machine-display-name machine)
+                     (condition-message c)))
+             ((formatted-message? c)
+              (leave (G_ "failed to deploy ~a: ~a~%")
+                     (machine-display-name machine)
+                     (apply format #f
+                            (gettext (formatted-message-string c)
+                                     %gettext-domain)
+                            (formatted-message-arguments c))))
+             ((deploy-error? c)
+              (when (deploy-error-should-roll-back c)
+                (info (G_ "rolling back ~a...~%")
+                      (machine-display-name machine))
+                (run-with-store store (roll-back-machine machine)))
+              (apply throw (deploy-error-captured-args c))))
+        (run-with-store store (deploy-machine machine))
 
-    (info (G_ "successfully deployed ~a~%")
-          (machine-display-name machine))))
+      (info (G_ "successfully deployed ~a~%")
+            (machine-display-name machine)))))
 
 (define (invoke-command store machine command)
   "Invoke COMMAND, a list of strings, on MACHINE.  Display its output (if any)

base-commit: cdf1d7dded027019f0ebbd5d6f0147b13dfdd28d
-- 
2.41.0