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