GNU bug report logs - #75144
[PATCH] machine: Implement 'hetzner-environment-type'.

Previous Next

To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 75144 in the body.
You can then email your comments to 75144 AT debbugs.gnu.org in the normal way.

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

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

From: Roman Scherer <roman <at> burningswell.com>
To: guix-patches <at> gnu.org
Cc: Roman Scherer <roman <at> burningswell.com>
Subject: [PATCH] machine: Implement 'hetzner-environment-type'.
Date: Fri, 27 Dec 2024 17:46:39 +0100

* gnu/machine/hetzner.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
* guix/ssh.scm (open-ssh-session): Add stricthostkeycheck option.
* doc/guix.texi (Invoking guix deploy): Add documentation for
'hetzner-configuration'.

Change-Id: Idc17dbc33279ecbf3cbfe2c53d7699140f8b9f41
---
 doc/guix.texi           |   86 ++++
 gnu/local.mk            |    1 +
 gnu/machine/hetzner.scm | 1039 +++++++++++++++++++++++++++++++++++++++
 guix/ssh.scm            |   19 +-
 4 files changed, 1137 insertions(+), 8 deletions(-)
 create mode 100644 gnu/machine/hetzner.scm

diff --git a/doc/guix.texi b/doc/guix.texi
index da4d2f5ebc..020f460327 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -44399,6 +44399,92 @@ Invoking guix deploy
 @end table
 @end deftp
 
