amaharaneko/guix-mirrors
1
1
Fork 0
mirror of https://codeberg.org/guix/guix.git synced 2025-10-02 02:15:12 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

machine: Implement 'hetzner-environment-type'.

Browse source 
* 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 <ludo@gnu.org>
This commit is contained in:
Roman Scherer 2025-02-04 20:01:14 +01:00 • committed by Ludovic Courtès
parent 96f05f003a
commit 0753a17ddf
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
8 changed files with 2402 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

2
Makefile.am
View file

@ -567,6 +567,8 @@ SCM_TESTS = \
tests/import-utils.scm \ tests/import-utils.scm \
tests/inferior.scm \ tests/inferior.scm \
tests/lint.scm \ tests/lint.scm \
tests/machine/hetzner.scm \
tests/machine/hetzner/http.scm \
tests/minetest.scm \ tests/minetest.scm \
tests/modules.scm \ tests/modules.scm \
tests/monads.scm \ tests/monads.scm \

129
doc/guix.texi
View file

@ -44877,6 +44877,135 @@ Whether or not the droplet should be created with IPv6 networking.
@end table @end table
@end deftp @end deftp
@deftp {Data Type} hetzner-configuration
This is the data type describing the server that should be created for a
machine with an @code{environment} of
@code{hetzner-environment-type}. It allows you to configure deployment
to a @acronym{VPS, virtual private server} hosted by
@uref{https://www.hetzner.com, Hetzner}.
@table @asis
@item @code{allow-downgrades?} (default: @code{#f})
Whether to allow potential downgrades.
@item @code{authorize?} (default: @code{#t})
If true, the public signing key @code{"/etc/guix/signing-key.pub"} of
the machine that invokes @command{guix deploy} will be added to the
operating system ACL keyring of the target machine.
@item @code{build-locally?} (default: @code{#t})
If true, system derivations will be built on the machine that invokes
@command{guix deploy}, otherwise derivations are build on the target
machine. Set this to @code{#f} if the machine you are deploying from
has a different architecture than the target machine and you can't build
derivations for the target architecture by other means, like offloading
(@pxref{Daemon Offload Setup}) or emulation
(@pxref{transparent-emulation-qemu, Transparent Emulation with QEMU}).
@item @code{delete?} (default: @code{#t})
If true, the server will be deleted when an error happens in the
provisioning phase. If false, the server will be kept in order to debug
any issues.
@item @code{labels} (default: @code{'()})
A user defined alist of key/value pairs attached to the SSH key and the
server on the Hetzner API. Keys and values must be strings,
e.g. @code{'(("environment" . "development"))}. For more information,
see @uref{https://docs.hetzner.cloud/#labels, Labels}.
@item @code{location} (default: @code{"fsn1"})
The name of a @uref{https://docs.hetzner.com/cloud/general/locations,
location} to create the server in. For example, @code{"fsn1"}
corresponds to the Hetzner site in Falkenstein, Germany, while
@code{"sin"} corresponds to its site in Singapore.
@item @code{server-type} (default: @code{"cx42"})
The name of the
@uref{https://docs.hetzner.com/cloud/servers/overview#server-types,
server type} this virtual server should be created with. For example,
@code{"cx42"} corresponds to a x86_64 server that has 8 VCPUs, 16 GB of
memory and 160 GB of storage, while @code{"cax31"} to the AArch64
equivalent. Other server types and their current prices can be found
@uref{https://www.hetzner.com/cloud/#pricing, here}.
@item @code{ssh-key}
The file name of the SSH private key to use to authenticate with the
remote host.
@end table
When deploying a machine for the first time, the following steps are
taken to provision a server for the machine on the
@uref{https://www.hetzner.com/cloud, Hetzner Cloud} service:
@itemize
@item
Create the SSH key of the machine on the Hetzner API.
@item
Create a server for the machine on the Hetzner API.
@item
Format the root partition of the disk using the file system of the
machine's operating system. Supported file systems are btrfs and ext4.
@item
Install a minimal Guix operating system on the server using the
@uref{https://docs.hetzner.com/cloud/servers/getting-started/rescue-system,
rescue mode}. This minimal system is used to install the machine's
operating system, after rebooting.
@item
Reboot the server and apply the machine's operating system on the
server.
@end itemize
Once the server has been provisioned and SSH is available, deployment
continues by delegating it to the @code{managed-host-environment-type}.
Servers on the Hetzner Cloud service can be provisioned on the AArch64
architecture using UEFI boot mode, or on the x86_64 architecture using
BIOS boot mode. The @code{(gnu machine hetzner)} module exports the
@code{%hetzner-os-arm} and @code{%hetzner-os-x86} operating systems that
are compatible with those two architectures, and can be used as a base
for defining your custom operating system.
The following example shows the definition of two machines that are
deployed on the Hetzner Cloud service. The first one uses the
@code{%hetzner-os-arm} operating system to run a server with 16 shared
vCPUs and 32 GB of RAM on the @code{aarch64} architecture, the second
one uses the @code{%hetzner-os-x86} operating system on a server with 16
shared vCPUs and 32 GB of RAM on the @code{x86_64} architecture.
@lisp
(use-modules (gnu machine)
(gnu machine hetzner))
(list (machine
(operating-system %hetzner-os-arm)
(environment hetzner-environment-type)
(configuration (hetzner-configuration
(server-type "cax41")
(ssh-key "/home/charlie/.ssh/id_rsa"))))
(machine
(operating-system %hetzner-os-x86)
(environment hetzner-environment-type)
(configuration (hetzner-configuration
(server-type "cpx51")
(ssh-key "/home/charlie/.ssh/id_rsa")))))
@end lisp
@vindex GUIX_HETZNER_API_TOKEN
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 @node Running Guix in a VM
@section Running Guix in a Virtual Machine @section Running Guix in a Virtual Machine

2
gnu/local.mk
View file

@ -921,6 +921,8 @@ if HAVE_GUILE_SSH
GNU_SYSTEM_MODULES += \ GNU_SYSTEM_MODULES += \
%D%/machine/digital-ocean.scm \ %D%/machine/digital-ocean.scm \
%D%/machine/hetzner.scm \
%D%/machine/hetzner/http.scm \
%D%/machine/ssh.scm %D%/machine/ssh.scm
endif HAVE_GUILE_SSH endif HAVE_GUILE_SSH

705
gnu/machine/hetzner.scm Normal file
View file

@ -0,0 +1,705 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2024 Roman Scherer <roman@burningswell.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu machine hetzner)
#:use-module (gnu bootloader grub)
#:use-module (gnu bootloader)
#:use-module (gnu machine hetzner http)
#:use-module (gnu machine ssh)
#:use-module (gnu machine)
#:use-module (gnu packages ssh)
#:use-module (gnu services base)
#:use-module (gnu services networking)
#:use-module (gnu services ssh)
#:use-module (gnu services)
#:use-module (gnu system file-systems)
#:use-module (gnu system image)
#:use-module (gnu system linux-initrd)
#:use-module (gnu system pam)
#:use-module (gnu system)
#:use-module (guix base32)
#:use-module (guix colors)
#:use-module (guix derivations)
#:use-module (guix diagnostics)
#:use-module (guix gexp)
#:use-module (guix i18n)
#:use-module (guix import json)
#:use-module (guix monads)
#:use-module (guix packages)
#:use-module (guix pki)
#:use-module (guix records)
#:use-module (guix ssh)
#:use-module (guix store)
#:use-module (ice-9 format)
#:use-module (ice-9 iconv)
#:use-module (ice-9 match)
#:use-module (ice-9 popen)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 string-fun)
#:use-module (ice-9 textual-ports)
#:use-module (json)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (srfi srfi-71)
#:use-module (ssh channel)
#:use-module (ssh key)
#:use-module (ssh popen)
#:use-module (ssh session)
#:use-module (ssh sftp)
#:use-module (ssh shell)
#:export (%hetzner-os-arm
%hetzner-os-x86
deploy-hetzner
hetzner-configuration
hetzner-configuration-allow-downgrades?
hetzner-configuration-api
hetzner-configuration-authorize?
hetzner-configuration-build-locally?
hetzner-configuration-delete?
hetzner-configuration-labels
hetzner-configuration-location
hetzner-configuration-server-type
hetzner-configuration-ssh-key
hetzner-configuration?
hetzner-environment-type))
;;; Commentary:
;;;
;;; This module implements a high-level interface for provisioning machines on
;;; the Hetzner Cloud service https://docs.hetzner.cloud.
;;;
;;;
;;; Hetzner operating systems.
;;;
;; Operating system for arm servers using UEFI boot mode.
(define %hetzner-os-arm
(operating-system
(host-name "guix-arm")
(bootloader
(bootloader-configuration
(bootloader grub-efi-bootloader)
(targets (list "/boot/efi"))
(terminal-outputs '(console))))
(file-systems
(cons* (file-system
(mount-point "/")
(device "/dev/sda1")
(type "ext4"))
(file-system
(mount-point "/boot/efi")
(device "/dev/sda15")
(type "vfat"))
%base-file-systems))
(initrd-modules
(cons* "sd_mod" "virtio_scsi" %base-initrd-modules))
(services
(cons* (service dhcp-client-service-type)
(service openssh-service-type
(openssh-configuration
(openssh openssh-sans-x)
(permit-root-login 'prohibit-password)))
%base-services))))
;; Operating system for x86 servers using BIOS boot mode.
(define %hetzner-os-x86
(operating-system
(inherit %hetzner-os-arm)
(host-name "guix-x86")
(bootloader
(bootloader-configuration
(bootloader grub-bootloader)
(targets (list "/dev/sda"))
(terminal-outputs '(console))))
(initrd-modules
(cons "virtio_scsi" %base-initrd-modules))
(file-systems
(cons (file-system
(mount-point "/")
(device "/dev/sda1")
(type "ext4"))
%base-file-systems))))
(define (operating-system-authorize os)
"Authorize the OS with the public signing key of the current machine."
(if (file-exists? %public-key-file)
(operating-system
(inherit os)
(services
(modify-services (operating-system-user-services os)
(guix-service-type
config => (guix-configuration
(inherit config)
(authorized-keys
(cons*
(local-file %public-key-file)
(guix-configuration-authorized-keys config))))))))
(raise-exception
(formatted-message (G_ "no signing key '~a'. \
Have you run 'guix archive --generate-key'?")
%public-key-file))))
(define (operating-system-root-file-system-type os)
"Return the root file system type of the operating system OS."
(let ((root-fs (find (lambda (file-system)
(equal? "/" (file-system-mount-point file-system)))
(operating-system-file-systems os))))
(if (file-system? root-fs)
(file-system-type root-fs)
(raise-exception
(formatted-message
(G_ "could not determine root file system type"))))))
;;;
;;; Helper functions.
;;;
(define (escape-backticks str)
"Escape all backticks in STR."
(string-replace-substring str "`" "\\`"))
;;;
;;; Hetzner configuration.
;;;
(define-record-type* <hetzner-configuration> hetzner-configuration
make-hetzner-configuration hetzner-configuration? this-hetzner-configuration
(allow-downgrades? hetzner-configuration-allow-downgrades? ; boolean
(default #f))
(api hetzner-configuration-api ; <hetzner-api>
(default (hetzner-api)))
(authorize? hetzner-configuration-authorize? ; boolean
(default #t))
(build-locally? hetzner-configuration-build-locally? ; boolean
(default #t))
(delete? hetzner-configuration-delete? ; boolean
(default #f))
(labels hetzner-configuration-labels ; list of strings
(default '()))
(location hetzner-configuration-location ; #f | string
(default "fsn1"))
(server-type hetzner-configuration-server-type ; string
(default "cx42"))
(ssh-key hetzner-configuration-ssh-key)) ; string
(define (hetzner-configuration-ssh-key-fingerprint config)
"Return the SSH public key fingerprint of CONFIG as a string."
(and-let* ((file-name (hetzner-configuration-ssh-key config))
(privkey (private-key-from-file file-name))
(pubkey (private-key->public-key privkey))
(hash (get-public-key-hash pubkey 'md5)))
(bytevector->hex-string hash)))
(define (hetzner-configuration-ssh-key-public config)
"Return the SSH public key of CONFIG as a string."
(and-let* ((ssh-key (hetzner-configuration-ssh-key config))
(public-key (public-key-from-file ssh-key)))
(format #f "ssh-~a ~a" (get-key-type public-key)
(public-key->string public-key))))
;;;
;;; Hetzner Machine.
;;;
(define (hetzner-machine-delegate target server)
"Return the delagate machine that uses SSH for deployment."
(let* ((config (machine-configuration target))
;; Get the operating system WITHOUT the provenance service to avoid a
;; duplicate symlink conflict in the store.
(os ((@@ (gnu machine) %machine-operating-system) target)))
(machine
(inherit target)
(operating-system
(if (hetzner-configuration-authorize? config)
(operating-system-authorize os)
os))
(environment managed-host-environment-type)
(configuration
(machine-ssh-configuration
(allow-downgrades? (hetzner-configuration-allow-downgrades? config))
(authorize? (hetzner-configuration-authorize? config))
(build-locally? (hetzner-configuration-build-locally? config))
(host-name (hetzner-server-public-ipv4 server))
(identity (hetzner-configuration-ssh-key config))
(system (hetzner-server-system server)))))))
(define (hetzner-machine-location machine)
"Find the location of MACHINE on the Hetzner API."
(let* ((config (machine-configuration machine))
(expected (hetzner-configuration-location config)))
(find (lambda (location)
(equal? expected (hetzner-location-name location)))
(hetzner-api-locations
(hetzner-configuration-api config)
#:params `(("name" . ,expected))))))
(define (hetzner-machine-server-type machine)
"Find the server type of MACHINE on the Hetzner API."
(let* ((config (machine-configuration machine))
(expected (hetzner-configuration-server-type config)))
(find (lambda (server-type)
(equal? expected (hetzner-server-type-name server-type)))
(hetzner-api-server-types
(hetzner-configuration-api config)
#:params `(("name" . ,expected))))))
(define (hetzner-machine-validate-api-token machine)
"Validate the Hetzner API authentication token of MACHINE."
(let* ((config (machine-configuration machine))
(api (hetzner-configuration-api config)))
(unless (hetzner-api-token api)
(raise-exception
(formatted-message
(G_ "Hetzner Cloud access token was not provided. \
This may be fixed by setting the environment variable GUIX_HETZNER_API_TOKEN \
to one procured from \
https://docs.hetzner.com/cloud/api/getting-started/generating-api-token"))))))
(define (hetzner-machine-validate-configuration-type machine)
"Raise an error if MACHINE's configuration is not an instance of
<hetzner-configuration>."
(let ((config (machine-configuration machine))
(environment (environment-type-name (machine-environment machine))))
(unless (and config (hetzner-configuration? config))
(raise-exception
(formatted-message (G_ "unsupported machine configuration '~a' \
for environment of type '~a'")
config
environment)))))
(define (hetzner-machine-validate-server-type machine)
"Raise an error if the server type of MACHINE is not supported."
(unless (hetzner-machine-server-type machine)
(let* ((config (machine-configuration machine))
(api (hetzner-configuration-api config)))
(raise-exception
(formatted-message
(G_ "server type '~a' not supported~%~%\
Available server types:~%~%~a~%~%For more details and prices, see: ~a")
(hetzner-configuration-server-type config)
(string-join
(map (lambda (type)
(format #f " - ~a: ~a, ~a ~a cores, ~a GB mem, ~a GB disk"
(colorize-string
(hetzner-server-type-name type)
(color BOLD))
(hetzner-server-type-architecture type)
(hetzner-server-type-cores type)
(hetzner-server-type-cpu-type type)
(hetzner-server-type-memory type)
(hetzner-server-type-disk type)))
(hetzner-api-server-types api))
"\n")
"https://www.hetzner.com/cloud#pricing")))))
(define (hetzner-machine-validate-location machine)
"Raise an error if the location of MACHINE is not supported."
(unless (hetzner-machine-location machine)
(let* ((config (machine-configuration machine))
(api (hetzner-configuration-api config)))
(raise-exception
(formatted-message
(G_ "server location '~a' not supported~%~%\
Available locations:~%~%~a~%~%For more details, see: ~a")
(hetzner-configuration-location config)
(string-join
(map (lambda (location)
(format #f " - ~a: ~a, ~a"
(colorize-string
(hetzner-location-name location)
(color BOLD))
(hetzner-location-description location)
(hetzner-location-country location)))
(hetzner-api-locations api))
"\n")
"https://www.hetzner.com/cloud#locations")))))
(define (hetzner-machine-validate machine)
"Validate the Hetzner MACHINE."
(hetzner-machine-validate-configuration-type machine)
(hetzner-machine-validate-api-token machine)
(hetzner-machine-validate-location machine)
(hetzner-machine-validate-server-type machine))
(define (hetzner-machine-bootstrap-os-form machine server)
"Return the form to bootstrap an operating system on SERVER."
(let* ((os (machine-operating-system machine))
(system (hetzner-server-system server))
(arm? (equal? "arm" (hetzner-server-architecture server)))
(x86? (equal? "x86" (hetzner-server-architecture server)))
(root-fs-type (operating-system-root-file-system-type os)))
`(operating-system
(host-name ,(operating-system-host-name os))
(timezone "Etc/UTC")
(bootloader (bootloader-configuration
(bootloader ,(cond (arm? 'grub-efi-bootloader)
(x86? 'grub-bootloader)))
(targets ,(cond (arm? '(list "/boot/efi"))
(x86? '(list "/dev/sda"))))
(terminal-outputs '(console))))
(initrd-modules (append
,(cond (arm? '(list "sd_mod" "virtio_scsi"))
(x86? '(list "virtio_scsi")))
%base-initrd-modules))
(file-systems ,(cond
(arm? `(cons* (file-system
(mount-point "/")
(device "/dev/sda1")
(type ,root-fs-type))
(file-system
(mount-point "/boot/efi")
(device "/dev/sda15")
(type "vfat"))
%base-file-systems))
(x86? `(cons* (file-system
(mount-point "/")
(device "/dev/sda1")
(type ,root-fs-type))
%base-file-systems))))
(services
(cons* (service dhcp-client-service-type)
(service openssh-service-type
(openssh-configuration
(openssh openssh-sans-x)
(permit-root-login 'prohibit-password)))
%base-services)))))
(define (rexec-verbose session cmd)
"Execute a command CMD on the remote side and print output. Return two
values: list of output lines returned by CMD and its exit code."
(let* ((channel (open-remote-input-pipe session cmd))
(result (let loop ((line (read-line channel))
(result '()))
(if (eof-object? line)
(reverse result)
(begin
(display line)
(newline)
(loop (read-line channel)
(cons line result))))))
(exit-status (channel-get-exit-status channel)))
(close channel)
(values result exit-status)))
(define (hetzner-machine-ssh-key machine)
"Find the SSH key for MACHINE on the Hetzner API."
(let* ((config (machine-configuration machine))
(expected (hetzner-configuration-ssh-key-fingerprint config)))
(find (lambda (ssh-key)
(equal? expected (hetzner-ssh-key-fingerprint ssh-key)))
(hetzner-api-ssh-keys
(hetzner-configuration-api config)
#:params `(("fingerprint" . ,expected))))))
(define (hetzner-machine-ssh-key-create machine)
"Create the SSH key for MACHINE on the Hetzner API."
(let ((name (machine-display-name machine)))
(format #t "creating ssh key for '~a'...\n" name)
(let* ((config (machine-configuration machine))
(api (hetzner-configuration-api config))
(ssh-key (hetzner-api-ssh-key-create
(hetzner-configuration-api config)
(hetzner-configuration-ssh-key-fingerprint config)
(hetzner-configuration-ssh-key-public config)
#:labels (hetzner-configuration-labels config))))
(format #t "successfully created ssh key for '~a'\n" name)
ssh-key)))
(define (hetzner-machine-server machine)
"Find the Hetzner server for MACHINE."
(let ((config (machine-configuration machine)))
(find (lambda (server)
(equal? (machine-display-name machine)
(hetzner-server-name server)))
(hetzner-api-servers
(hetzner-configuration-api config)
#:params `(("name" . ,(machine-display-name machine)))))))
(define (hetzner-machine-create-server machine)
"Create the Hetzner server for MACHINE."
(let* ((config (machine-configuration machine))
(name (machine-display-name machine))
(server-type (hetzner-configuration-server-type config)))
(format #t "creating '~a' server for '~a'...\n" server-type name)
(let* ((ssh-key (hetzner-machine-ssh-key machine))
(api (hetzner-configuration-api config))
(server (hetzner-api-server-create
api
(machine-display-name machine)
(list ssh-key)
#:labels (hetzner-configuration-labels config)
#:location (hetzner-configuration-location config)
#:server-type (hetzner-configuration-server-type config)))
(architecture (hetzner-server-architecture server)))
(format #t "successfully created '~a' ~a server for '~a'\n"
server-type architecture name)
server)))
(define (wait-for-ssh address ssh-key)
"Block until a SSH session can be made as 'root' with SSH-KEY at ADDRESS."
(format #t "connecting via SSH to '~a' using '~a'...\n" address ssh-key)
(let loop ()
(catch #t
(lambda ()
(open-ssh-session address #:user "root" #:identity ssh-key
#:strict-host-key-check? #f))
(lambda args
(let ((msg (cadr args)))
(if (formatted-message? msg)
(format #t "~a\n"
(string-trim-right
(apply format #f
(formatted-message-string msg)
(formatted-message-arguments msg))
#\newline))
(format #t "~a" args))
(sleep 5)
(loop))))))
(define (hetzner-machine-wait-for-ssh machine server)
"Wait for SSH connection to be established with the specified machine."
(wait-for-ssh (hetzner-server-public-ipv4 server)
(hetzner-configuration-ssh-key
(machine-configuration machine))))
(define (hetzner-machine-authenticate-host machine server)
"Add the host key of MACHINE to the list of known hosts."
(let ((ssh-session (hetzner-machine-wait-for-ssh machine server)))
(write-known-host! ssh-session)))
(define (hetzner-machine-enable-rescue-system machine server)
"Enable the rescue system on the Hetzner SERVER for MACHINE."
(let* ((name (machine-display-name machine))
(config (machine-configuration machine))
(api (hetzner-configuration-api config))
(ssh-keys (list (hetzner-machine-ssh-key machine))))
(format #t "enabling rescue system on '~a'...\n" name)
(let ((action (hetzner-api-server-enable-rescue-system api server ssh-keys)))
(format #t "successfully enabled rescue system on '~a'\n" name)
action)))
(define (hetzner-machine-power-on machine server)
"Power on the Hetzner SERVER for MACHINE."
(let* ((name (machine-display-name machine))
(config (machine-configuration machine))
(api (hetzner-configuration-api config)))
(format #t "powering on server for '~a'...\n" name)
(let ((action (hetzner-api-server-power-on api server)))
(format #t "successfully powered on server for '~a'\n" name)
action)))
(define (hetzner-machine-ssh-run-script ssh-session name content)
(let ((sftp-session (make-sftp-session ssh-session)))
(rexec ssh-session (format #f "rm -f ~a" name))
(rexec ssh-session (format #f "mkdir -p ~a" (dirname name)))
(call-with-remote-output-file
sftp-session name
(lambda (port)
(display content port)))
(sftp-chmod sftp-session name 755)
(let ((lines exit-code (rexec-verbose ssh-session
(format #f "~a 2>&1" name))))
(if (zero? exit-code)
lines
(raise-exception
(formatted-message
(G_ "failed to run script '~a' on machine, exit code: '~a'")
name exit-code))))))
;; Prevent compiler from inlining this function, so we can mock it in tests.
(set! hetzner-machine-ssh-run-script hetzner-machine-ssh-run-script)
(define (hetzner-machine-rescue-install-os machine ssh-session server)
(let ((name (machine-display-name machine))
(os (hetzner-machine-bootstrap-os-form machine server)))
(format #t "installing guix operating system on '~a'...\n" name)
(hetzner-machine-ssh-run-script
ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-install-os"
(format #f "#!/usr/bin/env bash
set -eo pipefail
mount /dev/sda1 /mnt
mkdir -p /mnt/boot/efi
mount /dev/sda15 /mnt/boot/efi
mkdir --parents /mnt/root/.ssh
chmod 700 /mnt/root/.ssh
cp /root/.ssh/authorized_keys /mnt/root/.ssh/authorized_keys
chmod 600 /mnt/root/.ssh/authorized_keys
cat > /tmp/guix/deploy/hetzner-os.scm << EOF
(use-modules (gnu) (guix utils))
(use-package-modules ssh)
(use-service-modules base networking ssh)
(use-system-modules linux-initrd)
~a
EOF
guix system init --verbosity=2 /tmp/guix/deploy/hetzner-os.scm /mnt"
(escape-backticks (format #f "~y" os))))
(format #t "successfully installed guix operating system on '~a'\n" name)))
(define (hetzner-machine-reboot machine server)
"Reboot the Hetzner SERVER for MACHINE."
(let* ((name (machine-display-name machine))
(config (machine-configuration machine))
(api (hetzner-configuration-api config)))
(format #t "rebooting server for '~a'...\n" name)
(let ((action (hetzner-api-server-reboot api server)))
(format #t "successfully rebooted server for '~a'\n" name)
action)))
(define (hetzner-machine-rescue-partition machine ssh-session)
"Setup the partitions of the Hetzner server for MACHINE using SSH-SESSION."
(let* ((name (machine-display-name machine))
(os (machine-operating-system machine))
(root-fs-type (operating-system-root-file-system-type os)))
(format #t "setting up partitions on '~a'...\n" name)
(hetzner-machine-ssh-run-script
ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-partition"
(format #f "#!/usr/bin/env bash
set -eo pipefail
growpart /dev/sda 1 || true
~a
fdisk -l /dev/sda"
(cond
((equal? "btrfs" root-fs-type)
(format #f "mkfs.btrfs -L ~a -f /dev/sda1" root-label))
((equal? "ext4" root-fs-type)
(format #f "mkfs.ext4 -L ~a -F /dev/sda1" root-label))
(else (raise-exception
(formatted-message
(G_ "unsupported root file system type '~a'")
root-fs-type))))))
(format #t "successfully setup partitions on '~a'\n" name)))
(define (hetzner-machine-rescue-install-packages machine ssh-session)
"Install packages on the Hetzner server for MACHINE using SSH-SESSION."
(let ((name (machine-display-name machine)))
(format #t "installing rescue system packages on '~a'...\n" name)
(hetzner-machine-ssh-run-script
ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-install-packages"
(format #f "#!/usr/bin/env bash
set -eo pipefail
apt-get update
apt-get install guix cloud-initramfs-growroot --assume-yes"))
(format #t "successfully installed rescue system packages on '~a'\n" name)))
(define (hetzner-machine-delete machine server)
"Delete the Hetzner server for MACHINE."
(let* ((name (machine-display-name machine))
(config (machine-configuration machine))
(api (hetzner-configuration-api config)))
(format #t "deleting server for '~a'...\n" name)
(let ((action (hetzner-api-server-delete api server)))
(format #t "successfully deleted server for '~a'\n" name)
action)))
(define (hetzner-machine-provision machine)
"Provision a server for MACHINE on the Hetzner Cloud service."
(with-exception-handler
(lambda (exception)
(let ((config (machine-configuration machine))
(server (hetzner-machine-server machine)))
(when (and server (hetzner-configuration-delete? config))
(hetzner-machine-delete machine server))
(raise-exception exception)))
(lambda ()
(let ((server (hetzner-machine-create-server machine)))
(hetzner-machine-enable-rescue-system machine server)
(hetzner-machine-power-on machine server)
(let ((ssh-session (hetzner-machine-wait-for-ssh machine server)))
(hetzner-machine-rescue-install-packages machine ssh-session)
(hetzner-machine-rescue-partition machine ssh-session)
(hetzner-machine-rescue-install-os machine ssh-session server)
(hetzner-machine-reboot machine server)
(sleep 5)
(hetzner-machine-authenticate-host machine server)
server)))
#:unwind? #t))
(define (machine-not-provisioned machine)
(formatted-message
(G_ "no server provisioned for machine '~a' on the Hetzner Cloud service")
(machine-display-name machine)))
;;;
;;; Remote evaluation.
;;;
(define (hetzner-remote-eval machine exp)
"Internal implementation of 'machine-remote-eval' for MACHINE instances with
an environment type of 'hetzner-environment-type'."
(hetzner-machine-validate machine)
(let ((server (hetzner-machine-server machine)))
(unless server (raise-exception (machine-not-provisioned machine)))
(machine-remote-eval (hetzner-machine-delegate machine server) exp)))
;;;
;;; System deployment.
;;;
(define (deploy-hetzner machine)
"Internal implementation of 'deploy-machine' for 'machine' instances with an
environment type of 'hetzner-environment-type'."
(hetzner-machine-validate machine)
(unless (hetzner-machine-ssh-key machine)
(hetzner-machine-ssh-key-create machine))
(let ((server (or (hetzner-machine-server machine)
(hetzner-machine-provision machine))))
(deploy-machine (hetzner-machine-delegate machine server))))
;;;
;;; Roll-back.
;;;
(define (roll-back-hetzner machine)
"Internal implementation of 'roll-back-machine' for MACHINE instances with an
environment type of 'hetzner-environment-type'."
(hetzner-machine-validate machine)
(let ((server (hetzner-machine-server machine)))
(unless server (raise-exception (machine-not-provisioned machine)))
(roll-back-machine (hetzner-machine-delegate machine server))))
;;;
;;; Environment type.
;;;
(define hetzner-environment-type
(environment-type
(machine-remote-eval hetzner-remote-eval)
(deploy-machine deploy-hetzner)
(roll-back-machine roll-back-hetzner)
(name 'hetzner-environment-type)
(description "Provisioning of virtual machine servers on the Hetzner Cloud
service.")))

664
gnu/machine/hetzner/http.scm Normal file
View file

@ -0,0 +1,664 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2024 Roman Scherer <roman@burningswell.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu machine hetzner http)
#:use-module (guix diagnostics)
#:use-module (guix i18n)
#:use-module (guix records)
#:use-module (ice-9 iconv)
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:use-module (ice-9 textual-ports)
#:use-module (json)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
#:use-module (ssh key)
#:use-module (web client)
#:use-module (web request)
#:use-module (web response)
#:use-module (web uri)
#:export (%hetzner-default-api-token
%hetzner-default-server-image
%hetzner-default-server-location
%hetzner-default-server-type
hetzner-action
hetzner-action-command
hetzner-action-error
hetzner-action-finished
hetzner-action-id
hetzner-action-progress
hetzner-action-resources
hetzner-action-started
hetzner-action-status
hetzner-action?
hetzner-api
hetzner-api-action-wait
hetzner-api-actions
hetzner-api-create-ssh-key
hetzner-api-locations
hetzner-api-request-body
hetzner-api-request-headers
hetzner-api-request-method
hetzner-api-request-params
hetzner-api-request-send
hetzner-api-request-url
hetzner-api-request?
hetzner-api-response
hetzner-api-response-body
hetzner-api-response-headers
hetzner-api-response-status
hetzner-api-response?
hetzner-api-server-create
hetzner-api-server-delete
hetzner-api-server-enable-rescue-system
hetzner-api-server-power-off
hetzner-api-server-power-on
hetzner-api-server-reboot
hetzner-api-server-types
hetzner-api-servers
hetzner-api-ssh-key-create
hetzner-api-ssh-key-delete
hetzner-api-ssh-keys
hetzner-api-token
hetzner-api?
hetzner-error-code
hetzner-error-message
hetzner-error?
hetzner-ipv4-blocked?
hetzner-ipv4-dns-ptr
hetzner-ipv4-id
hetzner-ipv4-ip
hetzner-ipv4?
hetzner-ipv6-blocked?
hetzner-ipv6-dns-ptr
hetzner-ipv6-id
hetzner-ipv6-ip
hetzner-ipv6?
hetzner-location
hetzner-location-city
hetzner-location-country
hetzner-location-description
hetzner-location-id
hetzner-location-latitude
hetzner-location-longitude
hetzner-location-name
hetzner-location-network-zone
hetzner-location?
hetzner-public-net
hetzner-public-net-ipv4
hetzner-public-net-ipv6
hetzner-resource
hetzner-resource-id
hetzner-resource-type
hetzner-resource?
hetzner-server-architecture
hetzner-server-created
hetzner-server-id
hetzner-server-labels
hetzner-server-name
hetzner-server-public-ipv4
hetzner-server-public-net
hetzner-server-rescue-enabled?
hetzner-server-system
hetzner-server-type
hetzner-server-type-architecture
hetzner-server-type-cores
hetzner-server-type-cpu-type
hetzner-server-type-deprecated
hetzner-server-type-deprecation
hetzner-server-type-description
hetzner-server-type-disk
hetzner-server-type-id
hetzner-server-type-memory
hetzner-server-type-name
hetzner-server-type-storage-type
hetzner-server-type?
hetzner-server?
hetzner-ssh-key-created
hetzner-ssh-key-fingerprint
hetzner-ssh-key-id
hetzner-ssh-key-labels
hetzner-ssh-key-name
hetzner-ssh-key-public-key
hetzner-ssh-key-read-file
hetzner-ssh-key?
make-hetzner-action
make-hetzner-error
make-hetzner-ipv4
make-hetzner-ipv6
make-hetzner-location
make-hetzner-public-net
make-hetzner-resource
make-hetzner-server
make-hetzner-server-type
make-hetzner-ssh-key))
;;; Commentary:
;;;
;;; This module implements a lower-level interface for interacting with the
;;; Hetzner Cloud API https://docs.hetzner.cloud.
;;;
(define %hetzner-default-api-token
(make-parameter (getenv "GUIX_HETZNER_API_TOKEN")))
;; Ideally this would be a Guix image. Maybe one day.
(define %hetzner-default-server-image "debian-11")
;; Falkenstein, Germany
(define %hetzner-default-server-location "fsn1")
;; x86, 8 VCPUs, 16 GB mem, 160 GB disk
(define %hetzner-default-server-type "cx42")
;;;
;;; Helper functions.
;;;
(define (format-query-param param)
"Format the query PARAM as a string."
(string-append (uri-encode (format #f "~a" (car param))) "="
(uri-encode (format #f "~a" (cdr param)))))
(define (format-query-params params)
"Format the query PARAMS as a string."
(if (> (length params) 0)
(string-append
"?"
(string-join
(map format-query-param params)
"&"))
""))
(define (json->maybe-hetzner-error json)
(and (list? json) (json->hetzner-error json)))
(define (string->time s)
(when (string? s) (car (strptime "%FT%T%z" s))))
(define (json->hetzner-dnses vector)
(map json->hetzner-dns (vector->list vector)))
(define (json->hetzner-resources vector)
(map json->hetzner-resource (vector->list vector)))
;;;
;;; Domain models.
;;;
(define-json-mapping <hetzner-action>
make-hetzner-action hetzner-action? json->hetzner-action
(command hetzner-action-command) ; string
(error hetzner-action-error "error"
json->maybe-hetzner-error) ; <hetzner-error> | #f
(finished hetzner-action-finished "finished" string->time) ; time
(id hetzner-action-id) ; integer
(progress hetzner-action-progress) ; integer
(resources hetzner-action-resources "resources"
json->hetzner-resources) ; list of <hetzner-resource>
(started hetzner-action-started "started" string->time) ; time
(status hetzner-action-status))
(define-json-mapping <hetzner-deprecation>
make-hetzner-deprecation hetzner-deprecation? json->hetzner-deprecation
(announced hetzner-deprecation-announced) ; string
(unavailable-after hetzner-deprecation-unavailable-after
"unavailable_after")) ; string
(define-json-mapping <hetzner-dns>
make-hetzner-dns hetzner-dns? json->hetzner-dns
(ip hetzner-dns-ip) ; string
(ptr hetzner-dns-ptr "dns_ptr")) ; string
(define-json-mapping <hetzner-error>
make-hetzner-error hetzner-error? json->hetzner-error
(code hetzner-error-code) ; string
(message hetzner-error-message)) ; <string>
(define-json-mapping <hetzner-ipv4>
make-hetzner-ipv4 hetzner-ipv4? json->hetzner-ipv4
(blocked? hetzner-ipv4-blocked? "blocked") ; boolean
(dns-ptr hetzner-ipv4-dns-ptr "dns_ptr") ; string
(id hetzner-ipv4-id) ; integer
(ip hetzner-ipv4-ip)) ; string
(define-json-mapping <hetzner-ipv6>
make-hetzner-ipv6 hetzner-ipv6? json->hetzner-ipv6
(blocked? hetzner-ipv6-blocked? "blocked") ; boolean
(dns-ptr hetzner-ipv6-dns-ptr "dns_ptr"
json->hetzner-dnses) ; list of <hetzner-dns>
(id hetzner-ipv6-id) ; integer
(ip hetzner-ipv6-ip)) ; string
(define-json-mapping <hetzner-location>
make-hetzner-location hetzner-location? json->hetzner-location
(city hetzner-location-city) ; string
(country hetzner-location-country) ; string
(description hetzner-location-description) ; string
(id hetzner-location-id) ; integer
(latitude hetzner-location-latitude) ; decimal
(longitude hetzner-location-longitude) ; decimal
(name hetzner-location-name) ; string
(network-zone hetzner-location-network-zone "network_zone"))
(define-json-mapping <hetzner-public-net>
make-hetzner-public-net hetzner-public-net? json->hetzner-public-net
(ipv4 hetzner-public-net-ipv4 "ipv4" json->hetzner-ipv4) ; <hetzner-ipv4>
(ipv6 hetzner-public-net-ipv6 "ipv6" json->hetzner-ipv6)) ; <hetzner-ipv6>
(define-json-mapping <hetzner-resource>
make-hetzner-resource hetzner-resource? json->hetzner-resource
(id hetzner-resource-id) ; integer
(type hetzner-resource-type)) ; string
(define-json-mapping <hetzner-server>
make-hetzner-server hetzner-server? json->hetzner-server
(created hetzner-server-created) ; time
(id hetzner-server-id) ; integer
(labels hetzner-server-labels) ; alist of string/string
(name hetzner-server-name) ; string
(public-net hetzner-server-public-net "public_net"
json->hetzner-public-net) ; <hetzner-public-net>
(rescue-enabled? hetzner-server-rescue-enabled? "rescue_enabled") ; boolean
(server-type hetzner-server-type "server_type"
json->hetzner-server-type)) ; <hetzner-server-type>
(define-json-mapping <hetzner-server-type>
make-hetzner-server-type hetzner-server-type? json->hetzner-server-type
(architecture hetzner-server-type-architecture) ; string
(cores hetzner-server-type-cores) ; integer
(cpu-type hetzner-server-type-cpu-type "cpu_type") ; string
(deprecated hetzner-server-type-deprecated) ; boolean
(deprecation hetzner-server-type-deprecation
json->hetzner-deprecation) ; <hetzner-deprecation>
(description hetzner-server-type-description) ; string
(disk hetzner-server-type-disk) ; integer
(id hetzner-server-type-id) ; integer
(memory hetzner-server-type-memory) ; integer
(name hetzner-server-type-name) ; string
(storage-type hetzner-server-type-storage-type "storage_type")) ; string
(define-json-mapping <hetzner-ssh-key>
make-hetzner-ssh-key hetzner-ssh-key? json->hetzner-ssh-key
(created hetzner-ssh-key-created "created" string->time) ; time
(fingerprint hetzner-ssh-key-fingerprint) ; string
(id hetzner-ssh-key-id) ; integer
(labels hetzner-ssh-key-labels) ; alist of string/string
(name hetzner-ssh-key-name) ; string
(public_key hetzner-ssh-key-public-key "public_key")) ; string
(define (hetzner-server-architecture server)
"Return the architecture of the Hetzner SERVER."
(hetzner-server-type-architecture (hetzner-server-type server)))
(define* (hetzner-server-path server #:optional (path ""))
"Return the PATH of the Hetzner SERVER."
(format #f "/servers/~a~a" (hetzner-server-id server) path))
(define (hetzner-server-public-ipv4 server)
"Return the public IPv4 address of the SERVER."
(and-let* ((public-net (hetzner-server-public-net server))
(ipv4 (hetzner-public-net-ipv4 public-net)))
(hetzner-ipv4-ip ipv4)))
(define (hetzner-server-system server)
"Return the Guix system architecture of the Hetzner SERVER."
(match (hetzner-server-architecture server)
("arm" "aarch64-linux")
("x86" "x86_64-linux")))
(define* (hetzner-ssh-key-path ssh-key #:optional (path ""))
"Return the PATH of the Hetzner SSH-KEY."
(format #f "/ssh_keys/~a~a" (hetzner-ssh-key-id ssh-key) path))
(define (hetzner-ssh-key-read-file file)
"Read the SSH private key from FILE and return a Hetzner SSH key."
(let* ((privkey (private-key-from-file file))
(pubkey (private-key->public-key privkey))
(hash (get-public-key-hash pubkey 'md5))
(fingerprint (bytevector->hex-string hash))
(public-key (format #f "ssh-~a ~a" (get-key-type pubkey)
(public-key->string pubkey))))
(make-hetzner-ssh-key #f fingerprint #f '() (basename file) public-key)))
;;;
;;; Hetzner API response.
;;;
(define-record-type* <hetzner-api-response>
hetzner-api-response make-hetzner-api-response hetzner-api-response?
(body hetzner-api-response-body (default *unspecified*))
(headers hetzner-api-response-headers (default '()))
(status hetzner-api-response-status (default 200)))
(define (hetzner-api-response-meta response)
"Return the meta information of the Hetzner API response."
(assoc-ref (hetzner-api-response-body response) "meta"))
(define (hetzner-api-response-pagination response)
"Return the meta information of the Hetzner API response."
(assoc-ref (hetzner-api-response-meta response) "pagination"))
(define (hetzner-api-response-pagination-combine resource responses)
"Combine multiple Hetzner API pagination responses into a single response."
(if (positive? (length responses))
(let* ((response (car responses))
(pagination (hetzner-api-response-pagination response))
(total-entries (assoc-ref pagination "total_entries")))
(hetzner-api-response
(inherit response)
(body `(("meta"
("pagination"
("last_page" . 1)
("next_page" . null)
("page" . 1)
("per_page" . ,total-entries)
("previous_page" . null)
("total_entries" . ,total-entries)))
(,resource . ,(append-map
(lambda (body)
(vector->list (assoc-ref body resource)))
(map hetzner-api-response-body responses)))))))
(raise-exception
(formatted-message
(G_ "expected a list of Hetzner API responses")))))
(define (hetzner-api-body-action body)
"Return the Hetzner API action from BODY."
(let ((json (assoc-ref body "action")))
(and json (json->hetzner-action json))))
(define (hetzner-api-response-read port)
"Read the Hetzner API response from PORT."
(let* ((response (read-response port))
(body (read-response-body response)))
(hetzner-api-response
(body (and body (json-string->scm (utf8->string body))))
(headers (response-headers response))
(status (response-code response)))))
(define (hetzner-api-response-validate-status response expected)
"Raise an error if the HTTP status code of RESPONSE is not in EXPECTED."
(when (not (member (hetzner-api-response-status response) expected))
(raise-exception
(formatted-message
(G_ "unexpected HTTP status code: ~a, expected: ~a~%~a")
(hetzner-api-response-status response)
expected
(with-output-to-string
(lambda ()
(pretty-print (hetzner-api-response-body response))))))))
;;;
;;; Hetzner API request.
;;;
(define-record-type* <hetzner-api-request>
hetzner-api-request make-hetzner-api-request hetzner-api-request?
(body hetzner-api-request-body (default *unspecified*))
(headers hetzner-api-request-headers (default '()))
(method hetzner-api-request-method (default 'GET))
(params hetzner-api-request-params (default '()))
(url hetzner-api-request-url))
(define (hetzner-api-request-uri request)
"Return the URI object of the Hetzner API request."
(let ((params (hetzner-api-request-params request)))
(string->uri (string-append (hetzner-api-request-url request)
(format-query-params params)))))
(define (hetzner-api-request-body-bytevector request)
"Return the body of the Hetzner API REQUEST as a bytevector."
(let ((body (hetzner-api-request-body request)))
(string->utf8 (if (unspecified? body) "" (scm->json-string body)))))
(define (hetzner-api-request-write port request)
"Write the Hetzner API REQUEST to PORT."
(let* ((body (hetzner-api-request-body-bytevector request))
(request (build-request
(hetzner-api-request-uri request)
#:method (hetzner-api-request-method request)
#:version '(1 . 1)
#:headers (cons* `(Content-Length
. ,(number->string
(if (unspecified? body)
0 (bytevector-length body))))
(hetzner-api-request-headers request))
#:port port))
(request (write-request request port)))
(unless (unspecified? body)
(write-request-body request body))
(force-output (request-port request))))
(define* (hetzner-api-request-send request #:key (expected (list 200 201 204)))
"Send the Hetzner API REQUEST via HTTP."
(let ((port (open-socket-for-uri (hetzner-api-request-uri request))))
(hetzner-api-request-write port request)
(let ((response (hetzner-api-response-read port)))
(close-port port)
(hetzner-api-response-validate-status response expected)
response)))
;; Prevent compiler from inlining this function, so we can mock it in tests.
(set! hetzner-api-request-send hetzner-api-request-send)
(define (hetzner-api-request-next-params request)
"Return the pagination params for the next page of the REQUEST."
(let* ((params (hetzner-api-request-params request))
(page (or (assoc-ref params "page") 1)))
(map (lambda (param)
(if (equal? "page" (car param))
(cons (car param) (+ page 1))
param))
params)))
(define (hetzner-api-request-paginate request)
"Fetch all pages of the REQUEST via pagination and return all responses."
(let* ((response (hetzner-api-request-send request))
(pagination (hetzner-api-response-pagination response))
(next-page (assoc-ref pagination "next_page")))
(if (number? next-page)
(cons response
(hetzner-api-request-paginate
(hetzner-api-request
(inherit request)
(params (hetzner-api-request-next-params request)))))
(list response))))
;;;
;;; Hetzner API.
;;;
(define-record-type* <hetzner-api>
hetzner-api make-hetzner-api hetzner-api?
(base-url hetzner-api-base-url ; string
(default "https://api.hetzner.cloud/v1"))
(token hetzner-api-token ; string
(default (%hetzner-default-api-token))))
(define (hetzner-api-authorization-header api)
"Return the authorization header for the Hetzner API."
(format #f "Bearer ~a" (hetzner-api-token api)))
(define (hetzner-api-default-headers api)
"Returns the default headers of the Hetzner API."
`((user-agent . "Guix Deploy")
(Accept . "application/json")
(Authorization . ,(hetzner-api-authorization-header api))
(Content-Type . "application/json")))
(define (hetzner-api-url api path)
"Append PATH to the base url of the Hetzner API."
(string-append (hetzner-api-base-url api) path))
(define (hetzner-api-delete api path)
"Delelte the resource at PATH with the Hetzner API."
(hetzner-api-response-body
(hetzner-api-request-send
(hetzner-api-request
(headers (hetzner-api-default-headers api))
(method 'DELETE)
(url (hetzner-api-url api path))))))
(define* (hetzner-api-list api path resources json->object #:key (params '()))
"Fetch all objects of RESOURCE from the Hetzner API."
(let ((body (hetzner-api-response-body
(hetzner-api-response-pagination-combine
resources (hetzner-api-request-paginate
(hetzner-api-request
(url (hetzner-api-url api path))
(headers (hetzner-api-default-headers api))
(params (cons '("page" . 1) params))))))))
(map json->object (assoc-ref body resources))))
(define* (hetzner-api-post api path #:key (body *unspecified*))
"Send a POST request to the Hetzner API at PATH using BODY."
(hetzner-api-response-body
(hetzner-api-request-send
(hetzner-api-request
(body body)
(method 'POST)
(url (hetzner-api-url api path))
(headers (hetzner-api-default-headers api))))))
(define (hetzner-api-actions api ids)
"Get actions from the Hetzner API."
(if (zero? (length ids))
(raise-exception
(formatted-message
(G_ "expected at least one action id, but got '~a'")
(length ids)))
(hetzner-api-list
api "/actions" "actions" json->hetzner-action
#:params `(("id" . ,(string-join (map number->string ids) ","))))))
(define* (hetzner-api-action-wait api action #:optional (status "success"))
"Wait until the ACTION has reached STATUS on the Hetzner API."
(let ((id (hetzner-action-id action)))
(let loop ()
(let ((actions (hetzner-api-actions api (list id))))
(cond
((zero? (length actions))
(raise-exception
(formatted-message (G_ "server action '~a' not found") id)))
((not (= 1 (length actions)))
(raise-exception
(formatted-message
(G_ "expected one server action, but got '~a'")
(length actions))))
((string= status (hetzner-action-status (car actions)))
(car actions))
(else
(sleep 5)
(loop)))))))
(define* (hetzner-api-locations api . options)
"Get deployment locations from the Hetzner API."
(apply hetzner-api-list api "/locations" "locations" json->hetzner-location options))
(define* (hetzner-api-server-create
api name ssh-keys
#:key
(enable-ipv4? #t)
(enable-ipv6? #t)
(image %hetzner-default-server-image)
(labels '())
(location %hetzner-default-server-location)
(public-net #f)
(server-type %hetzner-default-server-type)
(start-after-create? #f))
"Create a server with the Hetzner API."
(let ((body (hetzner-api-post
api "/servers"
#:body `(("image" . ,image)
("labels" . ,labels)
("name" . ,name)
("public_net"
. (("enable_ipv4" . ,enable-ipv4?)
("enable_ipv6" . ,enable-ipv6?)))
("location" . ,location)
("server_type" . ,server-type)
("ssh_keys" . ,(apply vector (map hetzner-ssh-key-id ssh-keys)))
("start_after_create" . ,start-after-create?)))))
(hetzner-api-action-wait api (hetzner-api-body-action body))
(json->hetzner-server (assoc-ref body "server"))))
(define (hetzner-api-server-delete api server)
"Delete the SERVER with the Hetzner API."
(let ((body (hetzner-api-delete api (hetzner-server-path server))))
(hetzner-api-action-wait api (hetzner-api-body-action body))))
(define* (hetzner-api-server-enable-rescue-system
api server ssh-keys #:key (type "linux64"))
"Enable the rescue system for SERVER with the Hetzner API."
(let* ((ssh-keys (apply vector (map hetzner-ssh-key-id ssh-keys)))
(body (hetzner-api-post
api (hetzner-server-path server "/actions/enable_rescue")
#:body `(("ssh_keys" . ,ssh-keys)
("type" . ,type)))))
(hetzner-api-action-wait api (hetzner-api-body-action body))))
(define* (hetzner-api-servers api . options)
"Get servers from the Hetzner API."
(apply hetzner-api-list api "/servers" "servers" json->hetzner-server options))
(define (hetzner-api-server-power-on api server)
"Send a power on request for SERVER to the Hetzner API."
(let ((body (hetzner-api-post api (hetzner-server-path server "/actions/poweron"))))
(hetzner-api-action-wait api (hetzner-api-body-action body))))
(define (hetzner-api-server-power-off api server)
"Send a power off request for SERVER to the Hetzner API."
(let ((body (hetzner-api-post api (hetzner-server-path server "/actions/poweroff"))))
(hetzner-api-action-wait api (hetzner-api-body-action body))))
(define (hetzner-api-server-reboot api server)
"Send a reboot request for SERVER to the Hetzner API."
(let ((body (hetzner-api-post api (hetzner-server-path server "/actions/reboot"))))
(hetzner-api-action-wait api (hetzner-api-body-action body))))
(define* (hetzner-api-ssh-key-create api name public-key #:key (labels '()))
"Create a SSH key with the Hetzner API."
(let ((body (hetzner-api-post
api "/ssh_keys"
#:body `(("name" . ,name)
("public_key" . ,public-key)
("labels" . ,labels)))))
(json->hetzner-ssh-key (assoc-ref body "ssh_key"))))
(define (hetzner-api-ssh-key-delete api ssh-key)
"Delete the SSH key on the Hetzner API."
(hetzner-api-delete api (hetzner-ssh-key-path ssh-key))
#t)
(define* (hetzner-api-ssh-keys api . options)
"Get SSH keys from the Hetzner API."
(apply hetzner-api-list api "/ssh_keys" "ssh_keys"
json->hetzner-ssh-key options))
(define* (hetzner-api-server-types api . options)
"Get server types from the Hetzner API."
(apply hetzner-api-list api "/server_types" "server_types"
json->hetzner-server-type options))

2
po/guix/POTFILES.in
View file

@ -81,6 +81,8 @@ gnu/installer/steps.scm
gnu/installer/timezone.scm gnu/installer/timezone.scm
gnu/installer/user.scm gnu/installer/user.scm
gnu/installer/utils.scm gnu/installer/utils.scm
gnu/machine/hetzner.scm
gnu/machine/hetzner/http.scm
gnu/machine/ssh.scm gnu/machine/ssh.scm
gnu/packages/bootstrap.scm gnu/packages/bootstrap.scm
guix/build/utils.scm guix/build/utils.scm

267
tests/machine/hetzner.scm Normal file
View file

@ -0,0 +1,267 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2024 Roman Scherer <roman@burningswell.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (tests machine hetzner)
#:use-module (gnu machine hetzner http)
#:use-module (gnu machine hetzner)
#:use-module (gnu machine ssh)
#:use-module (gnu machine)
#:use-module (gnu system)
#:use-module (guix build utils)
#:use-module (guix records)
#:use-module (guix ssh)
#:use-module (guix tests)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-64)
#:use-module (ssh key)
#:use-module (ssh session))
;;; Unit and integration tests for the (gnu machine hetzner) module.
;; Integration tests require the GUIX_HETZNER_API_TOKEN environment variable.
;; https://docs.hetzner.com/cloud/api/getting-started/generating-api-token
;; The integration tests sometimes fail due to the Hetzner API not being able
;; to allocate a resource. Switching to a different location might help.
(define %labels
'(("guix.gnu.org/test" . "true")))
(define %ssh-key-name
"guix-hetzner-machine-test-key")
(define %ssh-key-file
(string-append "/tmp/" %ssh-key-name))
(unless (file-exists? %ssh-key-file)
(private-key-to-file (make-keypair 'rsa 2048) %ssh-key-file))
(define %when-no-token
(if (hetzner-api-token (hetzner-api)) 0 1))
(define %arm-machine
(machine
(operating-system
(operating-system
(inherit %hetzner-os-arm)
(host-name "guix-deploy-hetzner-test-arm")))
(environment hetzner-environment-type)
(configuration (hetzner-configuration
(labels %labels)
(server-type "cax41")
(ssh-key %ssh-key-file)))))
(define %x86-machine
(machine
(operating-system
(operating-system
(inherit %hetzner-os-x86)
(host-name "guix-deploy-hetzner-test-x86")))
(environment hetzner-environment-type)
(configuration (hetzner-configuration
(labels %labels)
(server-type "cpx51")
(ssh-key %ssh-key-file)))))
(define (cleanup machine)
(let* ((config (machine-configuration machine))
(api (hetzner-configuration-api config)))
(for-each (lambda (server)
(hetzner-api-server-delete api server))
(hetzner-api-servers
api #:params `(("label_selector" . "guix.gnu.org/test=true"))))
(for-each (lambda (ssh-key)
(hetzner-api-ssh-key-delete api ssh-key))
(hetzner-api-ssh-keys
api #:params `(("label_selector" . "guix.gnu.org/test=true"))))
machine))
(define-syntax-rule (with-cleanup (machine-sym machine-init) body ...)
(let ((machine-sym (cleanup machine-init)))
(dynamic-wind
(const #t)
(lambda ()
body ...)
(lambda ()
(cleanup machine-sym)))))
(define (mock-action command)
(make-hetzner-action
command #f
(localtime (current-time))
1
100
'()
(localtime (current-time))
"success"))
(define (mock-location machine)
(let* ((config (machine-configuration machine))
(name (hetzner-configuration-location config)))
(make-hetzner-location
"Falkenstein" "DE" "Falkenstein DC Park 1"
1 50.47612 12.370071 name "eu-central")))
(define (mock-server-type machine)
(let* ((config (machine-configuration machine))
(name (hetzner-configuration-server-type config)))
(make-hetzner-server-type
"x86" 8 "shared" #f #f (string-upcase name)
160 106 16 name "local")))
(define (mock-server machine)
(let* ((config (machine-configuration machine))
(name (hetzner-configuration-location config)))
(make-hetzner-server
1
(localtime (current-time))
'()
(operating-system-host-name (machine-operating-system machine))
(make-hetzner-public-net
(make-hetzner-ipv4 #f "server.example.com" 1 "1.2.3.4")
(make-hetzner-ipv6 #f "server.example.com" 1 "2001:db8::1"))
#f
(mock-server-type machine))))
(define (mock-ssh-key machine)
(let ((config (machine-configuration machine)))
(hetzner-ssh-key-read-file (hetzner-configuration-ssh-key config))))
(define (expected-ssh-machine? machine ssh-machine)
(let ((config (machine-configuration machine))
(ssh-config (machine-configuration ssh-machine)))
(and (equal? (hetzner-configuration-authorize? config)
(machine-ssh-configuration-authorize? ssh-config))
(equal? (hetzner-configuration-allow-downgrades? config)
(machine-ssh-configuration-allow-downgrades? ssh-config))
(equal? (hetzner-configuration-build-locally? config)
(machine-ssh-configuration-build-locally? ssh-config))
(equal? (hetzner-server-public-ipv4 (mock-server machine))
(machine-ssh-configuration-host-name ssh-config)))))
(define-syntax mock*
(syntax-rules ()
((mock* () body1 body2 ...)
(let () body1 body2 ...))
((mock* ((mod1 sym1 fn1) (mod2 sym2 fn2) ...)
body1 body2 ...)
(mock (mod1 sym1 fn1)
(mock* ((mod2 sym2 fn2) ...)
body1) body2 ...))))
(test-begin "machine-hetzner")
;; The following tests deploy real machines using the Hetzner API and shut
;; them down afterwards.
(test-skip %when-no-token)
(test-assert "deploy-arm-machine"
(with-cleanup (machine %arm-machine)
(deploy-hetzner machine)))
(test-skip %when-no-token)
(test-assert "deploy-x86-machine"
(with-cleanup (machine %x86-machine)
(deploy-hetzner machine)))
;; The following tests simulate a deployment, they mock out the actual calls
;; to the Hetzner API.
;; Note: In order for mocking to work, the Guile compiler should not inline
;; the mocked functions. To prevent this it was necessary to set!
;; hetzner-machine-ssh-run-script in (gnu machine hetzner) like this:
;; (set! hetzner-machine-ssh-run-script hetzner-machine-ssh-run-script)
(test-assert "deploy-machine-mock-with-provisioned-server"
(let ((machine (machine
(operating-system %hetzner-os-x86)
(environment hetzner-environment-type)
(configuration (hetzner-configuration
(api (hetzner-api (token "mock")))
(ssh-key %ssh-key-file))))))
(mock* (((gnu machine hetzner http) hetzner-api-locations
(lambda* (api . options)
(list (mock-location machine))))
((gnu machine hetzner http) hetzner-api-server-types
(lambda* (api . options)
(list (mock-server-type machine))))
((gnu machine hetzner http) hetzner-api-ssh-keys
(lambda* (api . options)
(list (mock-ssh-key machine))))
((gnu machine hetzner http) hetzner-api-servers
(lambda* (api . options)
(list (mock-server machine))))
((gnu machine) deploy-machine
(lambda* (ssh-machine)
(expected-ssh-machine? machine ssh-machine))))
(deploy-hetzner machine))))
(test-assert "deploy-machine-mock-with-unprovisioned-server"
(let ((machine (machine
(operating-system %hetzner-os-x86)
(environment hetzner-environment-type)
(configuration (hetzner-configuration
(api (hetzner-api (token "mock")))
(ssh-key %ssh-key-file)))))
(servers '()))
(mock* (((gnu machine hetzner http) hetzner-api-locations
(lambda* (api . options)
(list (mock-location machine))))
((gnu machine hetzner http) hetzner-api-server-types
(lambda* (api . options)
(list (mock-server-type machine))))
((gnu machine hetzner http) hetzner-api-ssh-keys
(lambda* (api . options)
(list (mock-ssh-key machine))))
((gnu machine hetzner http) hetzner-api-servers
(lambda* (api . options)
servers))
((gnu machine hetzner http) hetzner-api-server-create
(lambda* (api name ssh-keys . options)
(set! servers (list (mock-server machine)))
(car servers)))
((gnu machine hetzner http) hetzner-api-server-enable-rescue-system
(lambda (api server ssh-keys)
(mock-action "enable_rescue")))
((gnu machine hetzner http) hetzner-api-server-power-on
(lambda (api server)
(mock-action "start_server")))
((gnu machine hetzner) hetzner-machine-ssh-run-script
(lambda (ssh-session name content)
#t))
((guix ssh) open-ssh-session
(lambda* (host . options)
(make-session #:host host)))
((gnu machine hetzner http) hetzner-api-server-reboot
(lambda (api server)
(mock-action "reboot_server")))
((ssh session) write-known-host!
(lambda (session)
#t))
((gnu machine) deploy-machine
(lambda* (ssh-machine)
(expected-ssh-machine? machine ssh-machine))))
(deploy-hetzner machine))))
(test-end "machine-hetzner")
;; Local Variables:
;; eval: (put 'with-cleanup 'scheme-indent-function 1)
;; End:

631
tests/machine/hetzner/http.scm Normal file
View file

@ -0,0 +1,631 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2024 Roman Scherer <roman@burningswell.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (tests machine hetzner http)
#:use-module (debugging assert)
#:use-module (gnu machine hetzner http)
#:use-module (guix build utils)
#:use-module (guix tests)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-64)
#:use-module (ssh key))
;; Unit and integration tests the (gnu machine hetzner http) module.
;; Integration tests require the GUIX_HETZNER_API_TOKEN environment variable.
;; https://docs.hetzner.com/cloud/api/getting-started/generating-api-token
;; The integration tests sometimes fail due to the Hetzner API not being able
;; to allocate a resource. Switching to a different location might help.
(define %labels
'(("guix.gnu.org/test" . "true")))
(define %server-name
"guix-hetzner-api-test-server")
(define %ssh-key-name
"guix-hetzner-api-test-key")
(define %ssh-key-file
(string-append "/tmp/" %ssh-key-name))
(unless (file-exists? %ssh-key-file)
(private-key-to-file (make-keypair 'rsa 2048) %ssh-key-file))
(define %ssh-key
(hetzner-ssh-key-read-file %ssh-key-file))
(define %when-no-token
(if (hetzner-api-token (hetzner-api)) 0 1))
(define action-create-server
(make-hetzner-action
"create_server" #f *unspecified* 1896091819 0
(list (make-hetzner-resource 59570198 "server"))
#(0 17 11 2 1 125 0 32 -1 0 #f) "running"))
(define action-create-server-alist
'(("command" . "create_server")
("error" . null)
("finished" . null)
("id" . 1896091819)
("progress" . 0)
("resources" . #((("type" . "server") ("id" . 59570198))))
("started" . "2025-02-02T11:17:00+00:00")
("status" . "running")))
(define action-delete-server
(make-hetzner-action
"delete_server" #f *unspecified* 1896091928 0
(list (make-hetzner-resource 59570198 "server"))
#(10 17 11 2 1 125 0 32 -1 0 #f) "running"))
(define action-delete-server-alist
'(("command" . "delete_server")
("error" . null)
("finished" . null)
("id" . 1896091928)
("progress" . 0)
("resources" . #((("type" . "server") ("id" . 59570198))))
("started" . "2025-02-02T11:17:10+00:00")
("status" . "running")))
(define action-enable-rescue
(make-hetzner-action
"enable_rescue" #f *unspecified* 1896091721 0
(list (make-hetzner-resource 59570198 "server"))
#(10 17 11 2 1 125 0 32 -1 0 #f) "success"))
(define action-enable-rescue-alist
'(("command" . "enable_rescue")
("error" . null)
("finished" . null)
("id" . 1896091721)
("progress" . 0)
("resources" . #((("type" . "server") ("id" . 59570198))))
("started" . "2025-02-02T11:17:10+00:00")
("status" . "running")))
(define action-power-off
(make-hetzner-action
"stop_server" #f *unspecified* 1896091721 0
(list (make-hetzner-resource 59570198 "server"))
#(10 17 11 2 1 125 0 32 -1 0 #f) "success"))
(define action-power-off-alist
'(("command" . "stop_server")
("error" . null)
("finished" . null)
("id" . 1896091721)
("progress" . 0)
("resources" . #((("type" . "server") ("id" . 59570198))))
("started" . "2025-02-02T11:17:10+00:00")
("status" . "running")))
(define action-power-on
(make-hetzner-action
"start_server" #f *unspecified* 1896091721 0
(list (make-hetzner-resource 59570198 "server"))
#(10 17 11 2 1 125 0 32 -1 0 #f) "success"))
(define action-power-on-alist
'(("command" . "start_server")
("error" . null)
("finished" . null)
("id" . 1896091721)
("progress" . 0)
("resources" . #((("type" . "server") ("id" . 59570198))))
("started" . "2025-02-02T11:17:10+00:00")
("status" . "running")))
(define action-reboot
(make-hetzner-action
"reboot_server" #f *unspecified* 1896091721 0
(list (make-hetzner-resource 59570198 "server"))
#(10 17 11 2 1 125 0 32 -1 0 #f) "success"))
(define action-reboot-alist
'(("command" . "reboot_server")
("error" . null)
("finished" . null)
("id" . 1896091721)
("progress" . 0)
("resources" . #((("type" . "server") ("id" . 59570198))))
("started" . "2025-02-02T11:17:10+00:00")
("status" . "running")))
(define meta-page-alist
'("pagination"
("last_page" . 1)
("next_page" . null)
("page" . 1)
("per_page" . 25)
("previous_page" . null)
("total_entries" . 1)))
(define location-falkenstein
(make-hetzner-location
"Falkenstein" "DE" "Falkenstein DC Park 1"
1 50.47612 12.370071 "fsn1" "eu-central"))
(define location-falkenstein-alist
`(("city" . "Falkenstein")
("country" . "DE")
("description" . "Falkenstein DC Park 1")
("id" . 1)
("latitude" . 50.47612)
("longitude" . 12.370071)
("name" . "fsn1")
("network_zone" . "eu-central")))
(define server-type-cpx-11
(make-hetzner-server-type
"x86" 2 "shared" #f *unspecified*
"CPX 11" 40 22 2 "cpx11" "local"))
(define server-type-cpx-11-alist
`(("architecture" . "x86")
("cores" . 2)
("cpu_type" . "shared")
("deprecated" . #f)
("deprecation" . null)
("description" . "CPX 11")
("disk" . 40)
("id" . 22)
("memory" . 2)
("name" . "cpx11")
("storage_type" . "local")))
(define server-x86
(make-hetzner-server
"2024-12-30T16:38:11+00:00"
59570198
'()
"guix-x86"
(make-hetzner-public-net
(make-hetzner-ipv4 #f "static.218.128.13.49.clients.your-server.de" 78014457 "49.13.128.218")
(make-hetzner-ipv6 #f '() 78014458 "2a01:4f8:c17:293e::/64"))
#f
server-type-cpx-11))
(define server-x86-alist
`(("backup_window" . null)
("created" . "2024-12-30T16:38:11+00:00")
("id" . 59570198)
("included_traffic" . 21990232555520)
("ingoing_traffic" . 124530000)
("iso" . null)
("labels")
("load_balancers" . #())
("locked" . #f)
("name" . "guix-x86")
("outgoing_traffic" . 1391250000)
("placement_group" . null)
("primary_disk_size" . 320)
("private_net" . #())
("protection" ("rebuild" . #f) ("delete" . #f))
("public_net"
("firewalls" . #())
("floating_ips" . #())
("ipv6"
("id" . 78014458)
("dns_ptr" . #())
("blocked" . #f)
("ip" . "2a01:4f8:c17:293e::/64"))
("ipv4"
("id" . 78014457)
("dns_ptr" . "static.218.128.13.49.clients.your-server.de")
("blocked" . #f)
("ip" . "49.13.128.218")))
("rescue_enabled" . #f)
("server_type" ,@server-type-cpx-11-alist)
("status" . "running")
("volumes" . #())))
(define ssh-key-root
(make-hetzner-ssh-key
#(55 2 19 28 9 123 6 300 -1 0 #f)
"8c:25:09:8f:37:0f:d8:f0:99:4e:ab:c7:5c:1b:c6:53"
16510983 '() "root@example.com"
"ssh-ed25519 ABCAC3NzaC1lZDI1NTE5AAAAIBT3lLYPfOZV9NNrNk0jGCufWmXbFSz+ORxowJdHoSIM"))
(define ssh-key-root-alist
`(("created" . "2023-10-28T19:02:55+00:00")
("fingerprint" . "8c:25:09:8f:37:0f:d8:f0:99:4e:ab:c7:5c:1b:c6:53")
("id" . 16510983)
("labels")
("name" . "root@example.com")
("public_key" . "ssh-ed25519 ABCAC3NzaC1lZDI1NTE5AAAAIBT3lLYPfOZV9NNrNk0jGCufWmXbFSz+ORxowJdHoSIM")))
(define* (create-ssh-key api ssh-key #:key (labels %labels))
(hetzner-api-ssh-key-create
api
(hetzner-ssh-key-name ssh-key)
(hetzner-ssh-key-public-key ssh-key)
#:labels labels))
(define* (create-server api ssh-key #:key (labels %labels))
(hetzner-api-server-create api %server-name (list ssh-key)
#:labels labels
#:server-type "cpx31"))
(define (cleanup api)
(for-each (lambda (server)
(hetzner-api-server-delete api server))
(hetzner-api-servers
api #:params `(("label_selector" . "guix.gnu.org/test=true"))))
(for-each (lambda (ssh-key)
(hetzner-api-ssh-key-delete api ssh-key))
(hetzner-api-ssh-keys
api #:params `(("label_selector" . "guix.gnu.org/test=true"))))
api)
(define-syntax-rule (with-cleanup-api (api-sym api-init) body ...)
(let ((api-sym (cleanup api-init)))
(dynamic-wind
(const #t)
(lambda ()
body ...)
(lambda ()
(cleanup api-sym)))))
(test-begin "machine-hetzner-api")
;; Unit Tests
(test-equal "hetzner-api-actions-unit"
(list action-create-server action-delete-server)
(let ((actions (list action-create-server-alist action-delete-server-alist)))
(mock ((gnu machine hetzner http) hetzner-api-request-send
(lambda* (request #:key expected)
(assert (equal? 'GET (hetzner-api-request-method request)))
(assert (equal? "https://api.hetzner.cloud/v1/actions"
(hetzner-api-request-url request)))
(assert (unspecified? (hetzner-api-request-body request)))
(assert (equal? `(("page" . 1)
("id" . ,(string-join
(map (lambda (action)
(number->string (assoc-ref action "id")))
actions)
",")))
(hetzner-api-request-params request)))
(hetzner-api-response
(body `(("meta" . ,meta-page-alist)
("actions" . #(,action-create-server-alist ,action-delete-server-alist)))))))
(hetzner-api-actions (hetzner-api)
(map (lambda (action)
(assoc-ref action "id"))
actions)))))
(test-equal "hetzner-api-locations-unit"
(list location-falkenstein)
(mock ((gnu machine hetzner http) hetzner-api-request-send
(lambda* (request #:key expected)
(assert (equal? 'GET (hetzner-api-request-method request)))
(assert (equal? "https://api.hetzner.cloud/v1/locations"
(hetzner-api-request-url request)))
(assert (unspecified? (hetzner-api-request-body request)))
(assert (equal? '(("page" . 1)) (hetzner-api-request-params request)))
(hetzner-api-response
(body `(("meta" . ,meta-page-alist)
("locations" . #(,location-falkenstein-alist)))))))
(hetzner-api-locations (hetzner-api))))
(test-equal "hetzner-api-server-types-unit"
(list server-type-cpx-11)
(mock ((gnu machine hetzner http) hetzner-api-request-send
(lambda* (request #:key expected)
(assert (equal? 'GET (hetzner-api-request-method request)))
(assert (equal? "https://api.hetzner.cloud/v1/server_types"
(hetzner-api-request-url request)))
(assert (unspecified? (hetzner-api-request-body request)))
(assert (equal? '(("page" . 1)) (hetzner-api-request-params request)))
(hetzner-api-response
(body `(("meta" . ,meta-page-alist)
("server_types" . #(,server-type-cpx-11-alist)))))))
(hetzner-api-server-types (hetzner-api))))
(test-equal "hetzner-api-server-create-unit"
server-x86
(mock ((gnu machine hetzner http) hetzner-api-request-send
(lambda* (request #:key expected)
(cond
((equal? "https://api.hetzner.cloud/v1/servers"
(hetzner-api-request-url request))
(assert (equal? 'POST (hetzner-api-request-method request)))
(hetzner-api-response
(body `(("action" . ,action-create-server-alist)
("server" . ,server-x86-alist)))))
((equal? "https://api.hetzner.cloud/v1/actions"
(hetzner-api-request-url request))
(assert (equal? 'GET (hetzner-api-request-method request)))
(hetzner-api-response
(body `(("actions" . ,(vector (cons `("status" . "success")
action-create-server-alist)))
("meta" . ,meta-page-alist))))))))
(hetzner-api-server-create (hetzner-api) %server-name (list ssh-key-root))))
(test-equal "hetzner-api-server-delete-unit"
(make-hetzner-action
"delete_server" #f *unspecified* 1896091928 0
(list (make-hetzner-resource 59570198 "server"))
#(10 17 11 2 1 125 0 32 -1 0 #f) "success")
(mock ((gnu machine hetzner http) hetzner-api-request-send
(lambda* (request #:key expected)
(cond
((equal? "https://api.hetzner.cloud/v1/servers/59570198"
(hetzner-api-request-url request))
(assert (equal? 'DELETE (hetzner-api-request-method request)))
(hetzner-api-response
(body `(("action" . ,action-delete-server-alist)))))
((equal? "https://api.hetzner.cloud/v1/actions"
(hetzner-api-request-url request))
(assert (equal? 'GET (hetzner-api-request-method request)))
(hetzner-api-response
(body `(("actions" . ,(vector (cons `("status" . "success")
action-delete-server-alist)))
("meta" . ,meta-page-alist))))))))
(hetzner-api-server-delete (hetzner-api) server-x86)))
(test-equal "hetzner-api-server-enable-rescue-system-unit"
action-enable-rescue
(mock ((gnu machine hetzner http) hetzner-api-request-send
(lambda* (request #:key expected)
(cond
((equal? "https://api.hetzner.cloud/v1/servers/59570198/actions/enable_rescue"
(hetzner-api-request-url request))
(assert (equal? 'POST (hetzner-api-request-method request)))
(hetzner-api-response
(body `(("action" . ,action-enable-rescue-alist)))))
((equal? "https://api.hetzner.cloud/v1/actions"
(hetzner-api-request-url request))
(assert (equal? 'GET (hetzner-api-request-method request)))
(hetzner-api-response
(body `(("actions" . ,(vector (cons `("status" . "success")
action-enable-rescue-alist)))
("meta" . ,meta-page-alist))))))))
(hetzner-api-server-enable-rescue-system (hetzner-api) server-x86 (list ssh-key-root))))
(test-equal "hetzner-api-server-power-on-unit"
action-power-on
(mock ((gnu machine hetzner http) hetzner-api-request-send
(lambda* (request #:key expected)
(cond
((equal? "https://api.hetzner.cloud/v1/servers/59570198/actions/poweron"
(hetzner-api-request-url request))
(assert (equal? 'POST (hetzner-api-request-method request)))
(hetzner-api-response
(body `(("action" . ,action-power-on-alist)))))
((equal? "https://api.hetzner.cloud/v1/actions"
(hetzner-api-request-url request))
(assert (equal? 'GET (hetzner-api-request-method request)))
(hetzner-api-response
(body `(("actions" . ,(vector (cons `("status" . "success")
action-power-on-alist)))
("meta" . ,meta-page-alist))))))))
(hetzner-api-server-power-on (hetzner-api) server-x86)))
(test-equal "hetzner-api-server-power-off-unit"
action-power-off
(mock ((gnu machine hetzner http) hetzner-api-request-send
(lambda* (request #:key expected)
(cond
((equal? "https://api.hetzner.cloud/v1/servers/59570198/actions/poweroff"
(hetzner-api-request-url request))
(assert (equal? 'POST (hetzner-api-request-method request)))
(hetzner-api-response
(body `(("action" . ,action-power-off-alist)))))
((equal? "https://api.hetzner.cloud/v1/actions"
(hetzner-api-request-url request))
(assert (equal? 'GET (hetzner-api-request-method request)))
(hetzner-api-response
(body `(("actions" . ,(vector (cons `("status" . "success")
action-power-off-alist)))
("meta" . ,meta-page-alist))))))))
(hetzner-api-server-power-off (hetzner-api) server-x86)))
(test-equal "hetzner-api-server-reboot-unit"
action-reboot
(mock ((gnu machine hetzner http) hetzner-api-request-send
(lambda* (request #:key expected)
(cond
((equal? "https://api.hetzner.cloud/v1/servers/59570198/actions/reboot"
(hetzner-api-request-url request))
(assert (equal? 'POST (hetzner-api-request-method request)))
(hetzner-api-response
(body `(("action" . ,action-reboot-alist)))))
((equal? "https://api.hetzner.cloud/v1/actions"
(hetzner-api-request-url request))
(assert (equal? 'GET (hetzner-api-request-method request)))
(hetzner-api-response
(body `(("actions" . ,(vector (cons `("status" . "success")
action-reboot-alist)))
("meta" . ,meta-page-alist))))))))
(hetzner-api-server-reboot (hetzner-api) server-x86)))
(test-equal "hetzner-api-servers-unit"
(list server-x86)
(mock ((gnu machine hetzner http) hetzner-api-request-send
(lambda* (request #:key expected)
(hetzner-api-response
(body `(("meta" . ,meta-page-alist)
("servers" . #(,server-x86-alist)))))))
(hetzner-api-servers (hetzner-api))))
(test-equal "hetzner-api-ssh-key-create-unit"
ssh-key-root
(mock ((gnu machine hetzner http) hetzner-api-request-send
(lambda* (request #:key expected)
(assert (equal? 'POST (hetzner-api-request-method request)))
(assert (equal? "https://api.hetzner.cloud/v1/ssh_keys"
(hetzner-api-request-url request)))
(assert (equal? `(("name" . "guix-hetzner-api-test-key")
("public_key" . "ssh-ed25519 ABCAC3NzaC1lZDI1NTE5AAAAIBT3lLYPfOZV9NNrNk0jGCufWmXbFSz+ORxowJdHoSIM")
("labels" . (("a" . "1"))))
(hetzner-api-request-body request)))
(assert (equal? `() (hetzner-api-request-params request)))
(hetzner-api-response
(body `(("ssh_key" . ,ssh-key-root-alist))))))
(hetzner-api-ssh-key-create
(hetzner-api)
"guix-hetzner-api-test-key"
"ssh-ed25519 ABCAC3NzaC1lZDI1NTE5AAAAIBT3lLYPfOZV9NNrNk0jGCufWmXbFSz+ORxowJdHoSIM"
#:labels '(("a" . "1")))))
(test-assert "hetzner-api-ssh-key-delete-unit"
(mock ((gnu machine hetzner http) hetzner-api-request-send
(lambda* (request #:key expected)
(assert (equal? "https://api.hetzner.cloud/v1/ssh_keys/16510983"
(hetzner-api-request-url request)))
(assert (equal? 'DELETE (hetzner-api-request-method request)))
(hetzner-api-response)))
(hetzner-api-ssh-key-delete (hetzner-api) ssh-key-root)))
(test-equal "hetzner-api-ssh-keys-unit"
(list ssh-key-root)
(mock ((gnu machine hetzner http) hetzner-api-request-send
(lambda* (request #:key expected)
(assert (equal? 'GET (hetzner-api-request-method request)))
(assert (equal? "https://api.hetzner.cloud/v1/ssh_keys"
(hetzner-api-request-url request)))
(assert (unspecified? (hetzner-api-request-body request)))
(assert (equal? '(("page" . 1)) (hetzner-api-request-params request)))
(hetzner-api-response
(body `(("meta" . ,meta-page-alist)
("ssh_keys" . #(,ssh-key-root-alist)))))))
(hetzner-api-ssh-keys (hetzner-api))))
;; Integration tests
(test-skip %when-no-token)
(test-assert "hetzner-api-actions-integration"
(with-cleanup-api (api (hetzner-api))
(let* ((ssh-key (create-ssh-key api %ssh-key))
(server (create-server api ssh-key))
(action (hetzner-api-server-enable-rescue-system api server (list ssh-key))))
(member action (hetzner-api-actions api (list (hetzner-action-id action)))))))
(test-skip %when-no-token)
(test-assert "hetzner-api-locations-integration"
(let ((locations (hetzner-api-locations (hetzner-api))))
(and (> (length locations) 0)
(every hetzner-location? locations))))
(test-skip %when-no-token)
(test-assert "hetzner-api-server-types-integration"
(let ((server-types (hetzner-api-server-types (hetzner-api))))
(and (> (length server-types) 0)
(every hetzner-server-type? server-types))))
(test-skip %when-no-token)
(test-assert "hetzner-api-server-create-integration"
(with-cleanup-api (api (hetzner-api))
(let* ((ssh-key (create-ssh-key api %ssh-key))
(server (create-server api ssh-key)))
(and (hetzner-server? server)
(equal? %server-name (hetzner-server-name server))))))
(test-skip %when-no-token)
(test-assert "hetzner-api-server-delete-integration"
(with-cleanup-api (api (hetzner-api))
(let* ((ssh-key (create-ssh-key api %ssh-key))
(server (create-server api ssh-key))
(action (hetzner-api-server-delete api server)))
(and (hetzner-action? action)
(equal? "delete_server"
(hetzner-action-command action))))))
(test-skip %when-no-token)
(test-assert "hetzner-api-server-enable-rescue-system-integration"
(with-cleanup-api (api (hetzner-api))
(let* ((ssh-key (create-ssh-key api %ssh-key))
(server (create-server api ssh-key))
(action (hetzner-api-server-enable-rescue-system api server (list ssh-key))))
(and (hetzner-action? action)
(equal? "enable_rescue"
(hetzner-action-command action))))))
(test-skip %when-no-token)
(test-assert "hetzner-api-server-power-on-integration"
(with-cleanup-api (api (hetzner-api))
(let* ((ssh-key (create-ssh-key api %ssh-key))
(server (create-server api ssh-key))
(action (hetzner-api-server-power-on api server)))
(and (hetzner-action? action)
(equal? "start_server"
(hetzner-action-command action))))))
(test-skip %when-no-token)
(test-assert "hetzner-api-server-power-off-integration"
(with-cleanup-api (api (hetzner-api))
(let* ((ssh-key (create-ssh-key api %ssh-key))
(server (create-server api ssh-key))
(action (hetzner-api-server-power-off api server)))
(and (hetzner-action? action)
(equal? "stop_server"
(hetzner-action-command action))))))
(test-skip %when-no-token)
(test-assert "hetzner-api-server-reboot-integration"
(with-cleanup-api (api (hetzner-api))
(let* ((ssh-key (create-ssh-key api %ssh-key))
(server (create-server api ssh-key))
(action (hetzner-api-server-reboot api server)))
(and (hetzner-action? action)
(equal? "reboot_server"
(hetzner-action-command action))))))
(test-skip %when-no-token)
(test-assert "hetzner-api-servers-integration"
(with-cleanup-api (api (hetzner-api))
(let* ((ssh-key (create-ssh-key api %ssh-key))
(server (create-server api ssh-key)))
(member server (hetzner-api-servers api)))))
(test-skip %when-no-token)
(test-assert "hetzner-api-ssh-key-create-integration"
(with-cleanup-api (api (hetzner-api))
(let ((ssh-key (create-ssh-key api %ssh-key)))
(and (hetzner-ssh-key? ssh-key)
(equal? (hetzner-ssh-key-fingerprint %ssh-key)
(hetzner-ssh-key-fingerprint ssh-key))
(equal? (hetzner-ssh-key-name %ssh-key)
(hetzner-ssh-key-name ssh-key))
(equal? (hetzner-ssh-key-public-key %ssh-key)
(hetzner-ssh-key-public-key ssh-key))))))
(test-skip %when-no-token)
(test-assert "hetzner-api-ssh-key-delete-integration"
(with-cleanup-api (api (hetzner-api))
(let ((ssh-key (create-ssh-key api %ssh-key)))
(and (equal? #t (hetzner-api-ssh-key-delete api ssh-key))
(not (member ssh-key (hetzner-api-ssh-keys api)))))))
(test-skip %when-no-token)
(test-assert "hetzner-api-ssh-keys-integration"
(with-cleanup-api (api (hetzner-api))
(let ((ssh-key (create-ssh-key api %ssh-key)))
(member ssh-key (hetzner-api-ssh-keys api)))))
(test-end "machine-hetzner-api")
;; Local Variables:
;; eval: (put 'with-cleanup-api 'scheme-indent-function 1)
;; End: