Subject: [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.

From: Roman Scherer <[email-masked]>
Date: Sun, 19 Jan 2025 17:59:06 +0100

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.

From a6290ec9911453a95ed35f11c660bb794f8b3103 Mon Sep 17 00:00:00 2001
Message-ID: <[email-masked]>
From: Roman Scherer <[email-masked]>
Date: Tue, 2 Jul 2024 22:43:00 +0200
Subject: [PATCH v2] machine: Implement 'hetzner-environment-type'.

* Makefile.am: Add test files to SCM_TESTS..
* doc/guix.texi (Invoking guix deploy): Add documentation.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add system modules.
* gnu/machine/hetzner.scm: Add machine module.
* gnu/machine/hetzner/http.scm: New HTTP API module.
* guix/ssh.scm (open-ssh-session): Add strict-host-key-check? option.
* po/guix/POTFILES.in: Add hetzner modules.

Change-Id: Idc17dbc33279ecbf3cbfe2c53d7699140f8b9f41
---
 Makefile.am                    |   2 +
 doc/guix.texi                  | 122 ++++++
 gnu/local.mk                   |   2 +
 gnu/machine/hetzner.scm        | 700 +++++++++++++++++++++++++++++++++
 gnu/machine/hetzner/http.scm   | 636 ++++++++++++++++++++++++++++++
 guix/ssh.scm                   |  22 +-
 po/guix/POTFILES.in            |   2 +
 tests/machine/hetzner.scm      | 244 ++++++++++++
 tests/machine/hetzner/http.scm | 167 ++++++++
 9 files changed, 1889 insertions(+), 8 deletions(-)
 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 f911d432dd..2a4f283dec 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -561,6 +561,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 0015d739bb..7396662404 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -44744,6 +44744,128 @@ 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.
+
+@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{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 CPUs, 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 342beca9f6..a1960d5087 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -920,6 +920,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..00f61e4ee4
--- /dev/null
+++ b/gnu/machine/hetzner.scm
@@ -0,0 +1,700 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Roman Scherer <[email-masked]>
+;;;
+;;; 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 pretty-print)
+  #:use-module (ice-9 rdelim)
+  #: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 (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)
+  #: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-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 (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 "`" "\\`"))
+
+
+
+;;;
+;;; 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 (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 (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~%~%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 (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 (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
+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 (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 (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 (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..c4a2d41068
--- /dev/null
+++ b/gnu/machine/hetzner/http.scm
@@ -0,0 +1,636 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Roman Scherer <[email-masked]>
+;;;
+;;; 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 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-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-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 VCUs, 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)
+  (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-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 (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?
+  (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 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)))
+
+(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 . options)
+  "Get actions from the Hetzner API."
+  (apply hetzner-api-list api "/actions" "actions" json->hetzner-action options))
+
+(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 #: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 (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/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)
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..5c84529c84
--- /dev/null
+++ b/tests/machine/hetzner.scm
@@ -0,0 +1,244 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Roman Scherer <[email-masked]>
+;;;
+;;; 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 (debugging assert)
+  #: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))
+
+;;; Tests for the (gnu machine hetzner) module.
+
+;; This test requires the GUIX_HETZNER_API_TOKEN environment variable to be set.
+;; https://docs.hetzner.com/cloud/api/getting-started/generating-api-token
+
+(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
+                   (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
+                   (server-type "cpx51")
+                   (ssh-key %ssh-key-file)))))
+
+(define (cleanup machine)
+  (let* ((config (machine-configuration machine))
+         (api (hetzner-configuration-api config)))
+    (for-each (lambda (ssh-key)
+                (hetzner-api-ssh-key-delete api ssh-key))
+              (hetzner-api-ssh-keys
+               (hetzner-configuration-api config)
+               #:params `(("name" . ,%ssh-key-name))))
+    (for-each (lambda (server)
+                (hetzner-api-server-delete api server))
+              (hetzner-api-servers
+               (hetzner-configuration-api config)
+               #:params `(("name" . ,(machine-display-name machine)))))
+    machine))
+
+(define-syntax-rule (with-cleanup-machine (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))))
+
+(test-begin "machine-hetzner")
+
+(test-skip %when-no-token)
+(test-assert "deploy-arm-machine"
+  (with-cleanup-machine (machine %arm-machine)
+    (deploy-hetzner machine)))
+
+(test-skip %when-no-token)
+(test-assert "deploy-x86-machine"
+  (with-cleanup-machine (machine %x86-machine)
+    (deploy-hetzner machine)))
+
+(define (expected-ssh-machine? machine ssh-machine)
+  (let ((config (machine-configuration machine))
+        (ssh-config (machine-configuration ssh-machine)))
+    (assert (equal? (hetzner-configuration-authorize? config)
+                    (machine-ssh-configuration-authorize? ssh-config)))
+    (assert (equal? (hetzner-configuration-allow-downgrades? config)
+                    (machine-ssh-configuration-allow-downgrades? ssh-config)))
+    (assert (equal? (hetzner-configuration-build-locally? config)
+                    (machine-ssh-configuration-build-locally? ssh-config)))
+    (assert (equal? (hetzner-server-public-ipv4 (mock-server machine))
+                    (machine-ssh-configuration-host-name ssh-config)))))
+
+(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))))
+          (mock ((gnu machine hetzner http) hetzner-api-server-types
+                 (lambda* (api . options)
+                   (list (mock-server-type machine))))
+                (mock ((gnu machine hetzner http) hetzner-api-ssh-keys
+                       (lambda* (api . options)
+                         (list (mock-ssh-key machine))))
+                      (mock ((gnu machine hetzner http) hetzner-api-servers
+                             (lambda* (api . options)
+                               (list (mock-server machine))))
+                            (mock ((gnu machine) deploy-machine
+                                   (lambda* (ssh-machine)
+                                     (assert (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))))
+          (mock ((gnu machine hetzner http) hetzner-api-server-types
+                 (lambda* (api . options)
+                   (list (mock-server-type machine))))
+                (mock ((gnu machine hetzner http) hetzner-api-ssh-keys
+                       (lambda* (api . options)
+                         (list (mock-ssh-key machine))))
+                      (mock ((gnu machine hetzner http) hetzner-api-servers
+                             (lambda* (api . options)
+                               servers))
+                            (mock ((gnu machine hetzner http) hetzner-api-server-create
+                                   (lambda* (api name ssh-keys . options)
+                                     (set! servers (list (mock-server machine)))
+                                     (car servers)))
+                                  (mock ((gnu machine hetzner http) hetzner-api-server-enable-rescue-system
+                                         (lambda (api server ssh-keys)
+                                           (format #t "MOCK ENABLE RESUCE~%")
+                                           (mock-action "enable_rescue")))
+                                        (mock ((gnu machine hetzner http) hetzner-api-server-power-on
+                                               (lambda (api server)
+                                                 (format #t "MOCK POWER ON~%")
+                                                 (mock-action "start_server")))
+                                              (mock ((gnu machine hetzner) hetzner-machine-ssh-run-script
+                                                     (lambda (ssh-session name content)
+                                                       (format #t "MOCK RUNNING SCRIPT: ~a~%" name)
+                                                       #t))
+                                                    (mock ((guix ssh) open-ssh-session
+                                                           (lambda* (host . options)
+                                                             (format #t "MOCK OPEN SSH SESSION~%")
+                                                             (make-session #:host host)))
+                                                          (mock ((gnu machine hetzner http) hetzner-api-server-reboot
+                                                                 (lambda (api server)
+                                                                   (mock-action "reboot_server")))
+                                                                (mock ((ssh session) write-known-host!
+                                                                       (lambda (session)
+                                                                         #t))
+                                                                      (mock ((gnu machine) deploy-machine
+                                                                             (lambda* (ssh-machine)
+                                                                               (assert (expected-ssh-machine? machine ssh-machine))))
+                                                                            (deploy-hetzner machine)))))))))))))))
+
+(test-end "machine-hetzner")
+
+;; Local Variables:
+;; eval: (put 'with-cleanup-machine '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..616c5ae67f
--- /dev/null
+++ b/tests/machine/hetzner/http.scm
@@ -0,0 +1,167 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Roman Scherer <[email-masked]>
+;;;
+;;; 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 (gnu machine hetzner http)
+  #:use-module (guix build utils)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-64)
+  #:use-module (ssh key))
+
+;;; Tests for the (gnu machine hetzner api) module.
+
+;; This test requires the GUIX_HETZNER_API_TOKEN environment variable to be set.
+;; https://docs.hetzner.com/cloud/api/getting-started/generating-api-token
+
+(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* (create-ssh-key api ssh-key #:key (labels '()))
+  (hetzner-api-ssh-key-create
+   api
+   (hetzner-ssh-key-name ssh-key)
+   (hetzner-ssh-key-public-key ssh-key)
+   #:labels labels))
+
+(define (cleanup api)
+  (let ((api (hetzner-api)))
+    (for-each (lambda (ssh-key)
+                (hetzner-api-ssh-key-delete api ssh-key))
+              (hetzner-api-ssh-keys
+               api #:params `(("name" . ,%ssh-key-name))))
+    (for-each (lambda (server)
+                (hetzner-api-server-delete api server))
+              (hetzner-api-servers
+               api #:params `(("name" . ,%server-name))))
+    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")
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-actions"
+  (every hetzner-action? (hetzner-api-actions (hetzner-api))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-locations"
+  (every hetzner-location? (hetzner-api-locations (hetzner-api))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-types"
+  (every hetzner-server-type? (hetzner-api-server-types (hetzner-api))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-create"
+  (with-cleanup-api (api (hetzner-api))
+    (let* ((key (create-ssh-key api %ssh-key))
+           (server (hetzner-api-server-create api %server-name (list key))))
+      (hetzner-server? server))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-delete"
+  (with-cleanup-api (api (hetzner-api))
+    (let* ((key (create-ssh-key api %ssh-key))
+           (server (hetzner-api-server-create api %server-name (list key)))
+           (action (hetzner-api-server-delete api server)))
+      (hetzner-action? action))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-enable-rescue-system"
+  (with-cleanup-api (api (hetzner-api))
+    (let* ((key (create-ssh-key api %ssh-key))
+           (server (hetzner-api-server-create api %server-name (list key)))
+           (action (hetzner-api-server-enable-rescue-system api server (list key))))
+      (hetzner-action? action))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-power-on"
+  (with-cleanup-api (api (hetzner-api))
+    (let* ((key (create-ssh-key api %ssh-key))
+           (server (hetzner-api-server-create api %server-name (list key)))
+           (action (hetzner-api-server-power-on api server)))
+      (hetzner-action? action))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-power-off"
+  (with-cleanup-api (api (hetzner-api))
+    (let* ((key (create-ssh-key api %ssh-key))
+           (server (hetzner-api-server-create api %server-name (list key)))
+           (action (hetzner-api-server-power-off api server)))
+      (hetzner-action? action))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-reboot"
+  (with-cleanup-api (api (hetzner-api))
+    (let* ((key (create-ssh-key api %ssh-key))
+           (server (hetzner-api-server-create api %server-name (list key)))
+           (action (hetzner-api-server-reboot api server)))
+      (hetzner-action? action))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-servers"
+  (every hetzner-server? (hetzner-api-servers (hetzner-api))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-ssh-key-create"
+  (with-cleanup-api (api (hetzner-api))
+    (let* ((api (cleanup (hetzner-api)))
+           (key (create-ssh-key api %ssh-key)))
+      (hetzner-ssh-key? key))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-ssh-key-delete"
+  (with-cleanup-api (api (hetzner-api))
+    (let* ((api (cleanup (hetzner-api)))
+           (key (create-ssh-key
+                 api %ssh-key
+                 #:labels '(("environment" . "development")))))
+      (hetzner-api-ssh-key-delete api key))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-ssh-keys"
+  (every hetzner-ssh-key? (hetzner-api-ssh-keys (hetzner-api))))
+
+(test-end "machine-hetzner-api")
+
+;; Local Variables:
+;; eval: (put 'with-cleanup-api 'scheme-indent-function 1)
+;; End:

base-commit: 7aae0e2c159b1612b405a372b18f25fbb58f9d82
prerequisite-patch-id: ac1f0d4a2d25a1b4d5bc2113465fff75fe16b173
prerequisite-patch-id: eb3f1eb84750594036d67d1415c45ac1b79ddef4
prerequisite-patch-id: 01e878a55309cfb2b19a5616530cc95e305a17df
prerequisite-patch-id: 5a938c41d076ed210df0dd2ea14064581d54d245
prerequisite-patch-id: 1d62fb01e63abea0cdd588a52c1e570a5175eff7
prerequisite-patch-id: e5bdca7bb03c74026330fbaae6bd89efcbf4c2a9
prerequisite-patch-id: 10a22db612648d6a35e93d44afac961b3e5d2e9e
prerequisite-patch-id: 6a052619a2a8a036f658f0de4a2f4e42f6354d19
prerequisite-patch-id: 7a18e5bff86d43b14e6633357c185cd9a1ebf072
prerequisite-patch-id: 0d39c3063a794f1c740021e5d5f43e98c3e74013
prerequisite-patch-id: 8d732b32581c39cd4e61cfd583be9b8fdff4b86d
prerequisite-patch-id: 4233e276f34af03e0e84ce06aec407d13a3c0dab
prerequisite-patch-id: a95d5a44ca76b5e4ee7d7a552fa644e3c07c1ca9
prerequisite-patch-id: 500d513328a3545d08a954e09f1cabcef6c22f8c
prerequisite-patch-id: e3538aa251c819e1e6f100b9f547f64e79535957
prerequisite-patch-id: 8be1562d2e1390bd513303496e2cfe930e83cf98
prerequisite-patch-id: 1384fe5a71920e6f02858ccce39ae9a481d5d170
prerequisite-patch-id: ac21d3b2571c5f51a0e4b338fa4292189928c9d4
prerequisite-patch-id: 11eccf9862f6122ae1d52c13d218eac0064f0b22
prerequisite-patch-id: 86f80755bf52b691ea258121089f394a49a7aca7
prerequisite-patch-id: fa2314d1b06b810ecd2bb69f86b8556204a87e22
prerequisite-patch-id: b41b483173b7790006158179a4f2459af02cc088
prerequisite-patch-id: a4833568bf4308b39b456841e89be021b444b17e
-- 
2.47.1

Ludovic Courtès <[email-masked]> writes:

> Hello Roman,
>
> Roman Scherer <[email-masked]> 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’.