summaryrefslogtreecommitdiff
path: root/gnu
diff options
context:
space:
mode:
authorRoman Scherer <[email protected]>2025-02-04 20:01:14 +0100
committerLudovic Courtès <[email protected]>2025-02-09 18:20:42 +0100
commit0753a17ddf6f4fab98b93c25f1a93b97ff9e46bb (patch)
treee56f2bcb4c52186364ee63a065bc6a20a2e252be /gnu
parent96f05f003a862c198e803901abf6f50b23969697 (diff)
machine: Implement 'hetzner-environment-type'.
* Makefile.am (SCM_TESTS): Add test modules. * doc/guix.texi: Add documentation. * gnu/local.mk (GNU_SYSTEM_MODULES): Add modules. * gnu/machine/hetzner.scm: Add hetzner-environment-type. * gnu/machine/hetzner/http.scm: Add HTTP API. * po/guix/POTFILES.in: Add Hetzner modules. * tests/machine/hetzner.scm: Add machine tests. * tests/machine/hetzner/http.scm Add HTTP API tests. Change-Id: I276ed5afed676bbccc6c852c56ee4db57ce3c1ea Signed-off-by: Ludovic Courtès <[email protected]>
Diffstat (limited to 'gnu')
-rw-r--r--gnu/local.mk2
-rw-r--r--gnu/machine/hetzner.scm705
-rw-r--r--gnu/machine/hetzner/http.scm664
3 files changed, 1371 insertions, 0 deletions
diff --git a/gnu/local.mk b/gnu/local.mk
index 3f18a51033..2d4608378b 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -921,6 +921,8 @@ if HAVE_GUILE_SSH
GNU_SYSTEM_MODULES += \
%D%/machine/digital-ocean.scm \
+ %D%/machine/hetzner.scm \
+ %D%/machine/hetzner/http.scm \
%D%/machine/ssh.scm
endif HAVE_GUILE_SSH
diff --git a/gnu/machine/hetzner.scm b/gnu/machine/hetzner.scm
new file mode 100644
index 0000000000..5e17bfae21
--- /dev/null
+++ b/gnu/machine/hetzner.scm
@@ -0,0 +1,705 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Roman Scherer <[email protected]>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu machine hetzner)
+ #:use-module (gnu bootloader grub)
+ #:use-module (gnu bootloader)
+ #:use-module (gnu machine hetzner http)
+ #:use-module (gnu machine ssh)
+ #:use-module (gnu machine)
+ #:use-module (gnu packages ssh)
+ #:use-module (gnu services base)
+ #:use-module (gnu services networking)
+ #:use-module (gnu services ssh)
+ #:use-module (gnu services)
+ #:use-module (gnu system file-systems)
+ #:use-module (gnu system image)
+ #:use-module (gnu system linux-initrd)
+ #:use-module (gnu system pam)
+ #:use-module (gnu system)
+ #:use-module (guix base32)
+ #:use-module (guix colors)
+ #:use-module (guix derivations)
+ #:use-module (guix diagnostics)
+ #:use-module (guix gexp)
+ #:use-module (guix i18n)
+ #:use-module (guix import json)
+ #:use-module (guix monads)
+ #:use-module (guix packages)
+ #:use-module (guix pki)
+ #:use-module (guix records)
+ #:use-module (guix ssh)
+ #:use-module (guix store)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 iconv)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 string-fun)
+ #:use-module (ice-9 textual-ports)
+ #:use-module (json)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-2)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (srfi srfi-71)
+ #:use-module (ssh channel)
+ #:use-module (ssh key)
+ #:use-module (ssh popen)
+ #:use-module (ssh session)
+ #:use-module (ssh sftp)
+ #:use-module (ssh shell)
+ #:export (%hetzner-os-arm
+ %hetzner-os-x86
+ deploy-hetzner
+ hetzner-configuration
+ hetzner-configuration-allow-downgrades?
+ hetzner-configuration-api
+ hetzner-configuration-authorize?
+ hetzner-configuration-build-locally?
+ hetzner-configuration-delete?
+ hetzner-configuration-labels
+ hetzner-configuration-location
+ hetzner-configuration-server-type
+ hetzner-configuration-ssh-key
+ hetzner-configuration?
+ hetzner-environment-type))
+
+;;; Commentary:
+;;;
+;;; This module implements a high-level interface for provisioning machines on
+;;; the Hetzner Cloud service https://docs.hetzner.cloud.
+;;;
+
+
+;;;
+;;; Hetzner operating systems.
+;;;
+
+;; Operating system for arm servers using UEFI boot mode.
+
+(define %hetzner-os-arm
+ (operating-system
+ (host-name "guix-arm")
+ (bootloader
+ (bootloader-configuration
+ (bootloader grub-efi-bootloader)
+ (targets (list "/boot/efi"))
+ (terminal-outputs '(console))))
+ (file-systems
+ (cons* (file-system
+ (mount-point "/")
+ (device "/dev/sda1")
+ (type "ext4"))
+ (file-system
+ (mount-point "/boot/efi")
+ (device "/dev/sda15")
+ (type "vfat"))
+ %base-file-systems))
+ (initrd-modules
+ (cons* "sd_mod" "virtio_scsi" %base-initrd-modules))
+ (services
+ (cons* (service dhcp-client-service-type)
+ (service openssh-service-type
+ (openssh-configuration
+ (openssh openssh-sans-x)
+ (permit-root-login 'prohibit-password)))
+ %base-services))))
+
+;; Operating system for x86 servers using BIOS boot mode.
+
+(define %hetzner-os-x86
+ (operating-system
+ (inherit %hetzner-os-arm)
+ (host-name "guix-x86")
+ (bootloader
+ (bootloader-configuration
+ (bootloader grub-bootloader)
+ (targets (list "/dev/sda"))
+ (terminal-outputs '(console))))
+ (initrd-modules
+ (cons "virtio_scsi" %base-initrd-modules))
+ (file-systems
+ (cons (file-system
+ (mount-point "/")
+ (device "/dev/sda1")
+ (type "ext4"))
+ %base-file-systems))))
+
+(define (operating-system-authorize os)
+ "Authorize the OS with the public signing key of the current machine."
+ (if (file-exists? %public-key-file)
+ (operating-system
+ (inherit os)
+ (services
+ (modify-services (operating-system-user-services os)
+ (guix-service-type
+ config => (guix-configuration
+ (inherit config)
+ (authorized-keys
+ (cons*
+ (local-file %public-key-file)
+ (guix-configuration-authorized-keys config))))))))
+ (raise-exception
+ (formatted-message (G_ "no signing key '~a'. \
+Have you run 'guix archive --generate-key'?")
+ %public-key-file))))
+
+(define (operating-system-root-file-system-type os)
+ "Return the root file system type of the operating system OS."
+ (let ((root-fs (find (lambda (file-system)
+ (equal? "/" (file-system-mount-point file-system)))
+ (operating-system-file-systems os))))
+ (if (file-system? root-fs)
+ (file-system-type root-fs)
+ (raise-exception
+ (formatted-message
+ (G_ "could not determine root file system type"))))))
+
+
+;;;
+;;; Helper functions.
+;;;
+
+(define (escape-backticks str)
+ "Escape all backticks in STR."
+ (string-replace-substring str "`" "\\`"))
+
+
+
+;;;
+;;; Hetzner configuration.
+;;;
+
+(define-record-type* <hetzner-configuration> hetzner-configuration
+ make-hetzner-configuration hetzner-configuration? this-hetzner-configuration
+ (allow-downgrades? hetzner-configuration-allow-downgrades? ; boolean
+ (default #f))
+ (api hetzner-configuration-api ; <hetzner-api>
+ (default (hetzner-api)))
+ (authorize? hetzner-configuration-authorize? ; boolean
+ (default #t))
+ (build-locally? hetzner-configuration-build-locally? ; boolean
+ (default #t))
+ (delete? hetzner-configuration-delete? ; boolean
+ (default #f))
+ (labels hetzner-configuration-labels ; list of strings
+ (default '()))
+ (location hetzner-configuration-location ; #f | string
+ (default "fsn1"))
+ (server-type hetzner-configuration-server-type ; string
+ (default "cx42"))
+ (ssh-key hetzner-configuration-ssh-key)) ; string
+
+(define (hetzner-configuration-ssh-key-fingerprint config)
+ "Return the SSH public key fingerprint of CONFIG as a string."
+ (and-let* ((file-name (hetzner-configuration-ssh-key config))
+ (privkey (private-key-from-file file-name))
+ (pubkey (private-key->public-key privkey))
+ (hash (get-public-key-hash pubkey 'md5)))
+ (bytevector->hex-string hash)))
+
+(define (hetzner-configuration-ssh-key-public config)
+ "Return the SSH public key of CONFIG as a string."
+ (and-let* ((ssh-key (hetzner-configuration-ssh-key config))
+ (public-key (public-key-from-file ssh-key)))
+ (format #f "ssh-~a ~a" (get-key-type public-key)
+ (public-key->string public-key))))
+
+
+;;;
+;;; Hetzner Machine.
+;;;
+
+(define (hetzner-machine-delegate target server)
+ "Return the delagate machine that uses SSH for deployment."
+ (let* ((config (machine-configuration target))
+ ;; Get the operating system WITHOUT the provenance service to avoid a
+ ;; duplicate symlink conflict in the store.
+ (os ((@@ (gnu machine) %machine-operating-system) target)))
+ (machine
+ (inherit target)
+ (operating-system
+ (if (hetzner-configuration-authorize? config)
+ (operating-system-authorize os)
+ os))
+ (environment managed-host-environment-type)
+ (configuration
+ (machine-ssh-configuration
+ (allow-downgrades? (hetzner-configuration-allow-downgrades? config))
+ (authorize? (hetzner-configuration-authorize? config))
+ (build-locally? (hetzner-configuration-build-locally? config))
+ (host-name (hetzner-server-public-ipv4 server))
+ (identity (hetzner-configuration-ssh-key config))
+ (system (hetzner-server-system server)))))))
+
+(define (hetzner-machine-location machine)
+ "Find the location of MACHINE on the Hetzner API."
+ (let* ((config (machine-configuration machine))
+ (expected (hetzner-configuration-location config)))
+ (find (lambda (location)
+ (equal? expected (hetzner-location-name location)))
+ (hetzner-api-locations
+ (hetzner-configuration-api config)
+ #:params `(("name" . ,expected))))))
+
+(define (hetzner-machine-server-type machine)
+ "Find the server type of MACHINE on the Hetzner API."
+ (let* ((config (machine-configuration machine))
+ (expected (hetzner-configuration-server-type config)))
+ (find (lambda (server-type)
+ (equal? expected (hetzner-server-type-name server-type)))
+ (hetzner-api-server-types
+ (hetzner-configuration-api config)
+ #:params `(("name" . ,expected))))))
+
+(define (hetzner-machine-validate-api-token machine)
+ "Validate the Hetzner API authentication token of MACHINE."
+ (let* ((config (machine-configuration machine))
+ (api (hetzner-configuration-api config)))
+ (unless (hetzner-api-token api)
+ (raise-exception
+ (formatted-message
+ (G_ "Hetzner Cloud access token was not provided. \
+This may be fixed by setting the environment variable GUIX_HETZNER_API_TOKEN \
+to one procured from \
+https://docs.hetzner.com/cloud/api/getting-started/generating-api-token"))))))
+
+(define (hetzner-machine-validate-configuration-type machine)
+ "Raise an error if MACHINE's configuration is not an instance of
+<hetzner-configuration>."
+ (let ((config (machine-configuration machine))
+ (environment (environment-type-name (machine-environment machine))))
+ (unless (and config (hetzner-configuration? config))
+ (raise-exception
+ (formatted-message (G_ "unsupported machine configuration '~a' \
+for environment of type '~a'")
+ config
+ environment)))))
+
+(define (hetzner-machine-validate-server-type machine)
+ "Raise an error if the server type of MACHINE is not supported."
+ (unless (hetzner-machine-server-type machine)
+ (let* ((config (machine-configuration machine))
+ (api (hetzner-configuration-api config)))
+ (raise-exception
+ (formatted-message
+ (G_ "server type '~a' not supported~%~%\
+Available server types:~%~%~a~%~%For more details and prices, see: ~a")
+ (hetzner-configuration-server-type config)
+ (string-join
+ (map (lambda (type)
+ (format #f " - ~a: ~a, ~a ~a cores, ~a GB mem, ~a GB disk"
+ (colorize-string
+ (hetzner-server-type-name type)
+ (color BOLD))
+ (hetzner-server-type-architecture type)
+ (hetzner-server-type-cores type)
+ (hetzner-server-type-cpu-type type)
+ (hetzner-server-type-memory type)
+ (hetzner-server-type-disk type)))
+ (hetzner-api-server-types api))
+ "\n")
+ "https://www.hetzner.com/cloud#pricing")))))
+
+(define (hetzner-machine-validate-location machine)
+ "Raise an error if the location of MACHINE is not supported."
+ (unless (hetzner-machine-location machine)
+ (let* ((config (machine-configuration machine))
+ (api (hetzner-configuration-api config)))
+ (raise-exception
+ (formatted-message
+ (G_ "server location '~a' not supported~%~%\
+Available locations:~%~%~a~%~%For more details, see: ~a")
+ (hetzner-configuration-location config)
+ (string-join
+ (map (lambda (location)
+ (format #f " - ~a: ~a, ~a"
+ (colorize-string
+ (hetzner-location-name location)
+ (color BOLD))
+ (hetzner-location-description location)
+ (hetzner-location-country location)))
+ (hetzner-api-locations api))
+ "\n")
+ "https://www.hetzner.com/cloud#locations")))))
+
+(define (hetzner-machine-validate machine)
+ "Validate the Hetzner MACHINE."
+ (hetzner-machine-validate-configuration-type machine)
+ (hetzner-machine-validate-api-token machine)
+ (hetzner-machine-validate-location machine)
+ (hetzner-machine-validate-server-type machine))
+
+(define (hetzner-machine-bootstrap-os-form machine server)
+ "Return the form to bootstrap an operating system on SERVER."
+ (let* ((os (machine-operating-system machine))
+ (system (hetzner-server-system server))
+ (arm? (equal? "arm" (hetzner-server-architecture server)))
+ (x86? (equal? "x86" (hetzner-server-architecture server)))
+ (root-fs-type (operating-system-root-file-system-type os)))
+ `(operating-system
+ (host-name ,(operating-system-host-name os))
+ (timezone "Etc/UTC")
+ (bootloader (bootloader-configuration
+ (bootloader ,(cond (arm? 'grub-efi-bootloader)
+ (x86? 'grub-bootloader)))
+ (targets ,(cond (arm? '(list "/boot/efi"))
+ (x86? '(list "/dev/sda"))))
+ (terminal-outputs '(console))))
+ (initrd-modules (append
+ ,(cond (arm? '(list "sd_mod" "virtio_scsi"))
+ (x86? '(list "virtio_scsi")))
+ %base-initrd-modules))
+ (file-systems ,(cond
+ (arm? `(cons* (file-system
+ (mount-point "/")
+ (device "/dev/sda1")
+ (type ,root-fs-type))
+ (file-system
+ (mount-point "/boot/efi")
+ (device "/dev/sda15")
+ (type "vfat"))
+ %base-file-systems))
+ (x86? `(cons* (file-system
+ (mount-point "/")
+ (device "/dev/sda1")
+ (type ,root-fs-type))
+ %base-file-systems))))
+ (services
+ (cons* (service dhcp-client-service-type)
+ (service openssh-service-type
+ (openssh-configuration
+ (openssh openssh-sans-x)
+ (permit-root-login 'prohibit-password)))
+ %base-services)))))
+
+(define (rexec-verbose session cmd)
+ "Execute a command CMD on the remote side and print output. Return two
+values: list of output lines returned by CMD and its exit code."
+ (let* ((channel (open-remote-input-pipe session cmd))
+ (result (let loop ((line (read-line channel))
+ (result '()))
+ (if (eof-object? line)
+ (reverse result)
+ (begin
+ (display line)
+ (newline)
+ (loop (read-line channel)
+ (cons line result))))))
+ (exit-status (channel-get-exit-status channel)))
+ (close channel)
+ (values result exit-status)))
+
+(define (hetzner-machine-ssh-key machine)
+ "Find the SSH key for MACHINE on the Hetzner API."
+ (let* ((config (machine-configuration machine))
+ (expected (hetzner-configuration-ssh-key-fingerprint config)))
+ (find (lambda (ssh-key)
+ (equal? expected (hetzner-ssh-key-fingerprint ssh-key)))
+ (hetzner-api-ssh-keys
+ (hetzner-configuration-api config)
+ #:params `(("fingerprint" . ,expected))))))
+
+(define (hetzner-machine-ssh-key-create machine)
+ "Create the SSH key for MACHINE on the Hetzner API."
+ (let ((name (machine-display-name machine)))
+ (format #t "creating ssh key for '~a'...\n" name)
+ (let* ((config (machine-configuration machine))
+ (api (hetzner-configuration-api config))
+ (ssh-key (hetzner-api-ssh-key-create
+ (hetzner-configuration-api config)
+ (hetzner-configuration-ssh-key-fingerprint config)
+ (hetzner-configuration-ssh-key-public config)
+ #:labels (hetzner-configuration-labels config))))
+ (format #t "successfully created ssh key for '~a'\n" name)
+ ssh-key)))
+
+(define (hetzner-machine-server machine)
+ "Find the Hetzner server for MACHINE."
+ (let ((config (machine-configuration machine)))
+ (find (lambda (server)
+ (equal? (machine-display-name machine)
+ (hetzner-server-name server)))
+ (hetzner-api-servers
+ (hetzner-configuration-api config)
+ #:params `(("name" . ,(machine-display-name machine)))))))
+
+(define (hetzner-machine-create-server machine)
+ "Create the Hetzner server for MACHINE."
+ (let* ((config (machine-configuration machine))
+ (name (machine-display-name machine))
+ (server-type (hetzner-configuration-server-type config)))
+ (format #t "creating '~a' server for '~a'...\n" server-type name)
+ (let* ((ssh-key (hetzner-machine-ssh-key machine))
+ (api (hetzner-configuration-api config))
+ (server (hetzner-api-server-create
+ api
+ (machine-display-name machine)
+ (list ssh-key)
+ #:labels (hetzner-configuration-labels config)
+ #:location (hetzner-configuration-location config)
+ #:server-type (hetzner-configuration-server-type config)))
+ (architecture (hetzner-server-architecture server)))
+ (format #t "successfully created '~a' ~a server for '~a'\n"
+ server-type architecture name)
+ server)))
+
+(define (wait-for-ssh address ssh-key)
+ "Block until a SSH session can be made as 'root' with SSH-KEY at ADDRESS."
+ (format #t "connecting via SSH to '~a' using '~a'...\n" address ssh-key)
+ (let loop ()
+ (catch #t
+ (lambda ()
+ (open-ssh-session address #:user "root" #:identity ssh-key
+ #:strict-host-key-check? #f))
+ (lambda args
+ (let ((msg (cadr args)))
+ (if (formatted-message? msg)
+ (format #t "~a\n"
+ (string-trim-right
+ (apply format #f
+ (formatted-message-string msg)
+ (formatted-message-arguments msg))
+ #\newline))
+ (format #t "~a" args))
+ (sleep 5)
+ (loop))))))
+
+(define (hetzner-machine-wait-for-ssh machine server)
+ "Wait for SSH connection to be established with the specified machine."
+ (wait-for-ssh (hetzner-server-public-ipv4 server)
+ (hetzner-configuration-ssh-key
+ (machine-configuration machine))))
+
+(define (hetzner-machine-authenticate-host machine server)
+ "Add the host key of MACHINE to the list of known hosts."
+ (let ((ssh-session (hetzner-machine-wait-for-ssh machine server)))
+ (write-known-host! ssh-session)))
+
+(define (hetzner-machine-enable-rescue-system machine server)
+ "Enable the rescue system on the Hetzner SERVER for MACHINE."
+ (let* ((name (machine-display-name machine))
+ (config (machine-configuration machine))
+ (api (hetzner-configuration-api config))
+ (ssh-keys (list (hetzner-machine-ssh-key machine))))
+ (format #t "enabling rescue system on '~a'...\n" name)
+ (let ((action (hetzner-api-server-enable-rescue-system api server ssh-keys)))
+ (format #t "successfully enabled rescue system on '~a'\n" name)
+ action)))
+
+(define (hetzner-machine-power-on machine server)
+ "Power on the Hetzner SERVER for MACHINE."
+ (let* ((name (machine-display-name machine))
+ (config (machine-configuration machine))
+ (api (hetzner-configuration-api config)))
+ (format #t "powering on server for '~a'...\n" name)
+ (let ((action (hetzner-api-server-power-on api server)))
+ (format #t "successfully powered on server for '~a'\n" name)
+ action)))
+
+(define (hetzner-machine-ssh-run-script ssh-session name content)
+ (let ((sftp-session (make-sftp-session ssh-session)))
+ (rexec ssh-session (format #f "rm -f ~a" name))
+ (rexec ssh-session (format #f "mkdir -p ~a" (dirname name)))
+ (call-with-remote-output-file
+ sftp-session name
+ (lambda (port)
+ (display content port)))
+ (sftp-chmod sftp-session name 755)
+ (let ((lines exit-code (rexec-verbose ssh-session
+ (format #f "~a 2>&1" name))))
+ (if (zero? exit-code)
+ lines
+ (raise-exception
+ (formatted-message
+ (G_ "failed to run script '~a' on machine, exit code: '~a'")
+ name exit-code))))))
+
+;; Prevent compiler from inlining this function, so we can mock it in tests.
+(set! hetzner-machine-ssh-run-script hetzner-machine-ssh-run-script)
+
+(define (hetzner-machine-rescue-install-os machine ssh-session server)
+ (let ((name (machine-display-name machine))
+ (os (hetzner-machine-bootstrap-os-form machine server)))
+ (format #t "installing guix operating system on '~a'...\n" name)
+ (hetzner-machine-ssh-run-script
+ ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-install-os"
+ (format #f "#!/usr/bin/env bash
+set -eo pipefail
+mount /dev/sda1 /mnt
+mkdir -p /mnt/boot/efi
+mount /dev/sda15 /mnt/boot/efi
+
+mkdir --parents /mnt/root/.ssh
+chmod 700 /mnt/root/.ssh
+cp /root/.ssh/authorized_keys /mnt/root/.ssh/authorized_keys
+chmod 600 /mnt/root/.ssh/authorized_keys
+
+cat > /tmp/guix/deploy/hetzner-os.scm << EOF
+(use-modules (gnu) (guix utils))
+(use-package-modules ssh)
+(use-service-modules base networking ssh)
+(use-system-modules linux-initrd)
+~a
+EOF
+guix system init --verbosity=2 /tmp/guix/deploy/hetzner-os.scm /mnt"
+ (escape-backticks (format #f "~y" os))))
+ (format #t "successfully installed guix operating system on '~a'\n" name)))
+
+(define (hetzner-machine-reboot machine server)
+ "Reboot the Hetzner SERVER for MACHINE."
+ (let* ((name (machine-display-name machine))
+ (config (machine-configuration machine))
+ (api (hetzner-configuration-api config)))
+ (format #t "rebooting server for '~a'...\n" name)
+ (let ((action (hetzner-api-server-reboot api server)))
+ (format #t "successfully rebooted server for '~a'\n" name)
+ action)))
+
+(define (hetzner-machine-rescue-partition machine ssh-session)
+ "Setup the partitions of the Hetzner server for MACHINE using SSH-SESSION."
+ (let* ((name (machine-display-name machine))
+ (os (machine-operating-system machine))
+ (root-fs-type (operating-system-root-file-system-type os)))
+ (format #t "setting up partitions on '~a'...\n" name)
+ (hetzner-machine-ssh-run-script
+ ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-partition"
+ (format #f "#!/usr/bin/env bash
+set -eo pipefail
+growpart /dev/sda 1 || true
+~a
+fdisk -l /dev/sda"
+ (cond
+ ((equal? "btrfs" root-fs-type)
+ (format #f "mkfs.btrfs -L ~a -f /dev/sda1" root-label))
+ ((equal? "ext4" root-fs-type)
+ (format #f "mkfs.ext4 -L ~a -F /dev/sda1" root-label))
+ (else (raise-exception
+ (formatted-message
+ (G_ "unsupported root file system type '~a'")
+ root-fs-type))))))
+ (format #t "successfully setup partitions on '~a'\n" name)))
+
+(define (hetzner-machine-rescue-install-packages machine ssh-session)
+ "Install packages on the Hetzner server for MACHINE using SSH-SESSION."
+ (let ((name (machine-display-name machine)))
+ (format #t "installing rescue system packages on '~a'...\n" name)
+ (hetzner-machine-ssh-run-script
+ ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-install-packages"
+ (format #f "#!/usr/bin/env bash
+set -eo pipefail
+apt-get update
+apt-get install guix cloud-initramfs-growroot --assume-yes"))
+ (format #t "successfully installed rescue system packages on '~a'\n" name)))
+
+(define (hetzner-machine-delete machine server)
+ "Delete the Hetzner server for MACHINE."
+ (let* ((name (machine-display-name machine))
+ (config (machine-configuration machine))
+ (api (hetzner-configuration-api config)))
+ (format #t "deleting server for '~a'...\n" name)
+ (let ((action (hetzner-api-server-delete api server)))
+ (format #t "successfully deleted server for '~a'\n" name)
+ action)))
+
+(define (hetzner-machine-provision machine)
+ "Provision a server for MACHINE on the Hetzner Cloud service."
+ (with-exception-handler
+ (lambda (exception)
+ (let ((config (machine-configuration machine))
+ (server (hetzner-machine-server machine)))
+ (when (and server (hetzner-configuration-delete? config))
+ (hetzner-machine-delete machine server))
+ (raise-exception exception)))
+ (lambda ()
+ (let ((server (hetzner-machine-create-server machine)))
+ (hetzner-machine-enable-rescue-system machine server)
+ (hetzner-machine-power-on machine server)
+ (let ((ssh-session (hetzner-machine-wait-for-ssh machine server)))
+ (hetzner-machine-rescue-install-packages machine ssh-session)
+ (hetzner-machine-rescue-partition machine ssh-session)
+ (hetzner-machine-rescue-install-os machine ssh-session server)
+ (hetzner-machine-reboot machine server)
+ (sleep 5)
+ (hetzner-machine-authenticate-host machine server)
+ server)))
+ #:unwind? #t))
+
+(define (machine-not-provisioned machine)
+ (formatted-message
+ (G_ "no server provisioned for machine '~a' on the Hetzner Cloud service")
+ (machine-display-name machine)))
+
+
+;;;
+;;; Remote evaluation.
+;;;
+
+(define (hetzner-remote-eval machine exp)
+ "Internal implementation of 'machine-remote-eval' for MACHINE instances with
+an environment type of 'hetzner-environment-type'."
+ (hetzner-machine-validate machine)
+ (let ((server (hetzner-machine-server machine)))
+ (unless server (raise-exception (machine-not-provisioned machine)))
+ (machine-remote-eval (hetzner-machine-delegate machine server) exp)))
+
+
+
+;;;
+;;; System deployment.
+;;;
+
+(define (deploy-hetzner machine)
+ "Internal implementation of 'deploy-machine' for 'machine' instances with an
+environment type of 'hetzner-environment-type'."
+ (hetzner-machine-validate machine)
+ (unless (hetzner-machine-ssh-key machine)
+ (hetzner-machine-ssh-key-create machine))
+ (let ((server (or (hetzner-machine-server machine)
+ (hetzner-machine-provision machine))))
+ (deploy-machine (hetzner-machine-delegate machine server))))
+
+
+
+;;;
+;;; Roll-back.
+;;;
+
+(define (roll-back-hetzner machine)
+ "Internal implementation of 'roll-back-machine' for MACHINE instances with an
+environment type of 'hetzner-environment-type'."
+ (hetzner-machine-validate machine)
+ (let ((server (hetzner-machine-server machine)))
+ (unless server (raise-exception (machine-not-provisioned machine)))
+ (roll-back-machine (hetzner-machine-delegate machine server))))
+
+
+
+;;;
+;;; Environment type.
+;;;
+
+(define hetzner-environment-type
+ (environment-type
+ (machine-remote-eval hetzner-remote-eval)
+ (deploy-machine deploy-hetzner)
+ (roll-back-machine roll-back-hetzner)
+ (name 'hetzner-environment-type)
+ (description "Provisioning of virtual machine servers on the Hetzner Cloud
+service.")))
diff --git a/gnu/machine/hetzner/http.scm b/gnu/machine/hetzner/http.scm
new file mode 100644
index 0000000000..bfd6555472
--- /dev/null
+++ b/gnu/machine/hetzner/http.scm
@@ -0,0 +1,664 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Roman Scherer <[email protected]>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu machine hetzner http)
+ #:use-module (guix diagnostics)
+ #:use-module (guix i18n)
+ #:use-module (guix records)
+ #:use-module (ice-9 iconv)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 pretty-print)
+ #:use-module (ice-9 textual-ports)
+ #:use-module (json)
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-2)
+ #:use-module (ssh key)
+ #:use-module (web client)
+ #:use-module (web request)
+ #:use-module (web response)
+ #:use-module (web uri)
+ #:export (%hetzner-default-api-token
+ %hetzner-default-server-image
+ %hetzner-default-server-location
+ %hetzner-default-server-type
+ hetzner-action
+ hetzner-action-command
+ hetzner-action-error
+ hetzner-action-finished
+ hetzner-action-id
+ hetzner-action-progress
+ hetzner-action-resources
+ hetzner-action-started
+ hetzner-action-status
+ hetzner-action?
+ hetzner-api
+ hetzner-api-action-wait
+ hetzner-api-actions
+ hetzner-api-create-ssh-key
+ hetzner-api-locations
+ hetzner-api-request-body
+ hetzner-api-request-headers
+ hetzner-api-request-method
+ hetzner-api-request-params
+ hetzner-api-request-send
+ hetzner-api-request-url
+ hetzner-api-request?
+ hetzner-api-response
+ hetzner-api-response-body
+ hetzner-api-response-headers
+ hetzner-api-response-status
+ hetzner-api-response?
+ hetzner-api-server-create
+ hetzner-api-server-delete
+ hetzner-api-server-enable-rescue-system
+ hetzner-api-server-power-off
+ hetzner-api-server-power-on
+ hetzner-api-server-reboot
+ hetzner-api-server-types
+ hetzner-api-servers
+ hetzner-api-ssh-key-create
+ hetzner-api-ssh-key-delete
+ hetzner-api-ssh-keys
+ hetzner-api-token
+ hetzner-api?
+ hetzner-error-code
+ hetzner-error-message
+ hetzner-error?
+ hetzner-ipv4-blocked?
+ hetzner-ipv4-dns-ptr
+ hetzner-ipv4-id
+ hetzner-ipv4-ip
+ hetzner-ipv4?
+ hetzner-ipv6-blocked?
+ hetzner-ipv6-dns-ptr
+ hetzner-ipv6-id
+ hetzner-ipv6-ip
+ hetzner-ipv6?
+ hetzner-location
+ hetzner-location-city
+ hetzner-location-country
+ hetzner-location-description
+ hetzner-location-id
+ hetzner-location-latitude
+ hetzner-location-longitude
+ hetzner-location-name
+ hetzner-location-network-zone
+ hetzner-location?
+ hetzner-public-net
+ hetzner-public-net-ipv4
+ hetzner-public-net-ipv6
+ hetzner-resource
+ hetzner-resource-id
+ hetzner-resource-type
+ hetzner-resource?
+ hetzner-server-architecture
+ hetzner-server-created
+ hetzner-server-id
+ hetzner-server-labels
+ hetzner-server-name
+ hetzner-server-public-ipv4
+ hetzner-server-public-net
+ hetzner-server-rescue-enabled?
+ hetzner-server-system
+ hetzner-server-type
+ hetzner-server-type-architecture
+ hetzner-server-type-cores
+ hetzner-server-type-cpu-type
+ hetzner-server-type-deprecated
+ hetzner-server-type-deprecation
+ hetzner-server-type-description
+ hetzner-server-type-disk
+ hetzner-server-type-id
+ hetzner-server-type-memory
+ hetzner-server-type-name
+ hetzner-server-type-storage-type
+ hetzner-server-type?
+ hetzner-server?
+ hetzner-ssh-key-created
+ hetzner-ssh-key-fingerprint
+ hetzner-ssh-key-id
+ hetzner-ssh-key-labels
+ hetzner-ssh-key-name
+ hetzner-ssh-key-public-key
+ hetzner-ssh-key-read-file
+ hetzner-ssh-key?
+ make-hetzner-action
+ make-hetzner-error
+ make-hetzner-ipv4
+ make-hetzner-ipv6
+ make-hetzner-location
+ make-hetzner-public-net
+ make-hetzner-resource
+ make-hetzner-server
+ make-hetzner-server-type
+ make-hetzner-ssh-key))
+
+;;; Commentary:
+;;;
+;;; This module implements a lower-level interface for interacting with the
+;;; Hetzner Cloud API https://docs.hetzner.cloud.
+;;;
+
+(define %hetzner-default-api-token
+ (make-parameter (getenv "GUIX_HETZNER_API_TOKEN")))
+
+;; Ideally this would be a Guix image. Maybe one day.
+(define %hetzner-default-server-image "debian-11")
+
+;; Falkenstein, Germany
+(define %hetzner-default-server-location "fsn1")
+
+;; x86, 8 VCPUs, 16 GB mem, 160 GB disk
+(define %hetzner-default-server-type "cx42")
+
+
+;;;
+;;; Helper functions.
+;;;
+
+(define (format-query-param param)
+ "Format the query PARAM as a string."
+ (string-append (uri-encode (format #f "~a" (car param))) "="
+ (uri-encode (format #f "~a" (cdr param)))))
+
+(define (format-query-params params)
+ "Format the query PARAMS as a string."
+ (if (> (length params) 0)
+ (string-append
+ "?"
+ (string-join
+ (map format-query-param params)
+ "&"))
+ ""))
+
+(define (json->maybe-hetzner-error json)
+ (and (list? json) (json->hetzner-error json)))
+
+(define (string->time s)
+ (when (string? s) (car (strptime "%FT%T%z" s))))
+
+(define (json->hetzner-dnses vector)
+ (map json->hetzner-dns (vector->list vector)))
+
+(define (json->hetzner-resources vector)
+ (map json->hetzner-resource (vector->list vector)))
+
+
+;;;
+;;; Domain models.
+;;;
+
+(define-json-mapping <hetzner-action>
+ make-hetzner-action hetzner-action? json->hetzner-action
+ (command hetzner-action-command) ; string
+ (error hetzner-action-error "error"
+ json->maybe-hetzner-error) ; <hetzner-error> | #f
+ (finished hetzner-action-finished "finished" string->time) ; time
+ (id hetzner-action-id) ; integer
+ (progress hetzner-action-progress) ; integer
+ (resources hetzner-action-resources "resources"
+ json->hetzner-resources) ; list of <hetzner-resource>
+ (started hetzner-action-started "started" string->time) ; time
+ (status hetzner-action-status))
+
+(define-json-mapping <hetzner-deprecation>
+ make-hetzner-deprecation hetzner-deprecation? json->hetzner-deprecation
+ (announced hetzner-deprecation-announced) ; string
+ (unavailable-after hetzner-deprecation-unavailable-after
+ "unavailable_after")) ; string
+
+(define-json-mapping <hetzner-dns>
+ make-hetzner-dns hetzner-dns? json->hetzner-dns
+ (ip hetzner-dns-ip) ; string
+ (ptr hetzner-dns-ptr "dns_ptr")) ; string
+
+(define-json-mapping <hetzner-error>
+ make-hetzner-error hetzner-error? json->hetzner-error
+ (code hetzner-error-code) ; string
+ (message hetzner-error-message)) ; <string>
+
+(define-json-mapping <hetzner-ipv4>
+ make-hetzner-ipv4 hetzner-ipv4? json->hetzner-ipv4
+ (blocked? hetzner-ipv4-blocked? "blocked") ; boolean
+ (dns-ptr hetzner-ipv4-dns-ptr "dns_ptr") ; string
+ (id hetzner-ipv4-id) ; integer
+ (ip hetzner-ipv4-ip)) ; string
+
+(define-json-mapping <hetzner-ipv6>
+ make-hetzner-ipv6 hetzner-ipv6? json->hetzner-ipv6
+ (blocked? hetzner-ipv6-blocked? "blocked") ; boolean
+ (dns-ptr hetzner-ipv6-dns-ptr "dns_ptr"
+ json->hetzner-dnses) ; list of <hetzner-dns>
+ (id hetzner-ipv6-id) ; integer
+ (ip hetzner-ipv6-ip)) ; string
+
+(define-json-mapping <hetzner-location>
+ make-hetzner-location hetzner-location? json->hetzner-location
+ (city hetzner-location-city) ; string
+ (country hetzner-location-country) ; string
+ (description hetzner-location-description) ; string
+ (id hetzner-location-id) ; integer
+ (latitude hetzner-location-latitude) ; decimal
+ (longitude hetzner-location-longitude) ; decimal
+ (name hetzner-location-name) ; string
+ (network-zone hetzner-location-network-zone "network_zone"))
+
+(define-json-mapping <hetzner-public-net>
+ make-hetzner-public-net hetzner-public-net? json->hetzner-public-net
+ (ipv4 hetzner-public-net-ipv4 "ipv4" json->hetzner-ipv4) ; <hetzner-ipv4>
+ (ipv6 hetzner-public-net-ipv6 "ipv6" json->hetzner-ipv6)) ; <hetzner-ipv6>
+
+(define-json-mapping <hetzner-resource>
+ make-hetzner-resource hetzner-resource? json->hetzner-resource
+ (id hetzner-resource-id) ; integer
+ (type hetzner-resource-type)) ; string
+
+(define-json-mapping <hetzner-server>
+ make-hetzner-server hetzner-server? json->hetzner-server
+ (created hetzner-server-created) ; time
+ (id hetzner-server-id) ; integer
+ (labels hetzner-server-labels) ; alist of string/string
+ (name hetzner-server-name) ; string
+ (public-net hetzner-server-public-net "public_net"
+ json->hetzner-public-net) ; <hetzner-public-net>
+ (rescue-enabled? hetzner-server-rescue-enabled? "rescue_enabled") ; boolean
+ (server-type hetzner-server-type "server_type"
+ json->hetzner-server-type)) ; <hetzner-server-type>
+
+(define-json-mapping <hetzner-server-type>
+ make-hetzner-server-type hetzner-server-type? json->hetzner-server-type
+ (architecture hetzner-server-type-architecture) ; string
+ (cores hetzner-server-type-cores) ; integer
+ (cpu-type hetzner-server-type-cpu-type "cpu_type") ; string
+ (deprecated hetzner-server-type-deprecated) ; boolean
+ (deprecation hetzner-server-type-deprecation
+ json->hetzner-deprecation) ; <hetzner-deprecation>
+ (description hetzner-server-type-description) ; string
+ (disk hetzner-server-type-disk) ; integer
+ (id hetzner-server-type-id) ; integer
+ (memory hetzner-server-type-memory) ; integer
+ (name hetzner-server-type-name) ; string
+ (storage-type hetzner-server-type-storage-type "storage_type")) ; string
+
+(define-json-mapping <hetzner-ssh-key>
+ make-hetzner-ssh-key hetzner-ssh-key? json->hetzner-ssh-key
+ (created hetzner-ssh-key-created "created" string->time) ; time
+ (fingerprint hetzner-ssh-key-fingerprint) ; string
+ (id hetzner-ssh-key-id) ; integer
+ (labels hetzner-ssh-key-labels) ; alist of string/string
+ (name hetzner-ssh-key-name) ; string
+ (public_key hetzner-ssh-key-public-key "public_key")) ; string
+
+(define (hetzner-server-architecture server)
+ "Return the architecture of the Hetzner SERVER."
+ (hetzner-server-type-architecture (hetzner-server-type server)))
+
+(define* (hetzner-server-path server #:optional (path ""))
+ "Return the PATH of the Hetzner SERVER."
+ (format #f "/servers/~a~a" (hetzner-server-id server) path))
+
+(define (hetzner-server-public-ipv4 server)
+ "Return the public IPv4 address of the SERVER."
+ (and-let* ((public-net (hetzner-server-public-net server))
+ (ipv4 (hetzner-public-net-ipv4 public-net)))
+ (hetzner-ipv4-ip ipv4)))
+
+(define (hetzner-server-system server)
+ "Return the Guix system architecture of the Hetzner SERVER."
+ (match (hetzner-server-architecture server)
+ ("arm" "aarch64-linux")
+ ("x86" "x86_64-linux")))
+
+(define* (hetzner-ssh-key-path ssh-key #:optional (path ""))
+ "Return the PATH of the Hetzner SSH-KEY."
+ (format #f "/ssh_keys/~a~a" (hetzner-ssh-key-id ssh-key) path))
+
+(define (hetzner-ssh-key-read-file file)
+ "Read the SSH private key from FILE and return a Hetzner SSH key."
+ (let* ((privkey (private-key-from-file file))
+ (pubkey (private-key->public-key privkey))
+ (hash (get-public-key-hash pubkey 'md5))
+ (fingerprint (bytevector->hex-string hash))
+ (public-key (format #f "ssh-~a ~a" (get-key-type pubkey)
+ (public-key->string pubkey))))
+ (make-hetzner-ssh-key #f fingerprint #f '() (basename file) public-key)))
+
+
+;;;
+;;; Hetzner API response.
+;;;
+
+(define-record-type* <hetzner-api-response>
+ hetzner-api-response make-hetzner-api-response hetzner-api-response?
+ (body hetzner-api-response-body (default *unspecified*))
+ (headers hetzner-api-response-headers (default '()))
+ (status hetzner-api-response-status (default 200)))
+
+(define (hetzner-api-response-meta response)
+ "Return the meta information of the Hetzner API response."
+ (assoc-ref (hetzner-api-response-body response) "meta"))
+
+(define (hetzner-api-response-pagination response)
+ "Return the meta information of the Hetzner API response."
+ (assoc-ref (hetzner-api-response-meta response) "pagination"))
+
+(define (hetzner-api-response-pagination-combine resource responses)
+ "Combine multiple Hetzner API pagination responses into a single response."
+ (if (positive? (length responses))
+ (let* ((response (car responses))
+ (pagination (hetzner-api-response-pagination response))
+ (total-entries (assoc-ref pagination "total_entries")))
+ (hetzner-api-response
+ (inherit response)
+ (body `(("meta"
+ ("pagination"
+ ("last_page" . 1)
+ ("next_page" . null)
+ ("page" . 1)
+ ("per_page" . ,total-entries)
+ ("previous_page" . null)
+ ("total_entries" . ,total-entries)))
+ (,resource . ,(append-map
+ (lambda (body)
+ (vector->list (assoc-ref body resource)))
+ (map hetzner-api-response-body responses)))))))
+ (raise-exception
+ (formatted-message
+ (G_ "expected a list of Hetzner API responses")))))
+
+(define (hetzner-api-body-action body)
+ "Return the Hetzner API action from BODY."
+ (let ((json (assoc-ref body "action")))
+ (and json (json->hetzner-action json))))
+
+(define (hetzner-api-response-read port)
+ "Read the Hetzner API response from PORT."
+ (let* ((response (read-response port))
+ (body (read-response-body response)))
+ (hetzner-api-response
+ (body (and body (json-string->scm (utf8->string body))))
+ (headers (response-headers response))
+ (status (response-code response)))))
+
+(define (hetzner-api-response-validate-status response expected)
+ "Raise an error if the HTTP status code of RESPONSE is not in EXPECTED."
+ (when (not (member (hetzner-api-response-status response) expected))
+ (raise-exception
+ (formatted-message
+ (G_ "unexpected HTTP status code: ~a, expected: ~a~%~a")
+ (hetzner-api-response-status response)
+ expected
+ (with-output-to-string
+ (lambda ()
+ (pretty-print (hetzner-api-response-body response))))))))
+
+
+;;;
+;;; Hetzner API request.
+;;;
+
+(define-record-type* <hetzner-api-request>
+ hetzner-api-request make-hetzner-api-request hetzner-api-request?
+ (body hetzner-api-request-body (default *unspecified*))
+ (headers hetzner-api-request-headers (default '()))
+ (method hetzner-api-request-method (default 'GET))
+ (params hetzner-api-request-params (default '()))
+ (url hetzner-api-request-url))
+
+(define (hetzner-api-request-uri request)
+ "Return the URI object of the Hetzner API request."
+ (let ((params (hetzner-api-request-params request)))
+ (string->uri (string-append (hetzner-api-request-url request)
+ (format-query-params params)))))
+
+(define (hetzner-api-request-body-bytevector request)
+ "Return the body of the Hetzner API REQUEST as a bytevector."
+ (let ((body (hetzner-api-request-body request)))
+ (string->utf8 (if (unspecified? body) "" (scm->json-string body)))))
+
+(define (hetzner-api-request-write port request)
+ "Write the Hetzner API REQUEST to PORT."
+ (let* ((body (hetzner-api-request-body-bytevector request))
+ (request (build-request
+ (hetzner-api-request-uri request)
+ #:method (hetzner-api-request-method request)
+ #:version '(1 . 1)
+ #:headers (cons* `(Content-Length
+ . ,(number->string
+ (if (unspecified? body)
+ 0 (bytevector-length body))))
+ (hetzner-api-request-headers request))
+ #:port port))
+ (request (write-request request port)))
+ (unless (unspecified? body)
+ (write-request-body request body))
+ (force-output (request-port request))))
+
+(define* (hetzner-api-request-send request #:key (expected (list 200 201 204)))
+ "Send the Hetzner API REQUEST via HTTP."
+ (let ((port (open-socket-for-uri (hetzner-api-request-uri request))))
+ (hetzner-api-request-write port request)
+ (let ((response (hetzner-api-response-read port)))
+ (close-port port)
+ (hetzner-api-response-validate-status response expected)
+ response)))
+
+;; Prevent compiler from inlining this function, so we can mock it in tests.
+(set! hetzner-api-request-send hetzner-api-request-send)
+
+(define (hetzner-api-request-next-params request)
+ "Return the pagination params for the next page of the REQUEST."
+ (let* ((params (hetzner-api-request-params request))
+ (page (or (assoc-ref params "page") 1)))
+ (map (lambda (param)
+ (if (equal? "page" (car param))
+ (cons (car param) (+ page 1))
+ param))
+ params)))
+
+(define (hetzner-api-request-paginate request)
+ "Fetch all pages of the REQUEST via pagination and return all responses."
+ (let* ((response (hetzner-api-request-send request))
+ (pagination (hetzner-api-response-pagination response))
+ (next-page (assoc-ref pagination "next_page")))
+ (if (number? next-page)
+ (cons response
+ (hetzner-api-request-paginate
+ (hetzner-api-request
+ (inherit request)
+ (params (hetzner-api-request-next-params request)))))
+ (list response))))
+
+
+
+;;;
+;;; Hetzner API.
+;;;
+
+(define-record-type* <hetzner-api>
+ hetzner-api make-hetzner-api hetzner-api?
+ (base-url hetzner-api-base-url ; string
+ (default "https://api.hetzner.cloud/v1"))
+ (token hetzner-api-token ; string
+ (default (%hetzner-default-api-token))))
+
+(define (hetzner-api-authorization-header api)
+ "Return the authorization header for the Hetzner API."
+ (format #f "Bearer ~a" (hetzner-api-token api)))
+
+(define (hetzner-api-default-headers api)
+ "Returns the default headers of the Hetzner API."
+ `((user-agent . "Guix Deploy")
+ (Accept . "application/json")
+ (Authorization . ,(hetzner-api-authorization-header api))
+ (Content-Type . "application/json")))
+
+(define (hetzner-api-url api path)
+ "Append PATH to the base url of the Hetzner API."
+ (string-append (hetzner-api-base-url api) path))
+
+(define (hetzner-api-delete api path)
+ "Delelte the resource at PATH with the Hetzner API."
+ (hetzner-api-response-body
+ (hetzner-api-request-send
+ (hetzner-api-request
+ (headers (hetzner-api-default-headers api))
+ (method 'DELETE)
+ (url (hetzner-api-url api path))))))
+
+(define* (hetzner-api-list api path resources json->object #:key (params '()))
+ "Fetch all objects of RESOURCE from the Hetzner API."
+ (let ((body (hetzner-api-response-body
+ (hetzner-api-response-pagination-combine
+ resources (hetzner-api-request-paginate
+ (hetzner-api-request
+ (url (hetzner-api-url api path))
+ (headers (hetzner-api-default-headers api))
+ (params (cons '("page" . 1) params))))))))
+ (map json->object (assoc-ref body resources))))
+
+(define* (hetzner-api-post api path #:key (body *unspecified*))
+ "Send a POST request to the Hetzner API at PATH using BODY."
+ (hetzner-api-response-body
+ (hetzner-api-request-send
+ (hetzner-api-request
+ (body body)
+ (method 'POST)
+ (url (hetzner-api-url api path))
+ (headers (hetzner-api-default-headers api))))))
+
+(define (hetzner-api-actions api ids)
+ "Get actions from the Hetzner API."
+ (if (zero? (length ids))
+ (raise-exception
+ (formatted-message
+ (G_ "expected at least one action id, but got '~a'")
+ (length ids)))
+ (hetzner-api-list
+ api "/actions" "actions" json->hetzner-action
+ #:params `(("id" . ,(string-join (map number->string ids) ","))))))
+
+(define* (hetzner-api-action-wait api action #:optional (status "success"))
+ "Wait until the ACTION has reached STATUS on the Hetzner API."
+ (let ((id (hetzner-action-id action)))
+ (let loop ()
+ (let ((actions (hetzner-api-actions api (list id))))
+ (cond
+ ((zero? (length actions))
+ (raise-exception
+ (formatted-message (G_ "server action '~a' not found") id)))
+ ((not (= 1 (length actions)))
+ (raise-exception
+ (formatted-message
+ (G_ "expected one server action, but got '~a'")
+ (length actions))))
+ ((string= status (hetzner-action-status (car actions)))
+ (car actions))
+ (else
+ (sleep 5)
+ (loop)))))))
+
+(define* (hetzner-api-locations api . options)
+ "Get deployment locations from the Hetzner API."
+ (apply hetzner-api-list api "/locations" "locations" json->hetzner-location options))
+
+(define* (hetzner-api-server-create
+ api name ssh-keys
+ #:key
+ (enable-ipv4? #t)
+ (enable-ipv6? #t)
+ (image %hetzner-default-server-image)
+ (labels '())
+ (location %hetzner-default-server-location)
+ (public-net #f)
+ (server-type %hetzner-default-server-type)
+ (start-after-create? #f))
+ "Create a server with the Hetzner API."
+ (let ((body (hetzner-api-post
+ api "/servers"
+ #:body `(("image" . ,image)
+ ("labels" . ,labels)
+ ("name" . ,name)
+ ("public_net"
+ . (("enable_ipv4" . ,enable-ipv4?)
+ ("enable_ipv6" . ,enable-ipv6?)))
+ ("location" . ,location)
+ ("server_type" . ,server-type)
+ ("ssh_keys" . ,(apply vector (map hetzner-ssh-key-id ssh-keys)))
+ ("start_after_create" . ,start-after-create?)))))
+ (hetzner-api-action-wait api (hetzner-api-body-action body))
+ (json->hetzner-server (assoc-ref body "server"))))
+
+(define (hetzner-api-server-delete api server)
+ "Delete the SERVER with the Hetzner API."
+ (let ((body (hetzner-api-delete api (hetzner-server-path server))))
+ (hetzner-api-action-wait api (hetzner-api-body-action body))))
+
+(define* (hetzner-api-server-enable-rescue-system
+ api server ssh-keys #:key (type "linux64"))
+ "Enable the rescue system for SERVER with the Hetzner API."
+ (let* ((ssh-keys (apply vector (map hetzner-ssh-key-id ssh-keys)))
+ (body (hetzner-api-post
+ api (hetzner-server-path server "/actions/enable_rescue")
+ #:body `(("ssh_keys" . ,ssh-keys)
+ ("type" . ,type)))))
+ (hetzner-api-action-wait api (hetzner-api-body-action body))))
+
+(define* (hetzner-api-servers api . options)
+ "Get servers from the Hetzner API."
+ (apply hetzner-api-list api "/servers" "servers" json->hetzner-server options))
+
+(define (hetzner-api-server-power-on api server)
+ "Send a power on request for SERVER to the Hetzner API."
+ (let ((body (hetzner-api-post api (hetzner-server-path server "/actions/poweron"))))
+ (hetzner-api-action-wait api (hetzner-api-body-action body))))
+
+(define (hetzner-api-server-power-off api server)
+ "Send a power off request for SERVER to the Hetzner API."
+ (let ((body (hetzner-api-post api (hetzner-server-path server "/actions/poweroff"))))
+ (hetzner-api-action-wait api (hetzner-api-body-action body))))
+
+(define (hetzner-api-server-reboot api server)
+ "Send a reboot request for SERVER to the Hetzner API."
+ (let ((body (hetzner-api-post api (hetzner-server-path server "/actions/reboot"))))
+ (hetzner-api-action-wait api (hetzner-api-body-action body))))
+
+(define* (hetzner-api-ssh-key-create api name public-key #:key (labels '()))
+ "Create a SSH key with the Hetzner API."
+ (let ((body (hetzner-api-post
+ api "/ssh_keys"
+ #:body `(("name" . ,name)
+ ("public_key" . ,public-key)
+ ("labels" . ,labels)))))
+ (json->hetzner-ssh-key (assoc-ref body "ssh_key"))))
+
+(define (hetzner-api-ssh-key-delete api ssh-key)
+ "Delete the SSH key on the Hetzner API."
+ (hetzner-api-delete api (hetzner-ssh-key-path ssh-key))
+ #t)
+
+(define* (hetzner-api-ssh-keys api . options)
+ "Get SSH keys from the Hetzner API."
+ (apply hetzner-api-list api "/ssh_keys" "ssh_keys"
+ json->hetzner-ssh-key options))
+
+(define* (hetzner-api-server-types api . options)
+ "Get server types from the Hetzner API."
+ (apply hetzner-api-list api "/server_types" "server_types"
+ json->hetzner-server-type options))