@@ -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})
@@ -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))
@@ -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)