Package: guix-patches;
Reported by: Herman Rimm <herman <at> rimm.ee>
Date: Fri, 26 Jan 2024 11:07:01 UTC
Severity: normal
Tags: moreinfo, patch
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
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.