From patchwork Tue Feb 4 19:01:14 2025 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Roman Scherer X-Patchwork-Id: 38203 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 7764127BBEA; Tue, 4 Feb 2025 19:02:45 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-7.6 required=5.0 tests=BAYES_00,DKIMWL_WL_HIGH, DKIM_SIGNED,DKIM_VALID,MAILING_LIST_MULTI,RCVD_IN_DNSWL_BLOCKED, RCVD_IN_VALIDITY_CERTIFIED,RCVD_IN_VALIDITY_RPBL,RCVD_IN_VALIDITY_SAFE, SPF_HELO_PASS,URIBL_BLOCKED autolearn=ham autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 12D0327BBE2 for ; Tue, 4 Feb 2025 19:02:42 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1tfOBV-0001Jf-Pv; Tue, 04 Feb 2025 14:02:12 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1tfOBS-0001If-Cr for guix-patches@gnu.org; Tue, 04 Feb 2025 14:02:06 -0500 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1tfOBR-0004kc-OE; Tue, 04 Feb 2025 14:02:05 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=debbugs.gnu.org; s=debbugs-gnu-org; h=MIME-Version:References:In-Reply-To:Date:From:To:Subject; bh=W//CVELOCvmOxtJazm7ygGh9QmVfnX4ntStQjwJ3bmo=; b=QUfn8QNFutud3Wn6AAA3seitLweeFik7r6Phys4F6jrWwlw4gWDarWo5bya0+1hFYZYzpNXO4TD4oYlfw1RAEetMFAJlo/IrHKNlt6EaIJcxfoPY9GO5sEz+stP7tcrCjmOy4XJhW8vKtHufITIODWd4M5usD1pKyWesRPn/BzXOdJvnlpr3/nvfssl1DH7ilmC3Li7jVezDQ6MWx8i5zveXsg9L4LmFlBmpBU6brJwtRS95Cpfp4M38iCN8s+UteiqJ6u0MhKDp8OmOumvFJHnsaMleUMUV/B0LOxZpA9x+WgNYGPnlgKgiM+uPJTy0UZNPDZ0ZTR3cZIPv9c8MAw==; Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1tfOBO-00060V-Pz; Tue, 04 Feb 2025 14:02:02 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#75144] [PATCH v3 2/2] machine: Implement 'hetzner-environment-type'. Resent-From: Roman Scherer Original-Sender: "Debbugs-submit" Resent-CC: pelzflorian@pelzflorian.de, julien@lepiller.eu, ludo@gnu.org, maxim.cournoyer@gmail.com, guix-patches@gnu.org Resent-Date: Tue, 04 Feb 2025 19:02:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 75144 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 75144@debbugs.gnu.org Cc: Roman Scherer , Florian Pelz , Julien Lepiller , Ludovic =?utf-8?q?Court=C3=A8s?= , Maxim Cournoyer X-Debbugs-Original-Xcc: Florian Pelz , Julien Lepiller , Ludovic =?utf-8?q?Court=C3=A8s?= , Maxim Cournoyer Received: via spool by 75144-submit@debbugs.gnu.org id=B75144.173869569623045 (code B ref 75144); Tue, 04 Feb 2025 19:02:02 +0000 Received: (at 75144) by debbugs.gnu.org; 4 Feb 2025 19:01:36 +0000 Received: from localhost ([127.0.0.1]:46679 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1tfOAy-0005zc-3n for submit@debbugs.gnu.org; Tue, 04 Feb 2025 14:01:36 -0500 Received: from mail-ed1-x536.google.com ([2a00:1450:4864:20::536]:60779) by debbugs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.84_2) (envelope-from ) id 1tfOAv-0005z6-PG for 75144@debbugs.gnu.org; Tue, 04 Feb 2025 14:01:34 -0500 Received: by mail-ed1-x536.google.com with SMTP id 4fb4d7f45d1cf-5d90a5581fcso10864924a12.1 for <75144@debbugs.gnu.org>; Tue, 04 Feb 2025 11:01:33 -0800 (PST) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=burningswell-com.20230601.gappssmtp.com; s=20230601; t=1738695687; x=1739300487; darn=debbugs.gnu.org; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:from:to:cc:subject:date :message-id:reply-to; bh=W//CVELOCvmOxtJazm7ygGh9QmVfnX4ntStQjwJ3bmo=; b=SkJJEGmW835mViZm2tPIc5wpi+uWUbjWAMOq/KReGZC+LneJfoBku7JT/uoCY/yXk1 cMntFj9iGfI6lgGg2GaIEF/YHU7jZhAqLRW2mqE3gFNEoxdFVZZ7DvVTY5EtdE/YpdvL TqS71RYioxgi6u+qekf1ws/+gs/u2IOovJBxWog5SZbYEyd9TfHI+/VewqX/vmrbLycM I2DutTna7b4l/+FmtCHDs6TSlbH0dp5yQ+8KUkAEJRP0+dzkCwpXfArckZz7AZmYV0Jn Ju2tIe4x6Vva7bjBufPSXBDcT0uh3zoxsT3ehiFAok10lBu/F1/FGhlBX8V5edNF+V06 e9NA== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20230601; t=1738695687; x=1739300487; h=content-transfer-encoding:mime-version:references:in-reply-to :message-id:date:subject:cc:to:from:x-gm-message-state:from:to:cc :subject:date:message-id:reply-to; bh=W//CVELOCvmOxtJazm7ygGh9QmVfnX4ntStQjwJ3bmo=; b=QVvjeJI74fTNMATkQnfqeIVuczYuI14+Gt3GahPMjiTK/eEudoLUfsMFsUxq4Ii7Bi BJxSxjF5kIDDLaNpw0+wq/6PfXnIpw1h68sEa7jz7TS6KLJt7lLhh+YHYMDzauWWBNNO pu6+DAoCCU5bCFU3tMdL5TBFmee1erCbFfT8F2C9zhLznaSccdn2u4nJupi9cpptQokv TyIKowUteFMCpFptV6LEckz0DaAMtwA8yszWdO/Llo80j4sHYlUrsaAgCpT/zDKbL5Kq LzWObMy1ME4M2ir9YRlr7VRPeeSyH96kpkpc+uQ2zieuFXVd+V06EUvV0s6eIfemwibW OO7g== X-Gm-Message-State: AOJu0Ywv+JltkxVNtGn2fc2jGIrqrwORyULO+1f4gIL47hXMhLka7D4b i5d/zlBePvGUKE47UUDZ4X8CBXXkoJ0fFOc6MwfA7WsYgSdOzuuvYU7J75mapdm+qileLA68YZN PQjsTYw== X-Gm-Gg: ASbGnct+ruEmEyD8iYsnzRpF5mks30K35ruXLgCXD6/w30u0I3+TwHUc4AjMdmBmWcI neOcjC8mHYvmvllfJXs5xwK/wJAwb/rSgALHViqY9zBkVhhoLfABCd8mI8y1qEGj3dl9Je+XWxp YZynLTZ2DIRinXbAmPBclUg2u2W35rFIX3vBB2rrpnu+2em72TV34y+CZ5PoArdqobuAWyUtL6t ky1g5tYExhaF3Xv8RdevrUmi53OOJBpQ1nejB24HY8jUFVX5tTmlhEQSylq6rw6H9vyHifv/qIE B3biJYpZxA9cponpdDxgja82G6NlBNCBf7RuutDNRoSMAnLILrYO7qNwMYnWOYFkqOQ= X-Google-Smtp-Source: AGHT+IEDPUf8O9IDzprnDNFaFQFMvgakqAo4xUyrjQyim0fU1Y39fES3Ifz4PvHTaUTQ9Y09WlCrqQ== X-Received: by 2002:a17:907:2cc5:b0:aa6:9eac:4b8e with SMTP id a640c23a62f3a-ab6cfdbf7e2mr3437516766b.41.1738695684344; Tue, 04 Feb 2025 11:01:24 -0800 (PST) Received: from localhost.localdomain (tmo-086-39.customers.d1-online.com. [80.187.86.39]) by smtp.gmail.com with ESMTPSA id a640c23a62f3a-ab6e47cf29fsm967666266b.38.2025.02.04.11.01.23 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Tue, 04 Feb 2025 11:01:23 -0800 (PST) From: Roman Scherer Date: Tue, 4 Feb 2025 20:01:14 +0100 Message-ID: <7b51e5d7ae56f7f9792252e98b57371b2904a3fe.1738695552.git.roman@burningswell.com> X-Mailer: git-send-email 2.48.1 In-Reply-To: <53d36027832470a5f3a38d4003ce426fabedb97b.1738695552.git.roman@burningswell.com> References: <53d36027832470a5f3a38d4003ce426fabedb97b.1738695552.git.roman@burningswell.com> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches * Makefile.am (SCM_TESTS): Add test modules. * doc/guix.texi: Add documentation. * gnu/local.mk (GNU_SYSTEM_MODULES): Add modules. * gnu/machine/hetzner.scm: Add hetzner-environment-type. * gnu/machine/hetzner/http.scm: Add HTTP API. * po/guix/POTFILES.in: Add Hetzner modules. * tests/machine/hetzner.scm: Add machine tests. * tests/machine/hetzner/http.scm Add HTTP API tests. Change-Id: I276ed5afed676bbccc6c852c56ee4db57ce3c1ea --- Makefile.am | 2 + doc/guix.texi | 128 ++++++ gnu/local.mk | 2 + gnu/machine/hetzner.scm | 705 +++++++++++++++++++++++++++++++++ gnu/machine/hetzner/http.scm | 664 +++++++++++++++++++++++++++++++ po/guix/POTFILES.in | 2 + tests/machine/hetzner.scm | 267 +++++++++++++ tests/machine/hetzner/http.scm | 631 +++++++++++++++++++++++++++++ 8 files changed, 2401 insertions(+) create mode 100644 gnu/machine/hetzner.scm create mode 100644 gnu/machine/hetzner/http.scm create mode 100644 tests/machine/hetzner.scm create mode 100644 tests/machine/hetzner/http.scm diff --git a/Makefile.am b/Makefile.am index f759803b8b..7bb75aa146 100644 --- a/Makefile.am +++ b/Makefile.am @@ -562,6 +562,8 @@ SCM_TESTS = \ tests/import-utils.scm \ tests/inferior.scm \ tests/lint.scm \ + tests/machine/hetzner.scm \ + tests/machine/hetzner/http.scm \ tests/minetest.scm \ tests/modules.scm \ tests/monads.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index bb5f29277f..4226d7ae26 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -44783,6 +44783,134 @@ Invoking guix deploy @end table @end deftp +@deftp {Data Type} hetzner-configuration +This is the data type describing the server that should be created for a +machine with an @code{environment} of +@code{hetzner-environment-type}. It allows you to configure deployment +to a @acronym{VPS, virtual private server} hosted by +@uref{https://www.hetzner.com, Hetzner}. + +@table @asis + +@item @code{allow-downgrades?} (default: @code{#f}) +Whether to allow potential downgrades. + +@item @code{authorize?} (default: @code{#t}) +If true, the public signing key @code{"/etc/guix/signing-key.pub"} of +the machine that invokes @command{guix deploy} will be added to the +operating system ACL keyring of the target machine. + +@item @code{build-locally?} (default: @code{#t}) +If true, system derivations will be built on the machine that invokes +@command{guix deploy}, otherwise derivations are build on the target +machine. Set this to @code{#f} if the machine you are deploying from +has a different architecture than the target machine and you can't build +derivations for the target architecture by other means, like offloading +(@pxref{Daemon Offload Setup}) or emulation +(@pxref{transparent-emulation-qemu, Transparent Emulation with QEMU}). + +@item @code{delete?} (default: @code{#t}) +If true, the server will be deleted when an error happens in the +provisioning phase. If false, the server will be kept in order to debug +any issues. + +@item @code{labels} (default: @code{'()}) +A user defined alist of key/value pairs attached to the SSH key and the +server on the Hetzner API. Keys and values must be strings, +e.g. @code{'(("environment" . "development"))}. For more information, +see @uref{https://docs.hetzner.cloud/#labels, Labels}. + +@item @code{location} (default: @code{"fsn1"}) +The name of a @uref{https://docs.hetzner.com/cloud/general/locations, +location} to create the server in. For example, @code{"fsn1"} +corresponds to the Hetzner site in Falkenstein, Germany, while +@code{"sin"} corresponds to its site in Singapore. + +@item @code{server-type} (default: @code{"cx42"}) +The name of the +@uref{https://docs.hetzner.com/cloud/servers/overview#server-types, +server type} this virtual server should be created with. For example, +@code{"cx42"} corresponds to a x86_64 server that has 8 VCPUs, 16 GB of +memory and 160 GB of storage, while @code{"cax31"} to the AArch64 +equivalent. Other server types and their current prices can be found +@uref{https://www.hetzner.com/cloud/#pricing, here}. + +@item @code{ssh-key} +The file name of the SSH private key to use to authenticate with the +remote host. + +@end table + +When deploying a machine for the first time, the following steps are +taken to provision a server for the machine on the +@uref{https://www.hetzner.com/cloud, Hetzner Cloud} service: + +@itemize + +@item +Create the SSH key of the machine on the Hetzner API. + +@item +Create a server for the machine on the Hetzner API. + +@item +Format the root partition of the disk using the file system of the +machine's operating system. Supported file systems are btrfs and ext4. + +@item +Install a minimal Guix operating system on the server using the +@uref{https://docs.hetzner.com/cloud/servers/getting-started/rescue-system, +rescue mode}. This minimal system is used to install the machine's +operating system, after rebooting. + +@item +Reboot the server and apply the machine's operating system on the +server. + +@end itemize + +Once the server has been provisioned and SSH is available, deployment +continues by delegating it to the @code{managed-host-environment-type}. + +Servers on the Hetzner Cloud service can be provisioned on the AArch64 +architecture using UEFI boot mode, or on the x86_64 architecture using +BIOS boot mode. The @code{(gnu machine hetzner)} module exports the +@code{%hetzner-os-arm} and @code{%hetzner-os-x86} operating systems that +are compatible with those two architectures, and can be used as a base +for defining your custom operating system. + +The following example shows the definition of two machines that are +deployed on the Hetzner Cloud service. The first one uses the +@code{%hetzner-os-arm} operating system to run a server with 16 shared +vCPUs and 32 GB of RAM on the @code{aarch64} architecture, the second +one uses the @code{%hetzner-os-x86} operating system on a server with 16 +shared vCPUs and 32 GB of RAM on the @code{x86_64} architecture. + +@lisp +(use-modules (gnu machine) + (gnu machine hetzner)) + +(list (machine + (operating-system %hetzner-os-arm) + (environment hetzner-environment-type) + (configuration (hetzner-configuration + (server-type "cax41") + (ssh-key "/home/charlie/.ssh/id_rsa")))) + (machine + (operating-system %hetzner-os-x86) + (environment hetzner-environment-type) + (configuration (hetzner-configuration + (server-type "cpx51") + (ssh-key "/home/charlie/.ssh/id_rsa"))))) +@end lisp + +Passing this file to @command{guix deploy} with the environment variable +@env{GUIX_HETZNER_API_TOKEN} set to a valid Hetzner +@uref{https://docs.hetzner.com/cloud/api/getting-started/generating-api-token, +API key} should provision two machines for you. + +@end deftp + @node Running Guix in a VM @section Running Guix in a Virtual Machine diff --git a/gnu/local.mk b/gnu/local.mk index 83abc86fe2..cc812ad6f3 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -921,6 +921,8 @@ if HAVE_GUILE_SSH GNU_SYSTEM_MODULES += \ %D%/machine/digital-ocean.scm \ + %D%/machine/hetzner.scm \ + %D%/machine/hetzner/http.scm \ %D%/machine/ssh.scm endif HAVE_GUILE_SSH diff --git a/gnu/machine/hetzner.scm b/gnu/machine/hetzner.scm new file mode 100644 index 0000000000..5e17bfae21 --- /dev/null +++ b/gnu/machine/hetzner.scm @@ -0,0 +1,705 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2024 Roman Scherer +;;; +;;; 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 . + +(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 + make-hetzner-configuration hetzner-configuration? this-hetzner-configuration + (allow-downgrades? hetzner-configuration-allow-downgrades? ; boolean + (default #f)) + (api hetzner-configuration-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 +." + (let ((config (machine-configuration machine)) + (environment (environment-type-name (machine-environment machine)))) + (unless (and config (hetzner-configuration? config)) + (raise-exception + (formatted-message (G_ "unsupported machine configuration '~a' \ +for environment of type '~a'") + config + environment))))) + +(define (hetzner-machine-validate-server-type machine) + "Raise an error if the server type of MACHINE is not supported." + (unless (hetzner-machine-server-type machine) + (let* ((config (machine-configuration machine)) + (api (hetzner-configuration-api config))) + (raise-exception + (formatted-message + (G_ "server type '~a' not supported~%~%\ +Available server types:~%~%~a~%~%For more details and prices, see: ~a") + (hetzner-configuration-server-type config) + (string-join + (map (lambda (type) + (format #f " - ~a: ~a, ~a ~a cores, ~a GB mem, ~a GB disk" + (colorize-string + (hetzner-server-type-name type) + (color BOLD)) + (hetzner-server-type-architecture type) + (hetzner-server-type-cores type) + (hetzner-server-type-cpu-type type) + (hetzner-server-type-memory type) + (hetzner-server-type-disk type))) + (hetzner-api-server-types api)) + "\n") + "https://www.hetzner.com/cloud#pricing"))))) + +(define (hetzner-machine-validate-location machine) + "Raise an error if the location of MACHINE is not supported." + (unless (hetzner-machine-location machine) + (let* ((config (machine-configuration machine)) + (api (hetzner-configuration-api config))) + (raise-exception + (formatted-message + (G_ "server location '~a' not supported~%~%\ +Available locations:~%~%~a~%~%For more details, see: ~a") + (hetzner-configuration-location config) + (string-join + (map (lambda (location) + (format #f " - ~a: ~a, ~a" + (colorize-string + (hetzner-location-name location) + (color BOLD)) + (hetzner-location-description location) + (hetzner-location-country location))) + (hetzner-api-locations api)) + "\n") + "https://www.hetzner.com/cloud#locations"))))) + +(define (hetzner-machine-validate machine) + "Validate the Hetzner MACHINE." + (hetzner-machine-validate-configuration-type machine) + (hetzner-machine-validate-api-token machine) + (hetzner-machine-validate-location machine) + (hetzner-machine-validate-server-type machine)) + +(define (hetzner-machine-bootstrap-os-form machine server) + "Return the form to bootstrap an operating system on SERVER." + (let* ((os (machine-operating-system machine)) + (system (hetzner-server-system server)) + (arm? (equal? "arm" (hetzner-server-architecture server))) + (x86? (equal? "x86" (hetzner-server-architecture server))) + (root-fs-type (operating-system-root-file-system-type os))) + `(operating-system + (host-name ,(operating-system-host-name os)) + (timezone "Etc/UTC") + (bootloader (bootloader-configuration + (bootloader ,(cond (arm? 'grub-efi-bootloader) + (x86? 'grub-bootloader))) + (targets ,(cond (arm? '(list "/boot/efi")) + (x86? '(list "/dev/sda")))) + (terminal-outputs '(console)))) + (initrd-modules (append + ,(cond (arm? '(list "sd_mod" "virtio_scsi")) + (x86? '(list "virtio_scsi"))) + %base-initrd-modules)) + (file-systems ,(cond + (arm? `(cons* (file-system + (mount-point "/") + (device "/dev/sda1") + (type ,root-fs-type)) + (file-system + (mount-point "/boot/efi") + (device "/dev/sda15") + (type "vfat")) + %base-file-systems)) + (x86? `(cons* (file-system + (mount-point "/") + (device "/dev/sda1") + (type ,root-fs-type)) + %base-file-systems)))) + (services + (cons* (service dhcp-client-service-type) + (service openssh-service-type + (openssh-configuration + (openssh openssh-sans-x) + (permit-root-login 'prohibit-password))) + %base-services))))) + +(define (rexec-verbose session cmd) + "Execute a command CMD on the remote side and print output. Return two +values: list of output lines returned by CMD and its exit code." + (let* ((channel (open-remote-input-pipe session cmd)) + (result (let loop ((line (read-line channel)) + (result '())) + (if (eof-object? line) + (reverse result) + (begin + (display line) + (newline) + (loop (read-line channel) + (cons line result)))))) + (exit-status (channel-get-exit-status channel))) + (close channel) + (values result exit-status))) + +(define (hetzner-machine-ssh-key machine) + "Find the SSH key for MACHINE on the Hetzner API." + (let* ((config (machine-configuration machine)) + (expected (hetzner-configuration-ssh-key-fingerprint config))) + (find (lambda (ssh-key) + (equal? expected (hetzner-ssh-key-fingerprint ssh-key))) + (hetzner-api-ssh-keys + (hetzner-configuration-api config) + #:params `(("fingerprint" . ,expected)))))) + +(define (hetzner-machine-ssh-key-create machine) + "Create the SSH key for MACHINE on the Hetzner API." + (let ((name (machine-display-name machine))) + (format #t "creating ssh key for '~a'...\n" name) + (let* ((config (machine-configuration machine)) + (api (hetzner-configuration-api config)) + (ssh-key (hetzner-api-ssh-key-create + (hetzner-configuration-api config) + (hetzner-configuration-ssh-key-fingerprint config) + (hetzner-configuration-ssh-key-public config) + #:labels (hetzner-configuration-labels config)))) + (format #t "successfully created ssh key for '~a'\n" name) + ssh-key))) + +(define (hetzner-machine-server machine) + "Find the Hetzner server for MACHINE." + (let ((config (machine-configuration machine))) + (find (lambda (server) + (equal? (machine-display-name machine) + (hetzner-server-name server))) + (hetzner-api-servers + (hetzner-configuration-api config) + #:params `(("name" . ,(machine-display-name machine))))))) + +(define (hetzner-machine-create-server machine) + "Create the Hetzner server for MACHINE." + (let* ((config (machine-configuration machine)) + (name (machine-display-name machine)) + (server-type (hetzner-configuration-server-type config))) + (format #t "creating '~a' server for '~a'...\n" server-type name) + (let* ((ssh-key (hetzner-machine-ssh-key machine)) + (api (hetzner-configuration-api config)) + (server (hetzner-api-server-create + api + (machine-display-name machine) + (list ssh-key) + #:labels (hetzner-configuration-labels config) + #:location (hetzner-configuration-location config) + #:server-type (hetzner-configuration-server-type config))) + (architecture (hetzner-server-architecture server))) + (format #t "successfully created '~a' ~a server for '~a'\n" + server-type architecture name) + server))) + +(define (wait-for-ssh address ssh-key) + "Block until a SSH session can be made as 'root' with SSH-KEY at ADDRESS." + (format #t "connecting via SSH to '~a' using '~a'...\n" address ssh-key) + (let loop () + (catch #t + (lambda () + (open-ssh-session address #:user "root" #:identity ssh-key + #:strict-host-key-check? #f)) + (lambda args + (let ((msg (cadr args))) + (if (formatted-message? msg) + (format #t "~a\n" + (string-trim-right + (apply format #f + (formatted-message-string msg) + (formatted-message-arguments msg)) + #\newline)) + (format #t "~a" args)) + (sleep 5) + (loop)))))) + +(define (hetzner-machine-wait-for-ssh machine server) + "Wait for SSH connection to be established with the specified machine." + (wait-for-ssh (hetzner-server-public-ipv4 server) + (hetzner-configuration-ssh-key + (machine-configuration machine)))) + +(define (hetzner-machine-authenticate-host machine server) + "Add the host key of MACHINE to the list of known hosts." + (let ((ssh-session (hetzner-machine-wait-for-ssh machine server))) + (write-known-host! ssh-session))) + +(define (hetzner-machine-enable-rescue-system machine server) + "Enable the rescue system on the Hetzner SERVER for MACHINE." + (let* ((name (machine-display-name machine)) + (config (machine-configuration machine)) + (api (hetzner-configuration-api config)) + (ssh-keys (list (hetzner-machine-ssh-key machine)))) + (format #t "enabling rescue system on '~a'...\n" name) + (let ((action (hetzner-api-server-enable-rescue-system api server ssh-keys))) + (format #t "successfully enabled rescue system on '~a'\n" name) + action))) + +(define (hetzner-machine-power-on machine server) + "Power on the Hetzner SERVER for MACHINE." + (let* ((name (machine-display-name machine)) + (config (machine-configuration machine)) + (api (hetzner-configuration-api config))) + (format #t "powering on server for '~a'...\n" name) + (let ((action (hetzner-api-server-power-on api server))) + (format #t "successfully powered on server for '~a'\n" name) + action))) + +(define (hetzner-machine-ssh-run-script ssh-session name content) + (let ((sftp-session (make-sftp-session ssh-session))) + (rexec ssh-session (format #f "rm -f ~a" name)) + (rexec ssh-session (format #f "mkdir -p ~a" (dirname name))) + (call-with-remote-output-file + sftp-session name + (lambda (port) + (display content port))) + (sftp-chmod sftp-session name 755) + (let ((lines exit-code (rexec-verbose ssh-session + (format #f "~a 2>&1" name)))) + (if (zero? exit-code) + lines + (raise-exception + (formatted-message + (G_ "failed to run script '~a' on machine, exit code: '~a'") + name exit-code)))))) + +;; Prevent compiler from inlining this function, so we can mock it in tests. +(set! hetzner-machine-ssh-run-script hetzner-machine-ssh-run-script) + +(define (hetzner-machine-rescue-install-os machine ssh-session server) + (let ((name (machine-display-name machine)) + (os (hetzner-machine-bootstrap-os-form machine server))) + (format #t "installing guix operating system on '~a'...\n" name) + (hetzner-machine-ssh-run-script + ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-install-os" + (format #f "#!/usr/bin/env bash +set -eo pipefail +mount /dev/sda1 /mnt +mkdir -p /mnt/boot/efi +mount /dev/sda15 /mnt/boot/efi + +mkdir --parents /mnt/root/.ssh +chmod 700 /mnt/root/.ssh +cp /root/.ssh/authorized_keys /mnt/root/.ssh/authorized_keys +chmod 600 /mnt/root/.ssh/authorized_keys + +cat > /tmp/guix/deploy/hetzner-os.scm << EOF +(use-modules (gnu) (guix utils)) +(use-package-modules ssh) +(use-service-modules base networking ssh) +(use-system-modules linux-initrd) +~a +EOF +guix system init --verbosity=2 /tmp/guix/deploy/hetzner-os.scm /mnt" + (escape-backticks (format #f "~y" os)))) + (format #t "successfully installed guix operating system on '~a'\n" name))) + +(define (hetzner-machine-reboot machine server) + "Reboot the Hetzner SERVER for MACHINE." + (let* ((name (machine-display-name machine)) + (config (machine-configuration machine)) + (api (hetzner-configuration-api config))) + (format #t "rebooting server for '~a'...\n" name) + (let ((action (hetzner-api-server-reboot api server))) + (format #t "successfully rebooted server for '~a'\n" name) + action))) + +(define (hetzner-machine-rescue-partition machine ssh-session) + "Setup the partitions of the Hetzner server for MACHINE using SSH-SESSION." + (let* ((name (machine-display-name machine)) + (os (machine-operating-system machine)) + (root-fs-type (operating-system-root-file-system-type os))) + (format #t "setting up partitions on '~a'...\n" name) + (hetzner-machine-ssh-run-script + ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-partition" + (format #f "#!/usr/bin/env bash +set -eo pipefail +growpart /dev/sda 1 || true +~a +fdisk -l /dev/sda" + (cond + ((equal? "btrfs" root-fs-type) + (format #f "mkfs.btrfs -L ~a -f /dev/sda1" root-label)) + ((equal? "ext4" root-fs-type) + (format #f "mkfs.ext4 -L ~a -F /dev/sda1" root-label)) + (else (raise-exception + (formatted-message + (G_ "unsupported root file system type '~a'") + root-fs-type)))))) + (format #t "successfully setup partitions on '~a'\n" name))) + +(define (hetzner-machine-rescue-install-packages machine ssh-session) + "Install packages on the Hetzner server for MACHINE using SSH-SESSION." + (let ((name (machine-display-name machine))) + (format #t "installing rescue system packages on '~a'...\n" name) + (hetzner-machine-ssh-run-script + ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-install-packages" + (format #f "#!/usr/bin/env bash +set -eo pipefail +apt-get update +apt-get install guix cloud-initramfs-growroot --assume-yes")) + (format #t "successfully installed rescue system packages on '~a'\n" name))) + +(define (hetzner-machine-delete machine server) + "Delete the Hetzner server for MACHINE." + (let* ((name (machine-display-name machine)) + (config (machine-configuration machine)) + (api (hetzner-configuration-api config))) + (format #t "deleting server for '~a'...\n" name) + (let ((action (hetzner-api-server-delete api server))) + (format #t "successfully deleted server for '~a'\n" name) + action))) + +(define (hetzner-machine-provision machine) + "Provision a server for MACHINE on the Hetzner Cloud service." + (with-exception-handler + (lambda (exception) + (let ((config (machine-configuration machine)) + (server (hetzner-machine-server machine))) + (when (and server (hetzner-configuration-delete? config)) + (hetzner-machine-delete machine server)) + (raise-exception exception))) + (lambda () + (let ((server (hetzner-machine-create-server machine))) + (hetzner-machine-enable-rescue-system machine server) + (hetzner-machine-power-on machine server) + (let ((ssh-session (hetzner-machine-wait-for-ssh machine server))) + (hetzner-machine-rescue-install-packages machine ssh-session) + (hetzner-machine-rescue-partition machine ssh-session) + (hetzner-machine-rescue-install-os machine ssh-session server) + (hetzner-machine-reboot machine server) + (sleep 5) + (hetzner-machine-authenticate-host machine server) + server))) + #:unwind? #t)) + +(define (machine-not-provisioned machine) + (formatted-message + (G_ "no server provisioned for machine '~a' on the Hetzner Cloud service") + (machine-display-name machine))) + + +;;; +;;; Remote evaluation. +;;; + +(define (hetzner-remote-eval machine exp) + "Internal implementation of 'machine-remote-eval' for MACHINE instances with +an environment type of 'hetzner-environment-type'." + (hetzner-machine-validate machine) + (let ((server (hetzner-machine-server machine))) + (unless server (raise-exception (machine-not-provisioned machine))) + (machine-remote-eval (hetzner-machine-delegate machine server) exp))) + + + +;;; +;;; System deployment. +;;; + +(define (deploy-hetzner machine) + "Internal implementation of 'deploy-machine' for 'machine' instances with an +environment type of 'hetzner-environment-type'." + (hetzner-machine-validate machine) + (unless (hetzner-machine-ssh-key machine) + (hetzner-machine-ssh-key-create machine)) + (let ((server (or (hetzner-machine-server machine) + (hetzner-machine-provision machine)))) + (deploy-machine (hetzner-machine-delegate machine server)))) + + + +;;; +;;; Roll-back. +;;; + +(define (roll-back-hetzner machine) + "Internal implementation of 'roll-back-machine' for MACHINE instances with an +environment type of 'hetzner-environment-type'." + (hetzner-machine-validate machine) + (let ((server (hetzner-machine-server machine))) + (unless server (raise-exception (machine-not-provisioned machine))) + (roll-back-machine (hetzner-machine-delegate machine server)))) + + + +;;; +;;; Environment type. +;;; + +(define hetzner-environment-type + (environment-type + (machine-remote-eval hetzner-remote-eval) + (deploy-machine deploy-hetzner) + (roll-back-machine roll-back-hetzner) + (name 'hetzner-environment-type) + (description "Provisioning of virtual machine servers on the Hetzner Cloud +service."))) diff --git a/gnu/machine/hetzner/http.scm b/gnu/machine/hetzner/http.scm new file mode 100644 index 0000000000..bfd6555472 --- /dev/null +++ b/gnu/machine/hetzner/http.scm @@ -0,0 +1,664 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2024 Roman Scherer +;;; +;;; 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 . + +(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 + make-hetzner-action hetzner-action? json->hetzner-action + (command hetzner-action-command) ; string + (error hetzner-action-error "error" + json->maybe-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 + (started hetzner-action-started "started" string->time) ; time + (status hetzner-action-status)) + +(define-json-mapping + 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 + make-hetzner-dns hetzner-dns? json->hetzner-dns + (ip hetzner-dns-ip) ; string + (ptr hetzner-dns-ptr "dns_ptr")) ; string + +(define-json-mapping + make-hetzner-error hetzner-error? json->hetzner-error + (code hetzner-error-code) ; string + (message hetzner-error-message)) ; + +(define-json-mapping + 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 + 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 + (id hetzner-ipv6-id) ; integer + (ip hetzner-ipv6-ip)) ; string + +(define-json-mapping + 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 + make-hetzner-public-net hetzner-public-net? json->hetzner-public-net + (ipv4 hetzner-public-net-ipv4 "ipv4" json->hetzner-ipv4) ; + (ipv6 hetzner-public-net-ipv6 "ipv6" json->hetzner-ipv6)) ; + +(define-json-mapping + make-hetzner-resource hetzner-resource? json->hetzner-resource + (id hetzner-resource-id) ; integer + (type hetzner-resource-type)) ; string + +(define-json-mapping + 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) ; + (rescue-enabled? hetzner-server-rescue-enabled? "rescue_enabled") ; boolean + (server-type hetzner-server-type "server_type" + json->hetzner-server-type)) ; + +(define-json-mapping + 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) ; + (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 + 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 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 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 make-hetzner-api hetzner-api? + (base-url hetzner-api-base-url ; string + (default "https://api.hetzner.cloud/v1")) + (token hetzner-api-token ; string + (default (%hetzner-default-api-token)))) + +(define (hetzner-api-authorization-header api) + "Return the authorization header for the Hetzner API." + (format #f "Bearer ~a" (hetzner-api-token api))) + +(define (hetzner-api-default-headers api) + "Returns the default headers of the Hetzner API." + `((user-agent . "Guix Deploy") + (Accept . "application/json") + (Authorization . ,(hetzner-api-authorization-header api)) + (Content-Type . "application/json"))) + +(define (hetzner-api-url api path) + "Append PATH to the base url of the Hetzner API." + (string-append (hetzner-api-base-url api) path)) + +(define (hetzner-api-delete api path) + "Delelte the resource at PATH with the Hetzner API." + (hetzner-api-response-body + (hetzner-api-request-send + (hetzner-api-request + (headers (hetzner-api-default-headers api)) + (method 'DELETE) + (url (hetzner-api-url api path)))))) + +(define* (hetzner-api-list api path resources json->object #:key (params '())) + "Fetch all objects of RESOURCE from the Hetzner API." + (let ((body (hetzner-api-response-body + (hetzner-api-response-pagination-combine + resources (hetzner-api-request-paginate + (hetzner-api-request + (url (hetzner-api-url api path)) + (headers (hetzner-api-default-headers api)) + (params (cons '("page" . 1) params)))))))) + (map json->object (assoc-ref body resources)))) + +(define* (hetzner-api-post api path #:key (body *unspecified*)) + "Send a POST request to the Hetzner API at PATH using BODY." + (hetzner-api-response-body + (hetzner-api-request-send + (hetzner-api-request + (body body) + (method 'POST) + (url (hetzner-api-url api path)) + (headers (hetzner-api-default-headers api)))))) + +(define (hetzner-api-actions api ids) + "Get actions from the Hetzner API." + (if (zero? (length ids)) + (raise-exception + (formatted-message + (G_ "expected at least one action id, but got '~a'") + (length ids))) + (hetzner-api-list + api "/actions" "actions" json->hetzner-action + #:params `(("id" . ,(string-join (map number->string ids) ",")))))) + +(define* (hetzner-api-action-wait api action #:optional (status "success")) + "Wait until the ACTION has reached STATUS on the Hetzner API." + (let ((id (hetzner-action-id action))) + (let loop () + (let ((actions (hetzner-api-actions api (list id)))) + (cond + ((zero? (length actions)) + (raise-exception + (formatted-message (G_ "server action '~a' not found") id))) + ((not (= 1 (length actions))) + (raise-exception + (formatted-message + (G_ "expected one server action, but got '~a'") + (length actions)))) + ((string= status (hetzner-action-status (car actions))) + (car actions)) + (else + (sleep 5) + (loop))))))) + +(define* (hetzner-api-locations api . options) + "Get deployment locations from the Hetzner API." + (apply hetzner-api-list api "/locations" "locations" json->hetzner-location options)) + +(define* (hetzner-api-server-create + api name ssh-keys + #:key + (enable-ipv4? #t) + (enable-ipv6? #t) + (image %hetzner-default-server-image) + (labels '()) + (location %hetzner-default-server-location) + (public-net #f) + (server-type %hetzner-default-server-type) + (start-after-create? #f)) + "Create a server with the Hetzner API." + (let ((body (hetzner-api-post + api "/servers" + #:body `(("image" . ,image) + ("labels" . ,labels) + ("name" . ,name) + ("public_net" + . (("enable_ipv4" . ,enable-ipv4?) + ("enable_ipv6" . ,enable-ipv6?))) + ("location" . ,location) + ("server_type" . ,server-type) + ("ssh_keys" . ,(apply vector (map hetzner-ssh-key-id ssh-keys))) + ("start_after_create" . ,start-after-create?))))) + (hetzner-api-action-wait api (hetzner-api-body-action body)) + (json->hetzner-server (assoc-ref body "server")))) + +(define (hetzner-api-server-delete api server) + "Delete the SERVER with the Hetzner API." + (let ((body (hetzner-api-delete api (hetzner-server-path server)))) + (hetzner-api-action-wait api (hetzner-api-body-action body)))) + +(define* (hetzner-api-server-enable-rescue-system + api server ssh-keys #:key (type "linux64")) + "Enable the rescue system for SERVER with the Hetzner API." + (let* ((ssh-keys (apply vector (map hetzner-ssh-key-id ssh-keys))) + (body (hetzner-api-post + api (hetzner-server-path server "/actions/enable_rescue") + #:body `(("ssh_keys" . ,ssh-keys) + ("type" . ,type))))) + (hetzner-api-action-wait api (hetzner-api-body-action body)))) + +(define* (hetzner-api-servers api . options) + "Get servers from the Hetzner API." + (apply hetzner-api-list api "/servers" "servers" json->hetzner-server options)) + +(define (hetzner-api-server-power-on api server) + "Send a power on request for SERVER to the Hetzner API." + (let ((body (hetzner-api-post api (hetzner-server-path server "/actions/poweron")))) + (hetzner-api-action-wait api (hetzner-api-body-action body)))) + +(define (hetzner-api-server-power-off api server) + "Send a power off request for SERVER to the Hetzner API." + (let ((body (hetzner-api-post api (hetzner-server-path server "/actions/poweroff")))) + (hetzner-api-action-wait api (hetzner-api-body-action body)))) + +(define (hetzner-api-server-reboot api server) + "Send a reboot request for SERVER to the Hetzner API." + (let ((body (hetzner-api-post api (hetzner-server-path server "/actions/reboot")))) + (hetzner-api-action-wait api (hetzner-api-body-action body)))) + +(define* (hetzner-api-ssh-key-create api name public-key #:key (labels '())) + "Create a SSH key with the Hetzner API." + (let ((body (hetzner-api-post + api "/ssh_keys" + #:body `(("name" . ,name) + ("public_key" . ,public-key) + ("labels" . ,labels))))) + (json->hetzner-ssh-key (assoc-ref body "ssh_key")))) + +(define (hetzner-api-ssh-key-delete api ssh-key) + "Delete the SSH key on the Hetzner API." + (hetzner-api-delete api (hetzner-ssh-key-path ssh-key)) + #t) + +(define* (hetzner-api-ssh-keys api . options) + "Get SSH keys from the Hetzner API." + (apply hetzner-api-list api "/ssh_keys" "ssh_keys" + json->hetzner-ssh-key options)) + +(define* (hetzner-api-server-types api . options) + "Get server types from the Hetzner API." + (apply hetzner-api-list api "/server_types" "server_types" + json->hetzner-server-type options)) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index e37da506fc..d68fad4e8c 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -81,6 +81,8 @@ gnu/installer/steps.scm gnu/installer/timezone.scm gnu/installer/user.scm gnu/installer/utils.scm +gnu/machine/hetzner.scm +gnu/machine/hetzner/http.scm gnu/machine/ssh.scm gnu/packages/bootstrap.scm guix/build/utils.scm diff --git a/tests/machine/hetzner.scm b/tests/machine/hetzner.scm new file mode 100644 index 0000000000..39eac4a4d5 --- /dev/null +++ b/tests/machine/hetzner.scm @@ -0,0 +1,267 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2024 Roman Scherer +;;; +;;; 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 . + +(define-module (tests machine hetzner) + #:use-module (gnu machine hetzner http) + #:use-module (gnu machine hetzner) + #:use-module (gnu machine ssh) + #:use-module (gnu machine) + #:use-module (gnu system) + #:use-module (guix build utils) + #:use-module (guix records) + #:use-module (guix ssh) + #:use-module (guix tests) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-64) + #:use-module (ssh key) + #:use-module (ssh session)) + +;;; Unit and integration tests for the (gnu machine hetzner) module. + +;; Integration tests require the GUIX_HETZNER_API_TOKEN environment variable. +;; https://docs.hetzner.com/cloud/api/getting-started/generating-api-token + +;; The integration tests sometimes fail due to the Hetzner API not being able +;; to allocate a resource. Switching to a different location might help. + +(define %labels + '(("guix.gnu.org/test" . "true"))) + +(define %ssh-key-name + "guix-hetzner-machine-test-key") + +(define %ssh-key-file + (string-append "/tmp/" %ssh-key-name)) + +(unless (file-exists? %ssh-key-file) + (private-key-to-file (make-keypair 'rsa 2048) %ssh-key-file)) + +(define %when-no-token + (if (hetzner-api-token (hetzner-api)) 0 1)) + +(define %arm-machine + (machine + (operating-system + (operating-system + (inherit %hetzner-os-arm) + (host-name "guix-deploy-hetzner-test-arm"))) + (environment hetzner-environment-type) + (configuration (hetzner-configuration + (labels %labels) + (server-type "cax41") + (ssh-key %ssh-key-file))))) + +(define %x86-machine + (machine + (operating-system + (operating-system + (inherit %hetzner-os-x86) + (host-name "guix-deploy-hetzner-test-x86"))) + (environment hetzner-environment-type) + (configuration (hetzner-configuration + (labels %labels) + (server-type "cpx51") + (ssh-key %ssh-key-file))))) + +(define (cleanup machine) + (let* ((config (machine-configuration machine)) + (api (hetzner-configuration-api config))) + (for-each (lambda (server) + (hetzner-api-server-delete api server)) + (hetzner-api-servers + api #:params `(("label_selector" . "guix.gnu.org/test=true")))) + (for-each (lambda (ssh-key) + (hetzner-api-ssh-key-delete api ssh-key)) + (hetzner-api-ssh-keys + api #:params `(("label_selector" . "guix.gnu.org/test=true")))) + machine)) + +(define-syntax-rule (with-cleanup (machine-sym machine-init) body ...) + (let ((machine-sym (cleanup machine-init))) + (dynamic-wind + (const #t) + (lambda () + body ...) + (lambda () + (cleanup machine-sym))))) + +(define (mock-action command) + (make-hetzner-action + command #f + (localtime (current-time)) + 1 + 100 + '() + (localtime (current-time)) + "success")) + +(define (mock-location machine) + (let* ((config (machine-configuration machine)) + (name (hetzner-configuration-location config))) + (make-hetzner-location + "Falkenstein" "DE" "Falkenstein DC Park 1" + 1 50.47612 12.370071 name "eu-central"))) + +(define (mock-server-type machine) + (let* ((config (machine-configuration machine)) + (name (hetzner-configuration-server-type config))) + (make-hetzner-server-type + "x86" 8 "shared" #f #f (string-upcase name) + 160 106 16 name "local"))) + +(define (mock-server machine) + (let* ((config (machine-configuration machine)) + (name (hetzner-configuration-location config))) + (make-hetzner-server + 1 + (localtime (current-time)) + '() + (operating-system-host-name (machine-operating-system machine)) + (make-hetzner-public-net + (make-hetzner-ipv4 #f "server.example.com" 1 "1.2.3.4") + (make-hetzner-ipv6 #f "server.example.com" 1 "2001:db8::1")) + #f + (mock-server-type machine)))) + +(define (mock-ssh-key machine) + (let ((config (machine-configuration machine))) + (hetzner-ssh-key-read-file (hetzner-configuration-ssh-key config)))) + +(define (expected-ssh-machine? machine ssh-machine) + (let ((config (machine-configuration machine)) + (ssh-config (machine-configuration ssh-machine))) + (and (equal? (hetzner-configuration-authorize? config) + (machine-ssh-configuration-authorize? ssh-config)) + (equal? (hetzner-configuration-allow-downgrades? config) + (machine-ssh-configuration-allow-downgrades? ssh-config)) + (equal? (hetzner-configuration-build-locally? config) + (machine-ssh-configuration-build-locally? ssh-config)) + (equal? (hetzner-server-public-ipv4 (mock-server machine)) + (machine-ssh-configuration-host-name ssh-config))))) + +(define-syntax mock* + (syntax-rules () + ((mock* () body1 body2 ...) + (let () body1 body2 ...)) + ((mock* ((mod1 sym1 fn1) (mod2 sym2 fn2) ...) + body1 body2 ...) + (mock (mod1 sym1 fn1) + (mock* ((mod2 sym2 fn2) ...) + body1) body2 ...)))) + +(test-begin "machine-hetzner") + +;; The following tests deploy real machines using the Hetzner API and shut +;; them down afterwards. + +(test-skip %when-no-token) +(test-assert "deploy-arm-machine" + (with-cleanup (machine %arm-machine) + (deploy-hetzner machine))) + +(test-skip %when-no-token) +(test-assert "deploy-x86-machine" + (with-cleanup (machine %x86-machine) + (deploy-hetzner machine))) + +;; The following tests simulate a deployment, they mock out the actual calls +;; to the Hetzner API. + +;; Note: In order for mocking to work, the Guile compiler should not inline +;; the mocked functions. To prevent this it was necessary to set! +;; hetzner-machine-ssh-run-script in (gnu machine hetzner) like this: + +;; (set! hetzner-machine-ssh-run-script hetzner-machine-ssh-run-script) + +(test-assert "deploy-machine-mock-with-provisioned-server" + (let ((machine (machine + (operating-system %hetzner-os-x86) + (environment hetzner-environment-type) + (configuration (hetzner-configuration + (api (hetzner-api (token "mock"))) + (ssh-key %ssh-key-file)))))) + (mock* (((gnu machine hetzner http) hetzner-api-locations + (lambda* (api . options) + (list (mock-location machine)))) + ((gnu machine hetzner http) hetzner-api-server-types + (lambda* (api . options) + (list (mock-server-type machine)))) + ((gnu machine hetzner http) hetzner-api-ssh-keys + (lambda* (api . options) + (list (mock-ssh-key machine)))) + ((gnu machine hetzner http) hetzner-api-servers + (lambda* (api . options) + (list (mock-server machine)))) + ((gnu machine) deploy-machine + (lambda* (ssh-machine) + (expected-ssh-machine? machine ssh-machine)))) + (deploy-hetzner machine)))) + +(test-assert "deploy-machine-mock-with-unprovisioned-server" + (let ((machine (machine + (operating-system %hetzner-os-x86) + (environment hetzner-environment-type) + (configuration (hetzner-configuration + (api (hetzner-api (token "mock"))) + (ssh-key %ssh-key-file))))) + (servers '())) + (mock* (((gnu machine hetzner http) hetzner-api-locations + (lambda* (api . options) + (list (mock-location machine)))) + ((gnu machine hetzner http) hetzner-api-server-types + (lambda* (api . options) + (list (mock-server-type machine)))) + ((gnu machine hetzner http) hetzner-api-ssh-keys + (lambda* (api . options) + (list (mock-ssh-key machine)))) + ((gnu machine hetzner http) hetzner-api-servers + (lambda* (api . options) + servers)) + ((gnu machine hetzner http) hetzner-api-server-create + (lambda* (api name ssh-keys . options) + (set! servers (list (mock-server machine))) + (car servers))) + ((gnu machine hetzner http) hetzner-api-server-enable-rescue-system + (lambda (api server ssh-keys) + (mock-action "enable_rescue"))) + ((gnu machine hetzner http) hetzner-api-server-power-on + (lambda (api server) + (mock-action "start_server"))) + ((gnu machine hetzner) hetzner-machine-ssh-run-script + (lambda (ssh-session name content) + #t)) + ((guix ssh) open-ssh-session + (lambda* (host . options) + (make-session #:host host))) + ((gnu machine hetzner http) hetzner-api-server-reboot + (lambda (api server) + (mock-action "reboot_server"))) + ((ssh session) write-known-host! + (lambda (session) + #t)) + ((gnu machine) deploy-machine + (lambda* (ssh-machine) + (expected-ssh-machine? machine ssh-machine)))) + (deploy-hetzner machine)))) + +(test-end "machine-hetzner") + +;; Local Variables: +;; eval: (put 'with-cleanup 'scheme-indent-function 1) +;; End: diff --git a/tests/machine/hetzner/http.scm b/tests/machine/hetzner/http.scm new file mode 100644 index 0000000000..618d9a4c94 --- /dev/null +++ b/tests/machine/hetzner/http.scm @@ -0,0 +1,631 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2024 Roman Scherer +;;; +;;; 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 . + +(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: