GNU bug report logs - #68733
[PATCH] machine: ssh: Add 'graft?' field.

Previous Next

To reply to this bug, email your comments to 68733 AT debbugs.gnu.org.

Toggle the display of automated, internal messages from the tracker.

Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):

From: Herman Rimm <herman <at> rimm.ee>
To: guix-patches <at> gnu.org
Cc: Herman Rimm <herman <at> rimm.ee>
Subject: [PATCH] machine: ssh: Add 'graft?' field.
Date: Fri, 26 Jan 2024 11:59:30 +0100

* 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

Message #8 received at 68733 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: Herman Rimm <herman <at> rimm.ee>
Cc: Josselin Poiret <dev <at> jpoiret.xyz>,
 Simon Tournier <zimon.toutoune <at> gmail.com>, Mathieu Othacehe <othacehe <at> gnu.org>,
 Tobias Geerinckx-Rice <me <at> tobias.gr>, 68733 <at> debbugs.gnu.org,
 Ricardo Wurmus <rekado <at> elephly.net>, Christopher Baines <guix <at> cbaines.net>
Subject: Re: [bug#68733] [PATCH] machine: ssh: Add 'graft?' field.
Date: Mon, 29 Jan 2024 14:17:09 +0100

Hi,

Herman Rimm <herman <at> rimm.ee> skribis:

> * 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?

[...]

> +@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.

When deploying to a different architecture, is it enough to set
(build-locally? #f) ?

Now, this field only exists for ‘machine-ssh-configuration’ and not for
Digital Ocean, but perhaps we could add it there?

Overall, I think we should cater to this use case (deploying to a
different architecture) without requiring users to disable grafts,
because that’d be exposing them to security vulnerabilities.

Thanks,
Ludo’.

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.