+@deftp {Data Type} hetzner-configuration
+This is the data type describing the server that should be created for a
+machine with an @code{environment} of @code{hetzner-environment-type}.
+
+@table @asis
+@item @code{allow-downgrades?} (default: @code{#f})
+Whether to allow potential downgrades.
+@item @code{authorize?} (default: @code{#t})
+If true, the coordinator's public signing key
+@code{"/etc/guix/signing-key.pub"} will be added to the server's ACL
+keyring.
+@item @code{build-locally?} (default: @code{#t})
+If false, system derivations will be built on the machine being deployed to.
+@item @code{delete?} (default: @code{#t})
+If true, the server will be deleted when an error happens in the
+provisioning phase. If false, the server will be kept in order to debug
+any issues.
+@item @code{enable-ipv6?} (default: @code{#t})
+If true, attach an IPv6 on the public NIC. If false, no IPv6 address will be attached.
+@item @code{labels} (default: @code{'()})
+A user defined alist of key/value pairs attached to the server. Keys and
+values must be strings. For more information, see
+@uref{https://docs.hetzner.cloud/#labels, Labels}.
+@item @code{location} (default: @code{"fsn1"})
+The name of a @uref{https://docs.hetzner.com/cloud/general/locations,
+location} to create the server in.
+@item @code{cleanup} (default: @code{#t})
+Whether to delete the Hetzner server if provisioning fails or not.
+@item @code{server-type} (default: @code{"cx42"})
+The name of the
+@uref{https://docs.hetzner.com/cloud/servers/overview#server-types,
+server type} this server should be created with.
+@item @code{ssh-key}
+The path to the SSH private key to use to authenticate with the remote
+host.
+@end table
+
+When deploying a machine with the @code{hetzner-environment-type} a
+virtual private server (VPS) is created for it on the
+@uref{https://www.hetzner.com/cloud, Hetzner Cloud} service.  The server
+is first booted into the
+@uref{https://docs.hetzner.com/cloud/servers/getting-started/rescue-system,
+Rescue System} to setup the partitions of the server and install a
+minimal Guix system, which is then used with the
+@code{managed-host-environment-type} to complete the deployment.
+
+Servers on the Hetzner Cloud service can be provisioned on the
+@code{aarch64} architecture using UEFI boot mode, or on the
+@code{x86_64} architecture using BIOS boot mode.  The @code{(gnu machine
+hetzner)} module exports the @code{%hetzner-os-arm} and
+@code{%hetzner-os-x86} operating systems that are compatible with those
+2 architectures, and can be used as a base for defining your custom
+operating system.
+
+The following example shows the definition of 2 machines that are
+deployed on the Hetzner Cloud service.  The first one uses the
+@code{%hetzner-os-arm} operating system to run a server with 16 shared
+vCPUs and 32 GB of RAM on the @code{aarch64} architecture, the second
+one uses the @code{%hetzner-os-x86} operating system on a server with 16
+shared vCPUs and 32 GB of RAM on the @code{x86_64} architecture.
+
+@lisp
+(use-modules (gnu machine)
+             (gnu machine hetzner))
+
+(list (machine
+       (operating-system %hetzner-os-arm)
+       (environment hetzner-environment-type)
+       (configuration (hetzner-configuration
+                       (server-type "cax41")
+                       (ssh-key "/home/charlie/.ssh/id_rsa"))))
+      (machine
+       (operating-system %hetzner-os-x86)
+       (environment hetzner-environment-type)
+       (configuration (hetzner-configuration
+                       (server-type "cpx51")
+                       (ssh-key "/home/charlie/.ssh/id_rsa")))))
+@end lisp
+
+Passing this file to @command{guix deploy} with the environment variable
+@env{GUIX_HETZNER_API_TOKEN} set to a valid Hetzner
+@uref{https://docs.hetzner.com/cloud/api/getting-started/generating-api-token,
+API key} should provision 2 machines for you.
+
+@end deftp
+
 @node Running Guix in a VM
 @section Running Guix in a Virtual Machine
 
diff --git a/gnu/local.mk b/gnu/local.mk
index 84160f407a..98000766af 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -911,6 +911,7 @@ if HAVE_GUILE_SSH
 
 GNU_SYSTEM_MODULES +=         			\
   %D%/machine/digital-ocean.scm			\
+  %D%/machine/hetzner.scm			\
   %D%/machine/ssh.scm
 
 endif HAVE_GUILE_SSH
diff --git a/gnu/machine/hetzner.scm b/gnu/machine/hetzner.scm
new file mode 100644
index 0000000000..9f8c3806b3
--- /dev/null
+++ b/gnu/machine/hetzner.scm
@@ -0,0 +1,1039 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Roman Scherer <roman <at> burningswell.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu machine hetzner)
+  #:use-module (gnu bootloader grub)
+  #:use-module (gnu bootloader)
+  #:use-module (gnu machine ssh)
+  #:use-module (gnu machine)
+  #:use-module (gnu packages ssh)
+  #:use-module (gnu services base)
+  #:use-module (gnu services networking)
+  #:use-module (gnu services ssh)
+  #:use-module (gnu services)
+  #:use-module (gnu system file-systems)
+  #:use-module (gnu system image)
+  #:use-module (gnu system linux-initrd)
+  #:use-module (gnu system pam)
+  #:use-module (gnu system)
+  #:use-module (guix base32)
+  #:use-module (guix colors)
+  #:use-module (guix derivations)
+  #:use-module (guix diagnostics)
+  #:use-module (guix gexp)
+  #:use-module (guix i18n)
+  #:use-module (guix import json)
+  #:use-module (guix monads)
+  #:use-module (guix packages)
+  #:use-module (guix pki)
+  #:use-module (guix records)
+  #:use-module (guix ssh)
+  #:use-module (guix store)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 iconv)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 string-fun)
+  #:use-module (ice-9 textual-ports)
+  #:use-module (json)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-2)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (ssh channel)
+  #:use-module (ssh key)
+  #:use-module (ssh popen)
+  #:use-module (ssh session)
+  #:use-module (ssh sftp)
+  #:use-module (ssh shell)
+  #:use-module (web client)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:export (%hetzner-os-arm
+            %hetzner-os-x86
+            deploy-hetzner
+            hetzner-api
+            hetzner-api-auth-token
+            hetzner-api-base-url
+            hetzner-configuration
+            hetzner-configuration-allow-downgrades?
+            hetzner-configuration-authorize?
+            hetzner-configuration-build-locally?
+            hetzner-configuration-delete?
+            hetzner-configuration-enable-ipv6?
+            hetzner-configuration-labels
+            hetzner-configuration-location
+            hetzner-configuration-networks
+            hetzner-configuration-server-type
+            hetzner-configuration-ssh-key
+            hetzner-configuration?
+            hetzner-environment-type))
+
+;;; Commentary:
+;;;
+;;; This module implements a high-level interface for provisioning "servers"
+;;; from the Hetzner Cloud service.
+;;;
+
+(define %hetzner-api-token
+  (make-parameter (getenv "GUIX_HETZNER_API_TOKEN")))
+
+
+;;;
+;;; Hetzner operating systems.
+;;;
+
+;; Operating system for arm servers using UEFI boot mode.
+
+(define %hetzner-os-arm
+  (operating-system
+    (host-name "guix-arm")
+    (bootloader
+     (bootloader-configuration
+      (bootloader grub-efi-bootloader)
+      (targets (list "/boot/efi"))
+      (terminal-outputs '(console))))
+    (file-systems
+     (cons* (file-system
+              (mount-point "/")
+              (device "/dev/sda1")
+              (type "ext4"))
+            (file-system
+              (mount-point "/boot/efi")
+              (device "/dev/sda15")
+              (type "vfat"))
+            %base-file-systems))
+    (initrd-modules
+     (cons* "sd_mod" "virtio_scsi" %base-initrd-modules))
+    (services
+     (cons* (service dhcp-client-service-type)
+            (service openssh-service-type
+                     (openssh-configuration
+                      (openssh openssh-sans-x)
+                      (permit-root-login 'prohibit-password)))
+            %base-services))))
+
+;; Operating system for x86 servers using BIOS boot mode.
+
+(define %hetzner-os-x86
+  (operating-system
+    (inherit %hetzner-os-arm)
+    (host-name "guix-x86")
+    (bootloader
+     (bootloader-configuration
+      (bootloader grub-bootloader)
+      (targets (list "/dev/sda"))
+      (terminal-outputs '(console))))
+    (initrd-modules
+     (cons "virtio_scsi" %base-initrd-modules))
+    (file-systems
+     (cons (file-system
+             (mount-point "/")
+             (device "/dev/sda1")
+             (type "ext4"))
+           %base-file-systems))))
+
+(define (operating-system-authorize os)
+  "Authorize the OS with the public signing key of the current machine."
+  (if (file-exists? %public-key-file)
+      (operating-system
+        (inherit os)
+        (services
+         (modify-services (operating-system-user-services os)
+           (guix-service-type
+            config => (guix-configuration
+                       (inherit config)
+                       (authorized-keys
+                        (cons*
+                         (local-file %public-key-file)
+                         (guix-configuration-authorized-keys config))))))))
+      (raise (formatted-message (G_ "no signing key '~a'. \
+Have you run 'guix archive --generate-key'?")
+                                %public-key-file))))
+
+(define (operating-system-root-file-system-type os)
+  "Return the root file system type of the operating system OS."
+  (let ((root-fs (find (lambda (file-system)
+                         (equal? "/" (file-system-mount-point file-system)))
+                       (operating-system-file-systems os))))
+    (if (file-system? root-fs)
+        (file-system-type root-fs)
+        (raise (formatted-message
+                (G_ "could not determine root file system type"))))))
+
+
+;;;
+;;; Helper functions.
+;;;
+
+(define (escape-backticks str)
+  "Escape all backticks in STR."
+  (string-replace-substring str "`" "\\`"))
+
+(define (format-query-param param)
+  "Format the query PARAM as a string."
+  (string-append (uri-encode (format #f "~a" (car param))) "="
+                 (uri-encode (format #f "~a" (cdr param)))))
+
+(define (format-query-params params)
+  "Format the query PARAMS as a string."
+  (if (> (length params) 0)
+      (string-append
+       "?"
+       (string-join
+        (map format-query-param params)
+        "&"))
+      ""))
+
+
+
+;;;
+;;; Hetzner API response.
+;;;
+
+(define-record-type* <hetzner-api-response> hetzner-api-response
+  make-hetzner-api-response hetzner-api-response? hetzner-api-response
+  (body hetzner-api-response-body)
+  (headers hetzner-api-response-headers)
+  (status hetzner-api-response-status))
+
+(define (hetzner-api-response-meta response)
+  "Return the meta information of the Hetzner API response."
+  (assoc-ref (hetzner-api-response-body response) "meta"))
+
+(define (hetzner-api-response-pagination response)
+  "Return the meta information of the Hetzner API response."
+  (assoc-ref (hetzner-api-response-meta response) "pagination"))
+
+(define (hetzner-api-response-pagination-combine resource responses)
+  "Combine multiple Hetzner API pagination responses into a single response."
+  (if (positive? (length responses))
+      (let* ((response (car responses))
+             (pagination (hetzner-api-response-pagination response))
+             (total-entries (assoc-ref pagination "total_entries")))
+        (hetzner-api-response
+         (inherit response)
+         (body `(("meta"
+                  ("pagination"
+                   ("last_page" . 1)
+                   ("next_page" . null)
+                   ("page" . 1)
+                   ("per_page" . ,total-entries)
+                   ("previous_page" . null)
+                   ("total_entries" . ,total-entries)))
+                 (,resource . ,(append-map
+                                (lambda (body)
+                                  (vector->list (assoc-ref body resource)))
+                                (map hetzner-api-response-body responses)))))))
+      (raise (formatted-message
+              (G_ "Expected a list of Hetzner API responses")))))
+
+(define (hetzner-api-response-read port)
+  "Read the Hetzner API response from PORT."
+  (let* ((response (read-response port))
+         (body (read-response-body response)))
+    (hetzner-api-response
+     (body (json-string->scm (bytevector->string body "UTF-8")))
+     (headers (response-headers response))
+     (status (response-code response)))))
+
+(define (hetzner-api-response-validate-status response expected)
+  "Raise an error if the HTTP status code of RESPONSE is not in EXPECTED."
+  (when (not (member (hetzner-api-response-status response) expected))
+    (raise (formatted-message
+            (G_ "Unexpected HTTP status code: ~a, expected: ~a~%~a")
+            (hetzner-api-response-status response)
+            expected
+            (hetzner-api-response-body response)))))
+
+
+
+;;;
+;;; Hetzner API request.
+;;;
+
+(define-record-type* <hetzner-api-request> hetzner-api-request
+  make-hetzner-api-request hetzner-api-request? hetzner-api-request
+  (body hetzner-api-request-body (default *unspecified*))
+  (headers hetzner-api-request-headers (default '()))
+  (method hetzner-api-request-method (default 'GET))
+  (params hetzner-api-request-params (default '()))
+  (url hetzner-api-request-url))
+
+(define (hetzner-api-request-uri request)
+  "Return the URI object of the Hetzner API request."
+  (let ((params (hetzner-api-request-params request)))
+    (string->uri (string-append (hetzner-api-request-url request)
+                                (format-query-params params)))))
+
+(define (hetzner-api-request-body-bytevector request)
+  "Return the body of the Hetzner API REQUEST as a bytevector."
+  (let* ((body (hetzner-api-request-body request))
+         (string (if (unspecified? body) "" (scm->json-string body))))
+    (string->bytevector string "UTF-8")))
+
+(define (hetzner-api-request-write port request)
+  "Write the Hetzner API REQUEST to PORT."
+  (let* ((body (hetzner-api-request-body-bytevector request))
+         (request (build-request
+                   (hetzner-api-request-uri request)
+                   #:method (hetzner-api-request-method request)
+                   #:version '(1 . 1)
+                   #:headers (cons* `(Content-Length
+                                      . ,(number->string
+                                          (if (unspecified? body)
+                                              0 (bytevector-length body))))
+                                    (hetzner-api-request-headers request))
+                   #:port port))
+         (request (write-request request port)))
+    (unless (unspecified? body)
+      (write-request-body request body))
+    (force-output (request-port request))))
+
+(define* (hetzner-api-request-send request #:key (expected (list 200 201)))
+  "Send the Hetzner API REQUEST via HTTP."
+  (let ((port (open-socket-for-uri (hetzner-api-request-uri request))))
+    (hetzner-api-request-write port request)
+    (let ((response (hetzner-api-response-read port)))
+      (close-port port)
+      (hetzner-api-response-validate-status response expected)
+      response)))
+
+(define (hetzner-api-request-next-params request)
+  "Return the pagination params for the next page of the REQUEST."
+  (let* ((params (hetzner-api-request-params request))
+         (page (or (assoc-ref params "page") 1)))
+    (map (lambda (param)
+           (if (equal? "page" (car param))
+               (cons (car param) (+ page 1))
+               param))
+         params)))
+
+(define (hetzner-api-request-paginate request)
+  "Fetch all pages of the REQUEST via pagination and return all responses."
+  (let* ((response (hetzner-api-request-send request))
+         (pagination (hetzner-api-response-pagination response))
+         (next-page (assoc-ref pagination "next_page")))
+    (if (number? next-page)
+        (cons response
+              (hetzner-api-request-paginate
+               (hetzner-api-request
+                (inherit request)
+                (params (hetzner-api-request-next-params request)))))
+        (list response))))
+
+
+
+;;;
+;;; Hetzner API.
+;;;
+
+(define-record-type* <hetzner-api> hetzner-api
+  make-hetzner-api hetzner-api? hetzner-api
+  (auth-token hetzner-api-auth-token ; string
+              (default (%hetzner-api-token)))
+  (base-url hetzner-api-base-url ; string
+            (default "https://api.hetzner.cloud/v1")))
+
+(define (hetzner-api-authorization-header api)
+  "Return the authorization header the Hetzner API."
+  (format #f "Bearer ~a" (hetzner-api-auth-token api)))
+
+(define (hetzner-api-default-headers api)
+  "Returns the default headers of the Hetzner API."
+  `((user-agent . "Guix Deploy")
+    (Accept . "application/json")
+    (Authorization . ,(hetzner-api-authorization-header api))
+    (Content-Type . "application/json")))
+
+(define (hetzner-api-url api path)
+  "Append PATH to the base url of the Hetzner API."
+  (string-append (hetzner-api-base-url api) path))
+
+(define (hetzner-api-delete api path)
+  "Delelte the resource at PATH with the Hetzner API."
+  (hetzner-api-request-send
+   (hetzner-api-request
+    (headers (hetzner-api-default-headers api))
+    (method 'DELETE)
+    (url (hetzner-api-url api path)))))
+
+(define* (hetzner-api-list api path resources #:key (params '()))
+  "Fetch all objects of RESOURCE from the Hetzner API."
+  (assoc-ref (hetzner-api-response-body
+              (hetzner-api-response-pagination-combine
+               resources (hetzner-api-request-paginate
+                          (hetzner-api-request
+                           (url (hetzner-api-url api path))
+                           (headers (hetzner-api-default-headers api))
+                           (params (cons '("page" . 1) params))))))
+             resources))
+
+(define* (hetzner-api-post api path #:key (body *unspecified*))
+  "Send a POST request to the Hetzner API at PATH using BODY."
+  (hetzner-api-response-body
+   (hetzner-api-request-send
+    (hetzner-api-request
+     (body body)
+     (method 'POST)
+     (url (hetzner-api-url api path))
+     (headers (hetzner-api-default-headers api))))))
+
+(define* (hetzner-api-actions api . options)
+  "Get actions from the Hetzner API."
+  (apply hetzner-api-list api "/actions" "actions" options))
+
+(define* (hetzner-api-action-wait api action #:optional (status "success"))
+  "Wait until the ACTION has reached STATUS on the Hetzner API."
+  (let ((id (assoc-ref action "id")))
+    (let loop ()
+      (let ((actions (hetzner-api-actions api #:params `(("id" . ,id)))))
+        (cond
+         ((zero? (length actions))
+          (raise (formatted-message (G_ "server action '~a' not found") id)))
+         ((not (= 1 (length actions)))
+          (raise (formatted-message
+                  (G_ "expected one server action, but got '~a'")
+                  (length actions))))
+         ((string= status (assoc-ref (car actions) "status"))
+          (car actions))
+         (else
+          (sleep 5)
+          (loop)))))))
+
+(define* (hetzner-api-locations api . options)
+  "Get deployment locations from the Hetzner API."
+  (apply hetzner-api-list api "/locations" "locations" options))
+
+(define (hetzner-api-server-create api server)
+  "Create a server on the Hetzner API."
+  (hetzner-api-post api "/servers" #:body server))
+
+(define (hetzner-api-server-delete api server)
+  "Delete the SERVER on the Hetzner API."
+  (hetzner-api-delete api (hetzner-server-path server)))
+
+(define* (hetzner-api-server-enable-rescue-system
+          api server #:key (ssh-keys '()) (type "linux64"))
+  "Enable the rescue system for SERVER on the Hetzner API."
+  (let ((ssh-keys (apply vector (map hetzner-ssh-key-id ssh-keys))))
+    (hetzner-api-post api (hetzner-server-path server "/actions/enable_rescue")
+                      #:body `(("ssh_keys" . ,ssh-keys)
+                               ("type" . ,type)))))
+
+(define* (hetzner-api-servers api . options)
+  "Get servers from the Hetzner API."
+  (apply hetzner-api-list api "/servers" "servers" options))
+
+(define (hetzner-api-server-power-on api server)
+  "Send a power on request for SERVER to the Hetzner API."
+  (hetzner-api-post api (hetzner-server-path server "/actions/poweron")))
+
+(define (hetzner-api-server-power-off api server)
+  "Send a power off request for SERVER to the Hetzner API."
+  (hetzner-api-post api (hetzner-server-path server "/actions/poweroff")))
+
+(define (hetzner-api-server-reboot api server)
+  "Send a reboot request for SERVER to the Hetzner API."
+  (hetzner-api-post api (hetzner-server-path server "/actions/reboot")))
+
+(define (hetzner-api-ssh-key-create api ssh-key)
+  "Create the SSH key on the Hetzner API."
+  (hetzner-api-post api "/ssh_keys" #:body ssh-key))
+
+(define* (hetzner-api-ssh-keys api . options)
+  "Get SSH keys from the Hetzner API."
+  (apply hetzner-api-list api "/ssh_keys" "ssh_keys" options))
+
+(define* (hetzner-api-server-types api . options)
+  "Get server types from the Hetzner API."
+  (apply hetzner-api-list api "/server_types" "server_types" options))
+
+
+
+;;;
+;;; Hetzner SSH key.
+;;;
+
+(define (hetzner-ssh-key-id ssh-key)
+  "Return the id of the SSH-KEY."
+  (assoc-ref ssh-key "id"))
+
+
+
+;;;
+;;; Hetzner server.
+;;;
+
+(define* (hetzner-server-path server #:optional (path ""))
+  "Return the PATH of the Hetzner SERVER."
+  (format #f "/servers/~a~a" (assoc-ref server "id") path))
+
+(define (hetzner-server-type server)
+  "Return the type of the Hetzner SERVER."
+  (assoc-ref server "server_type"))
+
+(define (hetzner-server-architecture server)
+  "Return the architecture of the Hetzner SERVER."
+  (assoc-ref (hetzner-server-type server) "architecture"))
+
+(define (hetzner-server-public-ipv4 server)
+  "Return the public IPv4 address of the SERVER."
+  (and-let* ((public-net (assoc-ref server "public_net"))
+             (network (assoc-ref public-net "ipv4")))
+    (assoc-ref network "ip")))
+
+(define (hetzner-server-system server)
+  "Return the Guix system architecture of the Hetzner SERVER."
+  (match (hetzner-server-architecture server)
+    ("arm" "aarch64-linux")
+    ("x86" "x86_64-linux")))
+
+
+;;;
+;;; Hetzner configuration.
+;;;
+
+(define-record-type* <hetzner-configuration> hetzner-configuration
+  make-hetzner-configuration hetzner-configuration? this-hetzner-configuration
+  (api hetzner-configuration-api ; <hetzner-api>
+       (default (hetzner-api)))
+  (allow-downgrades? hetzner-configuration-allow-downgrades? ; boolean
+                     (default #f))
+  (authorize? hetzner-configuration-authorize? ; boolean
+              (default #t))
+  (build-locally? hetzner-configuration-build-locally? ; boolean
+                  (default #t))
+  (delete? hetzner-configuration-delete? ; boolean
+           (default #f))
+  (enable-ipv6? hetzner-configuration-enable-ipv6? ; boolean
+                (default #t))
+  (labels hetzner-configuration-labels ; list of strings
+          (default '()))
+  (location hetzner-configuration-location  ; #f | string
+            (default "fsn1"))
+  (networks hetzner-configuration-networks ; list of integers
+            (default '()))
+  (server-type hetzner-configuration-server-type ; string
+               (default "cx42"))
+  (ssh-key hetzner-configuration-ssh-key)) ; string
+
+(define (hetzner-configuration-public-net config)
+  "Return the public network configuration of a server for CONFIG."
+  `(("enable_ipv6" . ,(hetzner-configuration-enable-ipv6? config))))
+
+(define (hetzner-configuration-ssh-key-fingerprint config)
+  "Return the SSH public key fingerprint of CONFIG as a string."
+  (and-let* ((file-name (hetzner-configuration-ssh-key config))
+             (privkey (private-key-from-file file-name))
+             (pubkey (private-key->public-key privkey))
+             (hash (get-public-key-hash pubkey 'md5)))
+    (bytevector->hex-string hash)))
+
+(define (hetzner-configuration-ssh-key-public config)
+  "Return the SSH public key of CONFIG as a string."
+  (and-let* ((ssh-key (hetzner-configuration-ssh-key config))
+             (public-key (public-key-from-file ssh-key)))
+    (format #f "ssh-~a ~a" (get-key-type public-key)
+            (public-key->string public-key))))
+
+
+;;;
+;;; Hetzner Machine.
+;;;
+
+(define (hetzner-machine-delegate target)
+  "Return the delagate machine that uses SSH for deployment."
+  (let* ((config (machine-configuration target))
+         (server (hetzner-machine-server target))
+         ;; Get the operating system WITHOUT the provenance service to avoid a
+         ;; duplicate symlink conflict in the store.
+         (os ((@@ (gnu machine) %machine-operating-system) target)))
+    (machine
+     (inherit target)
+     (operating-system
+       (if (hetzner-configuration-authorize? config)
+           (operating-system-authorize os)
+           os))
+     (environment managed-host-environment-type)
+     (configuration
+      (machine-ssh-configuration
+       (allow-downgrades? (hetzner-configuration-allow-downgrades? config))
+       (authorize? (hetzner-configuration-authorize? config))
+       (build-locally? (hetzner-configuration-build-locally? config))
+       (host-name (hetzner-server-public-ipv4 server))
+       (identity (hetzner-configuration-ssh-key config))
+       (system (hetzner-server-system server)))))))
+
+(define (hetzner-machine-location machine)
+  "Find the location of MACHINE on the Hetzner API."
+  (let* ((config (machine-configuration machine))
+         (location (hetzner-configuration-location config)))
+    (find (lambda (type)
+            (equal? location (assoc-ref type "name")))
+          (hetzner-api-locations
+           (hetzner-configuration-api config)
+           #:params `(("name" . ,location))))))
+
+(define (hetzner-machine-server-type machine)
+  "Find the server type of MACHINE on the Hetzner API."
+  (let* ((config (machine-configuration machine))
+         (server-type (hetzner-configuration-server-type config)))
+    (find (lambda (type)
+            (equal? server-type (assoc-ref type "name")))
+          (hetzner-api-server-types
+           (hetzner-configuration-api config)
+           #:params `(("name" . ,server-type))))))
+
+(define (hetzner-machine-validate-auth-token machine)
+  "Validate the Hetzner API authentication token of MACHINE."
+  (let* ((config (machine-configuration machine))
+         (api (hetzner-configuration-api config)))
+    (unless (hetzner-api-auth-token api)
+      (raise (formatted-message
+              (G_ "No Hetzner Cloud access token was provided. \
+This may be fixed by setting the environment variable GUIX_HETZNER_API_TOKEN
+to one procured from \
+https://docs.hetzner.com/cloud/api/getting-started/generating-api-token"))))))
+
+(define (hetzner-machine-validate-configuration-type machine)
+  "Raise an error if MACHINE's configuration is not an instance of
+<hetzner-configuration>."
+  (let ((config (machine-configuration machine))
+        (environment (environment-type-name (machine-environment machine))))
+    (unless (and config (hetzner-configuration? config))
+      (raise (formatted-message (G_ "unsupported machine configuration '~a' \
+for environment of type '~a'")
+                                config
+                                environment)))))
+
+(define (hetzner-machine-validate-server-type machine)
+  "Raise an error if the server type of MACHINE is not supported."
+  (unless (hetzner-machine-server-type machine)
+    (let* ((config (machine-configuration machine))
+           (api (hetzner-configuration-api config)))
+      (raise (formatted-message
+              (G_ "Server type '~a' not supported~%~%\
+Available server types:~%~%~a")
+              (hetzner-configuration-server-type config)
+              (string-join
+               (map (lambda (type)
+                      (format #f " - ~a: ~a, ~a ~a cores, ~a GB mem, ~a GB disk"
+                              (colorize-string (assoc-ref type "name")
+                                               (color BOLD))
+                              (assoc-ref type "architecture")
+                              (assoc-ref type "cores")
+                              (assoc-ref type "cpu_type")
+                              (assoc-ref type "memory")
+                              (assoc-ref type "disk")))
+                    (hetzner-api-server-types api))
+               "\n"))))))
+
+(define (hetzner-machine-validate-location machine)
+  "Raise an error if the location of MACHINE is not supported."
+  (unless (hetzner-machine-location machine)
+    (let* ((config (machine-configuration machine))
+           (api (hetzner-configuration-api config)))
+      (raise (formatted-message
+              (G_ "Server location '~a' not supported~%~%\
+Available locations:~%~%~a")
+              (hetzner-configuration-location config)
+              (string-join
+               (map (lambda (location)
+                      (format #f " - ~a: ~a, ~a"
+                              (colorize-string (assoc-ref location "name")
+                                               (color BOLD))
+                              (assoc-ref location "description")
+                              (assoc-ref location "country")))
+                    (hetzner-api-locations api))
+               "\n"))))))
+
+(define (hetzner-machine-validate machine)
+  "Validate the Hetzner MACHINE."
+  (hetzner-machine-validate-configuration-type machine)
+  (hetzner-machine-validate-auth-token machine)
+  (hetzner-machine-validate-location machine)
+  (hetzner-machine-validate-server-type machine))
+
+(define (hetzner-machine-bootstrap-os-form machine server)
+  "Return the form to bootstrap an operating system on SERVER."
+  (let* ((os (machine-operating-system machine))
+         (system (hetzner-server-system server))
+         (arm? (equal? "arm" (hetzner-server-architecture server)))
+         (x86? (equal? "x86" (hetzner-server-architecture server)))
+         (root-fs-type (operating-system-root-file-system-type os)))
+    `(operating-system
+       (host-name ,(operating-system-host-name os))
+       (timezone "Etc/UTC")
+       (bootloader (bootloader-configuration
+                    (bootloader ,(cond (arm? 'grub-efi-bootloader)
+                                       (x86? 'grub-bootloader)))
+                    (targets ,(cond (arm? '(list "/boot/efi"))
+                                    (x86? '(list "/dev/sda"))))
+                    (terminal-outputs '(console))))
+       (initrd-modules (append
+                        ,(cond (arm? '(list "sd_mod" "virtio_scsi"))
+                               (x86? '(list "virtio_scsi")))
+                        %base-initrd-modules))
+       (file-systems ,(cond
+                       (arm? `(cons* (file-system
+                                       (mount-point "/")
+                                       (device "/dev/sda1")
+                                       (type ,root-fs-type))
+                                     (file-system
+                                       (mount-point "/boot/efi")
+                                       (device "/dev/sda15")
+                                       (type "vfat"))
+                                     %base-file-systems))
+                       (x86? `(cons* (file-system
+                                       (mount-point "/")
+                                       (device "/dev/sda1")
+                                       (type ,root-fs-type))
+                                     %base-file-systems))))
+       (services
+        (cons* (service dhcp-client-service-type)
+               (service openssh-service-type
+                        (openssh-configuration
+                         (openssh openssh-sans-x)
+                         (permit-root-login 'prohibit-password)))
+               %base-services)))))
+
+(define (rexec-verbose session cmd)
+  "Execute a command CMD on the remote side and print output.  Return two
+values: list of output lines returned by CMD and its exit code."
+  (let* ((channel (open-remote-input-pipe session cmd))
+         (result  (let loop ((line   (read-line channel))
+                             (result '()))
+                    (if (eof-object? line)
+                        (reverse result)
+                        (begin
+                          (display line)
+                          (newline)
+                          (loop (read-line channel)
+                                (cons line result))))))
+         (exit-status (channel-get-exit-status channel)))
+    (close channel)
+    (values result exit-status)))
+
+(define (hetzner-machine-ssh-key machine)
+  "Find the SSH key for MACHINE on the Hetzner API."
+  (let* ((config (machine-configuration machine))
+         (fingerprint (hetzner-configuration-ssh-key-fingerprint config)))
+    (find (lambda (server)
+            (equal? (assoc-ref server "fingerprint") fingerprint))
+          (hetzner-api-ssh-keys
+           (hetzner-configuration-api config)
+           #:params `(("fingerprint" . ,fingerprint))))))
+
+(define (hetzner-machine-ssh-key-create machine)
+  "Create the SSH key for MACHINE on the Hetzner API."
+  (let ((name (machine-display-name machine)))
+    (format #t "creating ssh key for '~a'...\n" name)
+    (let* ((config (machine-configuration machine))
+           (api (hetzner-configuration-api config))
+           (body (hetzner-api-ssh-key-create
+                  (hetzner-configuration-api config)
+                  `(("name" . ,(machine-display-name machine))
+                    ("name" .
+                     ,(hetzner-configuration-ssh-key-fingerprint config))
+                    ("public_key" .
+                     ,(hetzner-configuration-ssh-key-public config))
+                    ("labels" . ,(hetzner-configuration-labels config))))))
+      (format #t "successfully created ssh key for '~a'\n" name)
+      (assoc-ref body "ssh_key"))))
+
+(define (hetzner-machine-server machine)
+  "Find the Hetzner server for MACHINE."
+  (let ((config (machine-configuration machine)))
+    (find (lambda (server)
+            (equal? (machine-display-name machine)
+                    (assoc-ref server "name")))
+          (hetzner-api-servers
+           (hetzner-configuration-api config)
+           #:params `(("name" . ,(machine-display-name machine)))))))
+
+(define (hetzner-machine-create-server machine)
+  "Create the Hetzner server for MACHINE."
+  (let* ((config (machine-configuration machine))
+         (name (machine-display-name machine))
+         (server-type (hetzner-configuration-server-type config)))
+    (format #t "creating '~a' server for '~a'...\n" server-type name)
+    (let* ((ssh-key (hetzner-machine-ssh-key machine))
+           (api (hetzner-configuration-api config))
+           (body (hetzner-api-server-create
+                  api
+                  `(("image" . "debian-11")
+                    ("labels" . ,(hetzner-configuration-labels config))
+                    ("name" . ,(machine-display-name machine))
+                    ("public_net" . ,(hetzner-configuration-public-net config))
+                    ("location" . ,(hetzner-configuration-location config))
+                    ("server_type" .
+                     ,(hetzner-configuration-server-type config))
+                    ("ssh_keys" . ,(vector (hetzner-ssh-key-id ssh-key)))
+                    ("start_after_create" . #f))))
+           (server (assoc-ref body "server"))
+           (architecture (hetzner-server-architecture server)))
+      (hetzner-api-action-wait api (assoc-ref body "action"))
+      (format #t "successfully created '~a' ~a server for '~a'\n"
+              server-type architecture name)
+      server)))
+
+(define (wait-for-ssh address ssh-key)
+  "Block until a SSH session can be made as 'root' with SSH-KEY at ADDRESS."
+  (format #t "connecting via SSH to '~a' using '~a'...\n" address ssh-key)
+  (let loop ()
+    (catch #t
+      (lambda ()
+        (open-ssh-session address #:user "root" #:identity ssh-key
+                          #:stricthostkeycheck #f))
+      (lambda args
+        (let ((msg (cadr args)))
+          (if (formatted-message? msg)
+              (format #t "~a\n"
+                      (string-trim-right
+                       (apply format #f
+                              (formatted-message-string msg)
+                              (formatted-message-arguments msg))
+                       #\newline))
+              (format #t "~a" args))
+          (sleep 5)
+          (loop))))))
+
+(define (hetzner-machine-wait-for-ssh machine)
+  "Wait for SSH connection to be established with the specified machine."
+  (let ((server (hetzner-machine-server machine)))
+    (wait-for-ssh (hetzner-server-public-ipv4 server)
+                  (hetzner-configuration-ssh-key
+                   (machine-configuration machine)))))
+
+(define (hetzner-machine-authenticate-host machine)
+  "Add the host key of MACHINE to the list of known hosts."
+  (let ((ssh-session (hetzner-machine-wait-for-ssh machine)))
+    (write-known-host! ssh-session)))
+
+(define (hetzner-machine-enable-rescue-system machine server)
+  "Enable the rescue system on the Hetzner SERVER for MACHINE."
+  (let* ((name (machine-display-name machine))
+         (config (machine-configuration machine))
+         (api (hetzner-configuration-api config))
+         (ssh-keys (list (hetzner-machine-ssh-key machine))))
+    (format #t "enabling rescue system on '~a'...\n" name)
+    (let ((body (hetzner-api-server-enable-rescue-system
+                 api server #:ssh-keys ssh-keys)))
+      (hetzner-api-action-wait api (assoc-ref body "action"))
+      (format #t "successfully enabled rescue system on '~a'\n" name)
+      body)))
+
+(define (hetzner-machine-power-on machine server)
+  "Power on the Hetzner SERVER for MACHINE."
+  (let* ((name (machine-display-name machine))
+         (config (machine-configuration machine))
+         (api (hetzner-configuration-api config)))
+    (format #t "powering on server for '~a'...\n" name)
+    (let ((body (hetzner-api-server-power-on api server)))
+      (hetzner-api-action-wait api (assoc-ref body "action"))
+      (format #t "successfully powered on server for '~a'\n" name)
+      body)))
+
+(define (hetzner-machine-ssh-run-script ssh-session name content)
+  (let ((sftp-session (make-sftp-session ssh-session)))
+    (rexec ssh-session (format #f "rm -f ~a" name))
+    (rexec ssh-session (format #f "mkdir -p ~a" (dirname name)))
+    (call-with-remote-output-file
+     sftp-session name
+     (lambda (port)
+       (display content port)))
+    (sftp-chmod sftp-session name 755)
+    (receive (lines exit-code)
+        (rexec-verbose ssh-session (format #f "~a 2>&1" name))
+      (if (zero? exit-code)
+          lines
+          (raise (formatted-message
+                  (G_ "failed to run script '~a' on machine, exit code: '~a'")
+                  name exit-code))))))
+
+(define (hetzner-machine-rescue-install-os machine ssh-session server)
+  (let ((name (machine-display-name machine))
+        (os (hetzner-machine-bootstrap-os-form machine server)))
+    (format #t "installing guix operating system on '~a'...\n" name)
+    (hetzner-machine-ssh-run-script
+     ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-install-os"
+     (format #f "#!/usr/bin/env bash
+set -eo pipefail
+mount /dev/sda1 /mnt
+mkdir -p /mnt/boot/efi
+mount /dev/sda15 /mnt/boot/efi
+
+mkdir --parents /mnt/root/.ssh
+chmod 700 /mnt/root/.ssh
+cp /root/.ssh/authorized_keys /mnt/root/.ssh/authorized_keys
+chmod 600 /mnt/root/.ssh/authorized_keys
+
+cat > /tmp/guix/deploy/hetzner-os.scm << EOF
+(use-modules (gnu) (guix utils))
+(use-package-modules ssh)
+(use-service-modules base networking ssh)
+(use-system-modules linux-initrd)
+~a
+EOF
+cat /tmp/guix/deploy/hetzner-os.scm
+guix system init --verbosity=2 /tmp/guix/deploy/hetzner-os.scm /mnt"
+             (escape-backticks (format #f "~y" os))))
+    (format #t "successfully installed guix operating system on '~a'\n" name)))
+
+(define (hetzner-machine-reboot machine server)
+  "Reboot the Hetzner SERVER for MACHINE."
+  (let* ((name (machine-display-name machine))
+         (config (machine-configuration machine))
+         (api (hetzner-configuration-api config)))
+    (format #t "rebooting server for '~a'...\n" name)
+    (let ((body (hetzner-api-server-reboot api server)))
+      (hetzner-api-action-wait api (assoc-ref body "action"))
+      (format #t "successfully rebooted server for '~a'\n" name)
+      body)))
+
+(define (hetzner-machine-rescue-partition machine ssh-session)
+  "Setup the partitions of the Hetzner server for MACHINE using SSH-SESSION."
+  (let* ((name (machine-display-name machine))
+         (os (machine-operating-system machine))
+         (root-fs-type (operating-system-root-file-system-type os)))
+    (format #t "setting up partitions on '~a'...\n" name)
+    (hetzner-machine-ssh-run-script
+     ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-partition"
+     (format #f "#!/usr/bin/env bash
+set -eo pipefail
+growpart /dev/sda 1 || true
+~a
+fdisk -l /dev/sda"
+             (cond
+              ((equal? "btrfs" root-fs-type)
+               (format #f "mkfs.btrfs -L ~a -f /dev/sda1" root-label))
+              ((equal? "ext4" root-fs-type)
+               (format #f "mkfs.ext4 -L ~a -F /dev/sda1" root-label))
+              (else (raise (formatted-message
+                            (G_ "unsupported root file system type '~a'")
+                            root-fs-type))))))
+    (format #t "successfully setup partitions on '~a'\n" name)))
+
+(define (hetzner-machine-rescue-install-packages machine ssh-session)
+  "Install packages on the Hetzner server for MACHINE using SSH-SESSION."
+  (let ((name (machine-display-name machine)))
+    (format #t "installing rescue system packages on '~a'...\n" name)
+    (hetzner-machine-ssh-run-script
+     ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-install-packages"
+     (format #f "#!/usr/bin/env bash
+set -eo pipefail
+apt-get update
+apt-get install guix cloud-initramfs-growroot --assume-yes"))
+    (format #t "successfully installed rescue system packages on '~a'\n" name)))
+
+(define (hetzner-machine-delete machine server)
+  "Delete the Hetzner server for MACHINE."
+  (let* ((name (machine-display-name machine))
+         (config (machine-configuration machine))
+         (api (hetzner-configuration-api config)))
+    (format #t "deleting server for '~a'...\n" name)
+    (let ((body (hetzner-api-server-delete api server)))
+      (hetzner-api-action-wait api (assoc-ref body "action"))
+      (format #t "successfully deleted server for '~a'\n" name)
+      body)))
+
+(define (hetzner-machine-provision machine)
+  "Provision a server for MACHINE on the Hetzner Cloud service."
+  (with-exception-handler
+      (lambda (exception)
+        (let ((config (machine-configuration machine))
+              (server (hetzner-machine-server machine)))
+          (when (and server (hetzner-configuration-delete? config))
+            (hetzner-machine-delete machine server))
+          (raise-exception exception)))
+    (lambda ()
+      (let ((server (hetzner-machine-create-server machine)))
+        (hetzner-machine-enable-rescue-system machine server)
+        (hetzner-machine-power-on machine server)
+        (let ((ssh-session (hetzner-machine-wait-for-ssh machine)))
+          (hetzner-machine-rescue-install-packages machine ssh-session)
+          (hetzner-machine-rescue-partition machine ssh-session)
+          (hetzner-machine-rescue-install-os machine ssh-session server)
+          (hetzner-machine-reboot machine server)
+          (sleep 5)
+          (hetzner-machine-authenticate-host machine))))
+    #:unwind? #t))
+
+
+;;;
+;;; Remote evaluation.
+;;;
+
+(define (hetzner-remote-eval machine exp)
+  "Internal implementation of 'machine-remote-eval' for MACHINE instances with
+an environment type of 'hetzner-environment-type'."
+  (hetzner-machine-validate machine)
+  (unless (hetzner-machine-server machine)
+    (raise (formatted-message
+            (G_ "machine '~a' not provisioned on the Hetzner Cloud service")
+            (machine-display-name machine))))
+  (machine-remote-eval (hetzner-machine-delegate machine) exp))
+
+
+
+;;;
+;;; System deployment.
+;;;
+
+(define (deploy-hetzner machine)
+  "Internal implementation of 'deploy-machine' for 'machine' instances with an
+environment type of 'hetzner-environment-type'."
+  (hetzner-machine-validate machine)
+  (unless (hetzner-machine-ssh-key machine)
+    (hetzner-machine-ssh-key-create machine))
+  (unless (hetzner-machine-server machine)
+    (hetzner-machine-provision machine))
+  (deploy-machine (hetzner-machine-delegate machine)))
+
+
+
+;;;
+;;; Roll-back.
+;;;
+
+(define (roll-back-hetzner machine)
+  "Internal implementation of 'roll-back-machine' for MACHINE instances with an
+environment type of 'hetzner-environment-type'."
+  (hetzner-machine-validate machine)
+  (roll-back-machine (hetzner-machine-delegate machine)))
+
+
+
+;;;
+;;; Environment type.
+;;;
+
+(define hetzner-environment-type
+  (environment-type
+   (machine-remote-eval hetzner-remote-eval)
+   (deploy-machine deploy-hetzner)
+   (roll-back-machine roll-back-hetzner)
+   (name 'hetzner-environment-type)
+   (description "Provisioning of virtual machine servers on the Hetzner Cloud
+service.")))
diff --git a/guix/ssh.scm b/guix/ssh.scm
index ae506df14c..196a92e813 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -103,7 +103,8 @@ (define* (open-ssh-session host #:key user port identity
                            host-key
                            (compression %compression)
                            (timeout 3600)
-                           (connection-timeout 10))
+                           (connection-timeout 10)
+                           (stricthostkeycheck #t))
   "Open an SSH session for HOST and return it.  IDENTITY specifies the file
 name of a private key to use for authenticating with the host.  When USER,
 PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config'
@@ -137,7 +138,8 @@ (define* (open-ssh-session host #:key user port identity
 
                                ;; Speed up RPCs by creating sockets with
                                ;; TCP_NODELAY.
-                               #:nodelay #t)))
+                               #:nodelay #t
+                               #:stricthostkeycheck stricthostkeycheck)))
 
     ;; Honor ~/.ssh/config.
     (session-parse-config! session)
@@ -149,13 +151,14 @@ (define* (open-ssh-session host #:key user port identity
            (authenticate-server* session host-key)
 
            ;; Authenticate against ~/.ssh/known_hosts.
-           (match (authenticate-server session)
-             ('ok #f)
-             (reason
-              (raise (formatted-message (G_ "failed to authenticate \
+           (when stricthostkeycheck
+             (match (authenticate-server session)
+               ('ok #f)
+               (reason
+                (raise (formatted-message (G_ "failed to authenticate \
 server at '~a': ~a")
-                                        (session-get session 'host)
-                                        reason)))))
+                                          (session-get session 'host)
+                                          reason))))))
 
        ;; Use public key authentication, via the SSH agent if it's available.
        (match (userauth-public-key/auto! session)

base-commit: 831b94a1efcea8f793afc949b5123a6235c9bb1a
-- 
2.47.1

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

From: Ludovic Courtès <ludo <at> gnu.org>
To: Roman Scherer <roman <at> burningswell.com>
Cc: Josselin Poiret <dev <at> jpoiret.xyz>,
 Maxim Cournoyer <maxim.cournoyer <at> gmail.com>,
 Simon Tournier <zimon.toutoune <at> gmail.com>, Mathieu Othacehe <othacehe <at> gnu.org>,
 Tobias Geerinckx-Rice <me <at> tobias.gr>, Christopher Baines <guix <at> cbaines.net>,
 75144 <at> debbugs.gnu.org
Subject: Re: [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
Date: Thu, 16 Jan 2025 22:26:18 +0100

Hello Roman,

Roman Scherer <roman <at> burningswell.com> skribis:

> * gnu/machine/hetzner.scm: New file.
> * gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
> * guix/ssh.scm (open-ssh-session): Add stricthostkeycheck option.
> * doc/guix.texi (Invoking guix deploy): Add documentation for
> 'hetzner-configuration'.
>
> Change-Id: Idc17dbc33279ecbf3cbfe2c53d7699140f8b9f41

Thumbs up for this big piece of work, one that I think is important for
the project!  ‘guix deploy’ is a great idea but it desperately needs
more backends like this one.

I’m not familiar with Hetzner so I’ll comment on more general aspects.
Chris, perhaps you can provide feedback on Hetzner-specific issues?  I
think we could put this backend to good use for Guix infra since a few
services are running at Hetzner.

> +@deftp {Data Type} hetzner-configuration
> +This is the data type describing the server that should be created for a
> +machine with an @code{environment} of @code{hetzner-environment-type}.

Could you add a sentence providing more context like:

  It allows you to configure deployment to a @acronym{VPS, virtual
  private server} hosted by @uref{https://www.hetzner.com, Hetzner}.

> +@item @code{authorize?} (default: @code{#t})
> +If true, the coordinator's public signing key

“coordinator” has nothing to do here I guess.

> +@item @code{labels} (default: @code{'()})
> +A user defined alist of key/value pairs attached to the server. Keys and
> +values must be strings. For more information, see
> +@uref{https://docs.hetzner.cloud/#labels, Labels}.

Maybe add a short example?

> +@item @code{location} (default: @code{"fsn1"})
> +The name of a @uref{https://docs.hetzner.com/cloud/general/locations,
> +location} to create the server in.

Maybe add: “For example, @code{"fsn1"} corresponds to the Hetzner site
in Falkenstein, Germany, while @code{"sin"} corresponds to its site in
Singapore.”

> +@item @code{server-type} (default: @code{"cx42"})
> +The name of the
> +@uref{https://docs.hetzner.com/cloud/servers/overview#server-types,
> +server type} this server should be created with.

Likewise, an example would be elcome.

> +@item @code{ssh-key}
> +The path to the SSH private key to use to authenticate with the remote
> +host.

s/path to/file name of/

> +The following example shows the definition of 2 machines that are

s/2/two/

> +vCPUs and 32 GB of RAM on the @code{aarch64} architecture, the second

s/@code{aarch64}/AArch64/

> +shared vCPUs and 32 GB of RAM on the @code{x86_64} architecture.

Drop @code.

> +@lisp
> +(use-modules (gnu machine)
> +             (gnu machine hetzner))
> +
> +(list (machine
> +       (operating-system %hetzner-os-arm)
> +       (environment hetzner-environment-type)
> +       (configuration (hetzner-configuration
> +                       (server-type "cax41")
> +                       (ssh-key "/home/charlie/.ssh/id_rsa"))))
> +      (machine
> +       (operating-system %hetzner-os-x86)
> +       (environment hetzner-environment-type)
> +       (configuration (hetzner-configuration
> +                       (server-type "cpx51")
> +                       (ssh-key "/home/charlie/.ssh/id_rsa")))))

Nice!

> +API key} should provision 2 machines for you.

s/2/two/

> +  #:use-module (ice-9 receive)

The code base preferable uses SRFI-71 for multiple-value returns.

> +      (raise (formatted-message
> +              (G_ "Expected a list of Hetzner API responses")))))

Messages should start with a lower-case letter (for all the messages in
this file).

Please add the file to ‘po/guix/POTFILES.in’ so that it’s actually
subject to translation.

> +(define (hetzner-api-response-read port)
> +  "Read the Hetzner API response from PORT."
> +  (let* ((response (read-response port))
> +         (body (read-response-body response)))
> +    (hetzner-api-response
> +     (body (json-string->scm (bytevector->string body "UTF-8")))

Just ‘string->utf8’ (shorter).

More importantly: instead of ‘json-string->scm’ (which gives an alist,
leading to ‘assoc-ref’ calls all over the code base along with free-form
alists, which is very error-prone), could you use ‘define-json-mapping’?

In essence it’s like ‘define-record-type’ but it additionally define how
to map a JSON dictionary to a Scheme record.  There are several examples
in Guix, such as (guix swh).

For clarity, it might be useful to move all the hetzner-api-* bits to a
separate module, for example (gnu machine hetzner http).  WDYT?


The rest of the code looks nice to me (modulo alists :-)) but that’s
about all I can say.  It’s quite a significant body of code.  What would
you suggest to prevent bitrot and support maintenance?  Are there parts
of it that could be usefully tested automatically, possibly by mocking
part of the Hetzner API?  Or are there tips on how you tested it that
could be written down in the file itself?


Could you move the (guix ssh) bits to a separate patch?

> +++ b/guix/ssh.scm
> @@ -103,7 +103,8 @@ (define* (open-ssh-session host #:key user port identity
>                             host-key
>                             (compression %compression)
>                             (timeout 3600)
> -                           (connection-timeout 10))
> +                           (connection-timeout 10)
> +                           (stricthostkeycheck #t))
>    "Open an SSH session for HOST and return it.  IDENTITY specifies the file
>  name of a private key to use for authenticating with the host.  When USER,
>  PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config'

Please update the docstring.

Rather ‘strict-host-key-check?’ to match naming conventions, even if
Guile-SSH calls it that way.

> @@ -137,7 +138,8 @@ (define* (open-ssh-session host #:key user port identity
>  
>                                 ;; Speed up RPCs by creating sockets with
>                                 ;; TCP_NODELAY.
> -                               #:nodelay #t)))
> +                               #:nodelay #t
> +                               #:stricthostkeycheck stricthostkeycheck)))

Not sure what this does actually.  Looks like the main part is the
“when stricthostkeycheck” condition that comes below, no?

Could you send a second version?

Thank you!

Ludo’.

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

From: Ludovic Courtès <ludo <at> gnu.org>
To: Roman Scherer <roman <at> burningswell.com>
Cc: Josselin Poiret <dev <at> jpoiret.xyz>,
 Maxim Cournoyer <maxim.cournoyer <at> gmail.com>,
 Simon Tournier <zimon.toutoune <at> gmail.com>, Mathieu Othacehe <othacehe <at> gnu.org>,
 Tobias Geerinckx-Rice <me <at> tobias.gr>, Christopher Baines <guix <at> cbaines.net>,
 75144 <at> debbugs.gnu.org
Subject: Re: [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
Date: Thu, 16 Jan 2025 22:26:55 +0100

Hello Roman,

Roman Scherer <roman <at> burningswell.com> skribis:

> * gnu/machine/hetzner.scm: New file.
> * gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
> * guix/ssh.scm (open-ssh-session): Add stricthostkeycheck option.
> * doc/guix.texi (Invoking guix deploy): Add documentation for
> 'hetzner-configuration'.
>
> Change-Id: Idc17dbc33279ecbf3cbfe2c53d7699140f8b9f41

Thumbs up for this big piece of work, one that I think is important for
the project!  ‘guix deploy’ is a great idea but it desperately needs
more backends like this one.

I’m not familiar with Hetzner so I’ll comment on more general aspects.
Chris, perhaps you can provide feedback on Hetzner-specific issues?  I
think we could put this backend to good use for Guix infra since a few
services are running at Hetzner.

> +@deftp {Data Type} hetzner-configuration
> +This is the data type describing the server that should be created for a
> +machine with an @code{environment} of @code{hetzner-environment-type}.

Could you add a sentence providing more context like:

  It allows you to configure deployment to a @acronym{VPS, virtual
  private server} hosted by @uref{https://www.hetzner.com, Hetzner}.

> +@item @code{authorize?} (default: @code{#t})
> +If true, the coordinator's public signing key

“coordinator” has nothing to do here I guess.

> +@item @code{labels} (default: @code{'()})
> +A user defined alist of key/value pairs attached to the server. Keys and
> +values must be strings. For more information, see
> +@uref{https://docs.hetzner.cloud/#labels, Labels}.

Maybe add a short example?

> +@item @code{location} (default: @code{"fsn1"})
> +The name of a @uref{https://docs.hetzner.com/cloud/general/locations,
> +location} to create the server in.

Maybe add: “For example, @code{"fsn1"} corresponds to the Hetzner site
in Falkenstein, Germany, while @code{"sin"} corresponds to its site in
Singapore.”

> +@item @code{server-type} (default: @code{"cx42"})
> +The name of the
> +@uref{https://docs.hetzner.com/cloud/servers/overview#server-types,
> +server type} this server should be created with.

Likewise, an example would be elcome.

> +@item @code{ssh-key}
> +The path to the SSH private key to use to authenticate with the remote
> +host.

s/path to/file name of/

> +The following example shows the definition of 2 machines that are

s/2/two/

> +vCPUs and 32 GB of RAM on the @code{aarch64} architecture, the second

s/@code{aarch64}/AArch64/

> +shared vCPUs and 32 GB of RAM on the @code{x86_64} architecture.

Drop @code.

> +@lisp
> +(use-modules (gnu machine)
> +             (gnu machine hetzner))
> +
> +(list (machine
> +       (operating-system %hetzner-os-arm)
> +       (environment hetzner-environment-type)
> +       (configuration (hetzner-configuration
> +                       (server-type "cax41")
> +                       (ssh-key "/home/charlie/.ssh/id_rsa"))))
> +      (machine
> +       (operating-system %hetzner-os-x86)
> +       (environment hetzner-environment-type)
> +       (configuration (hetzner-configuration
> +                       (server-type "cpx51")
> +                       (ssh-key "/home/charlie/.ssh/id_rsa")))))

Nice!

> +API key} should provision 2 machines for you.

s/2/two/

> +  #:use-module (ice-9 receive)

The code base preferable uses SRFI-71 for multiple-value returns.

> +      (raise (formatted-message
> +              (G_ "Expected a list of Hetzner API responses")))))

Messages should start with a lower-case letter (for all the messages in
this file).

Please add the file to ‘po/guix/POTFILES.in’ so that it’s actually
subject to translation.

> +(define (hetzner-api-response-read port)
> +  "Read the Hetzner API response from PORT."
> +  (let* ((response (read-response port))
> +         (body (read-response-body response)))
> +    (hetzner-api-response
> +     (body (json-string->scm (bytevector->string body "UTF-8")))

Just ‘string->utf8’ (shorter).

More importantly: instead of ‘json-string->scm’ (which gives an alist,
leading to ‘assoc-ref’ calls all over the code base along with free-form
alists, which is very error-prone), could you use ‘define-json-mapping’?

In essence it’s like ‘define-record-type’ but it additionally define how
to map a JSON dictionary to a Scheme record.  There are several examples
in Guix, such as (guix swh).

For clarity, it might be useful to move all the hetzner-api-* bits to a
separate module, for example (gnu machine hetzner http).  WDYT?


The rest of the code looks nice to me (modulo alists :-)) but that’s
about all I can say.  It’s quite a significant body of code.  What would
you suggest to prevent bitrot and support maintenance?  Are there parts
of it that could be usefully tested automatically, possibly by mocking
part of the Hetzner API?  Or are there tips on how you tested it that
could be written down in the file itself?


Could you move the (guix ssh) bits to a separate patch?

> +++ b/guix/ssh.scm
> @@ -103,7 +103,8 @@ (define* (open-ssh-session host #:key user port identity
>                             host-key
>                             (compression %compression)
>                             (timeout 3600)
> -                           (connection-timeout 10))
> +                           (connection-timeout 10)
> +                           (stricthostkeycheck #t))
>    "Open an SSH session for HOST and return it.  IDENTITY specifies the file
>  name of a private key to use for authenticating with the host.  When USER,
>  PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config'

Please update the docstring.

Rather ‘strict-host-key-check?’ to match naming conventions, even if
Guile-SSH calls it that way.

> @@ -137,7 +138,8 @@ (define* (open-ssh-session host #:key user port identity
>  
>                                 ;; Speed up RPCs by creating sockets with
>                                 ;; TCP_NODELAY.
> -                               #:nodelay #t)))
> +                               #:nodelay #t
> +                               #:stricthostkeycheck stricthostkeycheck)))

Not sure what this does actually.  Looks like the main part is the
“when stricthostkeycheck” condition that comes below, no?

Could you send a second version?

Thank you!

Ludo’.

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

From: Roman Scherer <roman <at> burningswell.com>
To: Ludovic Courtès <ludo <at> gnu.org>
Cc: Roman Scherer <roman <at> burningswell.com>,
 Maxim Cournoyer <maxim.cournoyer <at> gmail.com>,
 Simon Tournier <zimon.toutoune <at> gmail.com>, Mathieu Othacehe <othacehe <at> gnu.org>,
 Tobias Geerinckx-Rice <me <at> tobias.gr>, Josselin Poiret <dev <at> jpoiret.xyz>,
 Christopher Baines <guix <at> cbaines.net>, 75144 <at> debbugs.gnu.org
Subject: Re: [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
Date: Sun, 19 Jan 2025 17:59:06 +0100

[Message part 1 (text/plain, inline)]

Hi Ludo,

thanks for your review. Here is a v2, I hope I addressed your previous
comments with it, but I need some help.

As you suggested I also added some tests. Some use mocking, and some run
against the Hetzner API, if the GUIX_HETZNER_API_TOKEN env var is set.

./pre-inst-env make check TESTS="tests/machine/hetzner/http.scm"
./pre-inst-env make check TESTS="tests/machine/hetzner.scm"

All tests pass when I run them in the Geiser REPL, where I developed them.

But I have some trouble with one test that uses mocking. The
"deploy-machine-mock-with-unprovisioned-server" test in
tests/machine/hetzner.scm only fails when run in the terminal. :?

I'm using the "mock" function from (guix tests) to mock some HTTP and SSH
calls. The issue is that I see different behaviour whether I run the tests in
Geiser vs in the Terminal.

In Geiser I see the following output for this test, in it passes:

-------------------------------------------------------------------------------
creating 'cx42' server for 'guix-x86'...
successfully created 'cx42' x86 server for 'guix-x86'
enabling rescue system on 'guix-x86'...
MOCK ENABLE RESUCE
successfully enabled rescue system on 'guix-x86'
powering on server for 'guix-x86'...
MOCK POWER ON
successfully powered on server for 'guix-x86'
connecting via SSH to '1.2.3.4' using '/tmp/guix-hetzner-machine-test-key'...
MOCK OPEN SSH SESSION
installing rescue system packages on 'guix-x86'...
MOCK RUNNING SCRIPT: /tmp/guix/deploy/hetzner-machine-rescue-install-packages
successfully installed rescue system packages on 'guix-x86'
setting up partitions on 'guix-x86'...
MOCK RUNNING SCRIPT: /tmp/guix/deploy/hetzner-machine-rescue-partition
successfully setup partitions on 'guix-x86'
installing guix operating system on 'guix-x86'...
MOCK RUNNING SCRIPT: /tmp/guix/deploy/hetzner-machine-rescue-install-os
successfully installed guix operating system on 'guix-x86'
rebooting server for 'guix-x86'...
successfully rebooted server for 'guix-x86'
connecting via SSH to '1.2.3.4' using '/tmp/guix-hetzner-machine-test-key'...
MOCK OPEN SSH SESSION
-------------------------------------------------------------------------------

You can see that calls to "hetzner-machine-ssh-run-script" are mocked, because
"MOCK RUNNING SCRIPT" is printed multiple times.

But in a "guix shell -D" terminal I see the following output for the test, and
it is failing:

-------------------------------------------------------------------------------

creating 'cx42' server for 'guix-x86'...
successfully created 'cx42' x86 server for 'guix-x86'
enabling rescue system on 'guix-x86'...
MOCK ENABLE RESUCE
successfully enabled rescue system on 'guix-x86'
powering on server for 'guix-x86'...
MOCK POWER ON
successfully powered on server for 'guix-x86'
connecting via SSH to '1.2.3.4' using '/tmp/guix-hetzner-machine-test-key'...
MOCK OPEN SSH SESSION
installing rescue system packages on 'guix-x86'...
test-name: deploy-machine-mock-with-unprovisioned-server
location: /home/roman/workspace/guix/tests/machine/hetzner.scm:189

actual-value: #f
actual-error:
+ (guile-ssh-error
+   "%gssh-make-sftp-session"
+   "Could not create a SFTP session"
+   #<session #<undefined>@1.2.3.4:22 (disconnected) ffff85596de0>
+   #f)
result: FAIL

;;; [2025/01/19 17:39:16.791023, 0] [GSSH ERROR] Could not create a SFTP session: #<session #<undefined>@1.2.3.4:22 (disconnected) ffff85596de0>

-------------------------------------------------------------------------------

The tests fails here trying to use a disconnected SSH session object, that I
returned in a mocked call. This code should actually never be reached, because
I mock the "hetzner-machine-ssh-run-script" call. But for some reason the mock
is not working here. The "MOCK RUNNING SCRIPT" output is missing.

Do you have any ideas what could be going on here? I suspect this might be due
to some optimization or env issue, but I'm pretty lost.

I attached a WIP v2 for now. Will send a v3 and a separate patch for the ssh
modification once I fixed this mock test.

Thanks, Roman.

[v2-0001-machine-Implement-hetzner-environment-type.patch (text/x-patch, attachment)]

[Message part 3 (text/plain, inline)]

Ludovic Courtès <ludo <at> gnu.org> writes:

> Hello Roman,
>
> Roman Scherer <roman <at> burningswell.com> skribis:
>
>> * gnu/machine/hetzner.scm: New file.
>> * gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
>> * guix/ssh.scm (open-ssh-session): Add stricthostkeycheck option.
>> * doc/guix.texi (Invoking guix deploy): Add documentation for
>> 'hetzner-configuration'.
>>
>> Change-Id: Idc17dbc33279ecbf3cbfe2c53d7699140f8b9f41
>
> Thumbs up for this big piece of work, one that I think is important for
> the project!  ‘guix deploy’ is a great idea but it desperately needs
> more backends like this one.
>
> I’m not familiar with Hetzner so I’ll comment on more general aspects.
> Chris, perhaps you can provide feedback on Hetzner-specific issues?  I
> think we could put this backend to good use for Guix infra since a few
> services are running at Hetzner.
>
>> +@deftp {Data Type} hetzner-configuration
>> +This is the data type describing the server that should be created for a
>> +machine with an @code{environment} of @code{hetzner-environment-type}.
>
> Could you add a sentence providing more context like:
>
>   It allows you to configure deployment to a @acronym{VPS, virtual
>   private server} hosted by @uref{https://www.hetzner.com, Hetzner}.
>
>> +@item @code{authorize?} (default: @code{#t})
>> +If true, the coordinator's public signing key
>
> “coordinator” has nothing to do here I guess.
>
>> +@item @code{labels} (default: @code{'()})
>> +A user defined alist of key/value pairs attached to the server. Keys and
>> +values must be strings. For more information, see
>> +@uref{https://docs.hetzner.cloud/#labels, Labels}.
>
> Maybe add a short example?
>
>> +@item @code{location} (default: @code{"fsn1"})
>> +The name of a @uref{https://docs.hetzner.com/cloud/general/locations,
>> +location} to create the server in.
>
> Maybe add: “For example, @code{"fsn1"} corresponds to the Hetzner site
> in Falkenstein, Germany, while @code{"sin"} corresponds to its site in
> Singapore.”
>
>> +@item @code{server-type} (default: @code{"cx42"})
>> +The name of the
>> +@uref{https://docs.hetzner.com/cloud/servers/overview#server-types,
>> +server type} this server should be created with.
>
> Likewise, an example would be elcome.
>
>> +@item @code{ssh-key}
>> +The path to the SSH private key to use to authenticate with the remote
>> +host.
>
> s/path to/file name of/
>
>> +The following example shows the definition of 2 machines that are
>
> s/2/two/
>
>> +vCPUs and 32 GB of RAM on the @code{aarch64} architecture, the second
>
> s/@code{aarch64}/AArch64/
>
>> +shared vCPUs and 32 GB of RAM on the @code{x86_64} architecture.
>
> Drop @code.
>
>> +@lisp
>> +(use-modules (gnu machine)
>> +             (gnu machine hetzner))
>> +
>> +(list (machine
>> +       (operating-system %hetzner-os-arm)
>> +       (environment hetzner-environment-type)
>> +       (configuration (hetzner-configuration
>> +                       (server-type "cax41")
>> +                       (ssh-key "/home/charlie/.ssh/id_rsa"))))
>> +      (machine
>> +       (operating-system %hetzner-os-x86)
>> +       (environment hetzner-environment-type)
>> +       (configuration (hetzner-configuration
>> +                       (server-type "cpx51")
>> +                       (ssh-key "/home/charlie/.ssh/id_rsa")))))
>
> Nice!
>
>> +API key} should provision 2 machines for you.
>
> s/2/two/
>
>> +  #:use-module (ice-9 receive)
>
> The code base preferable uses SRFI-71 for multiple-value returns.
>
>> +      (raise (formatted-message
>> +              (G_ "Expected a list of Hetzner API responses")))))
>
> Messages should start with a lower-case letter (for all the messages in
> this file).
>
> Please add the file to ‘po/guix/POTFILES.in’ so that it’s actually
> subject to translation.
>
>> +(define (hetzner-api-response-read port)
>> +  "Read the Hetzner API response from PORT."
>> +  (let* ((response (read-response port))
>> +         (body (read-response-body response)))
>> +    (hetzner-api-response
>> +     (body (json-string->scm (bytevector->string body "UTF-8")))
>
> Just ‘string->utf8’ (shorter).
>
> More importantly: instead of ‘json-string->scm’ (which gives an alist,
> leading to ‘assoc-ref’ calls all over the code base along with free-form
> alists, which is very error-prone), could you use ‘define-json-mapping’?
>
> In essence it’s like ‘define-record-type’ but it additionally define how
> to map a JSON dictionary to a Scheme record.  There are several examples
> in Guix, such as (guix swh).
>
> For clarity, it might be useful to move all the hetzner-api-* bits to a
> separate module, for example (gnu machine hetzner http).  WDYT?
>
>
> The rest of the code looks nice to me (modulo alists :-)) but that’s
> about all I can say.  It’s quite a significant body of code.  What would
> you suggest to prevent bitrot and support maintenance?  Are there parts
> of it that could be usefully tested automatically, possibly by mocking
> part of the Hetzner API?  Or are there tips on how you tested it that
> could be written down in the file itself?
>
>
> Could you move the (guix ssh) bits to a separate patch?
>
>> +++ b/guix/ssh.scm
>> @@ -103,7 +103,8 @@ (define* (open-ssh-session host #:key user port identity
>>                             host-key
>>                             (compression %compression)
>>                             (timeout 3600)
>> -                           (connection-timeout 10))
>> +                           (connection-timeout 10)
>> +                           (stricthostkeycheck #t))
>>    "Open an SSH session for HOST and return it.  IDENTITY specifies the file
>>  name of a private key to use for authenticating with the host.  When USER,
>>  PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config'
>
> Please update the docstring.
>
> Rather ‘strict-host-key-check?’ to match naming conventions, even if
> Guile-SSH calls it that way.
>
>> @@ -137,7 +138,8 @@ (define* (open-ssh-session host #:key user port identity
>>
>>                                 ;; Speed up RPCs by creating sockets with
>>                                 ;; TCP_NODELAY.
>> -                               #:nodelay #t)))
>> +                               #:nodelay #t
>> +                               #:stricthostkeycheck stricthostkeycheck)))
>
> Not sure what this does actually.  Looks like the main part is the
> “when stricthostkeycheck” condition that comes below, no?
>
> Could you send a second version?
>
> Thank you!
>
> Ludo’.

[signature.asc (application/pgp-signature, inline)]

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

From: Roman Scherer <roman <at> burningswell.com>
To: Roman Scherer <roman <at> burningswell.com>
Cc: Josselin Poiret <dev <at> jpoiret.xyz>,
 Maxim Cournoyer <maxim.cournoyer <at> gmail.com>,
 Simon Tournier <zimon.toutoune <at> gmail.com>, Mathieu Othacehe <othacehe <at> gnu.org>,
 Ludovic Courtès <ludo <at> gnu.org>,
 Tobias Geerinckx-Rice <me <at> tobias.gr>, Christopher Baines <guix <at> cbaines.net>,
 75144 <at> debbugs.gnu.org
Subject: Re: [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
Date: Sat, 25 Jan 2025 14:37:16 +0100

[Message part 1 (text/plain, inline)]

I made a `mock*` macro to get around this ugly nesting in the meantime.

https://github.com/r0man/guix/blob/hetzner-machine-v2-mock-star/tests/machine/hetzner.scm#L165-L248

But I'm still wondering why the `mock` in `deploy-machine-mock-with-unprovisioned-server` is working in the REPL,
but failing when I run the test with make ...

Roman Scherer <roman <at> burningswell.com> writes:

> Hi Ludo,
>
> thanks for your review. Here is a v2, I hope I addressed your previous
> comments with it, but I need some help.
>
> As you suggested I also added some tests. Some use mocking, and some run
> against the Hetzner API, if the GUIX_HETZNER_API_TOKEN env var is set.
>
> ./pre-inst-env make check TESTS="tests/machine/hetzner/http.scm"
> ./pre-inst-env make check TESTS="tests/machine/hetzner.scm"
>
> All tests pass when I run them in the Geiser REPL, where I developed them.
>
> But I have some trouble with one test that uses mocking. The
> "deploy-machine-mock-with-unprovisioned-server" test in
> tests/machine/hetzner.scm only fails when run in the terminal. :?
>
> I'm using the "mock" function from (guix tests) to mock some HTTP and SSH
> calls. The issue is that I see different behaviour whether I run the tests in
> Geiser vs in the Terminal.
>
> In Geiser I see the following output for this test, in it passes:
>
> -------------------------------------------------------------------------------
> creating 'cx42' server for 'guix-x86'...
> successfully created 'cx42' x86 server for 'guix-x86'
> enabling rescue system on 'guix-x86'...
> MOCK ENABLE RESUCE
> successfully enabled rescue system on 'guix-x86'
> powering on server for 'guix-x86'...
> MOCK POWER ON
> successfully powered on server for 'guix-x86'
> connecting via SSH to '1.2.3.4' using '/tmp/guix-hetzner-machine-test-key'...
> MOCK OPEN SSH SESSION
> installing rescue system packages on 'guix-x86'...
> MOCK RUNNING SCRIPT: /tmp/guix/deploy/hetzner-machine-rescue-install-packages
> successfully installed rescue system packages on 'guix-x86'
> setting up partitions on 'guix-x86'...
> MOCK RUNNING SCRIPT: /tmp/guix/deploy/hetzner-machine-rescue-partition
> successfully setup partitions on 'guix-x86'
> installing guix operating system on 'guix-x86'...
> MOCK RUNNING SCRIPT: /tmp/guix/deploy/hetzner-machine-rescue-install-os
> successfully installed guix operating system on 'guix-x86'
> rebooting server for 'guix-x86'...
> successfully rebooted server for 'guix-x86'
> connecting via SSH to '1.2.3.4' using '/tmp/guix-hetzner-machine-test-key'...
> MOCK OPEN SSH SESSION
> -------------------------------------------------------------------------------
>
> You can see that calls to "hetzner-machine-ssh-run-script" are mocked, because
> "MOCK RUNNING SCRIPT" is printed multiple times.
>
> But in a "guix shell -D" terminal I see the following output for the test, and
> it is failing:
>
> -------------------------------------------------------------------------------
>
> creating 'cx42' server for 'guix-x86'...
> successfully created 'cx42' x86 server for 'guix-x86'
> enabling rescue system on 'guix-x86'...
> MOCK ENABLE RESUCE
> successfully enabled rescue system on 'guix-x86'
> powering on server for 'guix-x86'...
> MOCK POWER ON
> successfully powered on server for 'guix-x86'
> connecting via SSH to '1.2.3.4' using '/tmp/guix-hetzner-machine-test-key'...
> MOCK OPEN SSH SESSION
> installing rescue system packages on 'guix-x86'...
> test-name: deploy-machine-mock-with-unprovisioned-server
> location: /home/roman/workspace/guix/tests/machine/hetzner.scm:189
>
> actual-value: #f
> actual-error:
> + (guile-ssh-error
> +   "%gssh-make-sftp-session"
> +   "Could not create a SFTP session"
> +   #<session #<undefined>@1.2.3.4:22 (disconnected) ffff85596de0>
> +   #f)
> result: FAIL
>
> ;;; [2025/01/19 17:39:16.791023, 0] [GSSH ERROR] Could not create a SFTP session: #<session #<undefined>@1.2.3.4:22 (disconnected) ffff85596de0>
>
> -------------------------------------------------------------------------------
>
> The tests fails here trying to use a disconnected SSH session object, that I
> returned in a mocked call. This code should actually never be reached, because
> I mock the "hetzner-machine-ssh-run-script" call. But for some reason the mock
> is not working here. The "MOCK RUNNING SCRIPT" output is missing.
>
> Do you have any ideas what could be going on here? I suspect this might be due
> to some optimization or env issue, but I'm pretty lost.
>
> I attached a WIP v2 for now. Will send a v3 and a separate patch for the ssh
> modification once I fixed this mock test.
>
> Thanks, Roman.
>
> [2. text/x-patch; v2-0001-machine-Implement-hetzner-environment-type.patch]...
>
>
> Ludovic Courtès <ludo <at> gnu.org> writes:
>
>> Hello Roman,
>>
>> Roman Scherer <roman <at> burningswell.com> skribis:
>>
>>> * gnu/machine/hetzner.scm: New file.
>>> * gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
>>> * guix/ssh.scm (open-ssh-session): Add stricthostkeycheck option.
>>> * doc/guix.texi (Invoking guix deploy): Add documentation for
>>> 'hetzner-configuration'.
>>>
>>> Change-Id: Idc17dbc33279ecbf3cbfe2c53d7699140f8b9f41
>>
>> Thumbs up for this big piece of work, one that I think is important for
>> the project!  ‘guix deploy’ is a great idea but it desperately needs
>> more backends like this one.
>>
>> I’m not familiar with Hetzner so I’ll comment on more general aspects.
>> Chris, perhaps you can provide feedback on Hetzner-specific issues?  I
>> think we could put this backend to good use for Guix infra since a few
>> services are running at Hetzner.
>>
>>> +@deftp {Data Type} hetzner-configuration
>>> +This is the data type describing the server that should be created for a
>>> +machine with an @code{environment} of @code{hetzner-environment-type}.
>>
>> Could you add a sentence providing more context like:
>>
>>   It allows you to configure deployment to a @acronym{VPS, virtual
>>   private server} hosted by @uref{https://www.hetzner.com, Hetzner}.
>>
>>> +@item @code{authorize?} (default: @code{#t})
>>> +If true, the coordinator's public signing key
>>
>> “coordinator” has nothing to do here I guess.
>>
>>> +@item @code{labels} (default: @code{'()})
>>> +A user defined alist of key/value pairs attached to the server. Keys and
>>> +values must be strings. For more information, see
>>> +@uref{https://docs.hetzner.cloud/#labels, Labels}.
>>
>> Maybe add a short example?
>>
>>> +@item @code{location} (default: @code{"fsn1"})
>>> +The name of a @uref{https://docs.hetzner.com/cloud/general/locations,
>>> +location} to create the server in.
>>
>> Maybe add: “For example, @code{"fsn1"} corresponds to the Hetzner site
>> in Falkenstein, Germany, while @code{"sin"} corresponds to its site in
>> Singapore.”
>>
>>> +@item @code{server-type} (default: @code{"cx42"})
>>> +The name of the
>>> +@uref{https://docs.hetzner.com/cloud/servers/overview#server-types,
>>> +server type} this server should be created with.
>>
>> Likewise, an example would be elcome.
>>
>>> +@item @code{ssh-key}
>>> +The path to the SSH private key to use to authenticate with the remote
>>> +host.
>>
>> s/path to/file name of/
>>
>>> +The following example shows the definition of 2 machines that are
>>
>> s/2/two/
>>
>>> +vCPUs and 32 GB of RAM on the @code{aarch64} architecture, the second
>>
>> s/@code{aarch64}/AArch64/
>>
>>> +shared vCPUs and 32 GB of RAM on the @code{x86_64} architecture.
>>
>> Drop @code.
>>
>>> +@lisp
>>> +(use-modules (gnu machine)
>>> +             (gnu machine hetzner))
>>> +
>>> +(list (machine
>>> +       (operating-system %hetzner-os-arm)
>>> +       (environment hetzner-environment-type)
>>> +       (configuration (hetzner-configuration
>>> +                       (server-type "cax41")
>>> +                       (ssh-key "/home/charlie/.ssh/id_rsa"))))
>>> +      (machine
>>> +       (operating-system %hetzner-os-x86)
>>> +       (environment hetzner-environment-type)
>>> +       (configuration (hetzner-configuration
>>> +                       (server-type "cpx51")
>>> +                       (ssh-key "/home/charlie/.ssh/id_rsa")))))
>>
>> Nice!
>>
>>> +API key} should provision 2 machines for you.
>>
>> s/2/two/
>>
>>> +  #:use-module (ice-9 receive)
>>
>> The code base preferable uses SRFI-71 for multiple-value returns.
>>
>>> +      (raise (formatted-message
>>> +              (G_ "Expected a list of Hetzner API responses")))))
>>
>> Messages should start with a lower-case letter (for all the messages in
>> this file).
>>
>> Please add the file to ‘po/guix/POTFILES.in’ so that it’s actually
>> subject to translation.
>>
>>> +(define (hetzner-api-response-read port)
>>> +  "Read the Hetzner API response from PORT."
>>> +  (let* ((response (read-response port))
>>> +         (body (read-response-body response)))
>>> +    (hetzner-api-response
>>> +     (body (json-string->scm (bytevector->string body "UTF-8")))
>>
>> Just ‘string->utf8’ (shorter).
>>
>> More importantly: instead of ‘json-string->scm’ (which gives an alist,
>> leading to ‘assoc-ref’ calls all over the code base along with free-form
>> alists, which is very error-prone), could you use ‘define-json-mapping’?
>>
>> In essence it’s like ‘define-record-type’ but it additionally define how
>> to map a JSON dictionary to a Scheme record.  There are several examples
>> in Guix, such as (guix swh).
>>
>> For clarity, it might be useful to move all the hetzner-api-* bits to a
>> separate module, for example (gnu machine hetzner http).  WDYT?
>>
>>
>> The rest of the code looks nice to me (modulo alists :-)) but that’s
>> about all I can say.  It’s quite a significant body of code.  What would
>> you suggest to prevent bitrot and support maintenance?  Are there parts
>> of it that could be usefully tested automatically, possibly by mocking
>> part of the Hetzner API?  Or are there tips on how you tested it that
>> could be written down in the file itself?
>>
>>
>> Could you move the (guix ssh) bits to a separate patch?
>>
>>> +++ b/guix/ssh.scm
>>> @@ -103,7 +103,8 @@ (define* (open-ssh-session host #:key user port identity
>>>                             host-key
>>>                             (compression %compression)
>>>                             (timeout 3600)
>>> -                           (connection-timeout 10))
>>> +                           (connection-timeout 10)
>>> +                           (stricthostkeycheck #t))
>>>    "Open an SSH session for HOST and return it.  IDENTITY specifies the file
>>>  name of a private key to use for authenticating with the host.  When USER,
>>>  PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config'
>>
>> Please update the docstring.
>>
>> Rather ‘strict-host-key-check?’ to match naming conventions, even if
>> Guile-SSH calls it that way.
>>
>>> @@ -137,7 +138,8 @@ (define* (open-ssh-session host #:key user port identity
>>>
>>>                                 ;; Speed up RPCs by creating sockets with
>>>                                 ;; TCP_NODELAY.
>>> -                               #:nodelay #t)))
>>> +                               #:nodelay #t
>>> +                               #:stricthostkeycheck stricthostkeycheck)))
>>
>> Not sure what this does actually.  Looks like the main part is the
>> “when stricthostkeycheck” condition that comes below, no?
>>
>> Could you send a second version?
>>
>> Thank you!
>>
>> Ludo’.

[signature.asc (application/pgp-signature, inline)]

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

From: Maxim Cournoyer <maxim.cournoyer <at> gmail.com>
To: Roman Scherer <roman <at> burningswell.com>
Cc: Josselin Poiret <dev <at> jpoiret.xyz>,
 Simon Tournier <zimon.toutoune <at> gmail.com>, Mathieu Othacehe <othacehe <at> gnu.org>,
 Ludovic Courtès <ludo <at> gnu.org>,
 Tobias Geerinckx-Rice <me <at> tobias.gr>, Christopher Baines <guix <at> cbaines.net>,
 75144 <at> debbugs.gnu.org
Subject: Re: [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
Date: Mon, 27 Jan 2025 09:45:59 +0900

Hi Roman,

Roman Scherer <roman <at> burningswell.com> writes:

> I made a `mock*` macro to get around this ugly nesting in the meantime.
>
> https://github.com/r0man/guix/blob/hetzner-machine-v2-mock-star/tests/machine/hetzner.scm#L165-L248
>
> But I'm still wondering why the `mock` in
> `deploy-machine-mock-with-unprovisioned-server` is working in the
> REPL,
> but failing when I run the test with make ...

Could it be that you are tricked by the caching of HTTP queries?  I've
been tricked by this before, as if you expect to have to mock each
individual request it may not happen as some will already be cached.

If that's the case, either disabling cache could do, or more easily, use
something like done with mock-http-fetch in the tests/go.scm file.

Hope that helps,

-- 
Thanks,
Maxim

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

From: Roman Scherer <roman <at> burningswell.com>
To: Maxim Cournoyer <maxim.cournoyer <at> gmail.com>
Cc: Josselin Poiret <dev <at> jpoiret.xyz>,
 Simon Tournier <zimon.toutoune <at> gmail.com>, Mathieu Othacehe <othacehe <at> gnu.org>,
 Ludovic Courtès <ludo <at> gnu.org>,
 Tobias Geerinckx-Rice <me <at> tobias.gr>, Roman Scherer <roman <at> burningswell.com>,
 Christopher Baines <guix <at> cbaines.net>, 75144 <at> debbugs.gnu.org
Subject: Re: [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
Date: Tue, 28 Jan 2025 10:37:56 +0100

[Message part 1 (text/plain, inline)]

Hi Maxim,

thanks for your help and the tip about caching. Unless I'm missing
something, I don't think the caching of HTTP requests is involved
here.

I'm trying to test the (gnu machine hetzner) module and mock the
functions it uses from the (gnu machine hetzner http) module.

When I run the mocked test I expect no code from the (gnu machine
hetzner http) module to be executed, since I mocked all those
functions. This seems to work in the Geiser REPL, but for some reason it
does not work when I run the test with:

./pre-inst-env make check TESTS="tests/machine/hetzner.scm"

To me it looks like the mock function behaves differently in those 2
situations. In the meaintime I also tried setting -O0, but that didn't
make any difference either. :/

Roman

Maxim Cournoyer <maxim.cournoyer <at> gmail.com> writes:

> Hi Roman,
>
> Roman Scherer <roman <at> burningswell.com> writes:
>
>> I made a `mock*` macro to get around this ugly nesting in the meantime.
>>
>> https://github.com/r0man/guix/blob/hetzner-machine-v2-mock-star/tests/machine/hetzner.scm#L165-L248
>>
>> But I'm still wondering why the `mock` in
>> `deploy-machine-mock-with-unprovisioned-server` is working in the
>> REPL,
>> but failing when I run the test with make ...
>
> Could it be that you are tricked by the caching of HTTP queries?  I've
> been tricked by this before, as if you expect to have to mock each
> individual request it may not happen as some will already be cached.
>
> If that's the case, either disabling cache could do, or more easily, use
> something like done with mock-http-fetch in the tests/go.scm file.
>
> Hope that helps,

[signature.asc (application/pgp-signature, inline)]

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

From: Ludovic Courtès <ludo <at> gnu.org>
To: Roman Scherer <roman <at> burningswell.com>
Cc: Josselin Poiret <dev <at> jpoiret.xyz>,
 Maxim Cournoyer <maxim.cournoyer <at> gmail.com>,
 Simon Tournier <zimon.toutoune <at> gmail.com>, Mathieu Othacehe <othacehe <at> gnu.org>,
 Tobias Geerinckx-Rice <me <at> tobias.gr>, Christopher Baines <guix <at> cbaines.net>,
 75144 <at> debbugs.gnu.org
Subject: Re: [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
Date: Tue, 28 Jan 2025 11:51:16 +0100

Hi,

Roman Scherer <roman <at> burningswell.com> skribis:

> When I run the mocked test I expect no code from the (gnu machine
> hetzner http) module to be executed, since I mocked all those
> functions. This seems to work in the Geiser REPL, but for some reason it
> does not work when I run the test with:
>
> ./pre-inst-env make check TESTS="tests/machine/hetzner.scm"
>
> To me it looks like the mock function behaves differently in those 2
> situations. In the meaintime I also tried setting -O0, but that didn't
> make any difference either. :/

Hmm.  I was going to say that the likely problem is that code from (gnu
machines hetzner http) gets inlined so you cannot really mock it.

To make sure this can be mocked, you can use this trick:

  (set! proc proc)

where ‘proc’ is the procedure you want to mock (that statement prevents
the compiler from inlining it).

Ludo’.

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

From: Roman Scherer <roman <at> burningswell.com>
To: Ludovic Courtès <ludo <at> gnu.org>
Cc: Josselin Poiret <dev <at> jpoiret.xyz>,
 Maxim Cournoyer <maxim.cournoyer <at> gmail.com>,
 Simon Tournier <zimon.toutoune <at> gmail.com>, Mathieu Othacehe <othacehe <at> gnu.org>,
 Tobias Geerinckx-Rice <me <at> tobias.gr>, Roman Scherer <roman <at> burningswell.com>,
 Christopher Baines <guix <at> cbaines.net>, 75144 <at> debbugs.gnu.org
Subject: Re: [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
Date: Tue, 28 Jan 2025 20:57:41 +0100

[Message part 1 (text/plain, inline)]

Hi Ludo,

that's what I was looking for. Now it is working as expected!

I will send an updated patch soon.

Thanks for your help!

Roman

Ludovic Courtès <ludo <at> gnu.org> writes:

> Hi,
>
> Roman Scherer <roman <at> burningswell.com> skribis:
>
>> When I run the mocked test I expect no code from the (gnu machine
>> hetzner http) module to be executed, since I mocked all those
>> functions. This seems to work in the Geiser REPL, but for some reason it
>> does not work when I run the test with:
>>
>> ./pre-inst-env make check TESTS="tests/machine/hetzner.scm"
>>
>> To me it looks like the mock function behaves differently in those 2
>> situations. In the meaintime I also tried setting -O0, but that didn't
>> make any difference either. :/
>
> Hmm.  I was going to say that the likely problem is that code from (gnu
> machines hetzner http) gets inlined so you cannot really mock it.
>
> To make sure this can be mocked, you can use this trick:
>
>   (set! proc proc)
>
> where ‘proc’ is the procedure you want to mock (that statement prevents
> the compiler from inlining it).
>
> Ludo’.

[signature.asc (application/pgp-signature, inline)]

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

From: Roman Scherer <roman <at> burningswell.com>
To: 75144 <at> debbugs.gnu.org
Cc: Roman Scherer <roman <at> burningswell.com>
Subject: [PATCH v3 1/2] guix: ssh: Add strict-host-key-check? option.
Date: Tue,  4 Feb 2025 20:01:13 +0100

* guix/ssh.scm (open-ssh-session): Add strict-host-key-check? option.

Change-Id: Iae5df5ac8d45033b6b636e9c872f8910d4f6cfe9
---
 guix/ssh.scm | 22 ++++++++++++++--------
 1 file changed, 14 insertions(+), 8 deletions(-)

diff --git a/guix/ssh.scm b/guix/ssh.scm
index ae506df14c..8decfdbab9 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -103,7 +103,8 @@ (define* (open-ssh-session host #:key user port identity
                            host-key
                            (compression %compression)
                            (timeout 3600)
-                           (connection-timeout 10))
+                           (connection-timeout 10)
+                           (strict-host-key-check? #t))
   "Open an SSH session for HOST and return it.  IDENTITY specifies the file
 name of a private key to use for authenticating with the host.  When USER,
 PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config'
@@ -117,6 +118,9 @@ (define* (open-ssh-session host #:key user port identity
 seconds.  Install TIMEOUT as the maximum time in seconds after which a read or
 write operation on a channel of the returned session is considered as failing.
 
+IF STRICT-HOST-KEY-CHECK? is #f, strict host key checking is turned off for
+the new session.
+
 Throw an error on failure."
   (let ((session (make-session #:user user
                                #:identity identity
@@ -137,7 +141,8 @@ (define* (open-ssh-session host #:key user port identity
 
                                ;; Speed up RPCs by creating sockets with
                                ;; TCP_NODELAY.
-                               #:nodelay #t)))
+                               #:nodelay #t
+                               #:stricthostkeycheck strict-host-key-check?)))
 
     ;; Honor ~/.ssh/config.
     (session-parse-config! session)
@@ -149,13 +154,14 @@ (define* (open-ssh-session host #:key user port identity
            (authenticate-server* session host-key)
 
            ;; Authenticate against ~/.ssh/known_hosts.
-           (match (authenticate-server session)
-             ('ok #f)
-             (reason
-              (raise (formatted-message (G_ "failed to authenticate \
+           (when strict-host-key-check?
+             (match (authenticate-server session)
+               ('ok #f)
+               (reason
+                (raise (formatted-message (G_ "failed to authenticate \
 server at '~a': ~a")
-                                        (session-get session 'host)
-                                        reason)))))
+                                          (session-get session 'host)
+                                          reason))))))
 
        ;; Use public key authentication, via the SSH agent if it's available.
        (match (userauth-public-key/auto! session)

base-commit: 97fee203a5441f4d3004ccf43ed72fa3b51a7cdc
-- 
2.48.1

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

From: Roman Scherer <roman <at> burningswell.com>
To: 75144 <at> debbugs.gnu.org
Cc: Roman Scherer <roman <at> burningswell.com>
Subject: [PATCH v3 2/2] machine: Implement 'hetzner-environment-type'.
Date: Tue,  4 Feb 2025 20:01:14 +0100

* Makefile.am (SCM_TESTS): Add test modules.
* doc/guix.texi: Add documentation.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add modules.
* gnu/machine/hetzner.scm: Add hetzner-environment-type.
* gnu/machine/hetzner/http.scm: Add HTTP API.
* po/guix/POTFILES.in: Add Hetzner modules.
* tests/machine/hetzner.scm: Add machine tests.
* tests/machine/hetzner/http.scm Add HTTP API tests.

Change-Id: I276ed5afed676bbccc6c852c56ee4db57ce3c1ea
---
 Makefile.am                    |   2 +
 doc/guix.texi                  | 128 ++++++
 gnu/local.mk                   |   2 +
 gnu/machine/hetzner.scm        | 705 +++++++++++++++++++++++++++++++++
 gnu/machine/hetzner/http.scm   | 664 +++++++++++++++++++++++++++++++
 po/guix/POTFILES.in            |   2 +
 tests/machine/hetzner.scm      | 267 +++++++++++++
 tests/machine/hetzner/http.scm | 631 +++++++++++++++++++++++++++++
 8 files changed, 2401 insertions(+)
 create mode 100644 gnu/machine/hetzner.scm
 create mode 100644 gnu/machine/hetzner/http.scm
 create mode 100644 tests/machine/hetzner.scm
 create mode 100644 tests/machine/hetzner/http.scm

diff --git a/Makefile.am b/Makefile.am
index f759803b8b..7bb75aa146 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -562,6 +562,8 @@ SCM_TESTS =					\
   tests/import-utils.scm			\
   tests/inferior.scm				\
   tests/lint.scm				\
+  tests/machine/hetzner.scm                     \
+  tests/machine/hetzner/http.scm                 \
   tests/minetest.scm				\
   tests/modules.scm				\
   tests/monads.scm				\
diff --git a/doc/guix.texi b/doc/guix.texi
index bb5f29277f..4226d7ae26 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -44783,6 +44783,134 @@ Invoking guix deploy
 @end table
 @end deftp
 
+@deftp {Data Type} hetzner-configuration
+This is the data type describing the server that should be created for a
+machine with an @code{environment} of
+@code{hetzner-environment-type}. It allows you to configure deployment
+to a @acronym{VPS, virtual private server} hosted by
+@uref{https://www.hetzner.com, Hetzner}.
+
+@table @asis
+
+@item @code{allow-downgrades?} (default: @code{#f})
+Whether to allow potential downgrades.
+
+@item @code{authorize?} (default: @code{#t})
+If true, the public signing key @code{"/etc/guix/signing-key.pub"} of
+the machine that invokes @command{guix deploy} will be added to the
+operating system ACL keyring of the target machine.
+
+@item @code{build-locally?} (default: @code{#t})
+If true, system derivations will be built on the machine that invokes
+@command{guix deploy}, otherwise derivations are build on the target
+machine.  Set this to @code{#f} if the machine you are deploying from
+has a different architecture than the target machine and you can't build
+derivations for the target architecture by other means, like offloading
+(@pxref{Daemon Offload Setup}) or emulation
+(@pxref{transparent-emulation-qemu, Transparent Emulation with QEMU}).
+
+@item @code{delete?} (default: @code{#t})
+If true, the server will be deleted when an error happens in the
+provisioning phase. If false, the server will be kept in order to debug
+any issues.
+
+@item @code{labels} (default: @code{'()})
+A user defined alist of key/value pairs attached to the SSH key and the
+server on the Hetzner API.  Keys and values must be strings,
+e.g. @code{'(("environment" . "development"))}.  For more information,
+see @uref{https://docs.hetzner.cloud/#labels, Labels}.
+
+@item @code{location} (default: @code{"fsn1"})
+The name of a @uref{https://docs.hetzner.com/cloud/general/locations,
+location} to create the server in.  For example, @code{"fsn1"}
+corresponds to the Hetzner site in Falkenstein, Germany, while
+@code{"sin"} corresponds to its site in Singapore.
+
+@item @code{server-type} (default: @code{"cx42"})
+The name of the
+@uref{https://docs.hetzner.com/cloud/servers/overview#server-types,
+server type} this virtual server should be created with.  For example,
+@code{"cx42"} corresponds to a x86_64 server that has 8 VCPUs, 16 GB of
+memory and 160 GB of storage, while @code{"cax31"} to the AArch64
+equivalent.  Other server types and their current prices can be found
+@uref{https://www.hetzner.com/cloud/#pricing, here}.
+
+@item @code{ssh-key}
+The file name of the SSH private key to use to authenticate with the
+remote host.
+
+@end table
+
+When deploying a machine for the first time, the following steps are
+taken to provision a server for the machine on the
+@uref{https://www.hetzner.com/cloud, Hetzner Cloud} service:
+
+@itemize
+
+@item
+Create the SSH key of the machine on the Hetzner API.
+
+@item
+Create a server for the machine on the Hetzner API.
+
+@item
+Format the root partition of the disk using the file system of the
+machine's operating system.  Supported file systems are btrfs and ext4.
+
+@item
+Install a minimal Guix operating system on the server using the
+@uref{https://docs.hetzner.com/cloud/servers/getting-started/rescue-system,
+rescue mode}.  This minimal system is used to install the machine's
+operating system, after rebooting.
+
+@item
+Reboot the server and apply the machine's operating system on the
+server.
+
+@end itemize
+
+Once the server has been provisioned and SSH is available, deployment
+continues by delegating it to the @code{managed-host-environment-type}.
+
+Servers on the Hetzner Cloud service can be provisioned on the AArch64
+architecture using UEFI boot mode, or on the x86_64 architecture using
+BIOS boot mode.  The @code{(gnu machine hetzner)} module exports the
+@code{%hetzner-os-arm} and @code{%hetzner-os-x86} operating systems that
+are compatible with those two architectures, and can be used as a base
+for defining your custom operating system.
+
+The following example shows the definition of two machines that are
+deployed on the Hetzner Cloud service.  The first one uses the
+@code{%hetzner-os-arm} operating system to run a server with 16 shared
+vCPUs and 32 GB of RAM on the @code{aarch64} architecture, the second
+one uses the @code{%hetzner-os-x86} operating system on a server with 16
+shared vCPUs and 32 GB of RAM on the @code{x86_64} architecture.
+
+@lisp
+(use-modules (gnu machine)
+             (gnu machine hetzner))
+
+(list (machine
+       (operating-system %hetzner-os-arm)
+       (environment hetzner-environment-type)
+       (configuration (hetzner-configuration
+                       (server-type "cax41")
+                       (ssh-key "/home/charlie/.ssh/id_rsa"))))
+      (machine
+       (operating-system %hetzner-os-x86)
+       (environment hetzner-environment-type)
+       (configuration (hetzner-configuration
+                       (server-type "cpx51")
+                       (ssh-key "/home/charlie/.ssh/id_rsa")))))
+@end lisp
+
+Passing this file to @command{guix deploy} with the environment variable
+@env{GUIX_HETZNER_API_TOKEN} set to a valid Hetzner
+@uref{https://docs.hetzner.com/cloud/api/getting-started/generating-api-token,
+API key} should provision two machines for you.
+
+@end deftp
+
 @node Running Guix in a VM
 @section Running Guix in a Virtual Machine
 
diff --git a/gnu/local.mk b/gnu/local.mk
index 83abc86fe2..cc812ad6f3 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -921,6 +921,8 @@ if HAVE_GUILE_SSH
 
 GNU_SYSTEM_MODULES +=         			\
   %D%/machine/digital-ocean.scm			\
+  %D%/machine/hetzner.scm			\
+  %D%/machine/hetzner/http.scm			\
   %D%/machine/ssh.scm
 
 endif HAVE_GUILE_SSH
diff --git a/gnu/machine/hetzner.scm b/gnu/machine/hetzner.scm
new file mode 100644
index 0000000000..5e17bfae21
--- /dev/null
+++ b/gnu/machine/hetzner.scm
@@ -0,0 +1,705 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Roman Scherer <roman <at> burningswell.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu machine hetzner)
+  #:use-module (gnu bootloader grub)
+  #:use-module (gnu bootloader)
+  #:use-module (gnu machine hetzner http)
+  #:use-module (gnu machine ssh)
+  #:use-module (gnu machine)
+  #:use-module (gnu packages ssh)
+  #:use-module (gnu services base)
+  #:use-module (gnu services networking)
+  #:use-module (gnu services ssh)
+  #:use-module (gnu services)
+  #:use-module (gnu system file-systems)
+  #:use-module (gnu system image)
+  #:use-module (gnu system linux-initrd)
+  #:use-module (gnu system pam)
+  #:use-module (gnu system)
+  #:use-module (guix base32)
+  #:use-module (guix colors)
+  #:use-module (guix derivations)
+  #:use-module (guix diagnostics)
+  #:use-module (guix gexp)
+  #:use-module (guix i18n)
+  #:use-module (guix import json)
+  #:use-module (guix monads)
+  #:use-module (guix packages)
+  #:use-module (guix pki)
+  #:use-module (guix records)
+  #:use-module (guix ssh)
+  #:use-module (guix store)
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 iconv)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 string-fun)
+  #:use-module (ice-9 textual-ports)
+  #:use-module (json)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-2)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-71)
+  #:use-module (ssh channel)
+  #:use-module (ssh key)
+  #:use-module (ssh popen)
+  #:use-module (ssh session)
+  #:use-module (ssh sftp)
+  #:use-module (ssh shell)
+  #:export (%hetzner-os-arm
+            %hetzner-os-x86
+            deploy-hetzner
+            hetzner-configuration
+            hetzner-configuration-allow-downgrades?
+            hetzner-configuration-api
+            hetzner-configuration-authorize?
+            hetzner-configuration-build-locally?
+            hetzner-configuration-delete?
+            hetzner-configuration-labels
+            hetzner-configuration-location
+            hetzner-configuration-server-type
+            hetzner-configuration-ssh-key
+            hetzner-configuration?
+            hetzner-environment-type))
+
+;;; Commentary:
+;;;
+;;; This module implements a high-level interface for provisioning machines on
+;;; the Hetzner Cloud service https://docs.hetzner.cloud.
+;;;
+
+
+;;;
+;;; Hetzner operating systems.
+;;;
+
+;; Operating system for arm servers using UEFI boot mode.
+
+(define %hetzner-os-arm
+  (operating-system
+    (host-name "guix-arm")
+    (bootloader
+     (bootloader-configuration
+      (bootloader grub-efi-bootloader)
+      (targets (list "/boot/efi"))
+      (terminal-outputs '(console))))
+    (file-systems
+     (cons* (file-system
+              (mount-point "/")
+              (device "/dev/sda1")
+              (type "ext4"))
+            (file-system
+              (mount-point "/boot/efi")
+              (device "/dev/sda15")
+              (type "vfat"))
+            %base-file-systems))
+    (initrd-modules
+     (cons* "sd_mod" "virtio_scsi" %base-initrd-modules))
+    (services
+     (cons* (service dhcp-client-service-type)
+            (service openssh-service-type
+                     (openssh-configuration
+                      (openssh openssh-sans-x)
+                      (permit-root-login 'prohibit-password)))
+            %base-services))))
+
+;; Operating system for x86 servers using BIOS boot mode.
+
+(define %hetzner-os-x86
+  (operating-system
+    (inherit %hetzner-os-arm)
+    (host-name "guix-x86")
+    (bootloader
+     (bootloader-configuration
+      (bootloader grub-bootloader)
+      (targets (list "/dev/sda"))
+      (terminal-outputs '(console))))
+    (initrd-modules
+     (cons "virtio_scsi" %base-initrd-modules))
+    (file-systems
+     (cons (file-system
+             (mount-point "/")
+             (device "/dev/sda1")
+             (type "ext4"))
+           %base-file-systems))))
+
+(define (operating-system-authorize os)
+  "Authorize the OS with the public signing key of the current machine."
+  (if (file-exists? %public-key-file)
+      (operating-system
+        (inherit os)
+        (services
+         (modify-services (operating-system-user-services os)
+           (guix-service-type
+            config => (guix-configuration
+                       (inherit config)
+                       (authorized-keys
+                        (cons*
+                         (local-file %public-key-file)
+                         (guix-configuration-authorized-keys config))))))))
+      (raise-exception
+       (formatted-message (G_ "no signing key '~a'. \
+Have you run 'guix archive --generate-key'?")
+                          %public-key-file))))
+
+(define (operating-system-root-file-system-type os)
+  "Return the root file system type of the operating system OS."
+  (let ((root-fs (find (lambda (file-system)
+                         (equal? "/" (file-system-mount-point file-system)))
+                       (operating-system-file-systems os))))
+    (if (file-system? root-fs)
+        (file-system-type root-fs)
+        (raise-exception
+         (formatted-message
+          (G_ "could not determine root file system type"))))))
+
+
+;;;
+;;; Helper functions.
+;;;
+
+(define (escape-backticks str)
+  "Escape all backticks in STR."
+  (string-replace-substring str "`" "\\`"))
+
+
+
+;;;
+;;; Hetzner configuration.
+;;;
+
+(define-record-type* <hetzner-configuration> hetzner-configuration
+  make-hetzner-configuration hetzner-configuration? this-hetzner-configuration
+  (allow-downgrades? hetzner-configuration-allow-downgrades? ; boolean
+                     (default #f))
+  (api hetzner-configuration-api ; <hetzner-api>
+       (default (hetzner-api)))
+  (authorize? hetzner-configuration-authorize? ; boolean
+              (default #t))
+  (build-locally? hetzner-configuration-build-locally? ; boolean
+                  (default #t))
+  (delete? hetzner-configuration-delete? ; boolean
+           (default #f))
+  (labels hetzner-configuration-labels ; list of strings
+          (default '()))
+  (location hetzner-configuration-location ; #f | string
+            (default "fsn1"))
+  (server-type hetzner-configuration-server-type ; string
+               (default "cx42"))
+  (ssh-key hetzner-configuration-ssh-key)) ; string
+
+(define (hetzner-configuration-ssh-key-fingerprint config)
+  "Return the SSH public key fingerprint of CONFIG as a string."
+  (and-let* ((file-name (hetzner-configuration-ssh-key config))
+             (privkey (private-key-from-file file-name))
+             (pubkey (private-key->public-key privkey))
+             (hash (get-public-key-hash pubkey 'md5)))
+    (bytevector->hex-string hash)))
+
+(define (hetzner-configuration-ssh-key-public config)
+  "Return the SSH public key of CONFIG as a string."
+  (and-let* ((ssh-key (hetzner-configuration-ssh-key config))
+             (public-key (public-key-from-file ssh-key)))
+    (format #f "ssh-~a ~a" (get-key-type public-key)
+            (public-key->string public-key))))
+
+
+;;;
+;;; Hetzner Machine.
+;;;
+
+(define (hetzner-machine-delegate target server)
+  "Return the delagate machine that uses SSH for deployment."
+  (let* ((config (machine-configuration target))
+         ;; Get the operating system WITHOUT the provenance service to avoid a
+         ;; duplicate symlink conflict in the store.
+         (os ((@@ (gnu machine) %machine-operating-system) target)))
+    (machine
+     (inherit target)
+     (operating-system
+       (if (hetzner-configuration-authorize? config)
+           (operating-system-authorize os)
+           os))
+     (environment managed-host-environment-type)
+     (configuration
+      (machine-ssh-configuration
+       (allow-downgrades? (hetzner-configuration-allow-downgrades? config))
+       (authorize? (hetzner-configuration-authorize? config))
+       (build-locally? (hetzner-configuration-build-locally? config))
+       (host-name (hetzner-server-public-ipv4 server))
+       (identity (hetzner-configuration-ssh-key config))
+       (system (hetzner-server-system server)))))))
+
+(define (hetzner-machine-location machine)
+  "Find the location of MACHINE on the Hetzner API."
+  (let* ((config (machine-configuration machine))
+         (expected (hetzner-configuration-location config)))
+    (find (lambda (location)
+            (equal? expected (hetzner-location-name location)))
+          (hetzner-api-locations
+           (hetzner-configuration-api config)
+           #:params `(("name" . ,expected))))))
+
+(define (hetzner-machine-server-type machine)
+  "Find the server type of MACHINE on the Hetzner API."
+  (let* ((config (machine-configuration machine))
+         (expected (hetzner-configuration-server-type config)))
+    (find (lambda (server-type)
+            (equal? expected (hetzner-server-type-name server-type)))
+          (hetzner-api-server-types
+           (hetzner-configuration-api config)
+           #:params `(("name" . ,expected))))))
+
+(define (hetzner-machine-validate-api-token machine)
+  "Validate the Hetzner API authentication token of MACHINE."
+  (let* ((config (machine-configuration machine))
+         (api (hetzner-configuration-api config)))
+    (unless (hetzner-api-token api)
+      (raise-exception
+       (formatted-message
+        (G_ "Hetzner Cloud access token was not provided. \
+This may be fixed by setting the environment variable GUIX_HETZNER_API_TOKEN \
+to one procured from \
+https://docs.hetzner.com/cloud/api/getting-started/generating-api-token"))))))
+
+(define (hetzner-machine-validate-configuration-type machine)
+  "Raise an error if MACHINE's configuration is not an instance of
+<hetzner-configuration>."
+  (let ((config (machine-configuration machine))
+        (environment (environment-type-name (machine-environment machine))))
+    (unless (and config (hetzner-configuration? config))
+      (raise-exception
+       (formatted-message (G_ "unsupported machine configuration '~a' \
+for environment of type '~a'")
+                          config
+                          environment)))))
+
+(define (hetzner-machine-validate-server-type machine)
+  "Raise an error if the server type of MACHINE is not supported."
+  (unless (hetzner-machine-server-type machine)
+    (let* ((config (machine-configuration machine))
+           (api (hetzner-configuration-api config)))
+      (raise-exception
+       (formatted-message
+        (G_ "server type '~a' not supported~%~%\
+Available server types:~%~%~a~%~%For more details and prices, see: ~a")
+        (hetzner-configuration-server-type config)
+        (string-join
+         (map (lambda (type)
+                (format #f " - ~a: ~a, ~a ~a cores, ~a GB mem, ~a GB disk"
+                        (colorize-string
+                         (hetzner-server-type-name type)
+                         (color BOLD))
+                        (hetzner-server-type-architecture type)
+                        (hetzner-server-type-cores type)
+                        (hetzner-server-type-cpu-type type)
+                        (hetzner-server-type-memory type)
+                        (hetzner-server-type-disk type)))
+              (hetzner-api-server-types api))
+         "\n")
+        "https://www.hetzner.com/cloud#pricing")))))
+
+(define (hetzner-machine-validate-location machine)
+  "Raise an error if the location of MACHINE is not supported."
+  (unless (hetzner-machine-location machine)
+    (let* ((config (machine-configuration machine))
+           (api (hetzner-configuration-api config)))
+      (raise-exception
+       (formatted-message
+        (G_ "server location '~a' not supported~%~%\
+Available locations:~%~%~a~%~%For more details, see: ~a")
+        (hetzner-configuration-location config)
+        (string-join
+         (map (lambda (location)
+                (format #f " - ~a: ~a, ~a"
+                        (colorize-string
+                         (hetzner-location-name location)
+                         (color BOLD))
+                        (hetzner-location-description location)
+                        (hetzner-location-country location)))
+              (hetzner-api-locations api))
+         "\n")
+        "https://www.hetzner.com/cloud#locations")))))
+
+(define (hetzner-machine-validate machine)
+  "Validate the Hetzner MACHINE."
+  (hetzner-machine-validate-configuration-type machine)
+  (hetzner-machine-validate-api-token machine)
+  (hetzner-machine-validate-location machine)
+  (hetzner-machine-validate-server-type machine))
+
+(define (hetzner-machine-bootstrap-os-form machine server)
+  "Return the form to bootstrap an operating system on SERVER."
+  (let* ((os (machine-operating-system machine))
+         (system (hetzner-server-system server))
+         (arm? (equal? "arm" (hetzner-server-architecture server)))
+         (x86? (equal? "x86" (hetzner-server-architecture server)))
+         (root-fs-type (operating-system-root-file-system-type os)))
+    `(operating-system
+       (host-name ,(operating-system-host-name os))
+       (timezone "Etc/UTC")
+       (bootloader (bootloader-configuration
+                    (bootloader ,(cond (arm? 'grub-efi-bootloader)
+                                       (x86? 'grub-bootloader)))
+                    (targets ,(cond (arm? '(list "/boot/efi"))
+                                    (x86? '(list "/dev/sda"))))
+                    (terminal-outputs '(console))))
+       (initrd-modules (append
+                        ,(cond (arm? '(list "sd_mod" "virtio_scsi"))
+                               (x86? '(list "virtio_scsi")))
+                        %base-initrd-modules))
+       (file-systems ,(cond
+                       (arm? `(cons* (file-system
+                                       (mount-point "/")
+                                       (device "/dev/sda1")
+                                       (type ,root-fs-type))
+                                     (file-system
+                                       (mount-point "/boot/efi")
+                                       (device "/dev/sda15")
+                                       (type "vfat"))
+                                     %base-file-systems))
+                       (x86? `(cons* (file-system
+                                       (mount-point "/")
+                                       (device "/dev/sda1")
+                                       (type ,root-fs-type))
+                                     %base-file-systems))))
+       (services
+        (cons* (service dhcp-client-service-type)
+               (service openssh-service-type
+                        (openssh-configuration
+                         (openssh openssh-sans-x)
+                         (permit-root-login 'prohibit-password)))
+               %base-services)))))
+
+(define (rexec-verbose session cmd)
+  "Execute a command CMD on the remote side and print output.  Return two
+values: list of output lines returned by CMD and its exit code."
+  (let* ((channel (open-remote-input-pipe session cmd))
+         (result  (let loop ((line   (read-line channel))
+                             (result '()))
+                    (if (eof-object? line)
+                        (reverse result)
+                        (begin
+                          (display line)
+                          (newline)
+                          (loop (read-line channel)
+                                (cons line result))))))
+         (exit-status (channel-get-exit-status channel)))
+    (close channel)
+    (values result exit-status)))
+
+(define (hetzner-machine-ssh-key machine)
+  "Find the SSH key for MACHINE on the Hetzner API."
+  (let* ((config (machine-configuration machine))
+         (expected (hetzner-configuration-ssh-key-fingerprint config)))
+    (find (lambda (ssh-key)
+            (equal? expected (hetzner-ssh-key-fingerprint ssh-key)))
+          (hetzner-api-ssh-keys
+           (hetzner-configuration-api config)
+           #:params `(("fingerprint" . ,expected))))))
+
+(define (hetzner-machine-ssh-key-create machine)
+  "Create the SSH key for MACHINE on the Hetzner API."
+  (let ((name (machine-display-name machine)))
+    (format #t "creating ssh key for '~a'...\n" name)
+    (let* ((config (machine-configuration machine))
+           (api (hetzner-configuration-api config))
+           (ssh-key (hetzner-api-ssh-key-create
+                     (hetzner-configuration-api config)
+                     (hetzner-configuration-ssh-key-fingerprint config)
+                     (hetzner-configuration-ssh-key-public config)
+                     #:labels (hetzner-configuration-labels config))))
+      (format #t "successfully created ssh key for '~a'\n" name)
+      ssh-key)))
+
+(define (hetzner-machine-server machine)
+  "Find the Hetzner server for MACHINE."
+  (let ((config (machine-configuration machine)))
+    (find (lambda (server)
+            (equal? (machine-display-name machine)
+                    (hetzner-server-name server)))
+          (hetzner-api-servers
+           (hetzner-configuration-api config)
+           #:params `(("name" . ,(machine-display-name machine)))))))
+
+(define (hetzner-machine-create-server machine)
+  "Create the Hetzner server for MACHINE."
+  (let* ((config (machine-configuration machine))
+         (name (machine-display-name machine))
+         (server-type (hetzner-configuration-server-type config)))
+    (format #t "creating '~a' server for '~a'...\n" server-type name)
+    (let* ((ssh-key (hetzner-machine-ssh-key machine))
+           (api (hetzner-configuration-api config))
+           (server (hetzner-api-server-create
+                    api
+                    (machine-display-name machine)
+                    (list ssh-key)
+                    #:labels (hetzner-configuration-labels config)
+                    #:location (hetzner-configuration-location config)
+                    #:server-type (hetzner-configuration-server-type config)))
+           (architecture (hetzner-server-architecture server)))
+      (format #t "successfully created '~a' ~a server for '~a'\n"
+              server-type architecture name)
+      server)))
+
+(define (wait-for-ssh address ssh-key)
+  "Block until a SSH session can be made as 'root' with SSH-KEY at ADDRESS."
+  (format #t "connecting via SSH to '~a' using '~a'...\n" address ssh-key)
+  (let loop ()
+    (catch #t
+      (lambda ()
+        (open-ssh-session address #:user "root" #:identity ssh-key
+                          #:strict-host-key-check? #f))
+      (lambda args
+        (let ((msg (cadr args)))
+          (if (formatted-message? msg)
+              (format #t "~a\n"
+                      (string-trim-right
+                       (apply format #f
+                              (formatted-message-string msg)
+                              (formatted-message-arguments msg))
+                       #\newline))
+              (format #t "~a" args))
+          (sleep 5)
+          (loop))))))
+
+(define (hetzner-machine-wait-for-ssh machine server)
+  "Wait for SSH connection to be established with the specified machine."
+  (wait-for-ssh (hetzner-server-public-ipv4 server)
+                (hetzner-configuration-ssh-key
+                 (machine-configuration machine))))
+
+(define (hetzner-machine-authenticate-host machine server)
+  "Add the host key of MACHINE to the list of known hosts."
+  (let ((ssh-session (hetzner-machine-wait-for-ssh machine server)))
+    (write-known-host! ssh-session)))
+
+(define (hetzner-machine-enable-rescue-system machine server)
+  "Enable the rescue system on the Hetzner SERVER for MACHINE."
+  (let* ((name (machine-display-name machine))
+         (config (machine-configuration machine))
+         (api (hetzner-configuration-api config))
+         (ssh-keys (list (hetzner-machine-ssh-key machine))))
+    (format #t "enabling rescue system on '~a'...\n" name)
+    (let ((action (hetzner-api-server-enable-rescue-system api server ssh-keys)))
+      (format #t "successfully enabled rescue system on '~a'\n" name)
+      action)))
+
+(define (hetzner-machine-power-on machine server)
+  "Power on the Hetzner SERVER for MACHINE."
+  (let* ((name (machine-display-name machine))
+         (config (machine-configuration machine))
+         (api (hetzner-configuration-api config)))
+    (format #t "powering on server for '~a'...\n" name)
+    (let ((action (hetzner-api-server-power-on api server)))
+      (format #t "successfully powered on server for '~a'\n" name)
+      action)))
+
+(define (hetzner-machine-ssh-run-script ssh-session name content)
+  (let ((sftp-session (make-sftp-session ssh-session)))
+    (rexec ssh-session (format #f "rm -f ~a" name))
+    (rexec ssh-session (format #f "mkdir -p ~a" (dirname name)))
+    (call-with-remote-output-file
+     sftp-session name
+     (lambda (port)
+       (display content port)))
+    (sftp-chmod sftp-session name 755)
+    (let ((lines exit-code (rexec-verbose ssh-session
+                                          (format #f "~a 2>&1" name))))
+      (if (zero? exit-code)
+          lines
+          (raise-exception
+           (formatted-message
+            (G_ "failed to run script '~a' on machine, exit code: '~a'")
+            name exit-code))))))
+
+;; Prevent compiler from inlining this function, so we can mock it in tests.
+(set! hetzner-machine-ssh-run-script hetzner-machine-ssh-run-script)
+
+(define (hetzner-machine-rescue-install-os machine ssh-session server)
+  (let ((name (machine-display-name machine))
+        (os (hetzner-machine-bootstrap-os-form machine server)))
+    (format #t "installing guix operating system on '~a'...\n" name)
+    (hetzner-machine-ssh-run-script
+     ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-install-os"
+     (format #f "#!/usr/bin/env bash
+set -eo pipefail
+mount /dev/sda1 /mnt
+mkdir -p /mnt/boot/efi
+mount /dev/sda15 /mnt/boot/efi
+
+mkdir --parents /mnt/root/.ssh
+chmod 700 /mnt/root/.ssh
+cp /root/.ssh/authorized_keys /mnt/root/.ssh/authorized_keys
+chmod 600 /mnt/root/.ssh/authorized_keys
+
+cat > /tmp/guix/deploy/hetzner-os.scm << EOF
+(use-modules (gnu) (guix utils))
+(use-package-modules ssh)
+(use-service-modules base networking ssh)
+(use-system-modules linux-initrd)
+~a
+EOF
+guix system init --verbosity=2 /tmp/guix/deploy/hetzner-os.scm /mnt"
+             (escape-backticks (format #f "~y" os))))
+    (format #t "successfully installed guix operating system on '~a'\n" name)))
+
+(define (hetzner-machine-reboot machine server)
+  "Reboot the Hetzner SERVER for MACHINE."
+  (let* ((name (machine-display-name machine))
+         (config (machine-configuration machine))
+         (api (hetzner-configuration-api config)))
+    (format #t "rebooting server for '~a'...\n" name)
+    (let ((action (hetzner-api-server-reboot api server)))
+      (format #t "successfully rebooted server for '~a'\n" name)
+      action)))
+
+(define (hetzner-machine-rescue-partition machine ssh-session)
+  "Setup the partitions of the Hetzner server for MACHINE using SSH-SESSION."
+  (let* ((name (machine-display-name machine))
+         (os (machine-operating-system machine))
+         (root-fs-type (operating-system-root-file-system-type os)))
+    (format #t "setting up partitions on '~a'...\n" name)
+    (hetzner-machine-ssh-run-script
+     ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-partition"
+     (format #f "#!/usr/bin/env bash
+set -eo pipefail
+growpart /dev/sda 1 || true
+~a
+fdisk -l /dev/sda"
+             (cond
+              ((equal? "btrfs" root-fs-type)
+               (format #f "mkfs.btrfs -L ~a -f /dev/sda1" root-label))
+              ((equal? "ext4" root-fs-type)
+               (format #f "mkfs.ext4 -L ~a -F /dev/sda1" root-label))
+              (else (raise-exception
+                     (formatted-message
+                      (G_ "unsupported root file system type '~a'")
+                      root-fs-type))))))
+    (format #t "successfully setup partitions on '~a'\n" name)))
+
+(define (hetzner-machine-rescue-install-packages machine ssh-session)
+  "Install packages on the Hetzner server for MACHINE using SSH-SESSION."
+  (let ((name (machine-display-name machine)))
+    (format #t "installing rescue system packages on '~a'...\n" name)
+    (hetzner-machine-ssh-run-script
+     ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-install-packages"
+     (format #f "#!/usr/bin/env bash
+set -eo pipefail
+apt-get update
+apt-get install guix cloud-initramfs-growroot --assume-yes"))
+    (format #t "successfully installed rescue system packages on '~a'\n" name)))
+
+(define (hetzner-machine-delete machine server)
+  "Delete the Hetzner server for MACHINE."
+  (let* ((name (machine-display-name machine))
+         (config (machine-configuration machine))
+         (api (hetzner-configuration-api config)))
+    (format #t "deleting server for '~a'...\n" name)
+    (let ((action (hetzner-api-server-delete api server)))
+      (format #t "successfully deleted server for '~a'\n" name)
+      action)))
+
+(define (hetzner-machine-provision machine)
+  "Provision a server for MACHINE on the Hetzner Cloud service."
+  (with-exception-handler
+      (lambda (exception)
+        (let ((config (machine-configuration machine))
+              (server (hetzner-machine-server machine)))
+          (when (and server (hetzner-configuration-delete? config))
+            (hetzner-machine-delete machine server))
+          (raise-exception exception)))
+    (lambda ()
+      (let ((server (hetzner-machine-create-server machine)))
+        (hetzner-machine-enable-rescue-system machine server)
+        (hetzner-machine-power-on machine server)
+        (let ((ssh-session (hetzner-machine-wait-for-ssh machine server)))
+          (hetzner-machine-rescue-install-packages machine ssh-session)
+          (hetzner-machine-rescue-partition machine ssh-session)
+          (hetzner-machine-rescue-install-os machine ssh-session server)
+          (hetzner-machine-reboot machine server)
+          (sleep 5)
+          (hetzner-machine-authenticate-host machine server)
+          server)))
+    #:unwind? #t))
+
+(define (machine-not-provisioned machine)
+  (formatted-message
+   (G_ "no server provisioned for machine '~a' on the Hetzner Cloud service")
+   (machine-display-name machine)))
+
+
+;;;
+;;; Remote evaluation.
+;;;
+
+(define (hetzner-remote-eval machine exp)
+  "Internal implementation of 'machine-remote-eval' for MACHINE instances with
+an environment type of 'hetzner-environment-type'."
+  (hetzner-machine-validate machine)
+  (let ((server (hetzner-machine-server machine)))
+    (unless server (raise-exception (machine-not-provisioned machine)))
+    (machine-remote-eval (hetzner-machine-delegate machine server) exp)))
+
+
+
+;;;
+;;; System deployment.
+;;;
+
+(define (deploy-hetzner machine)
+  "Internal implementation of 'deploy-machine' for 'machine' instances with an
+environment type of 'hetzner-environment-type'."
+  (hetzner-machine-validate machine)
+  (unless (hetzner-machine-ssh-key machine)
+    (hetzner-machine-ssh-key-create machine))
+  (let ((server (or (hetzner-machine-server machine)
+                    (hetzner-machine-provision machine))))
+    (deploy-machine (hetzner-machine-delegate machine server))))
+
+
+
+;;;
+;;; Roll-back.
+;;;
+
+(define (roll-back-hetzner machine)
+  "Internal implementation of 'roll-back-machine' for MACHINE instances with an
+environment type of 'hetzner-environment-type'."
+  (hetzner-machine-validate machine)
+  (let ((server (hetzner-machine-server machine)))
+    (unless server (raise-exception (machine-not-provisioned machine)))
+    (roll-back-machine (hetzner-machine-delegate machine server))))
+
+
+
+;;;
+;;; Environment type.
+;;;
+
+(define hetzner-environment-type
+  (environment-type
+   (machine-remote-eval hetzner-remote-eval)
+   (deploy-machine deploy-hetzner)
+   (roll-back-machine roll-back-hetzner)
+   (name 'hetzner-environment-type)
+   (description "Provisioning of virtual machine servers on the Hetzner Cloud
+service.")))
diff --git a/gnu/machine/hetzner/http.scm b/gnu/machine/hetzner/http.scm
new file mode 100644
index 0000000000..bfd6555472
--- /dev/null
+++ b/gnu/machine/hetzner/http.scm
@@ -0,0 +1,664 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Roman Scherer <roman <at> burningswell.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu machine hetzner http)
+  #:use-module (guix diagnostics)
+  #:use-module (guix i18n)
+  #:use-module (guix records)
+  #:use-module (ice-9 iconv)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 pretty-print)
+  #:use-module (ice-9 textual-ports)
+  #:use-module (json)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-2)
+  #:use-module (ssh key)
+  #:use-module (web client)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:export (%hetzner-default-api-token
+            %hetzner-default-server-image
+            %hetzner-default-server-location
+            %hetzner-default-server-type
+            hetzner-action
+            hetzner-action-command
+            hetzner-action-error
+            hetzner-action-finished
+            hetzner-action-id
+            hetzner-action-progress
+            hetzner-action-resources
+            hetzner-action-started
+            hetzner-action-status
+            hetzner-action?
+            hetzner-api
+            hetzner-api-action-wait
+            hetzner-api-actions
+            hetzner-api-create-ssh-key
+            hetzner-api-locations
+            hetzner-api-request-body
+            hetzner-api-request-headers
+            hetzner-api-request-method
+            hetzner-api-request-params
+            hetzner-api-request-send
+            hetzner-api-request-url
+            hetzner-api-request?
+            hetzner-api-response
+            hetzner-api-response-body
+            hetzner-api-response-headers
+            hetzner-api-response-status
+            hetzner-api-response?
+            hetzner-api-server-create
+            hetzner-api-server-delete
+            hetzner-api-server-enable-rescue-system
+            hetzner-api-server-power-off
+            hetzner-api-server-power-on
+            hetzner-api-server-reboot
+            hetzner-api-server-types
+            hetzner-api-servers
+            hetzner-api-ssh-key-create
+            hetzner-api-ssh-key-delete
+            hetzner-api-ssh-keys
+            hetzner-api-token
+            hetzner-api?
+            hetzner-error-code
+            hetzner-error-message
+            hetzner-error?
+            hetzner-ipv4-blocked?
+            hetzner-ipv4-dns-ptr
+            hetzner-ipv4-id
+            hetzner-ipv4-ip
+            hetzner-ipv4?
+            hetzner-ipv6-blocked?
+            hetzner-ipv6-dns-ptr
+            hetzner-ipv6-id
+            hetzner-ipv6-ip
+            hetzner-ipv6?
+            hetzner-location
+            hetzner-location-city
+            hetzner-location-country
+            hetzner-location-description
+            hetzner-location-id
+            hetzner-location-latitude
+            hetzner-location-longitude
+            hetzner-location-name
+            hetzner-location-network-zone
+            hetzner-location?
+            hetzner-public-net
+            hetzner-public-net-ipv4
+            hetzner-public-net-ipv6
+            hetzner-resource
+            hetzner-resource-id
+            hetzner-resource-type
+            hetzner-resource?
+            hetzner-server-architecture
+            hetzner-server-created
+            hetzner-server-id
+            hetzner-server-labels
+            hetzner-server-name
+            hetzner-server-public-ipv4
+            hetzner-server-public-net
+            hetzner-server-rescue-enabled?
+            hetzner-server-system
+            hetzner-server-type
+            hetzner-server-type-architecture
+            hetzner-server-type-cores
+            hetzner-server-type-cpu-type
+            hetzner-server-type-deprecated
+            hetzner-server-type-deprecation
+            hetzner-server-type-description
+            hetzner-server-type-disk
+            hetzner-server-type-id
+            hetzner-server-type-memory
+            hetzner-server-type-name
+            hetzner-server-type-storage-type
+            hetzner-server-type?
+            hetzner-server?
+            hetzner-ssh-key-created
+            hetzner-ssh-key-fingerprint
+            hetzner-ssh-key-id
+            hetzner-ssh-key-labels
+            hetzner-ssh-key-name
+            hetzner-ssh-key-public-key
+            hetzner-ssh-key-read-file
+            hetzner-ssh-key?
+            make-hetzner-action
+            make-hetzner-error
+            make-hetzner-ipv4
+            make-hetzner-ipv6
+            make-hetzner-location
+            make-hetzner-public-net
+            make-hetzner-resource
+            make-hetzner-server
+            make-hetzner-server-type
+            make-hetzner-ssh-key))
+
+;;; Commentary:
+;;;
+;;; This module implements a lower-level interface for interacting with the
+;;; Hetzner Cloud API https://docs.hetzner.cloud.
+;;;
+
+(define %hetzner-default-api-token
+  (make-parameter (getenv "GUIX_HETZNER_API_TOKEN")))
+
+;; Ideally this would be a Guix image. Maybe one day.
+(define %hetzner-default-server-image "debian-11")
+
+;; Falkenstein, Germany
+(define %hetzner-default-server-location "fsn1")
+
+;; x86, 8 VCPUs, 16 GB mem, 160 GB disk
+(define %hetzner-default-server-type "cx42")
+
+
+;;;
+;;; Helper functions.
+;;;
+
+(define (format-query-param param)
+  "Format the query PARAM as a string."
+  (string-append (uri-encode (format #f "~a" (car param))) "="
+                 (uri-encode (format #f "~a" (cdr param)))))
+
+(define (format-query-params params)
+  "Format the query PARAMS as a string."
+  (if (> (length params) 0)
+      (string-append
+       "?"
+       (string-join
+        (map format-query-param params)
+        "&"))
+      ""))
+
+(define (json->maybe-hetzner-error json)
+  (and (list? json) (json->hetzner-error json)))
+
+(define (string->time s)
+  (when (string? s) (car (strptime "%FT%T%z" s))))
+
+(define (json->hetzner-dnses vector)
+  (map json->hetzner-dns (vector->list vector)))
+
+(define (json->hetzner-resources vector)
+  (map json->hetzner-resource (vector->list vector)))
+
+
+;;;
+;;; Domain models.
+;;;
+
+(define-json-mapping <hetzner-action>
+  make-hetzner-action hetzner-action? json->hetzner-action
+  (command hetzner-action-command) ; string
+  (error hetzner-action-error "error"
+         json->maybe-hetzner-error) ; <hetzner-error> | #f
+  (finished hetzner-action-finished "finished" string->time) ; time
+  (id hetzner-action-id) ; integer
+  (progress hetzner-action-progress) ; integer
+  (resources hetzner-action-resources "resources"
+             json->hetzner-resources) ; list of <hetzner-resource>
+  (started hetzner-action-started "started" string->time) ; time
+  (status hetzner-action-status))
+
+(define-json-mapping <hetzner-deprecation>
+  make-hetzner-deprecation hetzner-deprecation? json->hetzner-deprecation
+  (announced hetzner-deprecation-announced) ; string
+  (unavailable-after hetzner-deprecation-unavailable-after
+                     "unavailable_after")) ; string
+
+(define-json-mapping <hetzner-dns>
+  make-hetzner-dns hetzner-dns? json->hetzner-dns
+  (ip hetzner-dns-ip) ; string
+  (ptr hetzner-dns-ptr "dns_ptr")) ; string
+
+(define-json-mapping <hetzner-error>
+  make-hetzner-error hetzner-error? json->hetzner-error
+  (code hetzner-error-code) ; string
+  (message hetzner-error-message)) ; <string>
+
+(define-json-mapping <hetzner-ipv4>
+  make-hetzner-ipv4 hetzner-ipv4? json->hetzner-ipv4
+  (blocked? hetzner-ipv4-blocked? "blocked") ; boolean
+  (dns-ptr hetzner-ipv4-dns-ptr "dns_ptr") ; string
+  (id hetzner-ipv4-id) ; integer
+  (ip hetzner-ipv4-ip)) ; string
+
+(define-json-mapping <hetzner-ipv6>
+  make-hetzner-ipv6 hetzner-ipv6? json->hetzner-ipv6
+  (blocked? hetzner-ipv6-blocked? "blocked") ; boolean
+  (dns-ptr hetzner-ipv6-dns-ptr "dns_ptr"
+           json->hetzner-dnses) ; list of <hetzner-dns>
+  (id hetzner-ipv6-id) ; integer
+  (ip hetzner-ipv6-ip)) ; string
+
+(define-json-mapping <hetzner-location>
+  make-hetzner-location hetzner-location? json->hetzner-location
+  (city hetzner-location-city) ; string
+  (country hetzner-location-country) ; string
+  (description hetzner-location-description) ; string
+  (id hetzner-location-id) ; integer
+  (latitude hetzner-location-latitude) ; decimal
+  (longitude hetzner-location-longitude) ; decimal
+  (name hetzner-location-name) ; string
+  (network-zone hetzner-location-network-zone "network_zone"))
+
+(define-json-mapping <hetzner-public-net>
+  make-hetzner-public-net hetzner-public-net? json->hetzner-public-net
+  (ipv4 hetzner-public-net-ipv4 "ipv4" json->hetzner-ipv4) ; <hetzner-ipv4>
+  (ipv6 hetzner-public-net-ipv6 "ipv6" json->hetzner-ipv6)) ; <hetzner-ipv6>
+
+(define-json-mapping <hetzner-resource>
+  make-hetzner-resource hetzner-resource? json->hetzner-resource
+  (id hetzner-resource-id) ; integer
+  (type hetzner-resource-type)) ; string
+
+(define-json-mapping <hetzner-server>
+  make-hetzner-server hetzner-server? json->hetzner-server
+  (created hetzner-server-created) ; time
+  (id hetzner-server-id) ; integer
+  (labels hetzner-server-labels) ; alist of string/string
+  (name hetzner-server-name) ; string
+  (public-net hetzner-server-public-net "public_net"
+              json->hetzner-public-net) ; <hetzner-public-net>
+  (rescue-enabled? hetzner-server-rescue-enabled? "rescue_enabled") ; boolean
+  (server-type hetzner-server-type "server_type"
+               json->hetzner-server-type)) ; <hetzner-server-type>
+
+(define-json-mapping <hetzner-server-type>
+  make-hetzner-server-type hetzner-server-type? json->hetzner-server-type
+  (architecture hetzner-server-type-architecture) ; string
+  (cores hetzner-server-type-cores) ; integer
+  (cpu-type hetzner-server-type-cpu-type "cpu_type") ; string
+  (deprecated hetzner-server-type-deprecated) ; boolean
+  (deprecation hetzner-server-type-deprecation
+               json->hetzner-deprecation) ; <hetzner-deprecation>
+  (description hetzner-server-type-description) ; string
+  (disk hetzner-server-type-disk) ; integer
+  (id hetzner-server-type-id) ; integer
+  (memory hetzner-server-type-memory) ; integer
+  (name hetzner-server-type-name) ; string
+  (storage-type hetzner-server-type-storage-type "storage_type")) ; string
+
+(define-json-mapping <hetzner-ssh-key>
+  make-hetzner-ssh-key hetzner-ssh-key? json->hetzner-ssh-key
+  (created hetzner-ssh-key-created "created" string->time) ; time
+  (fingerprint hetzner-ssh-key-fingerprint) ; string
+  (id hetzner-ssh-key-id) ; integer
+  (labels hetzner-ssh-key-labels) ; alist of string/string
+  (name hetzner-ssh-key-name) ; string
+  (public_key hetzner-ssh-key-public-key "public_key")) ; string
+
+(define (hetzner-server-architecture server)
+  "Return the architecture of the Hetzner SERVER."
+  (hetzner-server-type-architecture (hetzner-server-type server)))
+
+(define* (hetzner-server-path server #:optional (path ""))
+  "Return the PATH of the Hetzner SERVER."
+  (format #f "/servers/~a~a" (hetzner-server-id server) path))
+
+(define (hetzner-server-public-ipv4 server)
+  "Return the public IPv4 address of the SERVER."
+  (and-let* ((public-net (hetzner-server-public-net server))
+             (ipv4 (hetzner-public-net-ipv4 public-net)))
+    (hetzner-ipv4-ip ipv4)))
+
+(define (hetzner-server-system server)
+  "Return the Guix system architecture of the Hetzner SERVER."
+  (match (hetzner-server-architecture server)
+    ("arm" "aarch64-linux")
+    ("x86" "x86_64-linux")))
+
+(define* (hetzner-ssh-key-path ssh-key #:optional (path ""))
+  "Return the PATH of the Hetzner SSH-KEY."
+  (format #f "/ssh_keys/~a~a" (hetzner-ssh-key-id ssh-key) path))
+
+(define (hetzner-ssh-key-read-file file)
+  "Read the SSH private key from FILE and return a Hetzner SSH key."
+  (let* ((privkey (private-key-from-file file))
+         (pubkey (private-key->public-key privkey))
+         (hash (get-public-key-hash pubkey 'md5))
+         (fingerprint (bytevector->hex-string hash))
+         (public-key (format #f "ssh-~a ~a" (get-key-type pubkey)
+                             (public-key->string pubkey))))
+    (make-hetzner-ssh-key #f fingerprint #f '() (basename file) public-key)))
+
+
+;;;
+;;; Hetzner API response.
+;;;
+
+(define-record-type* <hetzner-api-response>
+  hetzner-api-response make-hetzner-api-response hetzner-api-response?
+  (body hetzner-api-response-body (default *unspecified*))
+  (headers hetzner-api-response-headers (default '()))
+  (status hetzner-api-response-status (default 200)))
+
+(define (hetzner-api-response-meta response)
+  "Return the meta information of the Hetzner API response."
+  (assoc-ref (hetzner-api-response-body response) "meta"))
+
+(define (hetzner-api-response-pagination response)
+  "Return the meta information of the Hetzner API response."
+  (assoc-ref (hetzner-api-response-meta response) "pagination"))
+
+(define (hetzner-api-response-pagination-combine resource responses)
+  "Combine multiple Hetzner API pagination responses into a single response."
+  (if (positive? (length responses))
+      (let* ((response (car responses))
+             (pagination (hetzner-api-response-pagination response))
+             (total-entries (assoc-ref pagination "total_entries")))
+        (hetzner-api-response
+         (inherit response)
+         (body `(("meta"
+                  ("pagination"
+                   ("last_page" . 1)
+                   ("next_page" . null)
+                   ("page" . 1)
+                   ("per_page" . ,total-entries)
+                   ("previous_page" . null)
+                   ("total_entries" . ,total-entries)))
+                 (,resource . ,(append-map
+                                (lambda (body)
+                                  (vector->list (assoc-ref body resource)))
+                                (map hetzner-api-response-body responses)))))))
+      (raise-exception
+       (formatted-message
+        (G_ "expected a list of Hetzner API responses")))))
+
+(define (hetzner-api-body-action body)
+  "Return the Hetzner API action from BODY."
+  (let ((json (assoc-ref body "action")))
+    (and json (json->hetzner-action json))))
+
+(define (hetzner-api-response-read port)
+  "Read the Hetzner API response from PORT."
+  (let* ((response (read-response port))
+         (body (read-response-body response)))
+    (hetzner-api-response
+     (body (and body (json-string->scm (utf8->string body))))
+     (headers (response-headers response))
+     (status (response-code response)))))
+
+(define (hetzner-api-response-validate-status response expected)
+  "Raise an error if the HTTP status code of RESPONSE is not in EXPECTED."
+  (when (not (member (hetzner-api-response-status response) expected))
+    (raise-exception
+     (formatted-message
+      (G_ "unexpected HTTP status code: ~a, expected: ~a~%~a")
+      (hetzner-api-response-status response)
+      expected
+      (with-output-to-string
+        (lambda ()
+          (pretty-print (hetzner-api-response-body response))))))))
+
+
+;;;
+;;; Hetzner API request.
+;;;
+
+(define-record-type* <hetzner-api-request>
+  hetzner-api-request make-hetzner-api-request hetzner-api-request?
+  (body hetzner-api-request-body (default *unspecified*))
+  (headers hetzner-api-request-headers (default '()))
+  (method hetzner-api-request-method (default 'GET))
+  (params hetzner-api-request-params (default '()))
+  (url hetzner-api-request-url))
+
+(define (hetzner-api-request-uri request)
+  "Return the URI object of the Hetzner API request."
+  (let ((params (hetzner-api-request-params request)))
+    (string->uri (string-append (hetzner-api-request-url request)
+                                (format-query-params params)))))
+
+(define (hetzner-api-request-body-bytevector request)
+  "Return the body of the Hetzner API REQUEST as a bytevector."
+  (let ((body (hetzner-api-request-body request)))
+    (string->utf8 (if (unspecified? body) "" (scm->json-string body)))))
+
+(define (hetzner-api-request-write port request)
+  "Write the Hetzner API REQUEST to PORT."
+  (let* ((body (hetzner-api-request-body-bytevector request))
+         (request (build-request
+                   (hetzner-api-request-uri request)
+                   #:method (hetzner-api-request-method request)
+                   #:version '(1 . 1)
+                   #:headers (cons* `(Content-Length
+                                      . ,(number->string
+                                          (if (unspecified? body)
+                                              0 (bytevector-length body))))
+                                    (hetzner-api-request-headers request))
+                   #:port port))
+         (request (write-request request port)))
+    (unless (unspecified? body)
+      (write-request-body request body))
+    (force-output (request-port request))))
+
+(define* (hetzner-api-request-send request #:key (expected (list 200 201 204)))
+  "Send the Hetzner API REQUEST via HTTP."
+  (let ((port (open-socket-for-uri (hetzner-api-request-uri request))))
+    (hetzner-api-request-write port request)
+    (let ((response (hetzner-api-response-read port)))
+      (close-port port)
+      (hetzner-api-response-validate-status response expected)
+      response)))
+
+;; Prevent compiler from inlining this function, so we can mock it in tests.
+(set! hetzner-api-request-send hetzner-api-request-send)
+
+(define (hetzner-api-request-next-params request)
+  "Return the pagination params for the next page of the REQUEST."
+  (let* ((params (hetzner-api-request-params request))
+         (page (or (assoc-ref params "page") 1)))
+    (map (lambda (param)
+           (if (equal? "page" (car param))
+               (cons (car param) (+ page 1))
+               param))
+         params)))
+
+(define (hetzner-api-request-paginate request)
+  "Fetch all pages of the REQUEST via pagination and return all responses."
+  (let* ((response (hetzner-api-request-send request))
+         (pagination (hetzner-api-response-pagination response))
+         (next-page (assoc-ref pagination "next_page")))
+    (if (number? next-page)
+        (cons response
+              (hetzner-api-request-paginate
+               (hetzner-api-request
+                (inherit request)
+                (params (hetzner-api-request-next-params request)))))
+        (list response))))
+
+
+
+;;;
+;;; Hetzner API.
+;;;
+
+(define-record-type* <hetzner-api>
+  hetzner-api make-hetzner-api hetzner-api?
+  (base-url hetzner-api-base-url ; string
+            (default "https://api.hetzner.cloud/v1"))
+  (token hetzner-api-token ; string
+         (default (%hetzner-default-api-token))))
+
+(define (hetzner-api-authorization-header api)
+  "Return the authorization header for the Hetzner API."
+  (format #f "Bearer ~a" (hetzner-api-token api)))
+
+(define (hetzner-api-default-headers api)
+  "Returns the default headers of the Hetzner API."
+  `((user-agent . "Guix Deploy")
+    (Accept . "application/json")
+    (Authorization . ,(hetzner-api-authorization-header api))
+    (Content-Type . "application/json")))
+
+(define (hetzner-api-url api path)
+  "Append PATH to the base url of the Hetzner API."
+  (string-append (hetzner-api-base-url api) path))
+
+(define (hetzner-api-delete api path)
+  "Delelte the resource at PATH with the Hetzner API."
+  (hetzner-api-response-body
+   (hetzner-api-request-send
+    (hetzner-api-request
+     (headers (hetzner-api-default-headers api))
+     (method 'DELETE)
+     (url (hetzner-api-url api path))))))
+
+(define* (hetzner-api-list api path resources json->object #:key (params '()))
+  "Fetch all objects of RESOURCE from the Hetzner API."
+  (let ((body (hetzner-api-response-body
+               (hetzner-api-response-pagination-combine
+                resources (hetzner-api-request-paginate
+                           (hetzner-api-request
+                            (url (hetzner-api-url api path))
+                            (headers (hetzner-api-default-headers api))
+                            (params (cons '("page" . 1) params))))))))
+    (map json->object (assoc-ref body resources))))
+
+(define* (hetzner-api-post api path #:key (body *unspecified*))
+  "Send a POST request to the Hetzner API at PATH using BODY."
+  (hetzner-api-response-body
+   (hetzner-api-request-send
+    (hetzner-api-request
+     (body body)
+     (method 'POST)
+     (url (hetzner-api-url api path))
+     (headers (hetzner-api-default-headers api))))))
+
+(define (hetzner-api-actions api ids)
+  "Get actions from the Hetzner API."
+  (if (zero? (length ids))
+      (raise-exception
+       (formatted-message
+        (G_ "expected at least one action id, but got '~a'")
+        (length ids)))
+      (hetzner-api-list
+       api "/actions" "actions" json->hetzner-action
+       #:params `(("id" . ,(string-join (map number->string ids) ","))))))
+
+(define* (hetzner-api-action-wait api action #:optional (status "success"))
+  "Wait until the ACTION has reached STATUS on the Hetzner API."
+  (let ((id (hetzner-action-id action)))
+    (let loop ()
+      (let ((actions (hetzner-api-actions api (list id))))
+        (cond
+         ((zero? (length actions))
+          (raise-exception
+           (formatted-message (G_ "server action '~a' not found") id)))
+         ((not (= 1 (length actions)))
+          (raise-exception
+           (formatted-message
+            (G_ "expected one server action, but got '~a'")
+            (length actions))))
+         ((string= status (hetzner-action-status (car actions)))
+          (car actions))
+         (else
+          (sleep 5)
+          (loop)))))))
+
+(define* (hetzner-api-locations api . options)
+  "Get deployment locations from the Hetzner API."
+  (apply hetzner-api-list api "/locations" "locations" json->hetzner-location options))
+
+(define* (hetzner-api-server-create
+          api name ssh-keys
+          #:key
+          (enable-ipv4? #t)
+          (enable-ipv6? #t)
+          (image %hetzner-default-server-image)
+          (labels '())
+          (location %hetzner-default-server-location)
+          (public-net #f)
+          (server-type %hetzner-default-server-type)
+          (start-after-create? #f))
+  "Create a server with the Hetzner API."
+  (let ((body (hetzner-api-post
+               api "/servers"
+               #:body `(("image" . ,image)
+                        ("labels" . ,labels)
+                        ("name" . ,name)
+                        ("public_net"
+                         . (("enable_ipv4" . ,enable-ipv4?)
+                            ("enable_ipv6" . ,enable-ipv6?)))
+                        ("location" . ,location)
+                        ("server_type" . ,server-type)
+                        ("ssh_keys" . ,(apply vector (map hetzner-ssh-key-id ssh-keys)))
+                        ("start_after_create" . ,start-after-create?)))))
+    (hetzner-api-action-wait api (hetzner-api-body-action body))
+    (json->hetzner-server (assoc-ref body "server"))))
+
+(define (hetzner-api-server-delete api server)
+  "Delete the SERVER with the Hetzner API."
+  (let ((body (hetzner-api-delete api (hetzner-server-path server))))
+    (hetzner-api-action-wait api (hetzner-api-body-action body))))
+
+(define* (hetzner-api-server-enable-rescue-system
+          api server ssh-keys #:key (type "linux64"))
+  "Enable the rescue system for SERVER with the Hetzner API."
+  (let* ((ssh-keys (apply vector (map hetzner-ssh-key-id ssh-keys)))
+         (body (hetzner-api-post
+                api (hetzner-server-path server "/actions/enable_rescue")
+                #:body `(("ssh_keys" . ,ssh-keys)
+                         ("type" . ,type)))))
+    (hetzner-api-action-wait api (hetzner-api-body-action body))))
+
+(define* (hetzner-api-servers api . options)
+  "Get servers from the Hetzner API."
+  (apply hetzner-api-list api "/servers" "servers" json->hetzner-server options))
+
+(define (hetzner-api-server-power-on api server)
+  "Send a power on request for SERVER to the Hetzner API."
+  (let ((body (hetzner-api-post api (hetzner-server-path server "/actions/poweron"))))
+    (hetzner-api-action-wait api (hetzner-api-body-action body))))
+
+(define (hetzner-api-server-power-off api server)
+  "Send a power off request for SERVER to the Hetzner API."
+  (let ((body (hetzner-api-post api (hetzner-server-path server "/actions/poweroff"))))
+    (hetzner-api-action-wait api (hetzner-api-body-action body))))
+
+(define (hetzner-api-server-reboot api server)
+  "Send a reboot request for SERVER to the Hetzner API."
+  (let ((body (hetzner-api-post api (hetzner-server-path server "/actions/reboot"))))
+    (hetzner-api-action-wait api (hetzner-api-body-action body))))
+
+(define* (hetzner-api-ssh-key-create api name public-key #:key (labels '()))
+  "Create a SSH key with the Hetzner API."
+  (let ((body (hetzner-api-post
+               api "/ssh_keys"
+               #:body `(("name" . ,name)
+                        ("public_key" . ,public-key)
+                        ("labels" . ,labels)))))
+    (json->hetzner-ssh-key (assoc-ref body "ssh_key"))))
+
+(define (hetzner-api-ssh-key-delete api ssh-key)
+  "Delete the SSH key on the Hetzner API."
+  (hetzner-api-delete api (hetzner-ssh-key-path ssh-key))
+  #t)
+
+(define* (hetzner-api-ssh-keys api . options)
+  "Get SSH keys from the Hetzner API."
+  (apply hetzner-api-list api "/ssh_keys" "ssh_keys"
+         json->hetzner-ssh-key options))
+
+(define* (hetzner-api-server-types api . options)
+  "Get server types from the Hetzner API."
+  (apply hetzner-api-list api "/server_types" "server_types"
+         json->hetzner-server-type options))
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index e37da506fc..d68fad4e8c 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -81,6 +81,8 @@ gnu/installer/steps.scm
 gnu/installer/timezone.scm
 gnu/installer/user.scm
 gnu/installer/utils.scm
+gnu/machine/hetzner.scm
+gnu/machine/hetzner/http.scm
 gnu/machine/ssh.scm
 gnu/packages/bootstrap.scm
 guix/build/utils.scm
diff --git a/tests/machine/hetzner.scm b/tests/machine/hetzner.scm
new file mode 100644
index 0000000000..39eac4a4d5
--- /dev/null
+++ b/tests/machine/hetzner.scm
@@ -0,0 +1,267 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Roman Scherer <roman <at> burningswell.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (tests machine hetzner)
+  #:use-module (gnu machine hetzner http)
+  #:use-module (gnu machine hetzner)
+  #:use-module (gnu machine ssh)
+  #:use-module (gnu machine)
+  #:use-module (gnu system)
+  #:use-module (guix build utils)
+  #:use-module (guix records)
+  #:use-module (guix ssh)
+  #:use-module (guix tests)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-64)
+  #:use-module (ssh key)
+  #:use-module (ssh session))
+
+;;; Unit and integration tests for the (gnu machine hetzner) module.
+
+;; Integration tests require the GUIX_HETZNER_API_TOKEN environment variable.
+;; https://docs.hetzner.com/cloud/api/getting-started/generating-api-token
+
+;; The integration tests sometimes fail due to the Hetzner API not being able
+;; to allocate a resource.  Switching to a different location might help.
+
+(define %labels
+  '(("guix.gnu.org/test" . "true")))
+
+(define %ssh-key-name
+  "guix-hetzner-machine-test-key")
+
+(define %ssh-key-file
+  (string-append "/tmp/" %ssh-key-name))
+
+(unless (file-exists? %ssh-key-file)
+  (private-key-to-file (make-keypair 'rsa 2048) %ssh-key-file))
+
+(define %when-no-token
+  (if (hetzner-api-token (hetzner-api)) 0 1))
+
+(define %arm-machine
+  (machine
+   (operating-system
+     (operating-system
+       (inherit %hetzner-os-arm)
+       (host-name "guix-deploy-hetzner-test-arm")))
+   (environment hetzner-environment-type)
+   (configuration (hetzner-configuration
+                   (labels %labels)
+                   (server-type "cax41")
+                   (ssh-key %ssh-key-file)))))
+
+(define %x86-machine
+  (machine
+   (operating-system
+     (operating-system
+       (inherit %hetzner-os-x86)
+       (host-name "guix-deploy-hetzner-test-x86")))
+   (environment hetzner-environment-type)
+   (configuration (hetzner-configuration
+                   (labels %labels)
+                   (server-type "cpx51")
+                   (ssh-key %ssh-key-file)))))
+
+(define (cleanup machine)
+  (let* ((config (machine-configuration machine))
+         (api (hetzner-configuration-api config)))
+    (for-each (lambda (server)
+                (hetzner-api-server-delete api server))
+              (hetzner-api-servers
+               api #:params `(("label_selector" . "guix.gnu.org/test=true"))))
+    (for-each (lambda (ssh-key)
+                (hetzner-api-ssh-key-delete api ssh-key))
+              (hetzner-api-ssh-keys
+               api #:params `(("label_selector" . "guix.gnu.org/test=true"))))
+    machine))
+
+(define-syntax-rule (with-cleanup (machine-sym machine-init) body ...)
+  (let ((machine-sym (cleanup machine-init)))
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        body ...)
+      (lambda ()
+        (cleanup machine-sym)))))
+
+(define (mock-action command)
+  (make-hetzner-action
+   command #f
+   (localtime (current-time))
+   1
+   100
+   '()
+   (localtime (current-time))
+   "success"))
+
+(define (mock-location machine)
+  (let* ((config (machine-configuration machine))
+         (name (hetzner-configuration-location config)))
+    (make-hetzner-location
+     "Falkenstein" "DE" "Falkenstein DC Park 1"
+     1 50.47612 12.370071 name "eu-central")))
+
+(define (mock-server-type machine)
+  (let* ((config (machine-configuration machine))
+         (name (hetzner-configuration-server-type config)))
+    (make-hetzner-server-type
+     "x86" 8 "shared" #f  #f (string-upcase name)
+     160 106 16 name "local")))
+
+(define (mock-server machine)
+  (let* ((config (machine-configuration machine))
+         (name (hetzner-configuration-location config)))
+    (make-hetzner-server
+     1
+     (localtime (current-time))
+     '()
+     (operating-system-host-name (machine-operating-system machine))
+     (make-hetzner-public-net
+      (make-hetzner-ipv4 #f "server.example.com" 1 "1.2.3.4")
+      (make-hetzner-ipv6 #f "server.example.com" 1 "2001:db8::1"))
+     #f
+     (mock-server-type machine))))
+
+(define (mock-ssh-key machine)
+  (let ((config (machine-configuration machine)))
+    (hetzner-ssh-key-read-file  (hetzner-configuration-ssh-key config))))
+
+(define (expected-ssh-machine? machine ssh-machine)
+  (let ((config (machine-configuration machine))
+        (ssh-config (machine-configuration ssh-machine)))
+    (and (equal? (hetzner-configuration-authorize? config)
+                 (machine-ssh-configuration-authorize? ssh-config))
+         (equal? (hetzner-configuration-allow-downgrades? config)
+                 (machine-ssh-configuration-allow-downgrades? ssh-config))
+         (equal? (hetzner-configuration-build-locally? config)
+                 (machine-ssh-configuration-build-locally? ssh-config))
+         (equal? (hetzner-server-public-ipv4 (mock-server machine))
+                 (machine-ssh-configuration-host-name ssh-config)))))
+
+(define-syntax mock*
+  (syntax-rules ()
+    ((mock* () body1 body2 ...)
+     (let () body1 body2 ...))
+    ((mock* ((mod1 sym1 fn1) (mod2 sym2 fn2) ...)
+            body1 body2 ...)
+     (mock (mod1 sym1 fn1)
+           (mock* ((mod2 sym2 fn2) ...)
+                  body1) body2 ...))))
+
+(test-begin "machine-hetzner")
+
+;; The following tests deploy real machines using the Hetzner API and shut
+;; them down afterwards.
+
+(test-skip %when-no-token)
+(test-assert "deploy-arm-machine"
+  (with-cleanup (machine %arm-machine)
+    (deploy-hetzner machine)))
+
+(test-skip %when-no-token)
+(test-assert "deploy-x86-machine"
+  (with-cleanup (machine %x86-machine)
+    (deploy-hetzner machine)))
+
+;; The following tests simulate a deployment, they mock out the actual calls
+;; to the Hetzner API.
+
+;; Note: In order for mocking to work, the Guile compiler should not inline
+;; the mocked functions. To prevent this it was necessary to set!
+;; hetzner-machine-ssh-run-script in (gnu machine hetzner) like this:
+
+;; (set! hetzner-machine-ssh-run-script hetzner-machine-ssh-run-script)
+
+(test-assert "deploy-machine-mock-with-provisioned-server"
+  (let ((machine (machine
+                  (operating-system %hetzner-os-x86)
+                  (environment hetzner-environment-type)
+                  (configuration (hetzner-configuration
+                                  (api (hetzner-api (token "mock")))
+                                  (ssh-key %ssh-key-file))))))
+    (mock* (((gnu machine hetzner http) hetzner-api-locations
+             (lambda* (api . options)
+               (list (mock-location machine))))
+            ((gnu machine hetzner http) hetzner-api-server-types
+             (lambda* (api . options)
+               (list (mock-server-type machine))))
+            ((gnu machine hetzner http) hetzner-api-ssh-keys
+             (lambda* (api . options)
+               (list (mock-ssh-key machine))))
+            ((gnu machine hetzner http) hetzner-api-servers
+             (lambda* (api . options)
+               (list (mock-server machine))))
+            ((gnu machine) deploy-machine
+             (lambda* (ssh-machine)
+               (expected-ssh-machine? machine ssh-machine))))
+           (deploy-hetzner machine))))
+
+(test-assert "deploy-machine-mock-with-unprovisioned-server"
+  (let ((machine (machine
+                  (operating-system %hetzner-os-x86)
+                  (environment hetzner-environment-type)
+                  (configuration (hetzner-configuration
+                                  (api (hetzner-api (token "mock")))
+                                  (ssh-key %ssh-key-file)))))
+        (servers '()))
+    (mock* (((gnu machine hetzner http) hetzner-api-locations
+             (lambda* (api . options)
+               (list (mock-location machine))))
+            ((gnu machine hetzner http) hetzner-api-server-types
+             (lambda* (api . options)
+               (list (mock-server-type machine))))
+            ((gnu machine hetzner http) hetzner-api-ssh-keys
+             (lambda* (api . options)
+               (list (mock-ssh-key machine))))
+            ((gnu machine hetzner http) hetzner-api-servers
+             (lambda* (api . options)
+               servers))
+            ((gnu machine hetzner http) hetzner-api-server-create
+             (lambda* (api name ssh-keys . options)
+               (set! servers (list (mock-server machine)))
+               (car servers)))
+            ((gnu machine hetzner http) hetzner-api-server-enable-rescue-system
+             (lambda (api server ssh-keys)
+               (mock-action "enable_rescue")))
+            ((gnu machine hetzner http) hetzner-api-server-power-on
+             (lambda (api server)
+               (mock-action "start_server")))
+            ((gnu machine hetzner) hetzner-machine-ssh-run-script
+             (lambda (ssh-session name content)
+               #t))
+            ((guix ssh) open-ssh-session
+             (lambda* (host . options)
+               (make-session #:host host)))
+            ((gnu machine hetzner http) hetzner-api-server-reboot
+             (lambda (api server)
+               (mock-action "reboot_server")))
+            ((ssh session) write-known-host!
+             (lambda (session)
+               #t))
+            ((gnu machine) deploy-machine
+             (lambda* (ssh-machine)
+               (expected-ssh-machine? machine ssh-machine))))
+           (deploy-hetzner machine))))
+
+(test-end "machine-hetzner")
+
+;; Local Variables:
+;; eval: (put 'with-cleanup 'scheme-indent-function 1)
+;; End:
diff --git a/tests/machine/hetzner/http.scm b/tests/machine/hetzner/http.scm
new file mode 100644
index 0000000000..618d9a4c94
--- /dev/null
+++ b/tests/machine/hetzner/http.scm
@@ -0,0 +1,631 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Roman Scherer <roman <at> burningswell.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (tests machine hetzner http)
+  #:use-module (debugging assert)
+  #:use-module (gnu machine hetzner http)
+  #:use-module (guix build utils)
+  #:use-module (guix tests)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-64)
+  #:use-module (ssh key))
+
+;; Unit and integration tests the (gnu machine hetzner http) module.
+
+;; Integration tests require the GUIX_HETZNER_API_TOKEN environment variable.
+;; https://docs.hetzner.com/cloud/api/getting-started/generating-api-token
+
+;; The integration tests sometimes fail due to the Hetzner API not being able
+;; to allocate a resource.  Switching to a different location might help.
+
+(define %labels
+  '(("guix.gnu.org/test" . "true")))
+
+(define %server-name
+  "guix-hetzner-api-test-server")
+
+(define %ssh-key-name
+  "guix-hetzner-api-test-key")
+
+(define %ssh-key-file
+  (string-append "/tmp/" %ssh-key-name))
+
+(unless (file-exists? %ssh-key-file)
+  (private-key-to-file (make-keypair 'rsa 2048) %ssh-key-file))
+
+(define %ssh-key
+  (hetzner-ssh-key-read-file %ssh-key-file))
+
+(define %when-no-token
+  (if (hetzner-api-token (hetzner-api)) 0 1))
+
+(define action-create-server
+  (make-hetzner-action
+   "create_server" #f *unspecified* 1896091819 0
+   (list (make-hetzner-resource 59570198 "server"))
+   #(0 17 11 2 1 125 0 32 -1 0 #f) "running"))
+
+(define action-create-server-alist
+  '(("command" . "create_server")
+    ("error" . null)
+    ("finished" . null)
+    ("id" . 1896091819)
+    ("progress" . 0)
+    ("resources" . #((("type" . "server") ("id" . 59570198))))
+    ("started" . "2025-02-02T11:17:00+00:00")
+    ("status" . "running")))
+
+(define action-delete-server
+  (make-hetzner-action
+   "delete_server" #f *unspecified* 1896091928 0
+   (list (make-hetzner-resource 59570198 "server"))
+   #(10 17 11 2 1 125 0 32 -1 0 #f) "running"))
+
+(define action-delete-server-alist
+  '(("command" . "delete_server")
+    ("error" . null)
+    ("finished" . null)
+    ("id" . 1896091928)
+    ("progress" . 0)
+    ("resources" . #((("type" . "server") ("id" . 59570198))))
+    ("started" . "2025-02-02T11:17:10+00:00")
+    ("status" . "running")))
+
+(define action-enable-rescue
+  (make-hetzner-action
+   "enable_rescue" #f  *unspecified* 1896091721 0
+   (list (make-hetzner-resource 59570198 "server"))
+   #(10 17 11 2 1 125 0 32 -1 0 #f) "success"))
+
+(define action-enable-rescue-alist
+  '(("command" . "enable_rescue")
+    ("error" . null)
+    ("finished" . null)
+    ("id" . 1896091721)
+    ("progress" . 0)
+    ("resources" . #((("type" . "server") ("id" . 59570198))))
+    ("started" . "2025-02-02T11:17:10+00:00")
+    ("status" . "running")))
+
+(define action-power-off
+  (make-hetzner-action
+   "stop_server" #f  *unspecified* 1896091721 0
+   (list (make-hetzner-resource 59570198 "server"))
+   #(10 17 11 2 1 125 0 32 -1 0 #f) "success"))
+
+(define action-power-off-alist
+  '(("command" . "stop_server")
+    ("error" . null)
+    ("finished" . null)
+    ("id" . 1896091721)
+    ("progress" . 0)
+    ("resources" . #((("type" . "server") ("id" . 59570198))))
+    ("started" . "2025-02-02T11:17:10+00:00")
+    ("status" . "running")))
+
+(define action-power-on
+  (make-hetzner-action
+   "start_server" #f  *unspecified* 1896091721 0
+   (list (make-hetzner-resource 59570198 "server"))
+   #(10 17 11 2 1 125 0 32 -1 0 #f) "success"))
+
+(define action-power-on-alist
+  '(("command" . "start_server")
+    ("error" . null)
+    ("finished" . null)
+    ("id" . 1896091721)
+    ("progress" . 0)
+    ("resources" . #((("type" . "server") ("id" . 59570198))))
+    ("started" . "2025-02-02T11:17:10+00:00")
+    ("status" . "running")))
+
+(define action-reboot
+  (make-hetzner-action
+   "reboot_server" #f  *unspecified* 1896091721 0
+   (list (make-hetzner-resource 59570198 "server"))
+   #(10 17 11 2 1 125 0 32 -1 0 #f) "success"))
+
+(define action-reboot-alist
+  '(("command" . "reboot_server")
+    ("error" . null)
+    ("finished" . null)
+    ("id" . 1896091721)
+    ("progress" . 0)
+    ("resources" . #((("type" . "server") ("id" . 59570198))))
+    ("started" . "2025-02-02T11:17:10+00:00")
+    ("status" . "running")))
+
+(define meta-page-alist
+  '("pagination"
+    ("last_page" . 1)
+    ("next_page" . null)
+    ("page" . 1)
+    ("per_page" . 25)
+    ("previous_page" . null)
+    ("total_entries" . 1)))
+
+(define location-falkenstein
+  (make-hetzner-location
+   "Falkenstein" "DE" "Falkenstein DC Park 1"
+   1 50.47612 12.370071 "fsn1" "eu-central"))
+
+(define location-falkenstein-alist
+  `(("city" . "Falkenstein")
+    ("country" . "DE")
+    ("description" . "Falkenstein DC Park 1")
+    ("id" . 1)
+    ("latitude" . 50.47612)
+    ("longitude" . 12.370071)
+    ("name" . "fsn1")
+    ("network_zone" . "eu-central")))
+
+(define server-type-cpx-11
+  (make-hetzner-server-type
+   "x86" 2 "shared" #f *unspecified*
+   "CPX 11" 40 22 2 "cpx11" "local"))
+
+(define server-type-cpx-11-alist
+  `(("architecture" . "x86")
+    ("cores" . 2)
+    ("cpu_type" . "shared")
+    ("deprecated" . #f)
+    ("deprecation" . null)
+    ("description" . "CPX 11")
+    ("disk" . 40)
+    ("id" . 22)
+    ("memory" . 2)
+    ("name" . "cpx11")
+    ("storage_type" . "local")))
+
+(define server-x86
+  (make-hetzner-server
+   "2024-12-30T16:38:11+00:00"
+   59570198
+   '()
+   "guix-x86"
+   (make-hetzner-public-net
+    (make-hetzner-ipv4 #f "static.218.128.13.49.clients.your-server.de" 78014457 "49.13.128.218")
+    (make-hetzner-ipv6 #f '() 78014458 "2a01:4f8:c17:293e::/64"))
+   #f
+   server-type-cpx-11))
+
+(define server-x86-alist
+  `(("backup_window" . null)
+    ("created" . "2024-12-30T16:38:11+00:00")
+    ("id" . 59570198)
+    ("included_traffic" . 21990232555520)
+    ("ingoing_traffic" . 124530000)
+    ("iso" . null)
+    ("labels")
+    ("load_balancers" . #())
+    ("locked" . #f)
+    ("name" . "guix-x86")
+    ("outgoing_traffic" . 1391250000)
+    ("placement_group" . null)
+    ("primary_disk_size" . 320)
+    ("private_net" . #())
+    ("protection" ("rebuild" . #f) ("delete" . #f))
+    ("public_net"
+     ("firewalls" . #())
+     ("floating_ips" . #())
+     ("ipv6"
+      ("id" . 78014458)
+      ("dns_ptr" . #())
+      ("blocked" . #f)
+      ("ip" . "2a01:4f8:c17:293e::/64"))
+     ("ipv4"
+      ("id" . 78014457)
+      ("dns_ptr" . "static.218.128.13.49.clients.your-server.de")
+      ("blocked" . #f)
+      ("ip" . "49.13.128.218")))
+    ("rescue_enabled" . #f)
+    ("server_type" ,@server-type-cpx-11-alist)
+    ("status" . "running")
+    ("volumes" . #())))
+
+(define ssh-key-root
+  (make-hetzner-ssh-key
+   #(55 2 19 28 9 123 6 300 -1 0 #f)
+   "8c:25:09:8f:37:0f:d8:f0:99:4e:ab:c7:5c:1b:c6:53"
+   16510983 '() "root <at> example.com"
+   "ssh-ed25519 ABCAC3NzaC1lZDI1NTE5AAAAIBT3lLYPfOZV9NNrNk0jGCufWmXbFSz+ORxowJdHoSIM"))
+
+(define ssh-key-root-alist
+  `(("created" . "2023-10-28T19:02:55+00:00")
+    ("fingerprint" . "8c:25:09:8f:37:0f:d8:f0:99:4e:ab:c7:5c:1b:c6:53")
+    ("id" . 16510983)
+    ("labels")
+    ("name" . "root <at> example.com")
+    ("public_key" . "ssh-ed25519 ABCAC3NzaC1lZDI1NTE5AAAAIBT3lLYPfOZV9NNrNk0jGCufWmXbFSz+ORxowJdHoSIM")))
+
+(define* (create-ssh-key api ssh-key #:key (labels %labels))
+  (hetzner-api-ssh-key-create
+   api
+   (hetzner-ssh-key-name ssh-key)
+   (hetzner-ssh-key-public-key ssh-key)
+   #:labels labels))
+
+(define* (create-server api ssh-key #:key (labels %labels))
+  (hetzner-api-server-create api %server-name (list ssh-key)
+                             #:labels labels
+                             #:server-type "cpx31"))
+
+(define (cleanup api)
+  (for-each (lambda (server)
+              (hetzner-api-server-delete api server))
+            (hetzner-api-servers
+             api #:params `(("label_selector" . "guix.gnu.org/test=true"))))
+  (for-each (lambda (ssh-key)
+              (hetzner-api-ssh-key-delete api ssh-key))
+            (hetzner-api-ssh-keys
+             api #:params `(("label_selector" . "guix.gnu.org/test=true"))))
+  api)
+
+(define-syntax-rule (with-cleanup-api (api-sym api-init) body ...)
+  (let ((api-sym (cleanup api-init)))
+    (dynamic-wind
+      (const #t)
+      (lambda ()
+        body ...)
+      (lambda ()
+        (cleanup api-sym)))))
+
+(test-begin "machine-hetzner-api")
+
+;; Unit Tests
+
+(test-equal "hetzner-api-actions-unit"
+  (list action-create-server action-delete-server)
+  (let ((actions (list action-create-server-alist action-delete-server-alist)))
+    (mock ((gnu machine hetzner http) hetzner-api-request-send
+           (lambda* (request #:key expected)
+             (assert (equal? 'GET (hetzner-api-request-method request)))
+             (assert (equal? "https://api.hetzner.cloud/v1/actions"
+                             (hetzner-api-request-url request)))
+             (assert (unspecified? (hetzner-api-request-body request)))
+             (assert (equal? `(("page" . 1)
+                               ("id" . ,(string-join
+                                         (map (lambda (action)
+                                                (number->string (assoc-ref action "id")))
+                                              actions)
+                                         ",")))
+                             (hetzner-api-request-params request)))
+             (hetzner-api-response
+              (body `(("meta" . ,meta-page-alist)
+                      ("actions" . #(,action-create-server-alist ,action-delete-server-alist)))))))
+          (hetzner-api-actions (hetzner-api)
+                               (map (lambda (action)
+                                      (assoc-ref action "id"))
+                                    actions)))))
+
+(test-equal "hetzner-api-locations-unit"
+  (list location-falkenstein)
+  (mock ((gnu machine hetzner http) hetzner-api-request-send
+         (lambda* (request #:key expected)
+           (assert (equal? 'GET (hetzner-api-request-method request)))
+           (assert (equal? "https://api.hetzner.cloud/v1/locations"
+                           (hetzner-api-request-url request)))
+           (assert (unspecified? (hetzner-api-request-body request)))
+           (assert (equal? '(("page" . 1)) (hetzner-api-request-params request)))
+           (hetzner-api-response
+            (body `(("meta" . ,meta-page-alist)
+                    ("locations" . #(,location-falkenstein-alist)))))))
+        (hetzner-api-locations (hetzner-api))))
+
+(test-equal "hetzner-api-server-types-unit"
+  (list server-type-cpx-11)
+  (mock ((gnu machine hetzner http) hetzner-api-request-send
+         (lambda* (request #:key expected)
+           (assert (equal? 'GET (hetzner-api-request-method request)))
+           (assert (equal? "https://api.hetzner.cloud/v1/server_types"
+                           (hetzner-api-request-url request)))
+           (assert (unspecified? (hetzner-api-request-body request)))
+           (assert (equal? '(("page" . 1)) (hetzner-api-request-params request)))
+           (hetzner-api-response
+            (body `(("meta" . ,meta-page-alist)
+                    ("server_types" . #(,server-type-cpx-11-alist)))))))
+        (hetzner-api-server-types (hetzner-api))))
+
+(test-equal "hetzner-api-server-create-unit"
+  server-x86
+  (mock ((gnu machine hetzner http) hetzner-api-request-send
+         (lambda* (request #:key expected)
+           (cond
+            ((equal? "https://api.hetzner.cloud/v1/servers"
+                     (hetzner-api-request-url request))
+             (assert (equal? 'POST (hetzner-api-request-method request)))
+             (hetzner-api-response
+              (body `(("action" . ,action-create-server-alist)
+                      ("server" . ,server-x86-alist)))))
+            ((equal? "https://api.hetzner.cloud/v1/actions"
+                     (hetzner-api-request-url request))
+             (assert (equal? 'GET (hetzner-api-request-method request)))
+             (hetzner-api-response
+              (body `(("actions" . ,(vector (cons `("status" . "success")
+                                                  action-create-server-alist)))
+                      ("meta" . ,meta-page-alist))))))))
+        (hetzner-api-server-create (hetzner-api) %server-name (list ssh-key-root))))
+
+(test-equal "hetzner-api-server-delete-unit"
+  (make-hetzner-action
+   "delete_server" #f *unspecified* 1896091928 0
+   (list (make-hetzner-resource 59570198 "server"))
+   #(10 17 11 2 1 125 0 32 -1 0 #f) "success")
+  (mock ((gnu machine hetzner http) hetzner-api-request-send
+         (lambda* (request #:key expected)
+           (cond
+            ((equal? "https://api.hetzner.cloud/v1/servers/59570198"
+                     (hetzner-api-request-url request))
+             (assert (equal? 'DELETE (hetzner-api-request-method request)))
+             (hetzner-api-response
+              (body `(("action" . ,action-delete-server-alist)))))
+            ((equal? "https://api.hetzner.cloud/v1/actions"
+                     (hetzner-api-request-url request))
+             (assert (equal? 'GET (hetzner-api-request-method request)))
+             (hetzner-api-response
+              (body `(("actions" . ,(vector (cons `("status" . "success")
+                                                  action-delete-server-alist)))
+                      ("meta" . ,meta-page-alist))))))))
+        (hetzner-api-server-delete (hetzner-api) server-x86)))
+
+(test-equal "hetzner-api-server-enable-rescue-system-unit"
+  action-enable-rescue
+  (mock ((gnu machine hetzner http) hetzner-api-request-send
+         (lambda* (request #:key expected)
+           (cond
+            ((equal? "https://api.hetzner.cloud/v1/servers/59570198/actions/enable_rescue"
+                     (hetzner-api-request-url request))
+             (assert (equal? 'POST (hetzner-api-request-method request)))
+             (hetzner-api-response
+              (body `(("action" . ,action-enable-rescue-alist)))))
+            ((equal? "https://api.hetzner.cloud/v1/actions"
+                     (hetzner-api-request-url request))
+             (assert (equal? 'GET (hetzner-api-request-method request)))
+             (hetzner-api-response
+              (body `(("actions" . ,(vector (cons `("status" . "success")
+                                                  action-enable-rescue-alist)))
+                      ("meta" . ,meta-page-alist))))))))
+        (hetzner-api-server-enable-rescue-system (hetzner-api) server-x86 (list ssh-key-root))))
+
+(test-equal "hetzner-api-server-power-on-unit"
+  action-power-on
+  (mock ((gnu machine hetzner http) hetzner-api-request-send
+         (lambda* (request #:key expected)
+           (cond
+            ((equal? "https://api.hetzner.cloud/v1/servers/59570198/actions/poweron"
+                     (hetzner-api-request-url request))
+             (assert (equal? 'POST (hetzner-api-request-method request)))
+             (hetzner-api-response
+              (body `(("action" . ,action-power-on-alist)))))
+            ((equal? "https://api.hetzner.cloud/v1/actions"
+                     (hetzner-api-request-url request))
+             (assert (equal? 'GET (hetzner-api-request-method request)))
+             (hetzner-api-response
+              (body `(("actions" . ,(vector (cons `("status" . "success")
+                                                  action-power-on-alist)))
+                      ("meta" . ,meta-page-alist))))))))
+        (hetzner-api-server-power-on (hetzner-api) server-x86)))
+
+(test-equal "hetzner-api-server-power-off-unit"
+  action-power-off
+  (mock ((gnu machine hetzner http) hetzner-api-request-send
+         (lambda* (request #:key expected)
+           (cond
+            ((equal? "https://api.hetzner.cloud/v1/servers/59570198/actions/poweroff"
+                     (hetzner-api-request-url request))
+             (assert (equal? 'POST (hetzner-api-request-method request)))
+             (hetzner-api-response
+              (body `(("action" . ,action-power-off-alist)))))
+            ((equal? "https://api.hetzner.cloud/v1/actions"
+                     (hetzner-api-request-url request))
+             (assert (equal? 'GET (hetzner-api-request-method request)))
+             (hetzner-api-response
+              (body `(("actions" . ,(vector (cons `("status" . "success")
+                                                  action-power-off-alist)))
+                      ("meta" . ,meta-page-alist))))))))
+        (hetzner-api-server-power-off (hetzner-api) server-x86)))
+
+(test-equal "hetzner-api-server-reboot-unit"
+  action-reboot
+  (mock ((gnu machine hetzner http) hetzner-api-request-send
+         (lambda* (request #:key expected)
+           (cond
+            ((equal? "https://api.hetzner.cloud/v1/servers/59570198/actions/reboot"
+                     (hetzner-api-request-url request))
+             (assert (equal? 'POST (hetzner-api-request-method request)))
+             (hetzner-api-response
+              (body `(("action" . ,action-reboot-alist)))))
+            ((equal? "https://api.hetzner.cloud/v1/actions"
+                     (hetzner-api-request-url request))
+             (assert (equal? 'GET (hetzner-api-request-method request)))
+             (hetzner-api-response
+              (body `(("actions" . ,(vector (cons `("status" . "success")
+                                                  action-reboot-alist)))
+                      ("meta" . ,meta-page-alist))))))))
+        (hetzner-api-server-reboot (hetzner-api) server-x86)))
+
+(test-equal "hetzner-api-servers-unit"
+  (list server-x86)
+  (mock ((gnu machine hetzner http) hetzner-api-request-send
+         (lambda* (request #:key expected)
+           (hetzner-api-response
+            (body `(("meta" . ,meta-page-alist)
+                    ("servers" . #(,server-x86-alist)))))))
+        (hetzner-api-servers (hetzner-api))))
+
+(test-equal "hetzner-api-ssh-key-create-unit"
+  ssh-key-root
+  (mock ((gnu machine hetzner http) hetzner-api-request-send
+         (lambda* (request #:key expected)
+           (assert (equal? 'POST (hetzner-api-request-method request)))
+           (assert (equal? "https://api.hetzner.cloud/v1/ssh_keys"
+                           (hetzner-api-request-url request)))
+           (assert (equal? `(("name" . "guix-hetzner-api-test-key")
+                             ("public_key" . "ssh-ed25519 ABCAC3NzaC1lZDI1NTE5AAAAIBT3lLYPfOZV9NNrNk0jGCufWmXbFSz+ORxowJdHoSIM")
+                             ("labels" . (("a" . "1"))))
+                           (hetzner-api-request-body request)))
+           (assert (equal? `() (hetzner-api-request-params request)))
+           (hetzner-api-response
+            (body `(("ssh_key" . ,ssh-key-root-alist))))))
+        (hetzner-api-ssh-key-create
+         (hetzner-api)
+         "guix-hetzner-api-test-key"
+         "ssh-ed25519 ABCAC3NzaC1lZDI1NTE5AAAAIBT3lLYPfOZV9NNrNk0jGCufWmXbFSz+ORxowJdHoSIM"
+         #:labels '(("a" . "1")))))
+
+(test-assert "hetzner-api-ssh-key-delete-unit"
+  (mock ((gnu machine hetzner http) hetzner-api-request-send
+         (lambda* (request #:key expected)
+           (assert (equal? "https://api.hetzner.cloud/v1/ssh_keys/16510983"
+                           (hetzner-api-request-url request)))
+           (assert (equal? 'DELETE (hetzner-api-request-method request)))
+           (hetzner-api-response)))
+        (hetzner-api-ssh-key-delete (hetzner-api) ssh-key-root)))
+
+(test-equal "hetzner-api-ssh-keys-unit"
+  (list ssh-key-root)
+  (mock ((gnu machine hetzner http) hetzner-api-request-send
+         (lambda* (request #:key expected)
+           (assert (equal? 'GET (hetzner-api-request-method request)))
+           (assert (equal? "https://api.hetzner.cloud/v1/ssh_keys"
+                           (hetzner-api-request-url request)))
+           (assert (unspecified? (hetzner-api-request-body request)))
+           (assert (equal? '(("page" . 1)) (hetzner-api-request-params request)))
+           (hetzner-api-response
+            (body `(("meta" . ,meta-page-alist)
+                    ("ssh_keys" . #(,ssh-key-root-alist)))))))
+        (hetzner-api-ssh-keys (hetzner-api))))
+
+;; Integration tests
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-actions-integration"
+  (with-cleanup-api (api (hetzner-api))
+    (let* ((ssh-key (create-ssh-key api %ssh-key))
+           (server (create-server api ssh-key))
+           (action (hetzner-api-server-enable-rescue-system api server (list ssh-key))))
+      (member action (hetzner-api-actions api (list (hetzner-action-id action)))))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-locations-integration"
+  (let ((locations (hetzner-api-locations (hetzner-api))))
+    (and (> (length locations) 0)
+         (every hetzner-location? locations))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-types-integration"
+  (let ((server-types (hetzner-api-server-types (hetzner-api))))
+    (and (> (length server-types) 0)
+         (every hetzner-server-type? server-types))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-create-integration"
+  (with-cleanup-api (api (hetzner-api))
+    (let* ((ssh-key (create-ssh-key api %ssh-key))
+           (server (create-server api ssh-key)))
+      (and (hetzner-server? server)
+           (equal? %server-name (hetzner-server-name server))))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-delete-integration"
+  (with-cleanup-api (api (hetzner-api))
+    (let* ((ssh-key (create-ssh-key api %ssh-key))
+           (server (create-server api ssh-key))
+           (action (hetzner-api-server-delete api server)))
+      (and (hetzner-action? action)
+           (equal? "delete_server"
+                   (hetzner-action-command action))))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-enable-rescue-system-integration"
+  (with-cleanup-api (api (hetzner-api))
+    (let* ((ssh-key (create-ssh-key api %ssh-key))
+           (server (create-server api ssh-key))
+           (action (hetzner-api-server-enable-rescue-system api server (list ssh-key))))
+      (and (hetzner-action? action)
+           (equal? "enable_rescue"
+                   (hetzner-action-command action))))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-power-on-integration"
+  (with-cleanup-api (api (hetzner-api))
+    (let* ((ssh-key (create-ssh-key api %ssh-key))
+           (server (create-server api ssh-key))
+           (action (hetzner-api-server-power-on api server)))
+      (and (hetzner-action? action)
+           (equal? "start_server"
+                   (hetzner-action-command action))))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-power-off-integration"
+  (with-cleanup-api (api (hetzner-api))
+    (let* ((ssh-key (create-ssh-key api %ssh-key))
+           (server (create-server api ssh-key))
+           (action (hetzner-api-server-power-off api server)))
+      (and (hetzner-action? action)
+           (equal? "stop_server"
+                   (hetzner-action-command action))))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-reboot-integration"
+  (with-cleanup-api (api (hetzner-api))
+    (let* ((ssh-key (create-ssh-key api %ssh-key))
+           (server (create-server api ssh-key))
+           (action (hetzner-api-server-reboot api server)))
+      (and (hetzner-action? action)
+           (equal? "reboot_server"
+                   (hetzner-action-command action))))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-servers-integration"
+  (with-cleanup-api (api (hetzner-api))
+    (let* ((ssh-key (create-ssh-key api %ssh-key))
+           (server (create-server api ssh-key)))
+      (member server (hetzner-api-servers api)))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-ssh-key-create-integration"
+  (with-cleanup-api (api (hetzner-api))
+    (let ((ssh-key (create-ssh-key api %ssh-key)))
+      (and (hetzner-ssh-key? ssh-key)
+           (equal? (hetzner-ssh-key-fingerprint %ssh-key)
+                   (hetzner-ssh-key-fingerprint ssh-key))
+           (equal? (hetzner-ssh-key-name %ssh-key)
+                   (hetzner-ssh-key-name ssh-key))
+           (equal? (hetzner-ssh-key-public-key %ssh-key)
+                   (hetzner-ssh-key-public-key ssh-key))))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-ssh-key-delete-integration"
+  (with-cleanup-api (api (hetzner-api))
+    (let ((ssh-key (create-ssh-key api %ssh-key)))
+      (and (equal? #t (hetzner-api-ssh-key-delete api ssh-key))
+           (not (member ssh-key (hetzner-api-ssh-keys api)))))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-ssh-keys-integration"
+  (with-cleanup-api (api (hetzner-api))
+    (let ((ssh-key (create-ssh-key api %ssh-key)))
+      (member ssh-key (hetzner-api-ssh-keys api)))))
+
+(test-end "machine-hetzner-api")
+
+;; Local Variables:
+;; eval: (put 'with-cleanup-api 'scheme-indent-function 1)
+;; End:
-- 
2.48.1

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

From: Roman Scherer <roman <at> burningswell.com>
To: Roman Scherer <roman <at> burningswell.com>
Cc: Josselin Poiret <dev <at> jpoiret.xyz>,
 Maxim Cournoyer <maxim.cournoyer <at> gmail.com>,
 Simon Tournier <zimon.toutoune <at> gmail.com>, Mathieu Othacehe <othacehe <at> gnu.org>,
 Ludovic Courtès <ludo <at> gnu.org>,
 Tobias Geerinckx-Rice <me <at> tobias.gr>, Christopher Baines <guix <at> cbaines.net>,
 75144 <at> debbugs.gnu.org
Subject: Re: [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
Date: Tue, 04 Feb 2025 20:10:53 +0100

[Message part 1 (text/plain, inline)]

References: <6ff52cb81582c81835e39beebc7e6f7f3ecfd81d.1735317980.git.roman <at> burningswell.com>
	<8734hi1mdh.fsf <at> gnu.org> <868qr6n3j9.fsf <at> burningswell.com>
	<87ed0rt3oz.fsf <at> burningswell.com> <87o6zt5bjs.fsf <at> gmail.com>
	<87tt9je0sr.fsf <at> burningswell.com> <87y0yvdxej.fsf <at> gnu.org>
	<867c6e90ei.fsf <at> burningswell.com>
User-Agent: mu4e 1.12.8; emacs 29.4
Hi Ludo,

I just sent v3 of the patch series in which I added test. There are now unit
and integration tests. You can run them with:

./pre-inst-env make check TESTS="tests/machine/hetzner/http.scm"
./pre-inst-env make check TESTS="tests/machine/hetzner.scm"

The integration tests require network access and the GUIX_HETZNER_API_TOKEN
environment variable to be set, otherwise they are skipped.

Can you have another look please?

And Christopher Baines, since Ludo mentioned you have a Hetzner account, would
you be interested in trying this out and provide some feedback?

Things to improve another day:

- Get Hetzner to add a Guix image to their collectin of supported images. That
would remove the need for using the rescue system to install an initial Guix system.

- Installing the initial Guix system via the rescue system is kind of slow
(especially if there are no substituyes), and done in sequence. I'm not sure
how this could be parallelized with how things are invoke by guix deploy.

Roman

Date: Tue, 04 Feb 2025 20:10:53 +0100

Roman Scherer <roman <at> burningswell.com> writes:

> Hi Ludo,
>
> that's what I was looking for. Now it is working as expected!
>
> I will send an updated patch soon.
>
> Thanks for your help!
>
> Roman
>
> Ludovic Courtès <ludo <at> gnu.org> writes:
>
>> Hi,
>>
>> Roman Scherer <roman <at> burningswell.com> skribis:
>>
>>> When I run the mocked test I expect no code from the (gnu machine
>>> hetzner http) module to be executed, since I mocked all those
>>> functions. This seems to work in the Geiser REPL, but for some reason it
>>> does not work when I run the test with:
>>>
>>> ./pre-inst-env make check TESTS="tests/machine/hetzner.scm"
>>>
>>> To me it looks like the mock function behaves differently in those 2
>>> situations. In the meaintime I also tried setting -O0, but that didn't
>>> make any difference either. :/
>>
>> Hmm.  I was going to say that the likely problem is that code from (gnu
>> machines hetzner http) gets inlined so you cannot really mock it.
>>
>> To make sure this can be mocked, you can use this trick:
>>
>>   (set! proc proc)
>>
>> where ‘proc’ is the procedure you want to mock (that statement prevents
>> the compiler from inlining it).
>>
>> Ludo’.

[signature.asc (application/pgp-signature, inline)]

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

From: Maxim Cournoyer <maxim.cournoyer <at> gmail.com>
To: Roman Scherer <roman <at> burningswell.com>
Cc: Josselin Poiret <dev <at> jpoiret.xyz>,
 Simon Tournier <zimon.toutoune <at> gmail.com>, Mathieu Othacehe <othacehe <at> gnu.org>,
 Ludovic Courtès <ludo <at> gnu.org>,
 Tobias Geerinckx-Rice <me <at> tobias.gr>, Christopher Baines <guix <at> cbaines.net>,
 75144 <at> debbugs.gnu.org
Subject: Re: [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
Date: Fri, 07 Feb 2025 21:45:33 +0900

Hi Roman,

Roman Scherer <roman <at> burningswell.com> writes:

[...]

> Things to improve another day:
>
> - Get Hetzner to add a Guix image to their collectin of supported images. That
> would remove the need for using the rescue system to install an initial Guix system.
>
> - Installing the initial Guix system via the rescue system is kind of slow
> (especially if there are no substituyes), and done in sequence. I'm not sure
> how this could be parallelized with how things are invoke by guix deploy.

Forgive my ignorance, but I thought the idea of a deploy <machine>
environment type was to allow fully provisioning the OS via the service
API?

I haven't reviewed the change yet; perhaps you mean that currently such
provision must happen by going through the rescue system path (but is
still automated by this new environment type?)

-- 
Thanks,
Maxim

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

From: Roman Scherer <roman <at> burningswell.com>
To: Maxim Cournoyer <maxim.cournoyer <at> gmail.com>
Cc: Josselin Poiret <dev <at> jpoiret.xyz>,
 Simon Tournier <zimon.toutoune <at> gmail.com>, Mathieu Othacehe <othacehe <at> gnu.org>,
 Ludovic Courtès <ludo <at> gnu.org>,
 Tobias Geerinckx-Rice <me <at> tobias.gr>, Roman Scherer <roman <at> burningswell.com>,
 Christopher Baines <guix <at> cbaines.net>, 75144 <at> debbugs.gnu.org
Subject: Re: [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
Date: Fri, 07 Feb 2025 14:00:37 +0100

[Message part 1 (text/plain, inline)]

Hi Maxim,

yes, it is fully automated. What happens is:

- a server is provisioned through the Hetzner API
- the the server is booted into the rescue system via the API
- partitions are setup in the rescue system (enlarged)
- a minimal Guix system is installed
- then the server re-booted, starting the minimal Guix system
- then the machine-ssh-environment takes over and applies the final system configuration
- this all is done once, when the server is initially provisioned

Previsouly I tried the guix-infect.sh approach that installs a Guix
system on top of a debian/ubuntu image, but I found this was very
brittle (issues with dns when you remove /etc, etc.). From my experience
working with this I found the approach with the rescue system both more
reliable and faster.

Does this mnake sense?

Roman

Maxim Cournoyer <maxim.cournoyer <at> gmail.com> writes:

> Hi Roman,
>
> Roman Scherer <roman <at> burningswell.com> writes:
>
> [...]
>
>> Things to improve another day:
>>
>> - Get Hetzner to add a Guix image to their collectin of supported images. That
>> would remove the need for using the rescue system to install an initial Guix system.
>>
>> - Installing the initial Guix system via the rescue system is kind of slow
>> (especially if there are no substituyes), and done in sequence. I'm not sure
>> how this could be parallelized with how things are invoke by guix deploy.
>
> Forgive my ignorance, but I thought the idea of a deploy <machine>
> environment type was to allow fully provisioning the OS via the service
> API?
>
> I haven't reviewed the change yet; perhaps you mean that currently such
> provision must happen by going through the rescue system path (but is
> still automated by this new environment type?)

[signature.asc (application/pgp-signature, inline)]

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

From: Maxim Cournoyer <maxim.cournoyer <at> gmail.com>
To: Roman Scherer <roman <at> burningswell.com>
Cc: Josselin Poiret <dev <at> jpoiret.xyz>,
 Simon Tournier <zimon.toutoune <at> gmail.com>, Mathieu Othacehe <othacehe <at> gnu.org>,
 Ludovic Courtès <ludo <at> gnu.org>,
 Tobias Geerinckx-Rice <me <at> tobias.gr>, Christopher Baines <guix <at> cbaines.net>,
 75144 <at> debbugs.gnu.org
Subject: Re: [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
Date: Fri, 07 Feb 2025 23:08:11 +0900

Hi Roman,

Roman Scherer <roman <at> burningswell.com> writes:

> Hi Maxim,
>
> yes, it is fully automated. What happens is:
>
> - a server is provisioned through the Hetzner API
> - the the server is booted into the rescue system via the API
> - partitions are setup in the rescue system (enlarged)
> - a minimal Guix system is installed
> - then the server re-booted, starting the minimal Guix system
> - then the machine-ssh-environment takes over and applies the final system configuration
> - this all is done once, when the server is initially provisioned
>
> Previsouly I tried the guix-infect.sh approach that installs a Guix
> system on top of a debian/ubuntu image, but I found this was very
> brittle (issues with dns when you remove /etc, etc.). From my experience
> working with this I found the approach with the rescue system both more
> reliable and faster.
>
> Does this mnake sense?

Thanks for the clear explanation, it makes a lot of sense and it's
awesome that you could automate all that!  It looks a lot like the
manual steps I had to go through to install Guix System on a cheap OVH
VPS [0].  It'd be fun to review if their API would allow automating all
that as what you did here for Hetzner.  The nice thing with OVH is that
they do not place any upper limit on the amount of bandwidth consumed
(no extra billing), and it's quite inexpensive (I currently pay less
than 2 CAD/month, although that's only for the first year -- after it's
similar to Hetzner, about 6 CAD/month IIRC).

[0]  https://lists.gnu.org/archive/html/help-guix/2024-08/msg00125.html

-- 
Thanks,
Maxim

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

From: Roman Scherer <roman <at> burningswell.com>
To: Maxim Cournoyer <maxim.cournoyer <at> gmail.com>
Cc: Josselin Poiret <dev <at> jpoiret.xyz>,
 Simon Tournier <zimon.toutoune <at> gmail.com>, Mathieu Othacehe <othacehe <at> gnu.org>,
 Ludovic Courtès <ludo <at> gnu.org>,
 Tobias Geerinckx-Rice <me <at> tobias.gr>, Roman Scherer <roman <at> burningswell.com>,
 Christopher Baines <guix <at> cbaines.net>, 75144 <at> debbugs.gnu.org
Subject: Re: [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
Date: Fri, 07 Feb 2025 17:58:40 +0100

[Message part 1 (text/plain, inline)]

Hi Maxim,

I'm not really familiar with the OVH rescue mode. But a quick search
showed up this:

https://support.us.ovhcloud.com/hc/en-us/articles/20041782509203-Activating-Rescue-Mode-on-a-Public-Cloud-Instance
https://eu.api.ovh.com/console/?section=%2Fcloud&branch=v1#post-/cloud/project/-serviceName-/instance/-instanceId-/rescueMode

So, if it works similar to the Hetzner rescue system, which I think it
does, and you can install guix on it (the package manager is enough) I
don't see why this approach should not work there as well.

Thanks, Roman

Maxim Cournoyer <maxim.cournoyer <at> gmail.com> writes:

> Hi Roman,
>
> Roman Scherer <roman <at> burningswell.com> writes:
>
>> Hi Maxim,
>>
>> yes, it is fully automated. What happens is:
>>
>> - a server is provisioned through the Hetzner API
>> - the the server is booted into the rescue system via the API
>> - partitions are setup in the rescue system (enlarged)
>> - a minimal Guix system is installed
>> - then the server re-booted, starting the minimal Guix system
>> - then the machine-ssh-environment takes over and applies the final system configuration
>> - this all is done once, when the server is initially provisioned
>>
>> Previsouly I tried the guix-infect.sh approach that installs a Guix
>> system on top of a debian/ubuntu image, but I found this was very
>> brittle (issues with dns when you remove /etc, etc.). From my experience
>> working with this I found the approach with the rescue system both more
>> reliable and faster.
>>
>> Does this mnake sense?
>
> Thanks for the clear explanation, it makes a lot of sense and it's
> awesome that you could automate all that!  It looks a lot like the
> manual steps I had to go through to install Guix System on a cheap OVH
> VPS [0].  It'd be fun to review if their API would allow automating all
> that as what you did here for Hetzner.  The nice thing with OVH is that
> they do not place any upper limit on the amount of bandwidth consumed
> (no extra billing), and it's quite inexpensive (I currently pay less
> than 2 CAD/month, although that's only for the first year -- after it's
> similar to Hetzner, about 6 CAD/month IIRC).
>
> [0]  https://lists.gnu.org/archive/html/help-guix/2024-08/msg00125.html

[signature.asc (application/pgp-signature, inline)]

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

From: Ludovic Courtès <ludo <at> gnu.org>
To: Roman Scherer <roman <at> burningswell.com>
Cc: Julien Lepiller <julien <at> lepiller.eu>,
 Maxim Cournoyer <maxim.cournoyer <at> gmail.com>,
 Florian Pelz <pelzflorian <at> pelzflorian.de>, 75144 <at> debbugs.gnu.org
Subject: Re: [bug#75144] [PATCH v3 2/2] machine: Implement
 'hetzner-environment-type'.
Date: Sun, 09 Feb 2025 17:45:07 +0100

Hello Roman,

Applied with the one-line change below.

I wasn’t able to run tests that require an API token because I don’t
have one (but I may well give that a try eventually); other tests went
well.

Feel free to submit an entry for ‘etc/news.scm’ (make sure to provide
enough context so users can tell whether this is something of interest
to them).  A blog post for guix.gnu.org/blog showing how you use it and
how it’s implemented would also be welcome if you feel so inclined!

Thanks for all the work!

Ludo’.

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

From: Roman Scherer <roman <at> burningswell.com>
To: Ludovic Courtès <ludo <at> gnu.org>
Cc: Julien Lepiller <julien <at> lepiller.eu>,
 Roman Scherer <roman <at> burningswell.com>,
 Maxim Cournoyer <maxim.cournoyer <at> gmail.com>,
 Florian Pelz <pelzflorian <at> pelzflorian.de>, 75144 <at> debbugs.gnu.org
Subject: Re: [bug#75144] [PATCH v3 2/2] machine: Implement
 'hetzner-environment-type'.
Date: Mon, 10 Feb 2025 21:09:32 +0100

[Message part 1 (text/plain, inline)]

Hi Ludo, and everyone still listening,

thanks for merging it and your help on this! I plan to submit a news
entry patch tomorrow.

I don't have the time for a blog post unfortunatly. Too busy with other
things at the moment, sorry. :/ Maybe another time.

Another feedback I wanted to mention. We should really aim to improve on
substitute availability and stability of Guix if we want people to rely
on Guix and `guix deploy`. I think this was also mentioned in the
survey.

While working on this the user experience of guix deploy really
shined/falled, depending on substitute availability and stability. I'm
probably biased and having bad luck with aarch-64 based Guix systems.

For example, using the ARM based servers (which are cheaper than x86)
with Guix on Hetzner can lead to a headache if you or the the servers
you deploy to start building Rust and friends. :/

I think we get there, thanks again, and happy hacking!

Roman

Ludovic Courtès <ludo <at> gnu.org> writes:

> Hello Roman,
>
> Applied with the one-line change below.
>
> I wasn’t able to run tests that require an API token because I don’t
> have one (but I may well give that a try eventually); other tests went
> well.
>
> Feel free to submit an entry for ‘etc/news.scm’ (make sure to provide
> enough context so users can tell whether this is something of interest
> to them).  A blog post for guix.gnu.org/blog showing how you use it and
> how it’s implemented would also be welcome if you feel so inclined!
>
> Thanks for all the work!
>
> Ludo’.

[signature.asc (application/pgp-signature, inline)]

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

From: Roman Scherer <roman <at> burningswell.com>
To: 75144 <at> debbugs.gnu.org
Cc: Roman Scherer <roman <at> burningswell.com>
Subject: [PATCH] news: Add entry for 'hetzner-environment-type'
Date: Tue, 11 Feb 2025 10:22:55 +0100

* etc/news.scm: Add entry.

Change-Id: I7d2575d8e69855516cbf4c3747a23c344890321a
---
 etc/news.scm | 18 ++++++++++++++++++
 1 file changed, 18 insertions(+)

diff --git a/etc/news.scm b/etc/news.scm
index dfc64d59cd..147972548c 100644
--- a/etc/news.scm
+++ b/etc/news.scm
@@ -27,6 +27,8 @@
 ;; Copyright © 2024 Zheng Junjie <873216071 <at> qq.com>
 ;; Copyright © 2024 Nicolas Graves <ngraves <at> ngraves.fr>
 ;; Copyright © 2024 Sebastian Dümcke <code <at> sam-d.com>
+;; Copyright © 2024 Roman Scherer <roman <at> burningswell.com>
+
 ;;
 ;; Copying and distribution of this file, with or without modification, are
 ;; permitted in any medium without royalty provided the copyright notice and
@@ -35,6 +37,22 @@
 (channel-news
  (version 0)
 
+ (entry (commit "0753a17ddf6f4fab98b93c25f1a93b97ff9e46bb")
+        (title
+         (en "The @command{guix deploy} command now supports the Hetzner Cloud
+service"))
+        (body
+         (en "In addition to deploying machines over SSH and on the Digital
+Ocean cloud service, the @command{guix deploy} command now supports deployment
+on the Hetzner Cloud service as well.  When deploying a machine with the new
+@code{hetzner-environment-type}, a @acronym{VPS, virtual private server} will
+be provisioned on the Hetzner Cloud, and the machine configuration's operating
+system will be installed on it.  Provisioning happens through the Hetzner
+Cloud API and you need to set the @code{GUIX_HETZNER_API_TOKEN} environment
+variable to a Hetzner Cloud API token.  Additionally, you can use the
+@code{hetzner-configuration} record to customize the deployment, such as the
+system architecture, type of VPS, etc.")))
+
   (entry (commit "616ae36e0f557cecb4abe58c5b0973b9428d25e0")
         (title
          (en "Kernel persistent storage in UEFI disabled"))

base-commit: d7ca62b15de7ef89c88ef9b1118d29481ca50122
-- 
2.48.1

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

From: Roman Scherer <roman <at> burningswell.com>
To: Roman Scherer <roman <at> burningswell.com>
Cc: Julien Lepiller <julien <at> lepiller.eu>,
 Ludovic Courtès <ludo <at> gnu.org>,
 Maxim Cournoyer <maxim.cournoyer <at> gmail.com>,
 Florian Pelz <pelzflorian <at> pelzflorian.de>, 75144 <at> debbugs.gnu.org
Subject: Re: [bug#75144] [PATCH v3 2/2] machine: Implement
 'hetzner-environment-type'.
Date: Tue, 11 Feb 2025 10:24:31 +0100

[Message part 1 (text/plain, inline)]

Hello,

I just send another patch for the news entry to this bug number.

Could someone please review it?

Thanks, Roman

Roman Scherer <roman <at> burningswell.com> writes:

> Hi Ludo, and everyone still listening,
>
> thanks for merging it and your help on this! I plan to submit a news
> entry patch tomorrow.
>
> I don't have the time for a blog post unfortunatly. Too busy with other
> things at the moment, sorry. :/ Maybe another time.
>
> Another feedback I wanted to mention. We should really aim to improve on
> substitute availability and stability of Guix if we want people to rely
> on Guix and `guix deploy`. I think this was also mentioned in the
> survey.
>
> While working on this the user experience of guix deploy really
> shined/falled, depending on substitute availability and stability. I'm
> probably biased and having bad luck with aarch-64 based Guix systems.
>
> For example, using the ARM based servers (which are cheaper than x86)
> with Guix on Hetzner can lead to a headache if you or the the servers
> you deploy to start building Rust and friends. :/
>
> I think we get there, thanks again, and happy hacking!
>
> Roman
>
> Ludovic Courtès <ludo <at> gnu.org> writes:
>
>> Hello Roman,
>>
>> Applied with the one-line change below.
>>
>> I wasn’t able to run tests that require an API token because I don’t
>> have one (but I may well give that a try eventually); other tests went
>> well.
>>
>> Feel free to submit an entry for ‘etc/news.scm’ (make sure to provide
>> enough context so users can tell whether this is something of interest
>> to them).  A blog post for guix.gnu.org/blog showing how you use it and
>> how it’s implemented would also be welcome if you feel so inclined!
>>
>> Thanks for all the work!
>>
>> Ludo’.

[signature.asc (application/pgp-signature, inline)]

Message #67 received at 75144-done <at> debbugs.gnu.org (full text, mbox):

From: "pelzflorian (Florian Pelz)" <pelzflorian <at> pelzflorian.de>
To: Roman Scherer <roman <at> burningswell.com>
Cc: Julien Lepiller <julien <at> lepiller.eu>,
 Maxim Cournoyer <maxim.cournoyer <at> gmail.com>,
 Ludovic Courtès <ludo <at> gnu.org>, 75144-done <at> debbugs.gnu.org
Subject: Re: [bug#75144] [PATCH] news: Add entry for 'hetzner-environment-type'
Date: Tue, 11 Feb 2025 15:37:53 +0100

Pushed the news as 0bf82b3fd5fcca2baef872ee06b40995cfbba7df
with an added German translation.

I set your copyright year to 2025, though.  I hope the 2024 you wrote
had been a typo.  Also I ended the commit message’s first line with a
period.

Hetzner support is exciting news, though I have no account there and
have not tested.

By the way I just had to build rust’s bootstrap chain, before I could
install Guix System on my new ARM machine with which I committed your
patch.  Board info for its RAM is not free software; maybe substitutes
are missing for lack of fast freedom-respecting ARM devices.

Regards,
Florian

Message #70 received at 75144-done <at> debbugs.gnu.org (full text, mbox):

From: Roman Scherer <roman <at> burningswell.com>
To: "pelzflorian (Florian Pelz)" <pelzflorian <at> pelzflorian.de>
Cc: Roman Scherer <roman <at> burningswell.com>,
 Maxim Cournoyer <maxim.cournoyer <at> gmail.com>,
 Ludovic Courtès <ludo <at> gnu.org>,
 Julien Lepiller <julien <at> lepiller.eu>, 75144-done <at> debbugs.gnu.org
Subject: Re: [bug#75144] [PATCH] news: Add entry for 'hetzner-environment-type'
Date: Tue, 11 Feb 2025 16:24:57 +0100

[Message part 1 (text/plain, inline)]

Hi Florian,

thanks for applying the patch!

"pelzflorian (Florian Pelz)" <pelzflorian <at> pelzflorian.de> writes:

> Pushed the news as 0bf82b3fd5fcca2baef872ee06b40995cfbba7df
> with an added German translation.
>
> I set your copyright year to 2025, though.  I hope the 2024 you wrote
> had been a typo.  Also I ended the commit message’s first line with a
> period.

Yes, it was a typo. I worked on this in 2024 and 2025. Thanks for fixing it.

> Hetzner support is exciting news, though I have no account there and
> have not tested.
>
> By the way I just had to build rust’s bootstrap chain, before I could
> install Guix System on my new ARM machine with which I committed your
> patch.  Board info for its RAM is not free software; maybe substitutes
> are missing for lack of fast freedom-respecting ARM devices.

Yes, I also ran into this multiple times. I also run my own substitute
server for my asahi guix channel on Hetzner. That helps a bit. I don't
have hard data on this, but my feeling is it builds the Gnome/KDE
desktops, and Rust bootstrap chain more reliable/faster than the Guix
infrastructure. But I might be wrong.

> Regards,
> Florian

[signature.asc (application/pgp-signature, inline)]

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

From: Ludovic Courtès <ludo <at> gnu.org>
To: Roman Scherer <roman <at> burningswell.com>
Cc: Julien Lepiller <julien <at> lepiller.eu>,
 Maxim Cournoyer <maxim.cournoyer <at> gmail.com>,
 Florian Pelz <pelzflorian <at> pelzflorian.de>, 75144 <at> debbugs.gnu.org
Subject: Re: [bug#75144] [PATCH v3 2/2] machine: Implement
 'hetzner-environment-type'.
Date: Fri, 21 Feb 2025 10:44:21 +0100

Hi,

Roman Scherer <roman <at> burningswell.com> skribis:

> While working on this the user experience of guix deploy really
> shined/falled, depending on substitute availability and stability. I'm
> probably biased and having bad luck with aarch-64 based Guix systems.
>
> For example, using the ARM based servers (which are cheaper than x86)
> with Guix on Hetzner can lead to a headache if you or the the servers
> you deploy to start building Rust and friends. :/

Yup, I agree.  bordeaux.guix used to have very high substitute
availability for aarch64, while ci.guix has always been lagging behind,
mostly because it’s underpowered in aarch64.  For a couple of months,
bordeaux.guix was also lagging behind on all architectures, but that
appears to be fixed now:

  https://qa.guix.gnu.org/branch/master

Ludo’.

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

From: Roman Scherer <roman <at> burningswell.com>
To: Ludovic Courtès <ludo <at> gnu.org>
Cc: Julien Lepiller <julien <at> lepiller.eu>,
 Roman Scherer <roman <at> burningswell.com>,
 Maxim Cournoyer <maxim.cournoyer <at> gmail.com>,
 Florian Pelz <pelzflorian <at> pelzflorian.de>, 75144 <at> debbugs.gnu.org
Subject: Re: [bug#75144] [PATCH v3 2/2] machine: Implement
 'hetzner-environment-type'.
Date: Fri, 21 Feb 2025 22:21:57 +0100

[Message part 1 (text/plain, inline)]

Hi Ludo,

thanks for the insights. It's great bordeaux catched up again.

Roman

Ludovic Courtès <ludo <at> gnu.org> writes:

> Hi,
>
> Roman Scherer <roman <at> burningswell.com> skribis:
>
>> While working on this the user experience of guix deploy really
>> shined/falled, depending on substitute availability and stability. I'm
>> probably biased and having bad luck with aarch-64 based Guix systems.
>>
>> For example, using the ARM based servers (which are cheaper than x86)
>> with Guix on Hetzner can lead to a headache if you or the the servers
>> you deploy to start building Rust and friends. :/
>
> Yup, I agree.  bordeaux.guix used to have very high substitute
> availability for aarch64, while ci.guix has always been lagging behind,
> mostly because it’s underpowered in aarch64.  For a couple of months,
> bordeaux.guix was also lagging behind on all architectures, but that
> appears to be fixed now:
>
>   https://qa.guix.gnu.org/branch/master
>
> Ludo’.

[signature.asc (application/pgp-signature, inline)]

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

From: Sergey Trofimov <sarg <at> sarg.org.ru>
To: Roman Scherer <roman <at> burningswell.com>
Cc: Josselin Poiret <dev <at> jpoiret.xyz>,
 Maxim Cournoyer <maxim.cournoyer <at> gmail.com>,
 Simon Tournier <zimon.toutoune <at> gmail.com>, Mathieu Othacehe <othacehe <at> gnu.org>,
 Ludovic Court?s <ludo <at> gnu.org>, Tobias Geerinckx-Rice <me <at> tobias.gr>,
 Christopher Baines <guix <at> cbaines.net>, 75144 <at> debbugs.gnu.org
Subject: Re: [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
Date: Thu, 13 Mar 2025 11:07:50 +0100

Hi Roman,

Roman Scherer <roman <at> burningswell.com> writes:

> * gnu/machine/hetzner.scm: New file.
> * gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
> * guix/ssh.scm (open-ssh-session): Add stricthostkeycheck option.
> * doc/guix.texi (Invoking guix deploy): Add documentation for
> 'hetzner-configuration'.
>

That's a very welcome change and I'm glad it is merged already. I've
given it a try and stumbled upon some errors. See them below.

I started with the minimal configuration similar to the example from docs.
--8<---------------cut here---------------start------------->8---
(hetzner-configuration
    (server-type "cax11")
    (location "hel1")
    (ssh-key ".../id_rsa"))
--8<---------------cut here---------------end--------------->8---

Deploying it worked only half-way - the server got created, but
deploying actual OS failed due to my host (x86_64) not able to build
derivations for aarch64-linux.

This one I fixed by adding `qemu-binfmt-service-type` to my system config.
Second deployment attempt picked up the work (that's nice!) and started
building the derivations. After about 40 minutes I'd aborted it,
although I'm pretty sure it would've completed successfully. I just
didn't want to wait too long.

Next I've addded `(build-locally? #f)` to the VM config and repeated the
deployment. This one progressed much quicker, however it failed while
building `linux-modules`:

--8<---------------cut here---------------start------------->8---
building path(s) `/gnu/store/lsa1716vbccxf9flpnzbfqzbm9rh4ljl-linux-modules'
Backtrace:
          18 (primitive-load "/gnu/store/mfk843zl41s21banhzwkyfdxapa?")
In ice-9/eval.scm:
    619:8 17 (_ #f)
   626:19 16 (_ #<directory (guile-user) fffff771ec80>)
   293:34 15 (_ #(#<directory (guile-user) fffff771ec80> #<procedu?>))
In srfi/srfi-1.scm:
   586:29 14 (map1 _)
   586:29 13 (map1 _)
   586:29 12 (map1 _)
   586:29 11 (map1 _)
   586:29 10 (map1 _)
   586:29  9 (map1 _)
   586:29  8 (map1 _)
   586:29  7 (map1 _)
   586:29  6 (map1 _)
   586:29  5 (map1 _)
   586:29  4 (map1 _)
   586:29  3 (map1 _)
   586:29  2 (map1 _)
   586:17  1 (map1 ("pata_acpi" "pata_atiixp" "isci" "virtio_pci" # ?))
In gnu/build/linux-modules.scm:
    278:5  0 (_)

gnu/build/linux-modules.scm:278:5: kernel module not found "pata_acpi" "/gnu/store/nh5icvr5qvlaq1y54gpkqndy0rv2cq9r-linux-libre-6.13.6/lib/modules"
--8<---------------cut here---------------end--------------->8---

This seem to be caused by `deploy` not supporting `--target` parameter.
Adding these looked simple and I've jotted a small patch:

--8<---------------cut here---------------start------------->8---
From 0d438d2fadc95fbe2eca73fc3c7f4278d58829d7 Mon Sep 17 00:00:00 2001
Message-ID: <0d438d2fadc95fbe2eca73fc3c7f4278d58829d7.1741858564.git.sarg <at> sarg.org.ru>
From: Sergey Trofimov <sarg <at> sarg.org.ru>
Subject: [PATCH] Support --target and --system in guix deploy

---
 guix/scripts/deploy.scm | 28 +++++++++++++++++++---------
 1 file changed, 19 insertions(+), 9 deletions(-)

diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index e2ef0006e0..5b6c6b8e79 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -26,6 +26,7 @@ (define-module (guix scripts deploy)
   #:use-module (guix scripts)
   #:use-module (guix scripts build)
   #:use-module (guix store)
+  #:use-module (guix utils)
   #:use-module (guix gexp)
   #:use-module (guix ui)
   #:use-module ((guix status) #:select (with-status-verbosity))
@@ -93,21 +94,22 @@ (define %options
          (option '(#\x "execute") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'execute-command? #t result)))
-         (option '(#\s "system") #t #f
-                 (lambda (opt name arg result)
-                   (alist-cons 'system arg
-                               (alist-delete 'system result eq?))))
          (option '(#\v "verbosity") #t #f
                  (lambda (opt name arg result)
                    (let ((level (string->number* arg)))
                      (alist-cons 'verbosity level
                                  (alist-delete 'verbosity result)))))

-         %standard-build-options))
+         (append
+          %standard-build-options
+          %standard-native-build-options
+          %standard-cross-build-options)))

 (define %default-options
   ;; Alist of default option values.
   `((verbosity . 1)
+    (system . ,(%current-system))
+    (target . #f)
     (debug . 0)
     (graft? . #t)
     (substitutes? . #t)
@@ -186,9 +188,13 @@ (define (deploy-machine* store machine)
             (when (deploy-error-should-roll-back c)
               (info (G_ "rolling back ~a...~%")
                     (machine-display-name machine))
-              (run-with-store store (roll-back-machine machine)))
+              (run-with-store store (roll-back-machine machine)
+                              #:system (%current-system)
+                              #:target (%current-target-system)))
             (apply throw (deploy-error-captured-args c))))
-      (run-with-store store (deploy-machine machine))
+      (run-with-store store (deploy-machine machine)
+           #:system (%current-system)
+           #:target (%current-target-system))

     (info (G_ "successfully deployed ~a~%")
           (machine-display-name machine))))
@@ -266,7 +272,9 @@ (define (invoke-command store machine command)
                (loop (cons line lines))))))))

   (match (run-with-store store
-           (machine-remote-eval machine invocation))
+           (machine-remote-eval machine invocation)
+           #:system (%current-system)
+           #:target (%current-target-system))
     ((code output)
      (match code
        ((? zero?)
@@ -325,7 +333,9 @@ (define-command (guix-deploy . args)
                                               #:verbosity
                                               (assoc-ref opts 'verbosity)
                                               #:dry-run? dry-run?)
-            (parameterize ((%graft? (assq-ref opts 'graft?)))
+            (parameterize ((%graft? (assq-ref opts 'graft?))
+                           (%current-target-system (assoc-ref opts 'target))
+                           (%current-system (assoc-ref opts 'system)))
               (if execute-command?
                   (match command
                     (("--" command ..1)

base-commit: 9449ab3c2025820d2e6fd679fa7e34832b667ea7
--
2.48.1

--8<---------------cut here---------------end--------------->8---

I wasn't able to confirm the patch works as during the deployment it
tries to build the toolchain which I can't afford on my host:

--8<---------------cut here---------------start------------->8---
The following derivations will be built:
  /gnu/store/gxr8v1yisdiyndka0abxrc0xzrra66sv-binutils-cross-aarch64-linux-gnu-2.41.drv
  /gnu/store/lch3711iiczn6smxsr7r3sj991p8avwv-ld-wrapper-aarch64-linux-gnu-0.drv
  /gnu/store/zmsnlbyml0vmphfdxyxw4ps25bgrwz92-gcc-cross-sans-libc-aarch64-linux-gnu-14.2.0.drv
  /gnu/store/57jnlmvqlvk6jkyvqcnrk4psffhmak91-linux-libre-headers-cross-aarch64-linux-gnu-5.15.49.drv
  /gnu/store/b4f1my595ggl7d5qn46vr6qllwx7g49z-glibc-cross-aarch64-linux-gnu-2.39.drv
  /gnu/store/sl5vfnwdarghf9ypbspq1bdlamnz3j2a-gcc-cross-aarch64-linux-gnu-14.2.0.drv
  /gnu/store/3vp8a7mz1576xbk278k9b73nx2zqmzlw-libffi-3.4.4.drv
  /gnu/store/5ij0pv5z7mi25r397y4k62ma7q38qrka-pkg-config-aarch64-linux-gnu-0.29.2.drv
  /gnu/store/y3hqwsbc8rb2g1mac8c9vsdmaacf20xm-libatomic-ops-7.6.12.drv
  /gnu/store/bd09d178ni5sp9db62w869c6m7d3sh6v-libgc-8.2.4.drv
  /gnu/store/cs7mzhrypgdad8v0v29arafc8brl7ynd-bash-minimal-5.1.16.drv
  /gnu/store/np51g0ak713az6shj6sv9j3wkq4cjvjx-libunistring-1.1.drv
  /gnu/store/rbkb4ig158h9gblbrah5nx5annvfpb4q-libxcrypt-4.4.36.drv
  /gnu/store/lfmamfv5vx690l9n6a1ixbbk6kzw3gsr-guile-3.0.9.drv
--8<---------------cut here---------------end--------------->8---

Finally, I want to highlight a couple things that I haven't figured out
for my use-case yet:
1. My private ssh key is stored in GnuPG and I'd like to keep it that
way. Afaik `managed-host-environment-type` can utilise the running
ssh-agent, could it be also implemented for hetzner machines?

2. My use-case is an on-demand wireguard VPN. In my current setup I have
created a static ipv6 address which I attach to the VM created using
`hcloud`. The wireguard config hardcodes the same ipv6 and is installed
on the VM during cloud-init provision (`--user-data-from-file`
parameter). To replicate the same in guix deploy,
`hetzner-configuration` should be more flexible in regards to public ip
addresses. I.e. it should allow to use either v4 or v6 and to accept
existing one provided by the user.

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

From: Roman Scherer <roman <at> burningswell.com>
To: Sergey Trofimov <sarg <at> sarg.org.ru>
Cc: Roman Scherer <roman <at> burningswell.com>,
 Maxim Cournoyer <maxim.cournoyer <at> gmail.com>,
 Simon Tournier <zimon.toutoune <at> gmail.com>, Mathieu Othacehe <othacehe <at> gnu.org>,
 Ludovic Court?s <ludo <at> gnu.org>, Tobias Geerinckx-Rice <me <at> tobias.gr>,
 Josselin Poiret <dev <at> jpoiret.xyz>, Christopher Baines <guix <at> cbaines.net>,
 75144 <at> debbugs.gnu.org
Subject: Re: [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
Date: Fri, 14 Mar 2025 13:28:45 +0100

[Message part 1 (text/plain, inline)]

Sergey Trofimov <sarg <at> sarg.org.ru> writes:

Hi Sergey,

thanks for trying this out and your feedback.

> Hi Roman,
>
> Roman Scherer <roman <at> burningswell.com> writes:
>
> > * gnu/machine/hetzner.scm: New file.
> > * gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
> > * guix/ssh.scm (open-ssh-session): Add stricthostkeycheck option.
> > * doc/guix.texi (Invoking guix deploy): Add documentation for
> > 'hetzner-configuration'.
> >
>
> That's a very welcome change and I'm glad it is merged already. I've
> given it a try and stumbled upon some errors. See them below.
>
> I started with the minimal configuration similar to the example from docs.
> --8<---------------cut here---------------start------------->8---
> (hetzner-configuration
>     (server-type "cax11")
>     (location "hel1")
>     (ssh-key ".../id_rsa"))
> --8<---------------cut here---------------end--------------->8---
>
> Deploying it worked only half-way - the server got created, but
> deploying actual OS failed due to my host (x86_64) not able to build
> derivations for aarch64-linux.

You need some way to be able to build for the target
architecture. qemu-binfmt-service-type is one solution to it, I
personally use offloading, since I have machines with different
architectures available.

> This one I fixed by adding `qemu-binfmt-service-type` to my system config.
> Second deployment attempt picked up the work (that's nice!) and started
> building the derivations. After about 40 minutes I'd aborted it,
> although I'm pretty sure it would've completed successfully. I just
> didn't want to wait too long.

I also have seen these long deploy times. You probably run into a
situation where substitutes were not available for the thing you are
deploying. It's a know issue with aarch64.

> Next I've addded `(build-locally? #f)` to the VM config and repeated the
> deployment. This one progressed much quicker, however it failed while
> building `linux-modules`:

I usually had the best experience with build-locally? set to #t, since
for further deploys I have the build artifacts in my local store, and
not have to build them again and again on the servers I'm deploying to.

> --8<---------------cut here---------------start------------->8---
> building path(s) `/gnu/store/lsa1716vbccxf9flpnzbfqzbm9rh4ljl-linux-modules'
> Backtrace:
>           18 (primitive-load "/gnu/store/mfk843zl41s21banhzwkyfdxapa?")
> In ice-9/eval.scm:
>     619:8 17 (_ #f)
>    626:19 16 (_ #<directory (guile-user) fffff771ec80>)
>    293:34 15 (_ #(#<directory (guile-user) fffff771ec80> #<procedu?>))
> In srfi/srfi-1.scm:
>    586:29 14 (map1 _)
>    586:29 13 (map1 _)
>    586:29 12 (map1 _)
>    586:29 11 (map1 _)
>    586:29 10 (map1 _)
>    586:29  9 (map1 _)
>    586:29  8 (map1 _)
>    586:29  7 (map1 _)
>    586:29  6 (map1 _)
>    586:29  5 (map1 _)
>    586:29  4 (map1 _)
>    586:29  3 (map1 _)
>    586:29  2 (map1 _)
>    586:17  1 (map1 ("pata_acpi" "pata_atiixp" "isci" "virtio_pci" # ?))
> In gnu/build/linux-modules.scm:
>     278:5  0 (_)
>
> gnu/build/linux-modules.scm:278:5: kernel module not found "pata_acpi" "/gnu/store/nh5icvr5qvlaq1y54gpkqndy0rv2cq9r-linux-libre-6.13.6/lib/modules"
> --8<---------------cut here---------------end--------------->8---
>
> This seem to be caused by `deploy` not supporting `--target` parameter.
> Adding these looked simple and I've jotted a small patch:
>

Nice! Do you plan to submit this as a patch, once you got it working?

> --8<---------------cut here---------------start------------->8---
> From 0d438d2fadc95fbe2eca73fc3c7f4278d58829d7 Mon Sep 17 00:00:00 2001
> Message-ID: <0d438d2fadc95fbe2eca73fc3c7f4278d58829d7.1741858564.git.sarg <at> sarg.org.ru>
> From: Sergey Trofimov <sarg <at> sarg.org.ru>
> Subject: [PATCH] Support --target and --system in guix deploy
>
> ---
>  guix/scripts/deploy.scm | 28 +++++++++++++++++++---------
>  1 file changed, 19 insertions(+), 9 deletions(-)
>
> diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
> index e2ef0006e0..5b6c6b8e79 100644
> --- a/guix/scripts/deploy.scm
> +++ b/guix/scripts/deploy.scm
> @@ -26,6 +26,7 @@ (define-module (guix scripts deploy)
>    #:use-module (guix scripts)
>    #:use-module (guix scripts build)
>    #:use-module (guix store)
> +  #:use-module (guix utils)
>    #:use-module (guix gexp)
>    #:use-module (guix ui)
>    #:use-module ((guix status) #:select (with-status-verbosity))
> @@ -93,21 +94,22 @@ (define %options
>           (option '(#\x "execute") #f #f
>                   (lambda (opt name arg result)
>                     (alist-cons 'execute-command? #t result)))
> -         (option '(#\s "system") #t #f
> -                 (lambda (opt name arg result)
> -                   (alist-cons 'system arg
> -                               (alist-delete 'system result eq?))))
>           (option '(#\v "verbosity") #t #f
>                   (lambda (opt name arg result)
>                     (let ((level (string->number* arg)))
>                       (alist-cons 'verbosity level
>                                   (alist-delete 'verbosity result)))))
>
> -         %standard-build-options))
> +         (append
> +          %standard-build-options
> +          %standard-native-build-options
> +          %standard-cross-build-options)))
>
>  (define %default-options
>    ;; Alist of default option values.
>    `((verbosity . 1)
> +    (system . ,(%current-system))
> +    (target . #f)
>      (debug . 0)
>      (graft? . #t)
>      (substitutes? . #t)
> @@ -186,9 +188,13 @@ (define (deploy-machine* store machine)
>              (when (deploy-error-should-roll-back c)
>                (info (G_ "rolling back ~a...~%")
>                      (machine-display-name machine))
> -              (run-with-store store (roll-back-machine machine)))
> +              (run-with-store store (roll-back-machine machine)
> +                              #:system (%current-system)
> +                              #:target (%current-target-system)))
>              (apply throw (deploy-error-captured-args c))))
> -      (run-with-store store (deploy-machine machine))
> +      (run-with-store store (deploy-machine machine)
> +           #:system (%current-system)
> +           #:target (%current-target-system))
>
>      (info (G_ "successfully deployed ~a~%")
>            (machine-display-name machine))))
> @@ -266,7 +272,9 @@ (define (invoke-command store machine command)
>                 (loop (cons line lines))))))))
>
>    (match (run-with-store store
> -           (machine-remote-eval machine invocation))
> +           (machine-remote-eval machine invocation)
> +           #:system (%current-system)
> +           #:target (%current-target-system))
>      ((code output)
>       (match code
>         ((? zero?)
> @@ -325,7 +333,9 @@ (define-command (guix-deploy . args)
>                                                #:verbosity
>                                                (assoc-ref opts 'verbosity)
>                                                #:dry-run? dry-run?)
> -            (parameterize ((%graft? (assq-ref opts 'graft?)))
> +            (parameterize ((%graft? (assq-ref opts 'graft?))
> +                           (%current-target-system (assoc-ref opts 'target))
> +                           (%current-system (assoc-ref opts 'system)))
>                (if execute-command?
>                    (match command
>                      (("--" command ..1)
>
> base-commit: 9449ab3c2025820d2e6fd679fa7e34832b667ea7
> --
> 2.48.1
>
> --8<---------------cut here---------------end--------------->8---
>
> I wasn't able to confirm the patch works as during the deployment it
> tries to build the toolchain which I can't afford on my host:
>
> --8<---------------cut here---------------start------------->8---
> The following derivations will be built:
>   /gnu/store/gxr8v1yisdiyndka0abxrc0xzrra66sv-binutils-cross-aarch64-linux-gnu-2.41.drv
>   /gnu/store/lch3711iiczn6smxsr7r3sj991p8avwv-ld-wrapper-aarch64-linux-gnu-0.drv
>   /gnu/store/zmsnlbyml0vmphfdxyxw4ps25bgrwz92-gcc-cross-sans-libc-aarch64-linux-gnu-14.2.0.drv
>   /gnu/store/57jnlmvqlvk6jkyvqcnrk4psffhmak91-linux-libre-headers-cross-aarch64-linux-gnu-5.15.49.drv
>   /gnu/store/b4f1my595ggl7d5qn46vr6qllwx7g49z-glibc-cross-aarch64-linux-gnu-2.39.drv
>   /gnu/store/sl5vfnwdarghf9ypbspq1bdlamnz3j2a-gcc-cross-aarch64-linux-gnu-14.2.0.drv
>   /gnu/store/3vp8a7mz1576xbk278k9b73nx2zqmzlw-libffi-3.4.4.drv
>   /gnu/store/5ij0pv5z7mi25r397y4k62ma7q38qrka-pkg-config-aarch64-linux-gnu-0.29.2.drv
>   /gnu/store/y3hqwsbc8rb2g1mac8c9vsdmaacf20xm-libatomic-ops-7.6.12.drv
>   /gnu/store/bd09d178ni5sp9db62w869c6m7d3sh6v-libgc-8.2.4.drv
>   /gnu/store/cs7mzhrypgdad8v0v29arafc8brl7ynd-bash-minimal-5.1.16.drv
>   /gnu/store/np51g0ak713az6shj6sv9j3wkq4cjvjx-libunistring-1.1.drv
>   /gnu/store/rbkb4ig158h9gblbrah5nx5annvfpb4q-libxcrypt-4.4.36.drv
>   /gnu/store/lfmamfv5vx690l9n6a1ixbbk6kzw3gsr-guile-3.0.9.drv
> --8<---------------cut here---------------end--------------->8---
>
> Finally, I want to highlight a couple things that I haven't figured out
> for my use-case yet:
> 1. My private ssh key is stored in GnuPG and I'd like to keep it that
> way. Afaik `managed-host-environment-type` can utilise the running
> ssh-agent, could it be also implemented for hetzner machines?

Your public key needs to be added as an SSH key via the Hetzner API. I
believe the guix deploy command is doing the same here as the digital
ocean one. It takes the ssh key from the machine config and creates the
public key with the Hetzner API on the server.

Maybe we could also support specifiy a fingerprint in the machine
configuration and somehow get the public ssh key for it somehow from
your GPG agent in Guile. Not sure how to do this though.

I think the difference to managed-host-environment-type, is that with
managed-host-environment-type someone already put the public key on the
server (and authorized it) and Guix is using the private key from the
SSH agent when it connects to it.

> 2. My use-case is an on-demand wireguard VPN. In my current setup I have
> created a static ipv6 address which I attach to the VM created using
> `hcloud`. The wireguard config hardcodes the same ipv6 and is installed
> on the VM during cloud-init provision (`--user-data-from-file`
> parameter). To replicate the same in guix deploy,
> `hetzner-configuration` should be more flexible in regards to public ip
> addresses. I.e. it should allow to use either v4 or v6 and to accept
> existing one provided by the user.
>

Enabling/disabling IPv4/IPv4 should be easy to implement. The public_net
option has settings for enable_ipv4 and enable_ipv6. They both default
to #t, but it should be easy to add a configuration option for it.

https://docs.hetzner.cloud/#servers-create-a-server

The public_net also support ipv4 and ipv6 fields. The docs say:

ID of the ipv4 Primary IP to use. If omitted and enable_ipv4 is true, a
new ipv4 Primary IP will automatically be created.

And this seems to be the endpoint for creating those IPs:

https://docs.hetzner.cloud/#primary-ips-create-a-primary-ip

We don't have code to manage primary IPs in the Hetzner modules yet, but
it shouldn't be hard to add it.

I won't have time to look into this right now, but if you plan to do it,
I can certainly answer questions you might have or support you on this.

I hope that helps, and sorry your use case isn't covered yet.

Roman

[signature.asc (application/pgp-signature, inline)]

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

From: Sergey Trofimov <sarg <at> sarg.org.ru>
To: Roman Scherer <roman <at> burningswell.com>
Cc: 75144 <at> debbugs.gnu.org
Subject: Re: [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
Date: Sat, 15 Mar 2025 13:22:31 +0100

Hi Roman,

Roman Scherer <roman <at> burningswell.com> writes:

>
> I also have seen these long deploy times. You probably run into a
> situation where substitutes were not available for the thing you are
> deploying. It's a know issue with aarch64.

It was simply %hetzner-os-arm, nothing special. As I were deploying from
my local guix checkout, it could've caused more things to be built. I
recall most time got spent on ...-module-import derivations.

>>
>> gnu/build/linux-modules.scm:278:5: kernel module not found "pata_acpi" "/gnu/store/nh5icvr5qvlaq1y54gpkqndy0rv2cq9r-linux-libre-6.13.6/lib/modules"
>> --8<---------------cut here---------------end--------------->8---
>>
>> This seem to be caused by `deploy` not supporting `--target` parameter.
>> Adding these looked simple and I've jotted a small patch:
>>
>
> Nice! Do you plan to submit this as a patch, once you got it working?
>
https://issues.guix.gnu.org/77033


>>
>> Finally, I want to highlight a couple things that I haven't figured out
>> for my use-case yet:
>> 1. My private ssh key is stored in GnuPG and I'd like to keep it that
>> way. Afaik `managed-host-environment-type` can utilise the running
>> ssh-agent, could it be also implemented for hetzner machines?
>
> Your public key needs to be added as an SSH key via the Hetzner API. I
> believe the guix deploy command is doing the same here as the digital
> ocean one. It takes the ssh key from the machine config and creates the
> public key with the Hetzner API on the server.
>
> Maybe we could also support specifiy a fingerprint in the machine
> configuration and somehow get the public ssh key for it somehow from
> your GPG agent in Guile. Not sure how to do this though.
>
> I think the difference to managed-host-environment-type, is that with
> managed-host-environment-type someone already put the public key on the
> server (and authorized it) and Guix is using the private key from the
> SSH agent when it connects to it.
>

Only the public key is necessary to provision the VM. The private key
could be taken from ~/.ssh/config or ssh-agent by guile-ssh, the same as
it works for the managed-host. See the fix here: https://issues.guix.gnu.org/77013

>
>> 2. My use-case is an on-demand wireguard VPN. In my current setup I have
>> created a static ipv6 address which I attach to the VM created using
>> `hcloud`. The wireguard config hardcodes the same ipv6 and is installed
>> on the VM during cloud-init provision (`--user-data-from-file`
>> parameter). To replicate the same in guix deploy,
>> `hetzner-configuration` should be more flexible in regards to public ip
>> addresses. I.e. it should allow to use either v4 or v6 and to accept
>> existing one provided by the user.
>>
>
> Enabling/disabling IPv4/IPv4 should be easy to implement. The public_net
> option has settings for enable_ipv4 and enable_ipv6. They both default
> to #t, but it should be easy to add a configuration option for it.
>

Disabling ipv4 is a bit cumbersome - firstly the VM would have to rely
only on v6 and then the code would need to be adjusted to support
v6-only setups.

> https://docs.hetzner.cloud/#servers-create-a-server
>
> The public_net also support ipv4 and ipv6 fields. The docs say:
>
> ID of the ipv4 Primary IP to use. If omitted and enable_ipv4 is true, a
> new ipv4 Primary IP will automatically be created.
>
> And this seems to be the endpoint for creating those IPs:
>
> https://docs.hetzner.cloud/#primary-ips-create-a-primary-ip
>
> We don't have code to manage primary IPs in the Hetzner modules yet, but
> it shouldn't be hard to add it.
>

Here is the first revision of such change:
https://issues.guix.gnu.org/77019

Using all 3 patches I've been able to deploy such configuration:
./pre-inst-env guix deploy ~/.dotfiles/guix/hetzner-deploy.scm --system=aarch64-linux

--8<---------------cut here---------------start------------->8---
(machine
    (operating-system hetzner-os)
    (environment hetzner-environment-type)
    (configuration (hetzner-configuration
                    (server-type "cax11")
                    (build-locally? #f)
                    (location "hel1")
                    (ssh-public-key
                    (string->public-key "AAAA..<omitted>..==" 'rsa))
                    (ipv6 "vpn_ipv6"))))
--8<---------------cut here---------------end--------------->8---

However I had to adjust the operating-system to configure ipv6 upon
reboot:

--8<---------------cut here---------------start------------->8---
(service static-networking-service-type
    (list (static-networking
            (provision '(networking-ipv6))
            (requirement '(networking))
            (addresses
            (list (network-address
                    (device "eth0")
                    ; hetzner allocates /64, a static addr has to be
                    ; selected, ::1 in this case
                    (value "2a01:000:0000:0000::1/64"))))
            (routes
            (list (network-route
                    (destination "default")
                    (device "eth0")
                    (gateway "fe80::1"))))
            (name-servers
            '("1.1.1.1" "2a01:4ff:ff00::add:2" "2a01:4ff:ff00::add:1")))))
--8<---------------cut here---------------end--------------->8---

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

From: Roman Scherer <roman <at> burningswell.com>
To: Sergey Trofimov <sarg <at> sarg.org.ru>
Cc: Roman Scherer <roman <at> burningswell.com>, 75144 <at> debbugs.gnu.org
Subject: Re: [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
Date: Sun, 16 Mar 2025 12:31:33 +0100

[Message part 1 (text/plain, inline)]

Hi Sergyey,

thanks for working on this. I just started to test your cross build
patch without offloading. It's building and I will report back when it
went through ...

The other patches also look fine to me, but I think they are missing
tests. Could you please add some tests for the functionality you added?

There are 2 types of tests, some of them are mocked and some of them run
against the Hetzner API and deploy 2 machines.

To run all tests you need to set the GUIX_HETZNER_API_TOKEN variable,
otherwise only the mock tests are run. You can run those tests with:

./pre-inst-env make check TESTS="tests/machine/hetzner/http.scm"
./pre-inst-env make check TESTS="tests/machine/hetzner.scm"

Thanks, Roman.

Sergey Trofimov <sarg <at> sarg.org.ru> writes:

> Hi Roman,
>
> Roman Scherer <roman <at> burningswell.com> writes:
>
>>
>> I also have seen these long deploy times. You probably run into a
>> situation where substitutes were not available for the thing you are
>> deploying. It's a know issue with aarch64.
>
> It was simply %hetzner-os-arm, nothing special. As I were deploying from
> my local guix checkout, it could've caused more things to be built. I
> recall most time got spent on ...-module-import derivations.
>
>>>
>>> gnu/build/linux-modules.scm:278:5: kernel module not found "pata_acpi" "/gnu/store/nh5icvr5qvlaq1y54gpkqndy0rv2cq9r-linux-libre-6.13.6/lib/modules"
>>> --8<---------------cut here---------------end--------------->8---
>>>
>>> This seem to be caused by `deploy` not supporting `--target` parameter.
>>> Adding these looked simple and I've jotted a small patch:
>>>
>>
>> Nice! Do you plan to submit this as a patch, once you got it working?
>>
> https://issues.guix.gnu.org/77033
>
>
>>>
>>> Finally, I want to highlight a couple things that I haven't figured out
>>> for my use-case yet:
>>> 1. My private ssh key is stored in GnuPG and I'd like to keep it that
>>> way. Afaik `managed-host-environment-type` can utilise the running
>>> ssh-agent, could it be also implemented for hetzner machines?
>>
>> Your public key needs to be added as an SSH key via the Hetzner API. I
>> believe the guix deploy command is doing the same here as the digital
>> ocean one. It takes the ssh key from the machine config and creates the
>> public key with the Hetzner API on the server.
>>
>> Maybe we could also support specifiy a fingerprint in the machine
>> configuration and somehow get the public ssh key for it somehow from
>> your GPG agent in Guile. Not sure how to do this though.
>>
>> I think the difference to managed-host-environment-type, is that with
>> managed-host-environment-type someone already put the public key on the
>> server (and authorized it) and Guix is using the private key from the
>> SSH agent when it connects to it.
>>
>
> Only the public key is necessary to provision the VM. The private key
> could be taken from ~/.ssh/config or ssh-agent by guile-ssh, the same as
> it works for the managed-host. See the fix here: https://issues.guix.gnu.org/77013
>
>>
>>> 2. My use-case is an on-demand wireguard VPN. In my current setup I have
>>> created a static ipv6 address which I attach to the VM created using
>>> `hcloud`. The wireguard config hardcodes the same ipv6 and is installed
>>> on the VM during cloud-init provision (`--user-data-from-file`
>>> parameter). To replicate the same in guix deploy,
>>> `hetzner-configuration` should be more flexible in regards to public ip
>>> addresses. I.e. it should allow to use either v4 or v6 and to accept
>>> existing one provided by the user.
>>>
>>
>> Enabling/disabling IPv4/IPv4 should be easy to implement. The public_net
>> option has settings for enable_ipv4 and enable_ipv6. They both default
>> to #t, but it should be easy to add a configuration option for it.
>>
>
> Disabling ipv4 is a bit cumbersome - firstly the VM would have to rely
> only on v6 and then the code would need to be adjusted to support
> v6-only setups.
>
>> https://docs.hetzner.cloud/#servers-create-a-server
>>
>> The public_net also support ipv4 and ipv6 fields. The docs say:
>>
>> ID of the ipv4 Primary IP to use. If omitted and enable_ipv4 is true, a
>> new ipv4 Primary IP will automatically be created.
>>
>> And this seems to be the endpoint for creating those IPs:
>>
>> https://docs.hetzner.cloud/#primary-ips-create-a-primary-ip
>>
>> We don't have code to manage primary IPs in the Hetzner modules yet, but
>> it shouldn't be hard to add it.
>>
>
> Here is the first revision of such change:
> https://issues.guix.gnu.org/77019
>
> Using all 3 patches I've been able to deploy such configuration:
> ./pre-inst-env guix deploy ~/.dotfiles/guix/hetzner-deploy.scm --system=aarch64-linux
>
> --8<---------------cut here---------------start------------->8---
> (machine
>     (operating-system hetzner-os)
>     (environment hetzner-environment-type)
>     (configuration (hetzner-configuration
>                     (server-type "cax11")
>                     (build-locally? #f)
>                     (location "hel1")
>                     (ssh-public-key
>                     (string->public-key "AAAA..<omitted>..==" 'rsa))
>                     (ipv6 "vpn_ipv6"))))
> --8<---------------cut here---------------end--------------->8---
>
> However I had to adjust the operating-system to configure ipv6 upon
> reboot:
>
> --8<---------------cut here---------------start------------->8---
> (service static-networking-service-type
>     (list (static-networking
>             (provision '(networking-ipv6))
>             (requirement '(networking))
>             (addresses
>             (list (network-address
>                     (device "eth0")
>                     ; hetzner allocates /64, a static addr has to be
>                     ; selected, ::1 in this case
>                     (value "2a01:000:0000:0000::1/64"))))
>             (routes
>             (list (network-route
>                     (destination "default")
>                     (device "eth0")
>                     (gateway "fe80::1"))))
>             (name-servers
>             '("1.1.1.1" "2a01:4ff:ff00::add:2" "2a01:4ff:ff00::add:1")))))
> --8<---------------cut here---------------end--------------->8---

[signature.asc (application/pgp-signature, inline)]

Previous Next

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