* [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
@ 2024-12-27 16:46 Roman Scherer
2025-01-16 21:26 ` Ludovic Courtès
` (2 more replies)
0 siblings, 3 replies; 17+ messages in thread
From: Roman Scherer @ 2024-12-27 16:46 UTC (permalink / raw)
To: 75144
Cc: Roman Scherer, Christopher Baines, Josselin Poiret,
Ludovic Court?s, Mathieu Othacehe, Maxim Cournoyer,
Simon Tournier, Tobias Geerinckx-Rice
* gnu/machine/hetzner.scm: New file.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
* guix/ssh.scm (open-ssh-session): Add stricthostkeycheck option.
* doc/guix.texi (Invoking guix deploy): Add documentation for
'hetzner-configuration'.
Change-Id: Idc17dbc33279ecbf3cbfe2c53d7699140f8b9f41
---
doc/guix.texi | 86 ++++
gnu/local.mk | 1 +
gnu/machine/hetzner.scm | 1039 +++++++++++++++++++++++++++++++++++++++
guix/ssh.scm | 19 +-
4 files changed, 1137 insertions(+), 8 deletions(-)
create mode 100644 gnu/machine/hetzner.scm
diff --git a/doc/guix.texi b/doc/guix.texi
index da4d2f5ebc..020f460327 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -44399,6 +44399,92 @@ 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}.
+
+@table @asis
+@item @code{allow-downgrades?} (default: @code{#f})
+Whether to allow potential downgrades.
+@item @code{authorize?} (default: @code{#t})
+If true, the coordinator's public signing key
+@code{"/etc/guix/signing-key.pub"} will be added to the server's ACL
+keyring.
+@item @code{build-locally?} (default: @code{#t})
+If false, system derivations will be built on the machine being deployed to.
+@item @code{delete?} (default: @code{#t})
+If true, the server will be deleted when an error happens in the
+provisioning phase. If false, the server will be kept in order to debug
+any issues.
+@item @code{enable-ipv6?} (default: @code{#t})
+If true, attach an IPv6 on the public NIC. If false, no IPv6 address will be attached.
+@item @code{labels} (default: @code{'()})
+A user defined alist of key/value pairs attached to the server. Keys and
+values must be strings. For more information, see
+@uref{https://docs.hetzner.cloud/#labels, Labels}.
+@item @code{location} (default: @code{"fsn1"})
+The name of a @uref{https://docs.hetzner.com/cloud/general/locations,
+location} to create the server in.
+@item @code{cleanup} (default: @code{#t})
+Whether to delete the Hetzner server if provisioning fails or not.
+@item @code{server-type} (default: @code{"cx42"})
+The name of the
+@uref{https://docs.hetzner.com/cloud/servers/overview#server-types,
+server type} this server should be created with.
+@item @code{ssh-key}
+The path to the SSH private key to use to authenticate with the remote
+host.
+@end table
+
+When deploying a machine with the @code{hetzner-environment-type} a
+virtual private server (VPS) is created for it on the
+@uref{https://www.hetzner.com/cloud, Hetzner Cloud} service. The server
+is first booted into the
+@uref{https://docs.hetzner.com/cloud/servers/getting-started/rescue-system,
+Rescue System} to setup the partitions of the server and install a
+minimal Guix system, which is then used with the
+@code{managed-host-environment-type} to complete the deployment.
+
+Servers on the Hetzner Cloud service can be provisioned on the
+@code{aarch64} architecture using UEFI boot mode, or on the
+@code{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
+2 architectures, and can be used as a base for defining your custom
+operating system.
+
+The following example shows the definition of 2 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 2 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 84160f407a..98000766af 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -911,6 +911,7 @@ if HAVE_GUILE_SSH
GNU_SYSTEM_MODULES += \
%D%/machine/digital-ocean.scm \
+ %D%/machine/hetzner.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..9f8c3806b3
--- /dev/null
+++ b/gnu/machine/hetzner.scm
@@ -0,0 +1,1039 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Roman Scherer <roman@burningswell.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu machine hetzner)
+ #:use-module (gnu bootloader grub)
+ #:use-module (gnu bootloader)
+ #:use-module (gnu machine ssh)
+ #:use-module (gnu machine)
+ #:use-module (gnu packages ssh)
+ #:use-module (gnu services base)
+ #:use-module (gnu services networking)
+ #:use-module (gnu services ssh)
+ #:use-module (gnu services)
+ #:use-module (gnu system file-systems)
+ #:use-module (gnu system image)
+ #:use-module (gnu system linux-initrd)
+ #:use-module (gnu system pam)
+ #:use-module (gnu system)
+ #:use-module (guix base32)
+ #:use-module (guix colors)
+ #:use-module (guix derivations)
+ #:use-module (guix diagnostics)
+ #:use-module (guix gexp)
+ #:use-module (guix i18n)
+ #:use-module (guix import json)
+ #:use-module (guix monads)
+ #:use-module (guix packages)
+ #:use-module (guix pki)
+ #:use-module (guix records)
+ #:use-module (guix ssh)
+ #:use-module (guix store)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 iconv)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 pretty-print)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 receive)
+ #:use-module (ice-9 string-fun)
+ #:use-module (ice-9 textual-ports)
+ #:use-module (json)
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-2)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (ssh channel)
+ #:use-module (ssh key)
+ #:use-module (ssh popen)
+ #:use-module (ssh session)
+ #:use-module (ssh sftp)
+ #:use-module (ssh shell)
+ #:use-module (web client)
+ #:use-module (web request)
+ #:use-module (web response)
+ #:use-module (web uri)
+ #:export (%hetzner-os-arm
+ %hetzner-os-x86
+ deploy-hetzner
+ hetzner-api
+ hetzner-api-auth-token
+ hetzner-api-base-url
+ hetzner-configuration
+ hetzner-configuration-allow-downgrades?
+ hetzner-configuration-authorize?
+ hetzner-configuration-build-locally?
+ hetzner-configuration-delete?
+ hetzner-configuration-enable-ipv6?
+ hetzner-configuration-labels
+ hetzner-configuration-location
+ hetzner-configuration-networks
+ hetzner-configuration-server-type
+ hetzner-configuration-ssh-key
+ hetzner-configuration?
+ hetzner-environment-type))
+
+;;; Commentary:
+;;;
+;;; This module implements a high-level interface for provisioning "servers"
+;;; from the Hetzner Cloud service.
+;;;
+
+(define %hetzner-api-token
+ (make-parameter (getenv "GUIX_HETZNER_API_TOKEN")))
+
+\f
+;;;
+;;; Hetzner operating systems.
+;;;
+
+;; Operating system for arm servers using UEFI boot mode.
+
+(define %hetzner-os-arm
+ (operating-system
+ (host-name "guix-arm")
+ (bootloader
+ (bootloader-configuration
+ (bootloader grub-efi-bootloader)
+ (targets (list "/boot/efi"))
+ (terminal-outputs '(console))))
+ (file-systems
+ (cons* (file-system
+ (mount-point "/")
+ (device "/dev/sda1")
+ (type "ext4"))
+ (file-system
+ (mount-point "/boot/efi")
+ (device "/dev/sda15")
+ (type "vfat"))
+ %base-file-systems))
+ (initrd-modules
+ (cons* "sd_mod" "virtio_scsi" %base-initrd-modules))
+ (services
+ (cons* (service dhcp-client-service-type)
+ (service openssh-service-type
+ (openssh-configuration
+ (openssh openssh-sans-x)
+ (permit-root-login 'prohibit-password)))
+ %base-services))))
+
+;; Operating system for x86 servers using BIOS boot mode.
+
+(define %hetzner-os-x86
+ (operating-system
+ (inherit %hetzner-os-arm)
+ (host-name "guix-x86")
+ (bootloader
+ (bootloader-configuration
+ (bootloader grub-bootloader)
+ (targets (list "/dev/sda"))
+ (terminal-outputs '(console))))
+ (initrd-modules
+ (cons "virtio_scsi" %base-initrd-modules))
+ (file-systems
+ (cons (file-system
+ (mount-point "/")
+ (device "/dev/sda1")
+ (type "ext4"))
+ %base-file-systems))))
+
+(define (operating-system-authorize os)
+ "Authorize the OS with the public signing key of the current machine."
+ (if (file-exists? %public-key-file)
+ (operating-system
+ (inherit os)
+ (services
+ (modify-services (operating-system-user-services os)
+ (guix-service-type
+ config => (guix-configuration
+ (inherit config)
+ (authorized-keys
+ (cons*
+ (local-file %public-key-file)
+ (guix-configuration-authorized-keys config))))))))
+ (raise (formatted-message (G_ "no signing key '~a'. \
+Have you run 'guix archive --generate-key'?")
+ %public-key-file))))
+
+(define (operating-system-root-file-system-type os)
+ "Return the root file system type of the operating system OS."
+ (let ((root-fs (find (lambda (file-system)
+ (equal? "/" (file-system-mount-point file-system)))
+ (operating-system-file-systems os))))
+ (if (file-system? root-fs)
+ (file-system-type root-fs)
+ (raise (formatted-message
+ (G_ "could not determine root file system type"))))))
+
+\f
+;;;
+;;; Helper functions.
+;;;
+
+(define (escape-backticks str)
+ "Escape all backticks in STR."
+ (string-replace-substring str "`" "\\`"))
+
+(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)
+ "&"))
+ ""))
+
+
+\f
+;;;
+;;; Hetzner API response.
+;;;
+
+(define-record-type* <hetzner-api-response> hetzner-api-response
+ make-hetzner-api-response hetzner-api-response? hetzner-api-response
+ (body hetzner-api-response-body)
+ (headers hetzner-api-response-headers)
+ (status hetzner-api-response-status))
+
+(define (hetzner-api-response-meta response)
+ "Return the meta information of the Hetzner API response."
+ (assoc-ref (hetzner-api-response-body response) "meta"))
+
+(define (hetzner-api-response-pagination response)
+ "Return the meta information of the Hetzner API response."
+ (assoc-ref (hetzner-api-response-meta response) "pagination"))
+
+(define (hetzner-api-response-pagination-combine resource responses)
+ "Combine multiple Hetzner API pagination responses into a single response."
+ (if (positive? (length responses))
+ (let* ((response (car responses))
+ (pagination (hetzner-api-response-pagination response))
+ (total-entries (assoc-ref pagination "total_entries")))
+ (hetzner-api-response
+ (inherit response)
+ (body `(("meta"
+ ("pagination"
+ ("last_page" . 1)
+ ("next_page" . null)
+ ("page" . 1)
+ ("per_page" . ,total-entries)
+ ("previous_page" . null)
+ ("total_entries" . ,total-entries)))
+ (,resource . ,(append-map
+ (lambda (body)
+ (vector->list (assoc-ref body resource)))
+ (map hetzner-api-response-body responses)))))))
+ (raise (formatted-message
+ (G_ "Expected a list of Hetzner API responses")))))
+
+(define (hetzner-api-response-read port)
+ "Read the Hetzner API response from PORT."
+ (let* ((response (read-response port))
+ (body (read-response-body response)))
+ (hetzner-api-response
+ (body (json-string->scm (bytevector->string body "UTF-8")))
+ (headers (response-headers response))
+ (status (response-code response)))))
+
+(define (hetzner-api-response-validate-status response expected)
+ "Raise an error if the HTTP status code of RESPONSE is not in EXPECTED."
+ (when (not (member (hetzner-api-response-status response) expected))
+ (raise (formatted-message
+ (G_ "Unexpected HTTP status code: ~a, expected: ~a~%~a")
+ (hetzner-api-response-status response)
+ expected
+ (hetzner-api-response-body response)))))
+
+
+\f
+;;;
+;;; Hetzner API request.
+;;;
+
+(define-record-type* <hetzner-api-request> hetzner-api-request
+ make-hetzner-api-request hetzner-api-request? hetzner-api-request
+ (body hetzner-api-request-body (default *unspecified*))
+ (headers hetzner-api-request-headers (default '()))
+ (method hetzner-api-request-method (default 'GET))
+ (params hetzner-api-request-params (default '()))
+ (url hetzner-api-request-url))
+
+(define (hetzner-api-request-uri request)
+ "Return the URI object of the Hetzner API request."
+ (let ((params (hetzner-api-request-params request)))
+ (string->uri (string-append (hetzner-api-request-url request)
+ (format-query-params params)))))
+
+(define (hetzner-api-request-body-bytevector request)
+ "Return the body of the Hetzner API REQUEST as a bytevector."
+ (let* ((body (hetzner-api-request-body request))
+ (string (if (unspecified? body) "" (scm->json-string body))))
+ (string->bytevector string "UTF-8")))
+
+(define (hetzner-api-request-write port request)
+ "Write the Hetzner API REQUEST to PORT."
+ (let* ((body (hetzner-api-request-body-bytevector request))
+ (request (build-request
+ (hetzner-api-request-uri request)
+ #:method (hetzner-api-request-method request)
+ #:version '(1 . 1)
+ #:headers (cons* `(Content-Length
+ . ,(number->string
+ (if (unspecified? body)
+ 0 (bytevector-length body))))
+ (hetzner-api-request-headers request))
+ #:port port))
+ (request (write-request request port)))
+ (unless (unspecified? body)
+ (write-request-body request body))
+ (force-output (request-port request))))
+
+(define* (hetzner-api-request-send request #:key (expected (list 200 201)))
+ "Send the Hetzner API REQUEST via HTTP."
+ (let ((port (open-socket-for-uri (hetzner-api-request-uri request))))
+ (hetzner-api-request-write port request)
+ (let ((response (hetzner-api-response-read port)))
+ (close-port port)
+ (hetzner-api-response-validate-status response expected)
+ response)))
+
+(define (hetzner-api-request-next-params request)
+ "Return the pagination params for the next page of the REQUEST."
+ (let* ((params (hetzner-api-request-params request))
+ (page (or (assoc-ref params "page") 1)))
+ (map (lambda (param)
+ (if (equal? "page" (car param))
+ (cons (car param) (+ page 1))
+ param))
+ params)))
+
+(define (hetzner-api-request-paginate request)
+ "Fetch all pages of the REQUEST via pagination and return all responses."
+ (let* ((response (hetzner-api-request-send request))
+ (pagination (hetzner-api-response-pagination response))
+ (next-page (assoc-ref pagination "next_page")))
+ (if (number? next-page)
+ (cons response
+ (hetzner-api-request-paginate
+ (hetzner-api-request
+ (inherit request)
+ (params (hetzner-api-request-next-params request)))))
+ (list response))))
+
+
+\f
+;;;
+;;; Hetzner API.
+;;;
+
+(define-record-type* <hetzner-api> hetzner-api
+ make-hetzner-api hetzner-api? hetzner-api
+ (auth-token hetzner-api-auth-token ; string
+ (default (%hetzner-api-token)))
+ (base-url hetzner-api-base-url ; string
+ (default "https://api.hetzner.cloud/v1")))
+
+(define (hetzner-api-authorization-header api)
+ "Return the authorization header the Hetzner API."
+ (format #f "Bearer ~a" (hetzner-api-auth-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-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 #:key (params '()))
+ "Fetch all objects of RESOURCE from the Hetzner API."
+ (assoc-ref (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))))))
+ resources))
+
+(define* (hetzner-api-post api path #:key (body *unspecified*))
+ "Send a POST request to the Hetzner API at PATH using BODY."
+ (hetzner-api-response-body
+ (hetzner-api-request-send
+ (hetzner-api-request
+ (body body)
+ (method 'POST)
+ (url (hetzner-api-url api path))
+ (headers (hetzner-api-default-headers api))))))
+
+(define* (hetzner-api-actions api . options)
+ "Get actions from the Hetzner API."
+ (apply hetzner-api-list api "/actions" "actions" options))
+
+(define* (hetzner-api-action-wait api action #:optional (status "success"))
+ "Wait until the ACTION has reached STATUS on the Hetzner API."
+ (let ((id (assoc-ref action "id")))
+ (let loop ()
+ (let ((actions (hetzner-api-actions api #:params `(("id" . ,id)))))
+ (cond
+ ((zero? (length actions))
+ (raise (formatted-message (G_ "server action '~a' not found") id)))
+ ((not (= 1 (length actions)))
+ (raise (formatted-message
+ (G_ "expected one server action, but got '~a'")
+ (length actions))))
+ ((string= status (assoc-ref (car actions) "status"))
+ (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" options))
+
+(define (hetzner-api-server-create api server)
+ "Create a server on the Hetzner API."
+ (hetzner-api-post api "/servers" #:body server))
+
+(define (hetzner-api-server-delete api server)
+ "Delete the SERVER on the Hetzner API."
+ (hetzner-api-delete api (hetzner-server-path server)))
+
+(define* (hetzner-api-server-enable-rescue-system
+ api server #:key (ssh-keys '()) (type "linux64"))
+ "Enable the rescue system for SERVER on the Hetzner API."
+ (let ((ssh-keys (apply vector (map hetzner-ssh-key-id ssh-keys))))
+ (hetzner-api-post api (hetzner-server-path server "/actions/enable_rescue")
+ #:body `(("ssh_keys" . ,ssh-keys)
+ ("type" . ,type)))))
+
+(define* (hetzner-api-servers api . options)
+ "Get servers from the Hetzner API."
+ (apply hetzner-api-list api "/servers" "servers" options))
+
+(define (hetzner-api-server-power-on api server)
+ "Send a power on request for SERVER to the Hetzner API."
+ (hetzner-api-post api (hetzner-server-path server "/actions/poweron")))
+
+(define (hetzner-api-server-power-off api server)
+ "Send a power off request for SERVER to the Hetzner API."
+ (hetzner-api-post api (hetzner-server-path server "/actions/poweroff")))
+
+(define (hetzner-api-server-reboot api server)
+ "Send a reboot request for SERVER to the Hetzner API."
+ (hetzner-api-post api (hetzner-server-path server "/actions/reboot")))
+
+(define (hetzner-api-ssh-key-create api ssh-key)
+ "Create the SSH key on the Hetzner API."
+ (hetzner-api-post api "/ssh_keys" #:body ssh-key))
+
+(define* (hetzner-api-ssh-keys api . options)
+ "Get SSH keys from the Hetzner API."
+ (apply hetzner-api-list api "/ssh_keys" "ssh_keys" options))
+
+(define* (hetzner-api-server-types api . options)
+ "Get server types from the Hetzner API."
+ (apply hetzner-api-list api "/server_types" "server_types" options))
+
+
+\f
+;;;
+;;; Hetzner SSH key.
+;;;
+
+(define (hetzner-ssh-key-id ssh-key)
+ "Return the id of the SSH-KEY."
+ (assoc-ref ssh-key "id"))
+
+
+\f
+;;;
+;;; Hetzner server.
+;;;
+
+(define* (hetzner-server-path server #:optional (path ""))
+ "Return the PATH of the Hetzner SERVER."
+ (format #f "/servers/~a~a" (assoc-ref server "id") path))
+
+(define (hetzner-server-type server)
+ "Return the type of the Hetzner SERVER."
+ (assoc-ref server "server_type"))
+
+(define (hetzner-server-architecture server)
+ "Return the architecture of the Hetzner SERVER."
+ (assoc-ref (hetzner-server-type server) "architecture"))
+
+(define (hetzner-server-public-ipv4 server)
+ "Return the public IPv4 address of the SERVER."
+ (and-let* ((public-net (assoc-ref server "public_net"))
+ (network (assoc-ref public-net "ipv4")))
+ (assoc-ref network "ip")))
+
+(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")))
+
+\f
+;;;
+;;; Hetzner configuration.
+;;;
+
+(define-record-type* <hetzner-configuration> hetzner-configuration
+ make-hetzner-configuration hetzner-configuration? this-hetzner-configuration
+ (api hetzner-configuration-api ; <hetzner-api>
+ (default (hetzner-api)))
+ (allow-downgrades? hetzner-configuration-allow-downgrades? ; boolean
+ (default #f))
+ (authorize? hetzner-configuration-authorize? ; boolean
+ (default #t))
+ (build-locally? hetzner-configuration-build-locally? ; boolean
+ (default #t))
+ (delete? hetzner-configuration-delete? ; boolean
+ (default #f))
+ (enable-ipv6? hetzner-configuration-enable-ipv6? ; boolean
+ (default #t))
+ (labels hetzner-configuration-labels ; list of strings
+ (default '()))
+ (location hetzner-configuration-location ; #f | string
+ (default "fsn1"))
+ (networks hetzner-configuration-networks ; list of integers
+ (default '()))
+ (server-type hetzner-configuration-server-type ; string
+ (default "cx42"))
+ (ssh-key hetzner-configuration-ssh-key)) ; string
+
+(define (hetzner-configuration-public-net config)
+ "Return the public network configuration of a server for CONFIG."
+ `(("enable_ipv6" . ,(hetzner-configuration-enable-ipv6? config))))
+
+(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))))
+
+\f
+;;;
+;;; Hetzner Machine.
+;;;
+
+(define (hetzner-machine-delegate target)
+ "Return the delagate machine that uses SSH for deployment."
+ (let* ((config (machine-configuration target))
+ (server (hetzner-machine-server 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))
+ (location (hetzner-configuration-location config)))
+ (find (lambda (type)
+ (equal? location (assoc-ref type "name")))
+ (hetzner-api-locations
+ (hetzner-configuration-api config)
+ #:params `(("name" . ,location))))))
+
+(define (hetzner-machine-server-type machine)
+ "Find the server type of MACHINE on the Hetzner API."
+ (let* ((config (machine-configuration machine))
+ (server-type (hetzner-configuration-server-type config)))
+ (find (lambda (type)
+ (equal? server-type (assoc-ref type "name")))
+ (hetzner-api-server-types
+ (hetzner-configuration-api config)
+ #:params `(("name" . ,server-type))))))
+
+(define (hetzner-machine-validate-auth-token machine)
+ "Validate the Hetzner API authentication token of MACHINE."
+ (let* ((config (machine-configuration machine))
+ (api (hetzner-configuration-api config)))
+ (unless (hetzner-api-auth-token api)
+ (raise (formatted-message
+ (G_ "No Hetzner Cloud access token was provided. \
+This may be fixed by setting the environment variable GUIX_HETZNER_API_TOKEN
+to one procured from \
+https://docs.hetzner.com/cloud/api/getting-started/generating-api-token"))))))
+
+(define (hetzner-machine-validate-configuration-type machine)
+ "Raise an error if MACHINE's configuration is not an instance of
+<hetzner-configuration>."
+ (let ((config (machine-configuration machine))
+ (environment (environment-type-name (machine-environment machine))))
+ (unless (and config (hetzner-configuration? config))
+ (raise (formatted-message (G_ "unsupported machine configuration '~a' \
+for environment of type '~a'")
+ config
+ environment)))))
+
+(define (hetzner-machine-validate-server-type machine)
+ "Raise an error if the server type of MACHINE is not supported."
+ (unless (hetzner-machine-server-type machine)
+ (let* ((config (machine-configuration machine))
+ (api (hetzner-configuration-api config)))
+ (raise (formatted-message
+ (G_ "Server type '~a' not supported~%~%\
+Available server types:~%~%~a")
+ (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 (assoc-ref type "name")
+ (color BOLD))
+ (assoc-ref type "architecture")
+ (assoc-ref type "cores")
+ (assoc-ref type "cpu_type")
+ (assoc-ref type "memory")
+ (assoc-ref type "disk")))
+ (hetzner-api-server-types api))
+ "\n"))))))
+
+(define (hetzner-machine-validate-location machine)
+ "Raise an error if the location of MACHINE is not supported."
+ (unless (hetzner-machine-location machine)
+ (let* ((config (machine-configuration machine))
+ (api (hetzner-configuration-api config)))
+ (raise (formatted-message
+ (G_ "Server location '~a' not supported~%~%\
+Available locations:~%~%~a")
+ (hetzner-configuration-location config)
+ (string-join
+ (map (lambda (location)
+ (format #f " - ~a: ~a, ~a"
+ (colorize-string (assoc-ref location "name")
+ (color BOLD))
+ (assoc-ref location "description")
+ (assoc-ref location "country")))
+ (hetzner-api-locations api))
+ "\n"))))))
+
+(define (hetzner-machine-validate machine)
+ "Validate the Hetzner MACHINE."
+ (hetzner-machine-validate-configuration-type machine)
+ (hetzner-machine-validate-auth-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))
+ (fingerprint (hetzner-configuration-ssh-key-fingerprint config)))
+ (find (lambda (server)
+ (equal? (assoc-ref server "fingerprint") fingerprint))
+ (hetzner-api-ssh-keys
+ (hetzner-configuration-api config)
+ #:params `(("fingerprint" . ,fingerprint))))))
+
+(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))
+ (body (hetzner-api-ssh-key-create
+ (hetzner-configuration-api config)
+ `(("name" . ,(machine-display-name machine))
+ ("name" .
+ ,(hetzner-configuration-ssh-key-fingerprint config))
+ ("public_key" .
+ ,(hetzner-configuration-ssh-key-public config))
+ ("labels" . ,(hetzner-configuration-labels config))))))
+ (format #t "successfully created ssh key for '~a'\n" name)
+ (assoc-ref body "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)
+ (assoc-ref server "name")))
+ (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))
+ (body (hetzner-api-server-create
+ api
+ `(("image" . "debian-11")
+ ("labels" . ,(hetzner-configuration-labels config))
+ ("name" . ,(machine-display-name machine))
+ ("public_net" . ,(hetzner-configuration-public-net config))
+ ("location" . ,(hetzner-configuration-location config))
+ ("server_type" .
+ ,(hetzner-configuration-server-type config))
+ ("ssh_keys" . ,(vector (hetzner-ssh-key-id ssh-key)))
+ ("start_after_create" . #f))))
+ (server (assoc-ref body "server"))
+ (architecture (hetzner-server-architecture server)))
+ (hetzner-api-action-wait api (assoc-ref body "action"))
+ (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
+ #:stricthostkeycheck #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)
+ "Wait for SSH connection to be established with the specified machine."
+ (let ((server (hetzner-machine-server machine)))
+ (wait-for-ssh (hetzner-server-public-ipv4 server)
+ (hetzner-configuration-ssh-key
+ (machine-configuration machine)))))
+
+(define (hetzner-machine-authenticate-host machine)
+ "Add the host key of MACHINE to the list of known hosts."
+ (let ((ssh-session (hetzner-machine-wait-for-ssh machine)))
+ (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 ((body (hetzner-api-server-enable-rescue-system
+ api server #:ssh-keys ssh-keys)))
+ (hetzner-api-action-wait api (assoc-ref body "action"))
+ (format #t "successfully enabled rescue system on '~a'\n" name)
+ body)))
+
+(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 ((body (hetzner-api-server-power-on api server)))
+ (hetzner-api-action-wait api (assoc-ref body "action"))
+ (format #t "successfully powered on server for '~a'\n" name)
+ body)))
+
+(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)
+ (receive (lines exit-code)
+ (rexec-verbose ssh-session (format #f "~a 2>&1" name))
+ (if (zero? exit-code)
+ lines
+ (raise (formatted-message
+ (G_ "failed to run script '~a' on machine, exit code: '~a'")
+ name exit-code))))))
+
+(define (hetzner-machine-rescue-install-os machine ssh-session server)
+ (let ((name (machine-display-name machine))
+ (os (hetzner-machine-bootstrap-os-form machine server)))
+ (format #t "installing guix operating system on '~a'...\n" name)
+ (hetzner-machine-ssh-run-script
+ ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-install-os"
+ (format #f "#!/usr/bin/env bash
+set -eo pipefail
+mount /dev/sda1 /mnt
+mkdir -p /mnt/boot/efi
+mount /dev/sda15 /mnt/boot/efi
+
+mkdir --parents /mnt/root/.ssh
+chmod 700 /mnt/root/.ssh
+cp /root/.ssh/authorized_keys /mnt/root/.ssh/authorized_keys
+chmod 600 /mnt/root/.ssh/authorized_keys
+
+cat > /tmp/guix/deploy/hetzner-os.scm << EOF
+(use-modules (gnu) (guix utils))
+(use-package-modules ssh)
+(use-service-modules base networking ssh)
+(use-system-modules linux-initrd)
+~a
+EOF
+cat /tmp/guix/deploy/hetzner-os.scm
+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 ((body (hetzner-api-server-reboot api server)))
+ (hetzner-api-action-wait api (assoc-ref body "action"))
+ (format #t "successfully rebooted server for '~a'\n" name)
+ body)))
+
+(define (hetzner-machine-rescue-partition machine ssh-session)
+ "Setup the partitions of the Hetzner server for MACHINE using SSH-SESSION."
+ (let* ((name (machine-display-name machine))
+ (os (machine-operating-system machine))
+ (root-fs-type (operating-system-root-file-system-type os)))
+ (format #t "setting up partitions on '~a'...\n" name)
+ (hetzner-machine-ssh-run-script
+ ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-partition"
+ (format #f "#!/usr/bin/env bash
+set -eo pipefail
+growpart /dev/sda 1 || true
+~a
+fdisk -l /dev/sda"
+ (cond
+ ((equal? "btrfs" root-fs-type)
+ (format #f "mkfs.btrfs -L ~a -f /dev/sda1" root-label))
+ ((equal? "ext4" root-fs-type)
+ (format #f "mkfs.ext4 -L ~a -F /dev/sda1" root-label))
+ (else (raise (formatted-message
+ (G_ "unsupported root file system type '~a'")
+ root-fs-type))))))
+ (format #t "successfully setup partitions on '~a'\n" name)))
+
+(define (hetzner-machine-rescue-install-packages machine ssh-session)
+ "Install packages on the Hetzner server for MACHINE using SSH-SESSION."
+ (let ((name (machine-display-name machine)))
+ (format #t "installing rescue system packages on '~a'...\n" name)
+ (hetzner-machine-ssh-run-script
+ ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-install-packages"
+ (format #f "#!/usr/bin/env bash
+set -eo pipefail
+apt-get update
+apt-get install guix cloud-initramfs-growroot --assume-yes"))
+ (format #t "successfully installed rescue system packages on '~a'\n" name)))
+
+(define (hetzner-machine-delete machine server)
+ "Delete the Hetzner server for MACHINE."
+ (let* ((name (machine-display-name machine))
+ (config (machine-configuration machine))
+ (api (hetzner-configuration-api config)))
+ (format #t "deleting server for '~a'...\n" name)
+ (let ((body (hetzner-api-server-delete api server)))
+ (hetzner-api-action-wait api (assoc-ref body "action"))
+ (format #t "successfully deleted server for '~a'\n" name)
+ body)))
+
+(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)))
+ (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))))
+ #:unwind? #t))
+
+\f
+;;;
+;;; 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)
+ (unless (hetzner-machine-server machine)
+ (raise (formatted-message
+ (G_ "machine '~a' not provisioned on the Hetzner Cloud service")
+ (machine-display-name machine))))
+ (machine-remote-eval (hetzner-machine-delegate machine) exp))
+
+
+\f
+;;;
+;;; 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))
+ (unless (hetzner-machine-server machine)
+ (hetzner-machine-provision machine))
+ (deploy-machine (hetzner-machine-delegate machine)))
+
+
+\f
+;;;
+;;; 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)
+ (roll-back-machine (hetzner-machine-delegate machine)))
+
+
+\f
+;;;
+;;; 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/guix/ssh.scm b/guix/ssh.scm
index ae506df14c..196a92e813 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -103,7 +103,8 @@ (define* (open-ssh-session host #:key user port identity
host-key
(compression %compression)
(timeout 3600)
- (connection-timeout 10))
+ (connection-timeout 10)
+ (stricthostkeycheck #t))
"Open an SSH session for HOST and return it. IDENTITY specifies the file
name of a private key to use for authenticating with the host. When USER,
PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config'
@@ -137,7 +138,8 @@ (define* (open-ssh-session host #:key user port identity
;; Speed up RPCs by creating sockets with
;; TCP_NODELAY.
- #:nodelay #t)))
+ #:nodelay #t
+ #:stricthostkeycheck stricthostkeycheck)))
;; Honor ~/.ssh/config.
(session-parse-config! session)
@@ -149,13 +151,14 @@ (define* (open-ssh-session host #:key user port identity
(authenticate-server* session host-key)
;; Authenticate against ~/.ssh/known_hosts.
- (match (authenticate-server session)
- ('ok #f)
- (reason
- (raise (formatted-message (G_ "failed to authenticate \
+ (when stricthostkeycheck
+ (match (authenticate-server session)
+ ('ok #f)
+ (reason
+ (raise (formatted-message (G_ "failed to authenticate \
server at '~a': ~a")
- (session-get session 'host)
- reason)))))
+ (session-get session 'host)
+ reason))))))
;; Use public key authentication, via the SSH agent if it's available.
(match (userauth-public-key/auto! session)
base-commit: 831b94a1efcea8f793afc949b5123a6235c9bb1a
--
2.47.1
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
2024-12-27 16:46 [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type' Roman Scherer
@ 2025-01-16 21:26 ` Ludovic Courtès
2025-01-19 16:59 ` Roman Scherer
2025-01-16 21:26 ` Ludovic Courtès
2025-02-04 19:01 ` [bug#75144] [PATCH v3 1/2] guix: ssh: Add strict-host-key-check? option Roman Scherer
2 siblings, 1 reply; 17+ messages in thread
From: Ludovic Courtès @ 2025-01-16 21:26 UTC (permalink / raw)
To: Roman Scherer
Cc: Josselin Poiret, Maxim Cournoyer, Simon Tournier,
Mathieu Othacehe, Tobias Geerinckx-Rice, Christopher Baines,
75144
Hello Roman,
Roman Scherer <roman@burningswell.com> skribis:
> * gnu/machine/hetzner.scm: New file.
> * gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
> * guix/ssh.scm (open-ssh-session): Add stricthostkeycheck option.
> * doc/guix.texi (Invoking guix deploy): Add documentation for
> 'hetzner-configuration'.
>
> Change-Id: Idc17dbc33279ecbf3cbfe2c53d7699140f8b9f41
Thumbs up for this big piece of work, one that I think is important for
the project! ‘guix deploy’ is a great idea but it desperately needs
more backends like this one.
I’m not familiar with Hetzner so I’ll comment on more general aspects.
Chris, perhaps you can provide feedback on Hetzner-specific issues? I
think we could put this backend to good use for Guix infra since a few
services are running at Hetzner.
> +@deftp {Data Type} hetzner-configuration
> +This is the data type describing the server that should be created for a
> +machine with an @code{environment} of @code{hetzner-environment-type}.
Could you add a sentence providing more context like:
It allows you to configure deployment to a @acronym{VPS, virtual
private server} hosted by @uref{https://www.hetzner.com, Hetzner}.
> +@item @code{authorize?} (default: @code{#t})
> +If true, the coordinator's public signing key
“coordinator” has nothing to do here I guess.
> +@item @code{labels} (default: @code{'()})
> +A user defined alist of key/value pairs attached to the server. Keys and
> +values must be strings. For more information, see
> +@uref{https://docs.hetzner.cloud/#labels, Labels}.
Maybe add a short example?
> +@item @code{location} (default: @code{"fsn1"})
> +The name of a @uref{https://docs.hetzner.com/cloud/general/locations,
> +location} to create the server in.
Maybe add: “For example, @code{"fsn1"} corresponds to the Hetzner site
in Falkenstein, Germany, while @code{"sin"} corresponds to its site in
Singapore.”
> +@item @code{server-type} (default: @code{"cx42"})
> +The name of the
> +@uref{https://docs.hetzner.com/cloud/servers/overview#server-types,
> +server type} this server should be created with.
Likewise, an example would be elcome.
> +@item @code{ssh-key}
> +The path to the SSH private key to use to authenticate with the remote
> +host.
s/path to/file name of/
> +The following example shows the definition of 2 machines that are
s/2/two/
> +vCPUs and 32 GB of RAM on the @code{aarch64} architecture, the second
s/@code{aarch64}/AArch64/
> +shared vCPUs and 32 GB of RAM on the @code{x86_64} architecture.
Drop @code.
> +@lisp
> +(use-modules (gnu machine)
> + (gnu machine hetzner))
> +
> +(list (machine
> + (operating-system %hetzner-os-arm)
> + (environment hetzner-environment-type)
> + (configuration (hetzner-configuration
> + (server-type "cax41")
> + (ssh-key "/home/charlie/.ssh/id_rsa"))))
> + (machine
> + (operating-system %hetzner-os-x86)
> + (environment hetzner-environment-type)
> + (configuration (hetzner-configuration
> + (server-type "cpx51")
> + (ssh-key "/home/charlie/.ssh/id_rsa")))))
Nice!
> +API key} should provision 2 machines for you.
s/2/two/
> + #:use-module (ice-9 receive)
The code base preferable uses SRFI-71 for multiple-value returns.
> + (raise (formatted-message
> + (G_ "Expected a list of Hetzner API responses")))))
Messages should start with a lower-case letter (for all the messages in
this file).
Please add the file to ‘po/guix/POTFILES.in’ so that it’s actually
subject to translation.
> +(define (hetzner-api-response-read port)
> + "Read the Hetzner API response from PORT."
> + (let* ((response (read-response port))
> + (body (read-response-body response)))
> + (hetzner-api-response
> + (body (json-string->scm (bytevector->string body "UTF-8")))
Just ‘string->utf8’ (shorter).
More importantly: instead of ‘json-string->scm’ (which gives an alist,
leading to ‘assoc-ref’ calls all over the code base along with free-form
alists, which is very error-prone), could you use ‘define-json-mapping’?
In essence it’s like ‘define-record-type’ but it additionally define how
to map a JSON dictionary to a Scheme record. There are several examples
in Guix, such as (guix swh).
For clarity, it might be useful to move all the hetzner-api-* bits to a
separate module, for example (gnu machine hetzner http). WDYT?
The rest of the code looks nice to me (modulo alists :-)) but that’s
about all I can say. It’s quite a significant body of code. What would
you suggest to prevent bitrot and support maintenance? Are there parts
of it that could be usefully tested automatically, possibly by mocking
part of the Hetzner API? Or are there tips on how you tested it that
could be written down in the file itself?
Could you move the (guix ssh) bits to a separate patch?
> +++ b/guix/ssh.scm
> @@ -103,7 +103,8 @@ (define* (open-ssh-session host #:key user port identity
> host-key
> (compression %compression)
> (timeout 3600)
> - (connection-timeout 10))
> + (connection-timeout 10)
> + (stricthostkeycheck #t))
> "Open an SSH session for HOST and return it. IDENTITY specifies the file
> name of a private key to use for authenticating with the host. When USER,
> PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config'
Please update the docstring.
Rather ‘strict-host-key-check?’ to match naming conventions, even if
Guile-SSH calls it that way.
> @@ -137,7 +138,8 @@ (define* (open-ssh-session host #:key user port identity
>
> ;; Speed up RPCs by creating sockets with
> ;; TCP_NODELAY.
> - #:nodelay #t)))
> + #:nodelay #t
> + #:stricthostkeycheck stricthostkeycheck)))
Not sure what this does actually. Looks like the main part is the
“when stricthostkeycheck” condition that comes below, no?
Could you send a second version?
Thank you!
Ludo’.
^ permalink raw reply [flat|nested] 17+ messages in thread
* [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
2024-12-27 16:46 [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type' Roman Scherer
2025-01-16 21:26 ` Ludovic Courtès
@ 2025-01-16 21:26 ` Ludovic Courtès
2025-02-04 19:01 ` [bug#75144] [PATCH v3 1/2] guix: ssh: Add strict-host-key-check? option Roman Scherer
2 siblings, 0 replies; 17+ messages in thread
From: Ludovic Courtès @ 2025-01-16 21:26 UTC (permalink / raw)
To: Roman Scherer
Cc: Josselin Poiret, Maxim Cournoyer, Simon Tournier,
Mathieu Othacehe, Tobias Geerinckx-Rice, Christopher Baines,
75144
Hello Roman,
Roman Scherer <roman@burningswell.com> skribis:
> * gnu/machine/hetzner.scm: New file.
> * gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
> * guix/ssh.scm (open-ssh-session): Add stricthostkeycheck option.
> * doc/guix.texi (Invoking guix deploy): Add documentation for
> 'hetzner-configuration'.
>
> Change-Id: Idc17dbc33279ecbf3cbfe2c53d7699140f8b9f41
Thumbs up for this big piece of work, one that I think is important for
the project! ‘guix deploy’ is a great idea but it desperately needs
more backends like this one.
I’m not familiar with Hetzner so I’ll comment on more general aspects.
Chris, perhaps you can provide feedback on Hetzner-specific issues? I
think we could put this backend to good use for Guix infra since a few
services are running at Hetzner.
> +@deftp {Data Type} hetzner-configuration
> +This is the data type describing the server that should be created for a
> +machine with an @code{environment} of @code{hetzner-environment-type}.
Could you add a sentence providing more context like:
It allows you to configure deployment to a @acronym{VPS, virtual
private server} hosted by @uref{https://www.hetzner.com, Hetzner}.
> +@item @code{authorize?} (default: @code{#t})
> +If true, the coordinator's public signing key
“coordinator” has nothing to do here I guess.
> +@item @code{labels} (default: @code{'()})
> +A user defined alist of key/value pairs attached to the server. Keys and
> +values must be strings. For more information, see
> +@uref{https://docs.hetzner.cloud/#labels, Labels}.
Maybe add a short example?
> +@item @code{location} (default: @code{"fsn1"})
> +The name of a @uref{https://docs.hetzner.com/cloud/general/locations,
> +location} to create the server in.
Maybe add: “For example, @code{"fsn1"} corresponds to the Hetzner site
in Falkenstein, Germany, while @code{"sin"} corresponds to its site in
Singapore.”
> +@item @code{server-type} (default: @code{"cx42"})
> +The name of the
> +@uref{https://docs.hetzner.com/cloud/servers/overview#server-types,
> +server type} this server should be created with.
Likewise, an example would be elcome.
> +@item @code{ssh-key}
> +The path to the SSH private key to use to authenticate with the remote
> +host.
s/path to/file name of/
> +The following example shows the definition of 2 machines that are
s/2/two/
> +vCPUs and 32 GB of RAM on the @code{aarch64} architecture, the second
s/@code{aarch64}/AArch64/
> +shared vCPUs and 32 GB of RAM on the @code{x86_64} architecture.
Drop @code.
> +@lisp
> +(use-modules (gnu machine)
> + (gnu machine hetzner))
> +
> +(list (machine
> + (operating-system %hetzner-os-arm)
> + (environment hetzner-environment-type)
> + (configuration (hetzner-configuration
> + (server-type "cax41")
> + (ssh-key "/home/charlie/.ssh/id_rsa"))))
> + (machine
> + (operating-system %hetzner-os-x86)
> + (environment hetzner-environment-type)
> + (configuration (hetzner-configuration
> + (server-type "cpx51")
> + (ssh-key "/home/charlie/.ssh/id_rsa")))))
Nice!
> +API key} should provision 2 machines for you.
s/2/two/
> + #:use-module (ice-9 receive)
The code base preferable uses SRFI-71 for multiple-value returns.
> + (raise (formatted-message
> + (G_ "Expected a list of Hetzner API responses")))))
Messages should start with a lower-case letter (for all the messages in
this file).
Please add the file to ‘po/guix/POTFILES.in’ so that it’s actually
subject to translation.
> +(define (hetzner-api-response-read port)
> + "Read the Hetzner API response from PORT."
> + (let* ((response (read-response port))
> + (body (read-response-body response)))
> + (hetzner-api-response
> + (body (json-string->scm (bytevector->string body "UTF-8")))
Just ‘string->utf8’ (shorter).
More importantly: instead of ‘json-string->scm’ (which gives an alist,
leading to ‘assoc-ref’ calls all over the code base along with free-form
alists, which is very error-prone), could you use ‘define-json-mapping’?
In essence it’s like ‘define-record-type’ but it additionally define how
to map a JSON dictionary to a Scheme record. There are several examples
in Guix, such as (guix swh).
For clarity, it might be useful to move all the hetzner-api-* bits to a
separate module, for example (gnu machine hetzner http). WDYT?
The rest of the code looks nice to me (modulo alists :-)) but that’s
about all I can say. It’s quite a significant body of code. What would
you suggest to prevent bitrot and support maintenance? Are there parts
of it that could be usefully tested automatically, possibly by mocking
part of the Hetzner API? Or are there tips on how you tested it that
could be written down in the file itself?
Could you move the (guix ssh) bits to a separate patch?
> +++ b/guix/ssh.scm
> @@ -103,7 +103,8 @@ (define* (open-ssh-session host #:key user port identity
> host-key
> (compression %compression)
> (timeout 3600)
> - (connection-timeout 10))
> + (connection-timeout 10)
> + (stricthostkeycheck #t))
> "Open an SSH session for HOST and return it. IDENTITY specifies the file
> name of a private key to use for authenticating with the host. When USER,
> PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config'
Please update the docstring.
Rather ‘strict-host-key-check?’ to match naming conventions, even if
Guile-SSH calls it that way.
> @@ -137,7 +138,8 @@ (define* (open-ssh-session host #:key user port identity
>
> ;; Speed up RPCs by creating sockets with
> ;; TCP_NODELAY.
> - #:nodelay #t)))
> + #:nodelay #t
> + #:stricthostkeycheck stricthostkeycheck)))
Not sure what this does actually. Looks like the main part is the
“when stricthostkeycheck” condition that comes below, no?
Could you send a second version?
Thank you!
Ludo’.
^ permalink raw reply [flat|nested] 17+ messages in thread
* [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
2025-01-16 21:26 ` Ludovic Courtès
@ 2025-01-19 16:59 ` Roman Scherer
2025-01-25 13:37 ` Roman Scherer
0 siblings, 1 reply; 17+ messages in thread
From: Roman Scherer @ 2025-01-19 16:59 UTC (permalink / raw)
To: Ludovic Courtès
Cc: Roman Scherer, Maxim Cournoyer, Simon Tournier, Mathieu Othacehe,
Tobias Geerinckx-Rice, Josselin Poiret, Christopher Baines, 75144
[-- Attachment #1.1: Type: text/plain, Size: 4054 bytes --]
Hi Ludo,
thanks for your review. Here is a v2, I hope I addressed your previous
comments with it, but I need some help.
As you suggested I also added some tests. Some use mocking, and some run
against the Hetzner API, if the GUIX_HETZNER_API_TOKEN env var is set.
./pre-inst-env make check TESTS="tests/machine/hetzner/http.scm"
./pre-inst-env make check TESTS="tests/machine/hetzner.scm"
All tests pass when I run them in the Geiser REPL, where I developed them.
But I have some trouble with one test that uses mocking. The
"deploy-machine-mock-with-unprovisioned-server" test in
tests/machine/hetzner.scm only fails when run in the terminal. :?
I'm using the "mock" function from (guix tests) to mock some HTTP and SSH
calls. The issue is that I see different behaviour whether I run the tests in
Geiser vs in the Terminal.
In Geiser I see the following output for this test, in it passes:
-------------------------------------------------------------------------------
creating 'cx42' server for 'guix-x86'...
successfully created 'cx42' x86 server for 'guix-x86'
enabling rescue system on 'guix-x86'...
MOCK ENABLE RESUCE
successfully enabled rescue system on 'guix-x86'
powering on server for 'guix-x86'...
MOCK POWER ON
successfully powered on server for 'guix-x86'
connecting via SSH to '1.2.3.4' using '/tmp/guix-hetzner-machine-test-key'...
MOCK OPEN SSH SESSION
installing rescue system packages on 'guix-x86'...
MOCK RUNNING SCRIPT: /tmp/guix/deploy/hetzner-machine-rescue-install-packages
successfully installed rescue system packages on 'guix-x86'
setting up partitions on 'guix-x86'...
MOCK RUNNING SCRIPT: /tmp/guix/deploy/hetzner-machine-rescue-partition
successfully setup partitions on 'guix-x86'
installing guix operating system on 'guix-x86'...
MOCK RUNNING SCRIPT: /tmp/guix/deploy/hetzner-machine-rescue-install-os
successfully installed guix operating system on 'guix-x86'
rebooting server for 'guix-x86'...
successfully rebooted server for 'guix-x86'
connecting via SSH to '1.2.3.4' using '/tmp/guix-hetzner-machine-test-key'...
MOCK OPEN SSH SESSION
-------------------------------------------------------------------------------
You can see that calls to "hetzner-machine-ssh-run-script" are mocked, because
"MOCK RUNNING SCRIPT" is printed multiple times.
But in a "guix shell -D" terminal I see the following output for the test, and
it is failing:
-------------------------------------------------------------------------------
creating 'cx42' server for 'guix-x86'...
successfully created 'cx42' x86 server for 'guix-x86'
enabling rescue system on 'guix-x86'...
MOCK ENABLE RESUCE
successfully enabled rescue system on 'guix-x86'
powering on server for 'guix-x86'...
MOCK POWER ON
successfully powered on server for 'guix-x86'
connecting via SSH to '1.2.3.4' using '/tmp/guix-hetzner-machine-test-key'...
MOCK OPEN SSH SESSION
installing rescue system packages on 'guix-x86'...
test-name: deploy-machine-mock-with-unprovisioned-server
location: /home/roman/workspace/guix/tests/machine/hetzner.scm:189
actual-value: #f
actual-error:
+ (guile-ssh-error
+ "%gssh-make-sftp-session"
+ "Could not create a SFTP session"
+ #<session #<undefined>@1.2.3.4:22 (disconnected) ffff85596de0>
+ #f)
result: FAIL
;;; [2025/01/19 17:39:16.791023, 0] [GSSH ERROR] Could not create a SFTP session: #<session #<undefined>@1.2.3.4:22 (disconnected) ffff85596de0>
-------------------------------------------------------------------------------
The tests fails here trying to use a disconnected SSH session object, that I
returned in a mocked call. This code should actually never be reached, because
I mock the "hetzner-machine-ssh-run-script" call. But for some reason the mock
is not working here. The "MOCK RUNNING SCRIPT" output is missing.
Do you have any ideas what could be going on here? I suspect this might be due
to some optimization or env issue, but I'm pretty lost.
I attached a WIP v2 for now. Will send a v3 and a separate patch for the ssh
modification once I fixed this mock test.
Thanks, Roman.
[-- Attachment #1.2: v2-0001-machine-Implement-hetzner-environment-type.patch --]
[-- Type: text/x-patch, Size: 86430 bytes --]
From a6290ec9911453a95ed35f11c660bb794f8b3103 Mon Sep 17 00:00:00 2001
Message-ID: <a6290ec9911453a95ed35f11c660bb794f8b3103.1737305428.git.roman@burningswell.com>
From: Roman Scherer <roman@burningswell.com>
Date: Tue, 2 Jul 2024 22:43:00 +0200
Subject: [PATCH v2] machine: Implement 'hetzner-environment-type'.
* Makefile.am: Add test files to SCM_TESTS..
* doc/guix.texi (Invoking guix deploy): Add documentation.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add system modules.
* gnu/machine/hetzner.scm: Add machine module.
* gnu/machine/hetzner/http.scm: New HTTP API module.
* guix/ssh.scm (open-ssh-session): Add strict-host-key-check? option.
* po/guix/POTFILES.in: Add hetzner modules.
Change-Id: Idc17dbc33279ecbf3cbfe2c53d7699140f8b9f41
---
Makefile.am | 2 +
doc/guix.texi | 122 ++++++
gnu/local.mk | 2 +
gnu/machine/hetzner.scm | 700 +++++++++++++++++++++++++++++++++
gnu/machine/hetzner/http.scm | 636 ++++++++++++++++++++++++++++++
guix/ssh.scm | 22 +-
po/guix/POTFILES.in | 2 +
tests/machine/hetzner.scm | 244 ++++++++++++
tests/machine/hetzner/http.scm | 167 ++++++++
9 files changed, 1889 insertions(+), 8 deletions(-)
create mode 100644 gnu/machine/hetzner.scm
create mode 100644 gnu/machine/hetzner/http.scm
create mode 100644 tests/machine/hetzner.scm
create mode 100644 tests/machine/hetzner/http.scm
diff --git a/Makefile.am b/Makefile.am
index f911d432dd..2a4f283dec 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -561,6 +561,8 @@ SCM_TESTS = \
tests/import-utils.scm \
tests/inferior.scm \
tests/lint.scm \
+ tests/machine/hetzner.scm \
+ tests/machine/hetzner/http.scm \
tests/minetest.scm \
tests/modules.scm \
tests/monads.scm \
diff --git a/doc/guix.texi b/doc/guix.texi
index 0015d739bb..7396662404 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -44744,6 +44744,128 @@ Invoking guix deploy
@end table
@end deftp
+@deftp {Data Type} hetzner-configuration
+This is the data type describing the server that should be created for a
+machine with an @code{environment} of
+@code{hetzner-environment-type}. It allows you to configure deployment
+to a @acronym{VPS, virtual private server} hosted by
+@uref{https://www.hetzner.com, Hetzner}.
+
+@table @asis
+
+@item @code{allow-downgrades?} (default: @code{#f})
+Whether to allow potential downgrades.
+
+@item @code{authorize?} (default: @code{#t})
+If true, the public signing key @code{"/etc/guix/signing-key.pub"} of
+the machine that invokes @command{guix deploy} will be added to the
+operating system ACL keyring.
+
+@item @code{build-locally?} (default: @code{#t})
+If false, system derivations will be built on the machine being deployed to.
+
+@item @code{delete?} (default: @code{#t})
+If true, the server will be deleted when an error happens in the
+provisioning phase. If false, the server will be kept in order to debug
+any issues.
+
+@item @code{labels} (default: @code{'()})
+A user defined alist of key/value pairs attached to the SSH key and the
+server on the Hetzner API. Keys and values must be strings,
+e.g. @code{'(("environment" . "development"))}. For more information,
+see @uref{https://docs.hetzner.cloud/#labels, Labels}.
+
+@item @code{location} (default: @code{"fsn1"})
+The name of a @uref{https://docs.hetzner.com/cloud/general/locations,
+location} to create the server in. For example, @code{"fsn1"}
+corresponds to the Hetzner site in Falkenstein, Germany, while
+@code{"sin"} corresponds to its site in Singapore.
+
+@item @code{server-type} (default: @code{"cx42"})
+The name of the
+@uref{https://docs.hetzner.com/cloud/servers/overview#server-types,
+server type} this virtual server should be created with. For example,
+@code{"cx42"} corresponds to a x86_64 server that has 8 CPUs, 16 GB of
+memory and 160 GB of storage, while @code{"cax31"} to the AArch64
+equivalent. Other server types and their current prices can be found
+@uref{https://www.hetzner.com/cloud/#pricing, here}.
+
+@item @code{ssh-key}
+The file name of the SSH private key to use to authenticate with the
+remote host.
+
+@end table
+
+When deploying a machine for the first time, the following steps are
+taken to provision a server for the machine on the
+@uref{https://www.hetzner.com/cloud, Hetzner Cloud} service:
+
+@itemize
+
+@item
+Create the SSH key of the machine on the Hetzner API.
+
+@item
+Create a server for the machine on the Hetzner API.
+
+@item
+Format the root partition of the disk using the file system of the
+machine's operating system. Supported file systems are btrfs and ext4.
+
+@item
+Install a minimal Guix operating system on the server using the
+@uref{https://docs.hetzner.com/cloud/servers/getting-started/rescue-system,
+rescue mode}. This minimal system is used to install the machine's
+operating system, after rebooting.
+
+@item
+Reboot the server and apply the machine's operating system on the
+server.
+
+@end itemize
+
+Once the server has been provisioned and SSH is available, deployment
+continues by delegating it to the @code{managed-host-environment-type}.
+
+Servers on the Hetzner Cloud service can be provisioned on the AArch64
+architecture using UEFI boot mode, or on the x86_64 architecture using
+BIOS boot mode. The @code{(gnu machine hetzner)} module exports the
+@code{%hetzner-os-arm} and @code{%hetzner-os-x86} operating systems that
+are compatible with those two architectures, and can be used as a base
+for defining your custom operating system.
+
+The following example shows the definition of two machines that are
+deployed on the Hetzner Cloud service. The first one uses the
+@code{%hetzner-os-arm} operating system to run a server with 16 shared
+vCPUs and 32 GB of RAM on the @code{aarch64} architecture, the second
+one uses the @code{%hetzner-os-x86} operating system on a server with 16
+shared vCPUs and 32 GB of RAM on the @code{x86_64} architecture.
+
+@lisp
+(use-modules (gnu machine)
+ (gnu machine hetzner))
+
+(list (machine
+ (operating-system %hetzner-os-arm)
+ (environment hetzner-environment-type)
+ (configuration (hetzner-configuration
+ (server-type "cax41")
+ (ssh-key "/home/charlie/.ssh/id_rsa"))))
+ (machine
+ (operating-system %hetzner-os-x86)
+ (environment hetzner-environment-type)
+ (configuration (hetzner-configuration
+ (server-type "cpx51")
+ (ssh-key "/home/charlie/.ssh/id_rsa")))))
+@end lisp
+
+Passing this file to @command{guix deploy} with the environment variable
+@env{GUIX_HETZNER_API_TOKEN} set to a valid Hetzner
+@uref{https://docs.hetzner.com/cloud/api/getting-started/generating-api-token,
+API key} should provision two machines for you.
+
+@end deftp
+
@node Running Guix in a VM
@section Running Guix in a Virtual Machine
diff --git a/gnu/local.mk b/gnu/local.mk
index 342beca9f6..a1960d5087 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -920,6 +920,8 @@ if HAVE_GUILE_SSH
GNU_SYSTEM_MODULES += \
%D%/machine/digital-ocean.scm \
+ %D%/machine/hetzner.scm \
+ %D%/machine/hetzner/http.scm \
%D%/machine/ssh.scm
endif HAVE_GUILE_SSH
diff --git a/gnu/machine/hetzner.scm b/gnu/machine/hetzner.scm
new file mode 100644
index 0000000000..00f61e4ee4
--- /dev/null
+++ b/gnu/machine/hetzner.scm
@@ -0,0 +1,700 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Roman Scherer <roman@burningswell.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu machine hetzner)
+ #:use-module (gnu bootloader grub)
+ #:use-module (gnu bootloader)
+ #:use-module (gnu machine hetzner http)
+ #:use-module (gnu machine ssh)
+ #:use-module (gnu machine)
+ #:use-module (gnu packages ssh)
+ #:use-module (gnu services base)
+ #:use-module (gnu services networking)
+ #:use-module (gnu services ssh)
+ #:use-module (gnu services)
+ #:use-module (gnu system file-systems)
+ #:use-module (gnu system image)
+ #:use-module (gnu system linux-initrd)
+ #:use-module (gnu system pam)
+ #:use-module (gnu system)
+ #:use-module (guix base32)
+ #:use-module (guix colors)
+ #:use-module (guix derivations)
+ #:use-module (guix diagnostics)
+ #:use-module (guix gexp)
+ #:use-module (guix i18n)
+ #:use-module (guix import json)
+ #:use-module (guix monads)
+ #:use-module (guix packages)
+ #:use-module (guix pki)
+ #:use-module (guix records)
+ #:use-module (guix ssh)
+ #:use-module (guix store)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 iconv)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 pretty-print)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 string-fun)
+ #:use-module (ice-9 textual-ports)
+ #:use-module (json)
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-2)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (srfi srfi-71)
+ #:use-module (ssh channel)
+ #:use-module (ssh key)
+ #:use-module (ssh popen)
+ #:use-module (ssh session)
+ #:use-module (ssh sftp)
+ #:use-module (ssh shell)
+ #:use-module (web client)
+ #:use-module (web request)
+ #:use-module (web response)
+ #:use-module (web uri)
+ #:export (%hetzner-os-arm
+ %hetzner-os-x86
+ deploy-hetzner
+ hetzner-configuration
+ hetzner-configuration-allow-downgrades?
+ hetzner-configuration-api
+ hetzner-configuration-authorize?
+ hetzner-configuration-build-locally?
+ hetzner-configuration-delete?
+ hetzner-configuration-labels
+ hetzner-configuration-location
+ hetzner-configuration-server-type
+ hetzner-configuration-ssh-key
+ hetzner-configuration?
+ hetzner-environment-type))
+
+;;; Commentary:
+;;;
+;;; This module implements a high-level interface for provisioning machines on
+;;; the Hetzner Cloud service https://docs.hetzner.cloud.
+;;;
+
+\f
+;;;
+;;; Hetzner operating systems.
+;;;
+
+;; Operating system for arm servers using UEFI boot mode.
+
+(define %hetzner-os-arm
+ (operating-system
+ (host-name "guix-arm")
+ (bootloader
+ (bootloader-configuration
+ (bootloader grub-efi-bootloader)
+ (targets (list "/boot/efi"))
+ (terminal-outputs '(console))))
+ (file-systems
+ (cons* (file-system
+ (mount-point "/")
+ (device "/dev/sda1")
+ (type "ext4"))
+ (file-system
+ (mount-point "/boot/efi")
+ (device "/dev/sda15")
+ (type "vfat"))
+ %base-file-systems))
+ (initrd-modules
+ (cons* "sd_mod" "virtio_scsi" %base-initrd-modules))
+ (services
+ (cons* (service dhcp-client-service-type)
+ (service openssh-service-type
+ (openssh-configuration
+ (openssh openssh-sans-x)
+ (permit-root-login 'prohibit-password)))
+ %base-services))))
+
+;; Operating system for x86 servers using BIOS boot mode.
+
+(define %hetzner-os-x86
+ (operating-system
+ (inherit %hetzner-os-arm)
+ (host-name "guix-x86")
+ (bootloader
+ (bootloader-configuration
+ (bootloader grub-bootloader)
+ (targets (list "/dev/sda"))
+ (terminal-outputs '(console))))
+ (initrd-modules
+ (cons "virtio_scsi" %base-initrd-modules))
+ (file-systems
+ (cons (file-system
+ (mount-point "/")
+ (device "/dev/sda1")
+ (type "ext4"))
+ %base-file-systems))))
+
+(define (operating-system-authorize os)
+ "Authorize the OS with the public signing key of the current machine."
+ (if (file-exists? %public-key-file)
+ (operating-system
+ (inherit os)
+ (services
+ (modify-services (operating-system-user-services os)
+ (guix-service-type
+ config => (guix-configuration
+ (inherit config)
+ (authorized-keys
+ (cons*
+ (local-file %public-key-file)
+ (guix-configuration-authorized-keys config))))))))
+ (raise (formatted-message (G_ "no signing key '~a'. \
+Have you run 'guix archive --generate-key'?")
+ %public-key-file))))
+
+(define (operating-system-root-file-system-type os)
+ "Return the root file system type of the operating system OS."
+ (let ((root-fs (find (lambda (file-system)
+ (equal? "/" (file-system-mount-point file-system)))
+ (operating-system-file-systems os))))
+ (if (file-system? root-fs)
+ (file-system-type root-fs)
+ (raise (formatted-message
+ (G_ "could not determine root file system type"))))))
+
+\f
+;;;
+;;; Helper functions.
+;;;
+
+(define (escape-backticks str)
+ "Escape all backticks in STR."
+ (string-replace-substring str "`" "\\`"))
+
+
+\f
+;;;
+;;; Hetzner configuration.
+;;;
+
+(define-record-type* <hetzner-configuration> hetzner-configuration
+ make-hetzner-configuration hetzner-configuration? this-hetzner-configuration
+ (allow-downgrades? hetzner-configuration-allow-downgrades? ; boolean
+ (default #f))
+ (api hetzner-configuration-api ; <hetzner-api>
+ (default (hetzner-api)))
+ (authorize? hetzner-configuration-authorize? ; boolean
+ (default #t))
+ (build-locally? hetzner-configuration-build-locally? ; boolean
+ (default #t))
+ (delete? hetzner-configuration-delete? ; boolean
+ (default #f))
+ (labels hetzner-configuration-labels ; list of strings
+ (default '()))
+ (location hetzner-configuration-location ; #f | string
+ (default "fsn1"))
+ (server-type hetzner-configuration-server-type ; string
+ (default "cx42"))
+ (ssh-key hetzner-configuration-ssh-key)) ; string
+
+(define (hetzner-configuration-ssh-key-fingerprint config)
+ "Return the SSH public key fingerprint of CONFIG as a string."
+ (and-let* ((file-name (hetzner-configuration-ssh-key config))
+ (privkey (private-key-from-file file-name))
+ (pubkey (private-key->public-key privkey))
+ (hash (get-public-key-hash pubkey 'md5)))
+ (bytevector->hex-string hash)))
+
+(define (hetzner-configuration-ssh-key-public config)
+ "Return the SSH public key of CONFIG as a string."
+ (and-let* ((ssh-key (hetzner-configuration-ssh-key config))
+ (public-key (public-key-from-file ssh-key)))
+ (format #f "ssh-~a ~a" (get-key-type public-key)
+ (public-key->string public-key))))
+
+\f
+;;;
+;;; Hetzner Machine.
+;;;
+
+(define (hetzner-machine-delegate target server)
+ "Return the delagate machine that uses SSH for deployment."
+ (let* ((config (machine-configuration target))
+ ;; Get the operating system WITHOUT the provenance service to avoid a
+ ;; duplicate symlink conflict in the store.
+ (os ((@@ (gnu machine) %machine-operating-system) target)))
+ (machine
+ (inherit target)
+ (operating-system
+ (if (hetzner-configuration-authorize? config)
+ (operating-system-authorize os)
+ os))
+ (environment managed-host-environment-type)
+ (configuration
+ (machine-ssh-configuration
+ (allow-downgrades? (hetzner-configuration-allow-downgrades? config))
+ (authorize? (hetzner-configuration-authorize? config))
+ (build-locally? (hetzner-configuration-build-locally? config))
+ (host-name (hetzner-server-public-ipv4 server))
+ (identity (hetzner-configuration-ssh-key config))
+ (system (hetzner-server-system server)))))))
+
+(define (hetzner-machine-location machine)
+ "Find the location of MACHINE on the Hetzner API."
+ (let* ((config (machine-configuration machine))
+ (expected (hetzner-configuration-location config)))
+ (find (lambda (location)
+ (equal? expected (hetzner-location-name location)))
+ (hetzner-api-locations
+ (hetzner-configuration-api config)
+ #:params `(("name" . ,expected))))))
+
+(define (hetzner-machine-server-type machine)
+ "Find the server type of MACHINE on the Hetzner API."
+ (let* ((config (machine-configuration machine))
+ (expected (hetzner-configuration-server-type config)))
+ (find (lambda (server-type)
+ (equal? expected (hetzner-server-type-name server-type)))
+ (hetzner-api-server-types
+ (hetzner-configuration-api config)
+ #:params `(("name" . ,expected))))))
+
+(define (hetzner-machine-validate-api-token machine)
+ "Validate the Hetzner API authentication token of MACHINE."
+ (let* ((config (machine-configuration machine))
+ (api (hetzner-configuration-api config)))
+ (unless (hetzner-api-token api)
+ (raise (formatted-message
+ (G_ "Hetzner Cloud access token was not provided. \
+This may be fixed by setting the environment variable GUIX_HETZNER_API_TOKEN \
+to one procured from \
+https://docs.hetzner.com/cloud/api/getting-started/generating-api-token"))))))
+
+(define (hetzner-machine-validate-configuration-type machine)
+ "Raise an error if MACHINE's configuration is not an instance of
+<hetzner-configuration>."
+ (let ((config (machine-configuration machine))
+ (environment (environment-type-name (machine-environment machine))))
+ (unless (and config (hetzner-configuration? config))
+ (raise (formatted-message (G_ "unsupported machine configuration '~a' \
+for environment of type '~a'")
+ config
+ environment)))))
+
+(define (hetzner-machine-validate-server-type machine)
+ "Raise an error if the server type of MACHINE is not supported."
+ (unless (hetzner-machine-server-type machine)
+ (let* ((config (machine-configuration machine))
+ (api (hetzner-configuration-api config)))
+ (raise (formatted-message
+ (G_ "server type '~a' not supported~%~%\
+Available server types:~%~%~a~%~%For more details and prices, see: ~a")
+ (hetzner-configuration-server-type config)
+ (string-join
+ (map (lambda (type)
+ (format #f " - ~a: ~a, ~a ~a cores, ~a GB mem, ~a GB disk"
+ (colorize-string
+ (hetzner-server-type-name type)
+ (color BOLD))
+ (hetzner-server-type-architecture type)
+ (hetzner-server-type-cores type)
+ (hetzner-server-type-cpu-type type)
+ (hetzner-server-type-memory type)
+ (hetzner-server-type-disk type)))
+ (hetzner-api-server-types api))
+ "\n")
+ "https://www.hetzner.com/cloud#pricing")))))
+
+(define (hetzner-machine-validate-location machine)
+ "Raise an error if the location of MACHINE is not supported."
+ (unless (hetzner-machine-location machine)
+ (let* ((config (machine-configuration machine))
+ (api (hetzner-configuration-api config)))
+ (raise (formatted-message
+ (G_ "server location '~a' not supported~%~%\
+Available locations:~%~%~a~%~%For more details, see: ~a")
+ (hetzner-configuration-location config)
+ (string-join
+ (map (lambda (location)
+ (format #f " - ~a: ~a, ~a"
+ (colorize-string
+ (hetzner-location-name location)
+ (color BOLD))
+ (hetzner-location-description location)
+ (hetzner-location-country location)))
+ (hetzner-api-locations api))
+ "\n")
+ "https://www.hetzner.com/cloud#locations")))))
+
+(define (hetzner-machine-validate machine)
+ "Validate the Hetzner MACHINE."
+ (hetzner-machine-validate-configuration-type machine)
+ (hetzner-machine-validate-api-token machine)
+ (hetzner-machine-validate-location machine)
+ (hetzner-machine-validate-server-type machine))
+
+(define (hetzner-machine-bootstrap-os-form machine server)
+ "Return the form to bootstrap an operating system on SERVER."
+ (let* ((os (machine-operating-system machine))
+ (system (hetzner-server-system server))
+ (arm? (equal? "arm" (hetzner-server-architecture server)))
+ (x86? (equal? "x86" (hetzner-server-architecture server)))
+ (root-fs-type (operating-system-root-file-system-type os)))
+ `(operating-system
+ (host-name ,(operating-system-host-name os))
+ (timezone "Etc/UTC")
+ (bootloader (bootloader-configuration
+ (bootloader ,(cond (arm? 'grub-efi-bootloader)
+ (x86? 'grub-bootloader)))
+ (targets ,(cond (arm? '(list "/boot/efi"))
+ (x86? '(list "/dev/sda"))))
+ (terminal-outputs '(console))))
+ (initrd-modules (append
+ ,(cond (arm? '(list "sd_mod" "virtio_scsi"))
+ (x86? '(list "virtio_scsi")))
+ %base-initrd-modules))
+ (file-systems ,(cond
+ (arm? `(cons* (file-system
+ (mount-point "/")
+ (device "/dev/sda1")
+ (type ,root-fs-type))
+ (file-system
+ (mount-point "/boot/efi")
+ (device "/dev/sda15")
+ (type "vfat"))
+ %base-file-systems))
+ (x86? `(cons* (file-system
+ (mount-point "/")
+ (device "/dev/sda1")
+ (type ,root-fs-type))
+ %base-file-systems))))
+ (services
+ (cons* (service dhcp-client-service-type)
+ (service openssh-service-type
+ (openssh-configuration
+ (openssh openssh-sans-x)
+ (permit-root-login 'prohibit-password)))
+ %base-services)))))
+
+(define (rexec-verbose session cmd)
+ "Execute a command CMD on the remote side and print output. Return two
+values: list of output lines returned by CMD and its exit code."
+ (let* ((channel (open-remote-input-pipe session cmd))
+ (result (let loop ((line (read-line channel))
+ (result '()))
+ (if (eof-object? line)
+ (reverse result)
+ (begin
+ (display line)
+ (newline)
+ (loop (read-line channel)
+ (cons line result))))))
+ (exit-status (channel-get-exit-status channel)))
+ (close channel)
+ (values result exit-status)))
+
+(define (hetzner-machine-ssh-key machine)
+ "Find the SSH key for MACHINE on the Hetzner API."
+ (let* ((config (machine-configuration machine))
+ (expected (hetzner-configuration-ssh-key-fingerprint config)))
+ (find (lambda (ssh-key)
+ (equal? expected (hetzner-ssh-key-fingerprint ssh-key)))
+ (hetzner-api-ssh-keys
+ (hetzner-configuration-api config)
+ #:params `(("fingerprint" . ,expected))))))
+
+(define (hetzner-machine-ssh-key-create machine)
+ "Create the SSH key for MACHINE on the Hetzner API."
+ (let ((name (machine-display-name machine)))
+ (format #t "creating ssh key for '~a'...\n" name)
+ (let* ((config (machine-configuration machine))
+ (api (hetzner-configuration-api config))
+ (ssh-key (hetzner-api-ssh-key-create
+ (hetzner-configuration-api config)
+ (hetzner-configuration-ssh-key-fingerprint config)
+ (hetzner-configuration-ssh-key-public config)
+ #:labels (hetzner-configuration-labels config))))
+ (format #t "successfully created ssh key for '~a'\n" name)
+ ssh-key)))
+
+(define (hetzner-machine-server machine)
+ "Find the Hetzner server for MACHINE."
+ (let ((config (machine-configuration machine)))
+ (find (lambda (server)
+ (equal? (machine-display-name machine)
+ (hetzner-server-name server)))
+ (hetzner-api-servers
+ (hetzner-configuration-api config)
+ #:params `(("name" . ,(machine-display-name machine)))))))
+
+(define (hetzner-machine-create-server machine)
+ "Create the Hetzner server for MACHINE."
+ (let* ((config (machine-configuration machine))
+ (name (machine-display-name machine))
+ (server-type (hetzner-configuration-server-type config)))
+ (format #t "creating '~a' server for '~a'...\n" server-type name)
+ (let* ((ssh-key (hetzner-machine-ssh-key machine))
+ (api (hetzner-configuration-api config))
+ (server (hetzner-api-server-create
+ api
+ (machine-display-name machine)
+ (list ssh-key)
+ #:labels (hetzner-configuration-labels config)
+ #:location (hetzner-configuration-location config)
+ #:server-type (hetzner-configuration-server-type config)))
+ (architecture (hetzner-server-architecture server)))
+ (format #t "successfully created '~a' ~a server for '~a'\n"
+ server-type architecture name)
+ server)))
+
+(define (wait-for-ssh address ssh-key)
+ "Block until a SSH session can be made as 'root' with SSH-KEY at ADDRESS."
+ (format #t "connecting via SSH to '~a' using '~a'...\n" address ssh-key)
+ (let loop ()
+ (catch #t
+ (lambda ()
+ (open-ssh-session address #:user "root" #:identity ssh-key
+ #:strict-host-key-check? #f))
+ (lambda args
+ (let ((msg (cadr args)))
+ (if (formatted-message? msg)
+ (format #t "~a\n"
+ (string-trim-right
+ (apply format #f
+ (formatted-message-string msg)
+ (formatted-message-arguments msg))
+ #\newline))
+ (format #t "~a" args))
+ (sleep 5)
+ (loop))))))
+
+(define (hetzner-machine-wait-for-ssh machine server)
+ "Wait for SSH connection to be established with the specified machine."
+ (wait-for-ssh (hetzner-server-public-ipv4 server)
+ (hetzner-configuration-ssh-key
+ (machine-configuration machine))))
+
+(define (hetzner-machine-authenticate-host machine server)
+ "Add the host key of MACHINE to the list of known hosts."
+ (let ((ssh-session (hetzner-machine-wait-for-ssh machine server)))
+ (write-known-host! ssh-session)))
+
+(define (hetzner-machine-enable-rescue-system machine server)
+ "Enable the rescue system on the Hetzner SERVER for MACHINE."
+ (let* ((name (machine-display-name machine))
+ (config (machine-configuration machine))
+ (api (hetzner-configuration-api config))
+ (ssh-keys (list (hetzner-machine-ssh-key machine))))
+ (format #t "enabling rescue system on '~a'...\n" name)
+ (let ((action (hetzner-api-server-enable-rescue-system api server ssh-keys)))
+ (format #t "successfully enabled rescue system on '~a'\n" name)
+ action)))
+
+(define (hetzner-machine-power-on machine server)
+ "Power on the Hetzner SERVER for MACHINE."
+ (let* ((name (machine-display-name machine))
+ (config (machine-configuration machine))
+ (api (hetzner-configuration-api config)))
+ (format #t "powering on server for '~a'...\n" name)
+ (let ((action (hetzner-api-server-power-on api server)))
+ (format #t "successfully powered on server for '~a'\n" name)
+ action)))
+
+(define (hetzner-machine-ssh-run-script ssh-session name content)
+ (let ((sftp-session (make-sftp-session ssh-session)))
+ (rexec ssh-session (format #f "rm -f ~a" name))
+ (rexec ssh-session (format #f "mkdir -p ~a" (dirname name)))
+ (call-with-remote-output-file
+ sftp-session name
+ (lambda (port)
+ (display content port)))
+ (sftp-chmod sftp-session name 755)
+ (let ((lines exit-code (rexec-verbose ssh-session
+ (format #f "~a 2>&1" name))))
+ (if (zero? exit-code)
+ lines
+ (raise (formatted-message
+ (G_ "failed to run script '~a' on machine, exit code: '~a'")
+ name exit-code))))))
+
+(define (hetzner-machine-rescue-install-os machine ssh-session server)
+ (let ((name (machine-display-name machine))
+ (os (hetzner-machine-bootstrap-os-form machine server)))
+ (format #t "installing guix operating system on '~a'...\n" name)
+ (hetzner-machine-ssh-run-script
+ ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-install-os"
+ (format #f "#!/usr/bin/env bash
+set -eo pipefail
+mount /dev/sda1 /mnt
+mkdir -p /mnt/boot/efi
+mount /dev/sda15 /mnt/boot/efi
+
+mkdir --parents /mnt/root/.ssh
+chmod 700 /mnt/root/.ssh
+cp /root/.ssh/authorized_keys /mnt/root/.ssh/authorized_keys
+chmod 600 /mnt/root/.ssh/authorized_keys
+
+cat > /tmp/guix/deploy/hetzner-os.scm << EOF
+(use-modules (gnu) (guix utils))
+(use-package-modules ssh)
+(use-service-modules base networking ssh)
+(use-system-modules linux-initrd)
+~a
+EOF
+guix system init --verbosity=2 /tmp/guix/deploy/hetzner-os.scm /mnt"
+ (escape-backticks (format #f "~y" os))))
+ (format #t "successfully installed guix operating system on '~a'\n" name)))
+
+(define (hetzner-machine-reboot machine server)
+ "Reboot the Hetzner SERVER for MACHINE."
+ (let* ((name (machine-display-name machine))
+ (config (machine-configuration machine))
+ (api (hetzner-configuration-api config)))
+ (format #t "rebooting server for '~a'...\n" name)
+ (let ((action (hetzner-api-server-reboot api server)))
+ (format #t "successfully rebooted server for '~a'\n" name)
+ action)))
+
+(define (hetzner-machine-rescue-partition machine ssh-session)
+ "Setup the partitions of the Hetzner server for MACHINE using SSH-SESSION."
+ (let* ((name (machine-display-name machine))
+ (os (machine-operating-system machine))
+ (root-fs-type (operating-system-root-file-system-type os)))
+ (format #t "setting up partitions on '~a'...\n" name)
+ (hetzner-machine-ssh-run-script
+ ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-partition"
+ (format #f "#!/usr/bin/env bash
+set -eo pipefail
+growpart /dev/sda 1 || true
+~a
+fdisk -l /dev/sda"
+ (cond
+ ((equal? "btrfs" root-fs-type)
+ (format #f "mkfs.btrfs -L ~a -f /dev/sda1" root-label))
+ ((equal? "ext4" root-fs-type)
+ (format #f "mkfs.ext4 -L ~a -F /dev/sda1" root-label))
+ (else (raise (formatted-message
+ (G_ "unsupported root file system type '~a'")
+ root-fs-type))))))
+ (format #t "successfully setup partitions on '~a'\n" name)))
+
+(define (hetzner-machine-rescue-install-packages machine ssh-session)
+ "Install packages on the Hetzner server for MACHINE using SSH-SESSION."
+ (let ((name (machine-display-name machine)))
+ (format #t "installing rescue system packages on '~a'...\n" name)
+ (hetzner-machine-ssh-run-script
+ ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-install-packages"
+ (format #f "#!/usr/bin/env bash
+set -eo pipefail
+apt-get update
+apt-get install guix cloud-initramfs-growroot --assume-yes"))
+ (format #t "successfully installed rescue system packages on '~a'\n" name)))
+
+(define (hetzner-machine-delete machine server)
+ "Delete the Hetzner server for MACHINE."
+ (let* ((name (machine-display-name machine))
+ (config (machine-configuration machine))
+ (api (hetzner-configuration-api config)))
+ (format #t "deleting server for '~a'...\n" name)
+ (let ((action (hetzner-api-server-delete api server)))
+ (format #t "successfully deleted server for '~a'\n" name)
+ action)))
+
+(define (hetzner-machine-provision machine)
+ "Provision a server for MACHINE on the Hetzner Cloud service."
+ (with-exception-handler
+ (lambda (exception)
+ (let ((config (machine-configuration machine))
+ (server (hetzner-machine-server machine)))
+ (when (and server (hetzner-configuration-delete? config))
+ (hetzner-machine-delete machine server))
+ (raise-exception exception)))
+ (lambda ()
+ (let ((server (hetzner-machine-create-server machine)))
+ (hetzner-machine-enable-rescue-system machine server)
+ (hetzner-machine-power-on machine server)
+ (let ((ssh-session (hetzner-machine-wait-for-ssh machine server)))
+ (hetzner-machine-rescue-install-packages machine ssh-session)
+ (hetzner-machine-rescue-partition machine ssh-session)
+ (hetzner-machine-rescue-install-os machine ssh-session server)
+ (hetzner-machine-reboot machine server)
+ (sleep 5)
+ (hetzner-machine-authenticate-host machine server)
+ server)))
+ #:unwind? #t))
+
+(define (machine-not-provisioned machine)
+ (formatted-message
+ (G_ "no server provisioned for machine '~a' on the Hetzner Cloud service")
+ (machine-display-name machine)))
+
+\f
+;;;
+;;; Remote evaluation.
+;;;
+
+(define (hetzner-remote-eval machine exp)
+ "Internal implementation of 'machine-remote-eval' for MACHINE instances with
+an environment type of 'hetzner-environment-type'."
+ (hetzner-machine-validate machine)
+ (let ((server (hetzner-machine-server machine)))
+ (unless server (raise (machine-not-provisioned machine)))
+ (machine-remote-eval (hetzner-machine-delegate machine server) exp)))
+
+
+\f
+;;;
+;;; 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))))
+
+
+\f
+;;;
+;;; Roll-back.
+;;;
+
+(define (roll-back-hetzner machine)
+ "Internal implementation of 'roll-back-machine' for MACHINE instances with an
+environment type of 'hetzner-environment-type'."
+ (hetzner-machine-validate machine)
+ (let ((server (hetzner-machine-server machine)))
+ (unless server (raise (machine-not-provisioned machine)))
+ (roll-back-machine (hetzner-machine-delegate machine server))))
+
+
+\f
+;;;
+;;; Environment type.
+;;;
+
+(define hetzner-environment-type
+ (environment-type
+ (machine-remote-eval hetzner-remote-eval)
+ (deploy-machine deploy-hetzner)
+ (roll-back-machine roll-back-hetzner)
+ (name 'hetzner-environment-type)
+ (description "Provisioning of virtual machine servers on the Hetzner Cloud
+service.")))
diff --git a/gnu/machine/hetzner/http.scm b/gnu/machine/hetzner/http.scm
new file mode 100644
index 0000000000..c4a2d41068
--- /dev/null
+++ b/gnu/machine/hetzner/http.scm
@@ -0,0 +1,636 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Roman Scherer <roman@burningswell.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu machine hetzner http)
+ #:use-module (guix diagnostics)
+ #:use-module (guix i18n)
+ #:use-module (guix records)
+ #:use-module (ice-9 iconv)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 textual-ports)
+ #:use-module (json)
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-2)
+ #:use-module (ssh key)
+ #:use-module (web client)
+ #:use-module (web request)
+ #:use-module (web response)
+ #:use-module (web uri)
+ #:export (%hetzner-default-api-token
+ %hetzner-default-server-image
+ %hetzner-default-server-location
+ %hetzner-default-server-type
+ hetzner-action
+ hetzner-action-command
+ hetzner-action-error
+ hetzner-action-finished
+ hetzner-action-id
+ hetzner-action-progress
+ hetzner-action-resources
+ hetzner-action-started
+ hetzner-action-status
+ hetzner-action?
+ hetzner-api
+ hetzner-api-action-wait
+ hetzner-api-actions
+ hetzner-api-create-ssh-key
+ hetzner-api-locations
+ hetzner-api-server-create
+ hetzner-api-server-delete
+ hetzner-api-server-enable-rescue-system
+ hetzner-api-server-power-off
+ hetzner-api-server-power-on
+ hetzner-api-server-reboot
+ hetzner-api-server-types
+ hetzner-api-servers
+ hetzner-api-ssh-key-create
+ hetzner-api-ssh-key-delete
+ hetzner-api-ssh-keys
+ hetzner-api-token
+ hetzner-api?
+ hetzner-error-code
+ hetzner-error-message
+ hetzner-error?
+ hetzner-ipv4-blocked?
+ hetzner-ipv4-dns-ptr
+ hetzner-ipv4-id
+ hetzner-ipv4-ip
+ hetzner-ipv4?
+ hetzner-ipv6-blocked?
+ hetzner-ipv6-dns-ptr
+ hetzner-ipv6-id
+ hetzner-ipv6-ip
+ hetzner-ipv6?
+ hetzner-location
+ hetzner-location-city
+ hetzner-location-country
+ hetzner-location-description
+ hetzner-location-id
+ hetzner-location-latitude
+ hetzner-location-longitude
+ hetzner-location-name
+ hetzner-location-network-zone
+ hetzner-location?
+ hetzner-public-net
+ hetzner-public-net-ipv4
+ hetzner-public-net-ipv6
+ hetzner-resource
+ hetzner-resource-id
+ hetzner-resource-type
+ hetzner-resource?
+ hetzner-server-architecture
+ hetzner-server-created
+ hetzner-server-id
+ hetzner-server-labels
+ hetzner-server-name
+ hetzner-server-public-ipv4
+ hetzner-server-public-net
+ hetzner-server-rescue-enabled?
+ hetzner-server-system
+ hetzner-server-type
+ hetzner-server-type-architecture
+ hetzner-server-type-cores
+ hetzner-server-type-cpu-type
+ hetzner-server-type-deprecated
+ hetzner-server-type-deprecation
+ hetzner-server-type-description
+ hetzner-server-type-disk
+ hetzner-server-type-id
+ hetzner-server-type-memory
+ hetzner-server-type-name
+ hetzner-server-type-storage-type
+ hetzner-server-type?
+ hetzner-server?
+ hetzner-ssh-key-created
+ hetzner-ssh-key-fingerprint
+ hetzner-ssh-key-id
+ hetzner-ssh-key-labels
+ hetzner-ssh-key-name
+ hetzner-ssh-key-public-key
+ hetzner-ssh-key-read-file
+ hetzner-ssh-key?
+ make-hetzner-action
+ make-hetzner-error
+ make-hetzner-ipv4
+ make-hetzner-ipv6
+ make-hetzner-location
+ make-hetzner-public-net
+ make-hetzner-server
+ make-hetzner-server-type
+ make-hetzner-ssh-key))
+
+;;; Commentary:
+;;;
+;;; This module implements a lower-level interface for interacting with the
+;;; Hetzner Cloud API https://docs.hetzner.cloud.
+;;;
+
+(define %hetzner-default-api-token
+ (make-parameter (getenv "GUIX_HETZNER_API_TOKEN")))
+
+;; Ideally this would be a Guix image. Maybe one day.
+(define %hetzner-default-server-image "debian-11")
+
+;; Falkenstein, Germany
+(define %hetzner-default-server-location "fsn1")
+
+;; x86, 8 VCUs, 16 GB mem, 160 GB disk
+(define %hetzner-default-server-type "cx42")
+
+\f
+;;;
+;;; 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)))
+
+\f
+;;;
+;;; Domain models.
+;;;
+
+(define-json-mapping <hetzner-action>
+ make-hetzner-action hetzner-action? json->hetzner-action
+ (command hetzner-action-command) ; string
+ (error hetzner-action-error "error"
+ json->maybe-hetzner-error) ; <hetzner-error> | #f
+ (finished hetzner-action-finished "finished" string->time) ; time
+ (id hetzner-action-id) ; integer
+ (progress hetzner-action-progress) ; integer
+ (resources hetzner-action-resources "resources"
+ json->hetzner-resources) ; list of <hetzner-resource>
+ (started hetzner-action-started "started" string->time) ; time
+ (status hetzner-action-status))
+
+(define-json-mapping <hetzner-deprecation>
+ make-hetzner-deprecation hetzner-deprecation? json->hetzner-deprecation
+ (announced hetzner-deprecation-announced) ; string
+ (unavailable-after hetzner-deprecation-unavailable-after
+ "unavailable_after")) ; string
+
+(define-json-mapping <hetzner-dns>
+ make-hetzner-dns hetzner-dns? json->hetzner-dns
+ (ip hetzner-dns-ip) ; string
+ (ptr hetzner-dns-ptr "dns_ptr")) ; string
+
+(define-json-mapping <hetzner-error>
+ make-hetzner-error hetzner-error? json->hetzner-error
+ (code hetzner-error-code) ; string
+ (message hetzner-error-message)) ; <string>
+
+(define-json-mapping <hetzner-ipv4>
+ make-hetzner-ipv4 hetzner-ipv4? json->hetzner-ipv4
+ (blocked? hetzner-ipv4-blocked? "blocked") ; boolean
+ (dns-ptr hetzner-ipv4-dns-ptr "dns_ptr") ; string
+ (id hetzner-ipv4-id) ; integer
+ (ip hetzner-ipv4-ip)) ; string
+
+(define-json-mapping <hetzner-ipv6>
+ make-hetzner-ipv6 hetzner-ipv6? json->hetzner-ipv6
+ (blocked? hetzner-ipv6-blocked? "blocked") ; boolean
+ (dns-ptr hetzner-ipv6-dns-ptr "dns_ptr"
+ json->hetzner-dnses) ; list of <hetzner-dns>
+ (id hetzner-ipv6-id) ; integer
+ (ip hetzner-ipv6-ip)) ; string
+
+(define-json-mapping <hetzner-location>
+ make-hetzner-location hetzner-location? json->hetzner-location
+ (city hetzner-location-city) ; string
+ (country hetzner-location-country) ; string
+ (description hetzner-location-description) ; string
+ (id hetzner-location-id) ; integer
+ (latitude hetzner-location-latitude) ; decimal
+ (longitude hetzner-location-longitude) ; decimal
+ (name hetzner-location-name) ; string
+ (network-zone hetzner-location-network-zone "network_zone"))
+
+(define-json-mapping <hetzner-public-net>
+ make-hetzner-public-net hetzner-public-net? json->hetzner-public-net
+ (ipv4 hetzner-public-net-ipv4 "ipv4" json->hetzner-ipv4) ; <hetzner-ipv4>
+ (ipv6 hetzner-public-net-ipv6 "ipv6" json->hetzner-ipv6)) ; <hetzner-ipv6>
+
+(define-json-mapping <hetzner-resource>
+ make-hetzner-resource hetzner-resource? json->hetzner-resource
+ (id hetzner-resource-id) ; integer
+ (type hetzner-resource-type)) ; string
+
+(define-json-mapping <hetzner-server>
+ make-hetzner-server hetzner-server? json->hetzner-server
+ (created hetzner-server-created) ; time
+ (id hetzner-server-id) ; integer
+ (labels hetzner-server-labels) ; alist of string/string
+ (name hetzner-server-name) ; string
+ (public-net hetzner-server-public-net "public_net"
+ json->hetzner-public-net) ; <hetzner-public-net>
+ (rescue-enabled? hetzner-server-rescue-enabled? "rescue_enabled") ; boolean
+ (server-type hetzner-server-type "server_type"
+ json->hetzner-server-type)) ; <hetzner-server-type>
+
+(define-json-mapping <hetzner-server-type>
+ make-hetzner-server-type hetzner-server-type? json->hetzner-server-type
+ (architecture hetzner-server-type-architecture) ; string
+ (cores hetzner-server-type-cores) ; integer
+ (cpu-type hetzner-server-type-cpu-type "cpu_type") ; string
+ (deprecated hetzner-server-type-deprecated) ; boolean
+ (deprecation hetzner-server-type-deprecation
+ json->hetzner-deprecation) ; <hetzner-deprecation>
+ (description hetzner-server-type-description) ; string
+ (disk hetzner-server-type-disk) ; integer
+ (id hetzner-server-type-id) ; integer
+ (memory hetzner-server-type-memory) ; integer
+ (name hetzner-server-type-name) ; string
+ (storage-type hetzner-server-type-storage-type "storage_type")) ; string
+
+(define-json-mapping <hetzner-ssh-key>
+ make-hetzner-ssh-key hetzner-ssh-key? json->hetzner-ssh-key
+ (created hetzner-ssh-key-created "created" string->time) ; time
+ (fingerprint hetzner-ssh-key-fingerprint) ; string
+ (id hetzner-ssh-key-id) ; integer
+ (labels hetzner-ssh-key-labels) ; alist of string/string
+ (name hetzner-ssh-key-name) ; string
+ (public_key hetzner-ssh-key-public-key "public_key")) ; string
+
+(define (hetzner-server-architecture server)
+ "Return the architecture of the Hetzner SERVER."
+ (hetzner-server-type-architecture (hetzner-server-type server)))
+
+(define* (hetzner-server-path server #:optional (path ""))
+ "Return the PATH of the Hetzner SERVER."
+ (format #f "/servers/~a~a" (hetzner-server-id server) path))
+
+(define (hetzner-server-public-ipv4 server)
+ "Return the public IPv4 address of the SERVER."
+ (and-let* ((public-net (hetzner-server-public-net server))
+ (ipv4 (hetzner-public-net-ipv4 public-net)))
+ (hetzner-ipv4-ip ipv4)))
+
+(define (hetzner-server-system server)
+ "Return the Guix system architecture of the Hetzner SERVER."
+ (match (hetzner-server-architecture server)
+ ("arm" "aarch64-linux")
+ ("x86" "x86_64-linux")))
+
+(define* (hetzner-ssh-key-path ssh-key #:optional (path ""))
+ "Return the PATH of the Hetzner SSH-KEY."
+ (format #f "/ssh_keys/~a~a" (hetzner-ssh-key-id ssh-key) path))
+
+(define (hetzner-ssh-key-read-file file)
+ "Read the SSH private key from FILE and return a Hetzner SSH key."
+ (let* ((privkey (private-key-from-file file))
+ (pubkey (private-key->public-key privkey))
+ (hash (get-public-key-hash pubkey 'md5))
+ (fingerprint (bytevector->hex-string hash))
+ (public-key (format #f "ssh-~a ~a" (get-key-type pubkey)
+ (public-key->string pubkey))))
+ (make-hetzner-ssh-key #f fingerprint #f '() (basename file) public-key)))
+
+\f
+;;;
+;;; Hetzner API response.
+;;;
+
+(define-record-type* <hetzner-api-response>
+ hetzner-api-response make-hetzner-api-response hetzner-api-response?
+ (body hetzner-api-response-body)
+ (headers hetzner-api-response-headers)
+ (status hetzner-api-response-status))
+
+(define (hetzner-api-response-meta response)
+ "Return the meta information of the Hetzner API response."
+ (assoc-ref (hetzner-api-response-body response) "meta"))
+
+(define (hetzner-api-response-pagination response)
+ "Return the meta information of the Hetzner API response."
+ (assoc-ref (hetzner-api-response-meta response) "pagination"))
+
+(define (hetzner-api-response-pagination-combine resource responses)
+ "Combine multiple Hetzner API pagination responses into a single response."
+ (if (positive? (length responses))
+ (let* ((response (car responses))
+ (pagination (hetzner-api-response-pagination response))
+ (total-entries (assoc-ref pagination "total_entries")))
+ (hetzner-api-response
+ (inherit response)
+ (body `(("meta"
+ ("pagination"
+ ("last_page" . 1)
+ ("next_page" . null)
+ ("page" . 1)
+ ("per_page" . ,total-entries)
+ ("previous_page" . null)
+ ("total_entries" . ,total-entries)))
+ (,resource . ,(append-map
+ (lambda (body)
+ (vector->list (assoc-ref body resource)))
+ (map hetzner-api-response-body responses)))))))
+ (raise (formatted-message
+ (G_ "expected a list of Hetzner API responses")))))
+
+(define (hetzner-api-body-action body)
+ "Return the Hetzner API action from BODY."
+ (let ((json (assoc-ref body "action")))
+ (and json (json->hetzner-action json))))
+
+(define (hetzner-api-response-read port)
+ "Read the Hetzner API response from PORT."
+ (let* ((response (read-response port))
+ (body (read-response-body response)))
+ (hetzner-api-response
+ (body (and body (json-string->scm (utf8->string body))))
+ (headers (response-headers response))
+ (status (response-code response)))))
+
+(define (hetzner-api-response-validate-status response expected)
+ "Raise an error if the HTTP status code of RESPONSE is not in EXPECTED."
+ (when (not (member (hetzner-api-response-status response) expected))
+ (raise (formatted-message
+ (G_ "unexpected HTTP status code: ~a, expected: ~a~%~a")
+ (hetzner-api-response-status response)
+ expected
+ (hetzner-api-response-body response)))))
+
+
+\f
+;;;
+;;; Hetzner API request.
+;;;
+
+(define-record-type* <hetzner-api-request>
+ hetzner-api-request make-hetzner-api-request hetzner-api-request?
+ (body hetzner-api-request-body (default *unspecified*))
+ (headers hetzner-api-request-headers (default '()))
+ (method hetzner-api-request-method (default 'GET))
+ (params hetzner-api-request-params (default '()))
+ (url hetzner-api-request-url))
+
+(define (hetzner-api-request-uri request)
+ "Return the URI object of the Hetzner API request."
+ (let ((params (hetzner-api-request-params request)))
+ (string->uri (string-append (hetzner-api-request-url request)
+ (format-query-params params)))))
+
+(define (hetzner-api-request-body-bytevector request)
+ "Return the body of the Hetzner API REQUEST as a bytevector."
+ (let* ((body (hetzner-api-request-body request))
+ (string (if (unspecified? body) "" (scm->json-string body))))
+ (string->bytevector string "UTF-8")))
+
+(define (hetzner-api-request-write port request)
+ "Write the Hetzner API REQUEST to PORT."
+ (let* ((body (hetzner-api-request-body-bytevector request))
+ (request (build-request
+ (hetzner-api-request-uri request)
+ #:method (hetzner-api-request-method request)
+ #:version '(1 . 1)
+ #:headers (cons* `(Content-Length
+ . ,(number->string
+ (if (unspecified? body)
+ 0 (bytevector-length body))))
+ (hetzner-api-request-headers request))
+ #:port port))
+ (request (write-request request port)))
+ (unless (unspecified? body)
+ (write-request-body request body))
+ (force-output (request-port request))))
+
+(define* (hetzner-api-request-send request #:key (expected (list 200 201 204)))
+ "Send the Hetzner API REQUEST via HTTP."
+ (let ((port (open-socket-for-uri (hetzner-api-request-uri request))))
+ (hetzner-api-request-write port request)
+ (let ((response (hetzner-api-response-read port)))
+ (close-port port)
+ (hetzner-api-response-validate-status response expected)
+ response)))
+
+(define (hetzner-api-request-next-params request)
+ "Return the pagination params for the next page of the REQUEST."
+ (let* ((params (hetzner-api-request-params request))
+ (page (or (assoc-ref params "page") 1)))
+ (map (lambda (param)
+ (if (equal? "page" (car param))
+ (cons (car param) (+ page 1))
+ param))
+ params)))
+
+(define (hetzner-api-request-paginate request)
+ "Fetch all pages of the REQUEST via pagination and return all responses."
+ (let* ((response (hetzner-api-request-send request))
+ (pagination (hetzner-api-response-pagination response))
+ (next-page (assoc-ref pagination "next_page")))
+ (if (number? next-page)
+ (cons response
+ (hetzner-api-request-paginate
+ (hetzner-api-request
+ (inherit request)
+ (params (hetzner-api-request-next-params request)))))
+ (list response))))
+
+
+\f
+;;;
+;;; Hetzner API.
+;;;
+
+(define-record-type* <hetzner-api>
+ hetzner-api make-hetzner-api hetzner-api?
+ (base-url hetzner-api-base-url ; string
+ (default "https://api.hetzner.cloud/v1"))
+ (token hetzner-api-token ; string
+ (default (%hetzner-default-api-token))))
+
+(define (hetzner-api-authorization-header api)
+ "Return the authorization header for the Hetzner API."
+ (format #f "Bearer ~a" (hetzner-api-token api)))
+
+(define (hetzner-api-default-headers api)
+ "Returns the default headers of the Hetzner API."
+ `((user-agent . "Guix Deploy")
+ (Accept . "application/json")
+ (Authorization . ,(hetzner-api-authorization-header api))
+ (Content-Type . "application/json")))
+
+(define (hetzner-api-url api path)
+ "Append PATH to the base url of the Hetzner API."
+ (string-append (hetzner-api-base-url api) path))
+
+(define (hetzner-api-delete api path)
+ "Delelte the resource at PATH with the Hetzner API."
+ (hetzner-api-response-body
+ (hetzner-api-request-send
+ (hetzner-api-request
+ (headers (hetzner-api-default-headers api))
+ (method 'DELETE)
+ (url (hetzner-api-url api path))))))
+
+(define* (hetzner-api-list api path resources json->object #:key (params '()))
+ "Fetch all objects of RESOURCE from the Hetzner API."
+ (let ((body (hetzner-api-response-body
+ (hetzner-api-response-pagination-combine
+ resources (hetzner-api-request-paginate
+ (hetzner-api-request
+ (url (hetzner-api-url api path))
+ (headers (hetzner-api-default-headers api))
+ (params (cons '("page" . 1) params))))))))
+ (map json->object (assoc-ref body resources))))
+
+(define* (hetzner-api-post api path #:key (body *unspecified*))
+ "Send a POST request to the Hetzner API at PATH using BODY."
+ (hetzner-api-response-body
+ (hetzner-api-request-send
+ (hetzner-api-request
+ (body body)
+ (method 'POST)
+ (url (hetzner-api-url api path))
+ (headers (hetzner-api-default-headers api))))))
+
+(define* (hetzner-api-actions api . options)
+ "Get actions from the Hetzner API."
+ (apply hetzner-api-list api "/actions" "actions" json->hetzner-action options))
+
+(define* (hetzner-api-action-wait api action #:optional (status "success"))
+ "Wait until the ACTION has reached STATUS on the Hetzner API."
+ (let ((id (hetzner-action-id action)))
+ (let loop ()
+ (let ((actions (hetzner-api-actions api #:params `(("id" . ,id)))))
+ (cond
+ ((zero? (length actions))
+ (raise (formatted-message (G_ "server action '~a' not found") id)))
+ ((not (= 1 (length actions)))
+ (raise (formatted-message
+ (G_ "expected one server action, but got '~a'")
+ (length actions))))
+ ((string= status (hetzner-action-status (car actions)))
+ (car actions))
+ (else
+ (sleep 5)
+ (loop)))))))
+
+(define* (hetzner-api-locations api . options)
+ "Get deployment locations from the Hetzner API."
+ (apply hetzner-api-list api "/locations" "locations" json->hetzner-location options))
+
+(define* (hetzner-api-server-create
+ api name ssh-keys
+ #:key
+ (enable-ipv4? #t)
+ (enable-ipv6? #t)
+ (image %hetzner-default-server-image)
+ (labels '())
+ (location %hetzner-default-server-location)
+ (public-net #f)
+ (server-type %hetzner-default-server-type)
+ (start-after-create? #f))
+ "Create a server with the Hetzner API."
+ (let ((body (hetzner-api-post
+ api "/servers"
+ #:body `(("image" . ,image)
+ ("labels" . ,labels)
+ ("name" . ,name)
+ ("public_net"
+ . (("enable_ipv4" . ,enable-ipv4?)
+ ("enable_ipv6" . ,enable-ipv6?)))
+ ("location" . ,location)
+ ("server_type" . ,server-type)
+ ("ssh_keys" . ,(apply vector (map hetzner-ssh-key-id ssh-keys)))
+ ("start_after_create" . ,start-after-create?)))))
+ (hetzner-api-action-wait api (hetzner-api-body-action body))
+ (json->hetzner-server (assoc-ref body "server"))))
+
+(define (hetzner-api-server-delete api server)
+ "Delete the SERVER with the Hetzner API."
+ (let ((body (hetzner-api-delete api (hetzner-server-path server))))
+ (hetzner-api-action-wait api (hetzner-api-body-action body))))
+
+(define* (hetzner-api-server-enable-rescue-system
+ api server ssh-keys #:key (type "linux64"))
+ "Enable the rescue system for SERVER with the Hetzner API."
+ (let* ((ssh-keys (apply vector (map hetzner-ssh-key-id ssh-keys)))
+ (body (hetzner-api-post
+ api (hetzner-server-path server "/actions/enable_rescue")
+ #:body `(("ssh_keys" . ,ssh-keys)
+ ("type" . ,type)))))
+ (hetzner-api-action-wait api (hetzner-api-body-action body))))
+
+(define* (hetzner-api-servers api . options)
+ "Get servers from the Hetzner API."
+ (apply hetzner-api-list api "/servers" "servers" json->hetzner-server options))
+
+(define (hetzner-api-server-power-on api server)
+ "Send a power on request for SERVER to the Hetzner API."
+ (let ((body (hetzner-api-post api (hetzner-server-path server "/actions/poweron"))))
+ (hetzner-api-action-wait api (hetzner-api-body-action body))))
+
+(define (hetzner-api-server-power-off api server)
+ "Send a power off request for SERVER to the Hetzner API."
+ (let ((body (hetzner-api-post api (hetzner-server-path server "/actions/poweroff"))))
+ (hetzner-api-action-wait api (hetzner-api-body-action body))))
+
+(define (hetzner-api-server-reboot api server)
+ "Send a reboot request for SERVER to the Hetzner API."
+ (let ((body (hetzner-api-post api (hetzner-server-path server "/actions/reboot"))))
+ (hetzner-api-action-wait api (hetzner-api-body-action body))))
+
+(define* (hetzner-api-ssh-key-create api name public-key #:key (labels '()))
+ "Create a SSH key with the Hetzner API."
+ (let ((body (hetzner-api-post
+ api "/ssh_keys"
+ #:body `(("name" . ,name)
+ ("public_key" . ,public-key)
+ ("labels" . ,labels)))))
+ (json->hetzner-ssh-key (assoc-ref body "ssh_key"))))
+
+(define (hetzner-api-ssh-key-delete api ssh-key)
+ "Delete the SSH key on the Hetzner API."
+ (hetzner-api-delete api (hetzner-ssh-key-path ssh-key))
+ #t)
+
+(define* (hetzner-api-ssh-keys api . options)
+ "Get SSH keys from the Hetzner API."
+ (apply hetzner-api-list api "/ssh_keys" "ssh_keys"
+ json->hetzner-ssh-key options))
+
+(define* (hetzner-api-server-types api . options)
+ "Get server types from the Hetzner API."
+ (apply hetzner-api-list api "/server_types" "server_types"
+ json->hetzner-server-type options))
diff --git a/guix/ssh.scm b/guix/ssh.scm
index ae506df14c..8decfdbab9 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -103,7 +103,8 @@ (define* (open-ssh-session host #:key user port identity
host-key
(compression %compression)
(timeout 3600)
- (connection-timeout 10))
+ (connection-timeout 10)
+ (strict-host-key-check? #t))
"Open an SSH session for HOST and return it. IDENTITY specifies the file
name of a private key to use for authenticating with the host. When USER,
PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config'
@@ -117,6 +118,9 @@ (define* (open-ssh-session host #:key user port identity
seconds. Install TIMEOUT as the maximum time in seconds after which a read or
write operation on a channel of the returned session is considered as failing.
+IF STRICT-HOST-KEY-CHECK? is #f, strict host key checking is turned off for
+the new session.
+
Throw an error on failure."
(let ((session (make-session #:user user
#:identity identity
@@ -137,7 +141,8 @@ (define* (open-ssh-session host #:key user port identity
;; Speed up RPCs by creating sockets with
;; TCP_NODELAY.
- #:nodelay #t)))
+ #:nodelay #t
+ #:stricthostkeycheck strict-host-key-check?)))
;; Honor ~/.ssh/config.
(session-parse-config! session)
@@ -149,13 +154,14 @@ (define* (open-ssh-session host #:key user port identity
(authenticate-server* session host-key)
;; Authenticate against ~/.ssh/known_hosts.
- (match (authenticate-server session)
- ('ok #f)
- (reason
- (raise (formatted-message (G_ "failed to authenticate \
+ (when strict-host-key-check?
+ (match (authenticate-server session)
+ ('ok #f)
+ (reason
+ (raise (formatted-message (G_ "failed to authenticate \
server at '~a': ~a")
- (session-get session 'host)
- reason)))))
+ (session-get session 'host)
+ reason))))))
;; Use public key authentication, via the SSH agent if it's available.
(match (userauth-public-key/auto! session)
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index e37da506fc..d68fad4e8c 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -81,6 +81,8 @@ gnu/installer/steps.scm
gnu/installer/timezone.scm
gnu/installer/user.scm
gnu/installer/utils.scm
+gnu/machine/hetzner.scm
+gnu/machine/hetzner/http.scm
gnu/machine/ssh.scm
gnu/packages/bootstrap.scm
guix/build/utils.scm
diff --git a/tests/machine/hetzner.scm b/tests/machine/hetzner.scm
new file mode 100644
index 0000000000..5c84529c84
--- /dev/null
+++ b/tests/machine/hetzner.scm
@@ -0,0 +1,244 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Roman Scherer <roman@burningswell.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (tests machine hetzner)
+ #:use-module (debugging assert)
+ #:use-module (gnu machine hetzner http)
+ #:use-module (gnu machine hetzner)
+ #:use-module (gnu machine ssh)
+ #:use-module (gnu machine)
+ #:use-module (gnu system)
+ #:use-module (guix build utils)
+ #:use-module (guix records)
+ #:use-module (guix ssh)
+ #:use-module (guix tests)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-64)
+ #:use-module (ssh key)
+ #:use-module (ssh session))
+
+;;; Tests for the (gnu machine hetzner) module.
+
+;; This test requires the GUIX_HETZNER_API_TOKEN environment variable to be set.
+;; https://docs.hetzner.com/cloud/api/getting-started/generating-api-token
+
+(define %ssh-key-name
+ "guix-hetzner-machine-test-key")
+
+(define %ssh-key-file
+ (string-append "/tmp/" %ssh-key-name))
+
+(unless (file-exists? %ssh-key-file)
+ (private-key-to-file (make-keypair 'rsa 2048) %ssh-key-file))
+
+(define %when-no-token
+ (if (hetzner-api-token (hetzner-api)) 0 1))
+
+(define %arm-machine
+ (machine
+ (operating-system
+ (operating-system
+ (inherit %hetzner-os-arm)
+ (host-name "guix-deploy-hetzner-test-arm")))
+ (environment hetzner-environment-type)
+ (configuration (hetzner-configuration
+ (server-type "cax41")
+ (ssh-key %ssh-key-file)))))
+
+(define %x86-machine
+ (machine
+ (operating-system
+ (operating-system
+ (inherit %hetzner-os-x86)
+ (host-name "guix-deploy-hetzner-test-x86")))
+ (environment hetzner-environment-type)
+ (configuration (hetzner-configuration
+ (server-type "cpx51")
+ (ssh-key %ssh-key-file)))))
+
+(define (cleanup machine)
+ (let* ((config (machine-configuration machine))
+ (api (hetzner-configuration-api config)))
+ (for-each (lambda (ssh-key)
+ (hetzner-api-ssh-key-delete api ssh-key))
+ (hetzner-api-ssh-keys
+ (hetzner-configuration-api config)
+ #:params `(("name" . ,%ssh-key-name))))
+ (for-each (lambda (server)
+ (hetzner-api-server-delete api server))
+ (hetzner-api-servers
+ (hetzner-configuration-api config)
+ #:params `(("name" . ,(machine-display-name machine)))))
+ machine))
+
+(define-syntax-rule (with-cleanup-machine (machine-sym machine-init) body ...)
+ (let ((machine-sym (cleanup machine-init)))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ body ...)
+ (lambda ()
+ (cleanup machine-sym)))))
+
+(define (mock-action command)
+ (make-hetzner-action
+ command #f
+ (localtime (current-time))
+ 1
+ 100
+ '()
+ (localtime (current-time))
+ "success"))
+
+(define (mock-location machine)
+ (let* ((config (machine-configuration machine))
+ (name (hetzner-configuration-location config)))
+ (make-hetzner-location
+ "Falkenstein" "DE" "Falkenstein DC Park 1"
+ 1 50.47612 12.370071 name "eu-central")))
+
+(define (mock-server-type machine)
+ (let* ((config (machine-configuration machine))
+ (name (hetzner-configuration-server-type config)))
+ (make-hetzner-server-type
+ "x86" 8 "shared" #f #f (string-upcase name)
+ 160 106 16 name "local")))
+
+(define (mock-server machine)
+ (let* ((config (machine-configuration machine))
+ (name (hetzner-configuration-location config)))
+ (make-hetzner-server
+ 1
+ (localtime (current-time))
+ '()
+ (operating-system-host-name (machine-operating-system machine))
+ (make-hetzner-public-net
+ (make-hetzner-ipv4 #f "server.example.com" 1 "1.2.3.4")
+ (make-hetzner-ipv6 #f "server.example.com" 1 "2001:db8::1"))
+ #f
+ (mock-server-type machine))))
+
+(define (mock-ssh-key machine)
+ (let ((config (machine-configuration machine)))
+ (hetzner-ssh-key-read-file (hetzner-configuration-ssh-key config))))
+
+(test-begin "machine-hetzner")
+
+(test-skip %when-no-token)
+(test-assert "deploy-arm-machine"
+ (with-cleanup-machine (machine %arm-machine)
+ (deploy-hetzner machine)))
+
+(test-skip %when-no-token)
+(test-assert "deploy-x86-machine"
+ (with-cleanup-machine (machine %x86-machine)
+ (deploy-hetzner machine)))
+
+(define (expected-ssh-machine? machine ssh-machine)
+ (let ((config (machine-configuration machine))
+ (ssh-config (machine-configuration ssh-machine)))
+ (assert (equal? (hetzner-configuration-authorize? config)
+ (machine-ssh-configuration-authorize? ssh-config)))
+ (assert (equal? (hetzner-configuration-allow-downgrades? config)
+ (machine-ssh-configuration-allow-downgrades? ssh-config)))
+ (assert (equal? (hetzner-configuration-build-locally? config)
+ (machine-ssh-configuration-build-locally? ssh-config)))
+ (assert (equal? (hetzner-server-public-ipv4 (mock-server machine))
+ (machine-ssh-configuration-host-name ssh-config)))))
+
+(test-assert "deploy-machine-mock-with-provisioned-server"
+ (let* ((machine (machine
+ (operating-system %hetzner-os-x86)
+ (environment hetzner-environment-type)
+ (configuration (hetzner-configuration
+ (api (hetzner-api (token "mock")))
+ (ssh-key %ssh-key-file))))))
+ (mock ((gnu machine hetzner http) hetzner-api-locations
+ (lambda* (api . options)
+ (list (mock-location machine))))
+ (mock ((gnu machine hetzner http) hetzner-api-server-types
+ (lambda* (api . options)
+ (list (mock-server-type machine))))
+ (mock ((gnu machine hetzner http) hetzner-api-ssh-keys
+ (lambda* (api . options)
+ (list (mock-ssh-key machine))))
+ (mock ((gnu machine hetzner http) hetzner-api-servers
+ (lambda* (api . options)
+ (list (mock-server machine))))
+ (mock ((gnu machine) deploy-machine
+ (lambda* (ssh-machine)
+ (assert (expected-ssh-machine? machine ssh-machine))))
+ (deploy-hetzner machine))))))))
+
+(test-assert "deploy-machine-mock-with-unprovisioned-server"
+ (let* ((machine (machine
+ (operating-system %hetzner-os-x86)
+ (environment hetzner-environment-type)
+ (configuration (hetzner-configuration
+ (api (hetzner-api (token "mock")))
+ (ssh-key %ssh-key-file)))))
+ (servers '()))
+ (mock ((gnu machine hetzner http) hetzner-api-locations
+ (lambda* (api . options)
+ (list (mock-location machine))))
+ (mock ((gnu machine hetzner http) hetzner-api-server-types
+ (lambda* (api . options)
+ (list (mock-server-type machine))))
+ (mock ((gnu machine hetzner http) hetzner-api-ssh-keys
+ (lambda* (api . options)
+ (list (mock-ssh-key machine))))
+ (mock ((gnu machine hetzner http) hetzner-api-servers
+ (lambda* (api . options)
+ servers))
+ (mock ((gnu machine hetzner http) hetzner-api-server-create
+ (lambda* (api name ssh-keys . options)
+ (set! servers (list (mock-server machine)))
+ (car servers)))
+ (mock ((gnu machine hetzner http) hetzner-api-server-enable-rescue-system
+ (lambda (api server ssh-keys)
+ (format #t "MOCK ENABLE RESUCE~%")
+ (mock-action "enable_rescue")))
+ (mock ((gnu machine hetzner http) hetzner-api-server-power-on
+ (lambda (api server)
+ (format #t "MOCK POWER ON~%")
+ (mock-action "start_server")))
+ (mock ((gnu machine hetzner) hetzner-machine-ssh-run-script
+ (lambda (ssh-session name content)
+ (format #t "MOCK RUNNING SCRIPT: ~a~%" name)
+ #t))
+ (mock ((guix ssh) open-ssh-session
+ (lambda* (host . options)
+ (format #t "MOCK OPEN SSH SESSION~%")
+ (make-session #:host host)))
+ (mock ((gnu machine hetzner http) hetzner-api-server-reboot
+ (lambda (api server)
+ (mock-action "reboot_server")))
+ (mock ((ssh session) write-known-host!
+ (lambda (session)
+ #t))
+ (mock ((gnu machine) deploy-machine
+ (lambda* (ssh-machine)
+ (assert (expected-ssh-machine? machine ssh-machine))))
+ (deploy-hetzner machine)))))))))))))))
+
+(test-end "machine-hetzner")
+
+;; Local Variables:
+;; eval: (put 'with-cleanup-machine 'scheme-indent-function 1)
+;; End:
diff --git a/tests/machine/hetzner/http.scm b/tests/machine/hetzner/http.scm
new file mode 100644
index 0000000000..616c5ae67f
--- /dev/null
+++ b/tests/machine/hetzner/http.scm
@@ -0,0 +1,167 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Roman Scherer <roman@burningswell.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (tests machine hetzner http)
+ #:use-module (gnu machine hetzner http)
+ #:use-module (guix build utils)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-64)
+ #:use-module (ssh key))
+
+;;; Tests for the (gnu machine hetzner api) module.
+
+;; This test requires the GUIX_HETZNER_API_TOKEN environment variable to be set.
+;; https://docs.hetzner.com/cloud/api/getting-started/generating-api-token
+
+(define %server-name
+ "guix-hetzner-api-test-server")
+
+(define %ssh-key-name
+ "guix-hetzner-api-test-key")
+
+(define %ssh-key-file
+ (string-append "/tmp/" %ssh-key-name))
+
+(unless (file-exists? %ssh-key-file)
+ (private-key-to-file (make-keypair 'rsa 2048) %ssh-key-file))
+
+(define %ssh-key
+ (hetzner-ssh-key-read-file %ssh-key-file))
+
+(define %when-no-token
+ (if (hetzner-api-token (hetzner-api)) 0 1))
+
+(define* (create-ssh-key api ssh-key #:key (labels '()))
+ (hetzner-api-ssh-key-create
+ api
+ (hetzner-ssh-key-name ssh-key)
+ (hetzner-ssh-key-public-key ssh-key)
+ #:labels labels))
+
+(define (cleanup api)
+ (let ((api (hetzner-api)))
+ (for-each (lambda (ssh-key)
+ (hetzner-api-ssh-key-delete api ssh-key))
+ (hetzner-api-ssh-keys
+ api #:params `(("name" . ,%ssh-key-name))))
+ (for-each (lambda (server)
+ (hetzner-api-server-delete api server))
+ (hetzner-api-servers
+ api #:params `(("name" . ,%server-name))))
+ api))
+
+(define-syntax-rule (with-cleanup-api (api-sym api-init) body ...)
+ (let ((api-sym (cleanup api-init)))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ body ...)
+ (lambda ()
+ (cleanup api-sym)))))
+
+(test-begin "machine-hetzner-api")
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-actions"
+ (every hetzner-action? (hetzner-api-actions (hetzner-api))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-locations"
+ (every hetzner-location? (hetzner-api-locations (hetzner-api))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-types"
+ (every hetzner-server-type? (hetzner-api-server-types (hetzner-api))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-create"
+ (with-cleanup-api (api (hetzner-api))
+ (let* ((key (create-ssh-key api %ssh-key))
+ (server (hetzner-api-server-create api %server-name (list key))))
+ (hetzner-server? server))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-delete"
+ (with-cleanup-api (api (hetzner-api))
+ (let* ((key (create-ssh-key api %ssh-key))
+ (server (hetzner-api-server-create api %server-name (list key)))
+ (action (hetzner-api-server-delete api server)))
+ (hetzner-action? action))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-enable-rescue-system"
+ (with-cleanup-api (api (hetzner-api))
+ (let* ((key (create-ssh-key api %ssh-key))
+ (server (hetzner-api-server-create api %server-name (list key)))
+ (action (hetzner-api-server-enable-rescue-system api server (list key))))
+ (hetzner-action? action))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-power-on"
+ (with-cleanup-api (api (hetzner-api))
+ (let* ((key (create-ssh-key api %ssh-key))
+ (server (hetzner-api-server-create api %server-name (list key)))
+ (action (hetzner-api-server-power-on api server)))
+ (hetzner-action? action))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-power-off"
+ (with-cleanup-api (api (hetzner-api))
+ (let* ((key (create-ssh-key api %ssh-key))
+ (server (hetzner-api-server-create api %server-name (list key)))
+ (action (hetzner-api-server-power-off api server)))
+ (hetzner-action? action))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-reboot"
+ (with-cleanup-api (api (hetzner-api))
+ (let* ((key (create-ssh-key api %ssh-key))
+ (server (hetzner-api-server-create api %server-name (list key)))
+ (action (hetzner-api-server-reboot api server)))
+ (hetzner-action? action))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-servers"
+ (every hetzner-server? (hetzner-api-servers (hetzner-api))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-ssh-key-create"
+ (with-cleanup-api (api (hetzner-api))
+ (let* ((api (cleanup (hetzner-api)))
+ (key (create-ssh-key api %ssh-key)))
+ (hetzner-ssh-key? key))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-ssh-key-delete"
+ (with-cleanup-api (api (hetzner-api))
+ (let* ((api (cleanup (hetzner-api)))
+ (key (create-ssh-key
+ api %ssh-key
+ #:labels '(("environment" . "development")))))
+ (hetzner-api-ssh-key-delete api key))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-ssh-keys"
+ (every hetzner-ssh-key? (hetzner-api-ssh-keys (hetzner-api))))
+
+(test-end "machine-hetzner-api")
+
+;; Local Variables:
+;; eval: (put 'with-cleanup-api 'scheme-indent-function 1)
+;; End:
base-commit: 7aae0e2c159b1612b405a372b18f25fbb58f9d82
prerequisite-patch-id: ac1f0d4a2d25a1b4d5bc2113465fff75fe16b173
prerequisite-patch-id: eb3f1eb84750594036d67d1415c45ac1b79ddef4
prerequisite-patch-id: 01e878a55309cfb2b19a5616530cc95e305a17df
prerequisite-patch-id: 5a938c41d076ed210df0dd2ea14064581d54d245
prerequisite-patch-id: 1d62fb01e63abea0cdd588a52c1e570a5175eff7
prerequisite-patch-id: e5bdca7bb03c74026330fbaae6bd89efcbf4c2a9
prerequisite-patch-id: 10a22db612648d6a35e93d44afac961b3e5d2e9e
prerequisite-patch-id: 6a052619a2a8a036f658f0de4a2f4e42f6354d19
prerequisite-patch-id: 7a18e5bff86d43b14e6633357c185cd9a1ebf072
prerequisite-patch-id: 0d39c3063a794f1c740021e5d5f43e98c3e74013
prerequisite-patch-id: 8d732b32581c39cd4e61cfd583be9b8fdff4b86d
prerequisite-patch-id: 4233e276f34af03e0e84ce06aec407d13a3c0dab
prerequisite-patch-id: a95d5a44ca76b5e4ee7d7a552fa644e3c07c1ca9
prerequisite-patch-id: 500d513328a3545d08a954e09f1cabcef6c22f8c
prerequisite-patch-id: e3538aa251c819e1e6f100b9f547f64e79535957
prerequisite-patch-id: 8be1562d2e1390bd513303496e2cfe930e83cf98
prerequisite-patch-id: 1384fe5a71920e6f02858ccce39ae9a481d5d170
prerequisite-patch-id: ac21d3b2571c5f51a0e4b338fa4292189928c9d4
prerequisite-patch-id: 11eccf9862f6122ae1d52c13d218eac0064f0b22
prerequisite-patch-id: 86f80755bf52b691ea258121089f394a49a7aca7
prerequisite-patch-id: fa2314d1b06b810ecd2bb69f86b8556204a87e22
prerequisite-patch-id: b41b483173b7790006158179a4f2459af02cc088
prerequisite-patch-id: a4833568bf4308b39b456841e89be021b444b17e
--
2.47.1
[-- Attachment #1.3: Type: text/plain, Size: 6745 bytes --]
Ludovic Courtès <ludo@gnu.org> writes:
> Hello Roman,
>
> Roman Scherer <roman@burningswell.com> skribis:
>
>> * gnu/machine/hetzner.scm: New file.
>> * gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
>> * guix/ssh.scm (open-ssh-session): Add stricthostkeycheck option.
>> * doc/guix.texi (Invoking guix deploy): Add documentation for
>> 'hetzner-configuration'.
>>
>> Change-Id: Idc17dbc33279ecbf3cbfe2c53d7699140f8b9f41
>
> Thumbs up for this big piece of work, one that I think is important for
> the project! ‘guix deploy’ is a great idea but it desperately needs
> more backends like this one.
>
> I’m not familiar with Hetzner so I’ll comment on more general aspects.
> Chris, perhaps you can provide feedback on Hetzner-specific issues? I
> think we could put this backend to good use for Guix infra since a few
> services are running at Hetzner.
>
>> +@deftp {Data Type} hetzner-configuration
>> +This is the data type describing the server that should be created for a
>> +machine with an @code{environment} of @code{hetzner-environment-type}.
>
> Could you add a sentence providing more context like:
>
> It allows you to configure deployment to a @acronym{VPS, virtual
> private server} hosted by @uref{https://www.hetzner.com, Hetzner}.
>
>> +@item @code{authorize?} (default: @code{#t})
>> +If true, the coordinator's public signing key
>
> “coordinator” has nothing to do here I guess.
>
>> +@item @code{labels} (default: @code{'()})
>> +A user defined alist of key/value pairs attached to the server. Keys and
>> +values must be strings. For more information, see
>> +@uref{https://docs.hetzner.cloud/#labels, Labels}.
>
> Maybe add a short example?
>
>> +@item @code{location} (default: @code{"fsn1"})
>> +The name of a @uref{https://docs.hetzner.com/cloud/general/locations,
>> +location} to create the server in.
>
> Maybe add: “For example, @code{"fsn1"} corresponds to the Hetzner site
> in Falkenstein, Germany, while @code{"sin"} corresponds to its site in
> Singapore.”
>
>> +@item @code{server-type} (default: @code{"cx42"})
>> +The name of the
>> +@uref{https://docs.hetzner.com/cloud/servers/overview#server-types,
>> +server type} this server should be created with.
>
> Likewise, an example would be elcome.
>
>> +@item @code{ssh-key}
>> +The path to the SSH private key to use to authenticate with the remote
>> +host.
>
> s/path to/file name of/
>
>> +The following example shows the definition of 2 machines that are
>
> s/2/two/
>
>> +vCPUs and 32 GB of RAM on the @code{aarch64} architecture, the second
>
> s/@code{aarch64}/AArch64/
>
>> +shared vCPUs and 32 GB of RAM on the @code{x86_64} architecture.
>
> Drop @code.
>
>> +@lisp
>> +(use-modules (gnu machine)
>> + (gnu machine hetzner))
>> +
>> +(list (machine
>> + (operating-system %hetzner-os-arm)
>> + (environment hetzner-environment-type)
>> + (configuration (hetzner-configuration
>> + (server-type "cax41")
>> + (ssh-key "/home/charlie/.ssh/id_rsa"))))
>> + (machine
>> + (operating-system %hetzner-os-x86)
>> + (environment hetzner-environment-type)
>> + (configuration (hetzner-configuration
>> + (server-type "cpx51")
>> + (ssh-key "/home/charlie/.ssh/id_rsa")))))
>
> Nice!
>
>> +API key} should provision 2 machines for you.
>
> s/2/two/
>
>> + #:use-module (ice-9 receive)
>
> The code base preferable uses SRFI-71 for multiple-value returns.
>
>> + (raise (formatted-message
>> + (G_ "Expected a list of Hetzner API responses")))))
>
> Messages should start with a lower-case letter (for all the messages in
> this file).
>
> Please add the file to ‘po/guix/POTFILES.in’ so that it’s actually
> subject to translation.
>
>> +(define (hetzner-api-response-read port)
>> + "Read the Hetzner API response from PORT."
>> + (let* ((response (read-response port))
>> + (body (read-response-body response)))
>> + (hetzner-api-response
>> + (body (json-string->scm (bytevector->string body "UTF-8")))
>
> Just ‘string->utf8’ (shorter).
>
> More importantly: instead of ‘json-string->scm’ (which gives an alist,
> leading to ‘assoc-ref’ calls all over the code base along with free-form
> alists, which is very error-prone), could you use ‘define-json-mapping’?
>
> In essence it’s like ‘define-record-type’ but it additionally define how
> to map a JSON dictionary to a Scheme record. There are several examples
> in Guix, such as (guix swh).
>
> For clarity, it might be useful to move all the hetzner-api-* bits to a
> separate module, for example (gnu machine hetzner http). WDYT?
>
>
> The rest of the code looks nice to me (modulo alists :-)) but that’s
> about all I can say. It’s quite a significant body of code. What would
> you suggest to prevent bitrot and support maintenance? Are there parts
> of it that could be usefully tested automatically, possibly by mocking
> part of the Hetzner API? Or are there tips on how you tested it that
> could be written down in the file itself?
>
>
> Could you move the (guix ssh) bits to a separate patch?
>
>> +++ b/guix/ssh.scm
>> @@ -103,7 +103,8 @@ (define* (open-ssh-session host #:key user port identity
>> host-key
>> (compression %compression)
>> (timeout 3600)
>> - (connection-timeout 10))
>> + (connection-timeout 10)
>> + (stricthostkeycheck #t))
>> "Open an SSH session for HOST and return it. IDENTITY specifies the file
>> name of a private key to use for authenticating with the host. When USER,
>> PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config'
>
> Please update the docstring.
>
> Rather ‘strict-host-key-check?’ to match naming conventions, even if
> Guile-SSH calls it that way.
>
>> @@ -137,7 +138,8 @@ (define* (open-ssh-session host #:key user port identity
>>
>> ;; Speed up RPCs by creating sockets with
>> ;; TCP_NODELAY.
>> - #:nodelay #t)))
>> + #:nodelay #t
>> + #:stricthostkeycheck stricthostkeycheck)))
>
> Not sure what this does actually. Looks like the main part is the
> “when stricthostkeycheck” condition that comes below, no?
>
> Could you send a second version?
>
> Thank you!
>
> Ludo’.
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 519 bytes --]
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
2025-01-19 16:59 ` Roman Scherer
@ 2025-01-25 13:37 ` Roman Scherer
2025-01-27 0:45 ` Maxim Cournoyer
0 siblings, 1 reply; 17+ messages in thread
From: Roman Scherer @ 2025-01-25 13:37 UTC (permalink / raw)
To: Roman Scherer
Cc: Josselin Poiret, Maxim Cournoyer, Simon Tournier,
Mathieu Othacehe, Ludovic Courtès, Tobias Geerinckx-Rice,
Christopher Baines, 75144
[-- Attachment #1: Type: text/plain, Size: 11727 bytes --]
I made a `mock*` macro to get around this ugly nesting in the meantime.
https://github.com/r0man/guix/blob/hetzner-machine-v2-mock-star/tests/machine/hetzner.scm#L165-L248
But I'm still wondering why the `mock` in `deploy-machine-mock-with-unprovisioned-server` is working in the REPL,
but failing when I run the test with make ...
Roman Scherer <roman@burningswell.com> writes:
> Hi Ludo,
>
> thanks for your review. Here is a v2, I hope I addressed your previous
> comments with it, but I need some help.
>
> As you suggested I also added some tests. Some use mocking, and some run
> against the Hetzner API, if the GUIX_HETZNER_API_TOKEN env var is set.
>
> ./pre-inst-env make check TESTS="tests/machine/hetzner/http.scm"
> ./pre-inst-env make check TESTS="tests/machine/hetzner.scm"
>
> All tests pass when I run them in the Geiser REPL, where I developed them.
>
> But I have some trouble with one test that uses mocking. The
> "deploy-machine-mock-with-unprovisioned-server" test in
> tests/machine/hetzner.scm only fails when run in the terminal. :?
>
> I'm using the "mock" function from (guix tests) to mock some HTTP and SSH
> calls. The issue is that I see different behaviour whether I run the tests in
> Geiser vs in the Terminal.
>
> In Geiser I see the following output for this test, in it passes:
>
> -------------------------------------------------------------------------------
> creating 'cx42' server for 'guix-x86'...
> successfully created 'cx42' x86 server for 'guix-x86'
> enabling rescue system on 'guix-x86'...
> MOCK ENABLE RESUCE
> successfully enabled rescue system on 'guix-x86'
> powering on server for 'guix-x86'...
> MOCK POWER ON
> successfully powered on server for 'guix-x86'
> connecting via SSH to '1.2.3.4' using '/tmp/guix-hetzner-machine-test-key'...
> MOCK OPEN SSH SESSION
> installing rescue system packages on 'guix-x86'...
> MOCK RUNNING SCRIPT: /tmp/guix/deploy/hetzner-machine-rescue-install-packages
> successfully installed rescue system packages on 'guix-x86'
> setting up partitions on 'guix-x86'...
> MOCK RUNNING SCRIPT: /tmp/guix/deploy/hetzner-machine-rescue-partition
> successfully setup partitions on 'guix-x86'
> installing guix operating system on 'guix-x86'...
> MOCK RUNNING SCRIPT: /tmp/guix/deploy/hetzner-machine-rescue-install-os
> successfully installed guix operating system on 'guix-x86'
> rebooting server for 'guix-x86'...
> successfully rebooted server for 'guix-x86'
> connecting via SSH to '1.2.3.4' using '/tmp/guix-hetzner-machine-test-key'...
> MOCK OPEN SSH SESSION
> -------------------------------------------------------------------------------
>
> You can see that calls to "hetzner-machine-ssh-run-script" are mocked, because
> "MOCK RUNNING SCRIPT" is printed multiple times.
>
> But in a "guix shell -D" terminal I see the following output for the test, and
> it is failing:
>
> -------------------------------------------------------------------------------
>
> creating 'cx42' server for 'guix-x86'...
> successfully created 'cx42' x86 server for 'guix-x86'
> enabling rescue system on 'guix-x86'...
> MOCK ENABLE RESUCE
> successfully enabled rescue system on 'guix-x86'
> powering on server for 'guix-x86'...
> MOCK POWER ON
> successfully powered on server for 'guix-x86'
> connecting via SSH to '1.2.3.4' using '/tmp/guix-hetzner-machine-test-key'...
> MOCK OPEN SSH SESSION
> installing rescue system packages on 'guix-x86'...
> test-name: deploy-machine-mock-with-unprovisioned-server
> location: /home/roman/workspace/guix/tests/machine/hetzner.scm:189
>
> actual-value: #f
> actual-error:
> + (guile-ssh-error
> + "%gssh-make-sftp-session"
> + "Could not create a SFTP session"
> + #<session #<undefined>@1.2.3.4:22 (disconnected) ffff85596de0>
> + #f)
> result: FAIL
>
> ;;; [2025/01/19 17:39:16.791023, 0] [GSSH ERROR] Could not create a SFTP session: #<session #<undefined>@1.2.3.4:22 (disconnected) ffff85596de0>
>
> -------------------------------------------------------------------------------
>
> The tests fails here trying to use a disconnected SSH session object, that I
> returned in a mocked call. This code should actually never be reached, because
> I mock the "hetzner-machine-ssh-run-script" call. But for some reason the mock
> is not working here. The "MOCK RUNNING SCRIPT" output is missing.
>
> Do you have any ideas what could be going on here? I suspect this might be due
> to some optimization or env issue, but I'm pretty lost.
>
> I attached a WIP v2 for now. Will send a v3 and a separate patch for the ssh
> modification once I fixed this mock test.
>
> Thanks, Roman.
>
> [2. text/x-patch; v2-0001-machine-Implement-hetzner-environment-type.patch]...
>
>
> Ludovic Courtès <ludo@gnu.org> writes:
>
>> Hello Roman,
>>
>> Roman Scherer <roman@burningswell.com> skribis:
>>
>>> * gnu/machine/hetzner.scm: New file.
>>> * gnu/local.mk (GNU_SYSTEM_MODULES): Add it.
>>> * guix/ssh.scm (open-ssh-session): Add stricthostkeycheck option.
>>> * doc/guix.texi (Invoking guix deploy): Add documentation for
>>> 'hetzner-configuration'.
>>>
>>> Change-Id: Idc17dbc33279ecbf3cbfe2c53d7699140f8b9f41
>>
>> Thumbs up for this big piece of work, one that I think is important for
>> the project! ‘guix deploy’ is a great idea but it desperately needs
>> more backends like this one.
>>
>> I’m not familiar with Hetzner so I’ll comment on more general aspects.
>> Chris, perhaps you can provide feedback on Hetzner-specific issues? I
>> think we could put this backend to good use for Guix infra since a few
>> services are running at Hetzner.
>>
>>> +@deftp {Data Type} hetzner-configuration
>>> +This is the data type describing the server that should be created for a
>>> +machine with an @code{environment} of @code{hetzner-environment-type}.
>>
>> Could you add a sentence providing more context like:
>>
>> It allows you to configure deployment to a @acronym{VPS, virtual
>> private server} hosted by @uref{https://www.hetzner.com, Hetzner}.
>>
>>> +@item @code{authorize?} (default: @code{#t})
>>> +If true, the coordinator's public signing key
>>
>> “coordinator” has nothing to do here I guess.
>>
>>> +@item @code{labels} (default: @code{'()})
>>> +A user defined alist of key/value pairs attached to the server. Keys and
>>> +values must be strings. For more information, see
>>> +@uref{https://docs.hetzner.cloud/#labels, Labels}.
>>
>> Maybe add a short example?
>>
>>> +@item @code{location} (default: @code{"fsn1"})
>>> +The name of a @uref{https://docs.hetzner.com/cloud/general/locations,
>>> +location} to create the server in.
>>
>> Maybe add: “For example, @code{"fsn1"} corresponds to the Hetzner site
>> in Falkenstein, Germany, while @code{"sin"} corresponds to its site in
>> Singapore.”
>>
>>> +@item @code{server-type} (default: @code{"cx42"})
>>> +The name of the
>>> +@uref{https://docs.hetzner.com/cloud/servers/overview#server-types,
>>> +server type} this server should be created with.
>>
>> Likewise, an example would be elcome.
>>
>>> +@item @code{ssh-key}
>>> +The path to the SSH private key to use to authenticate with the remote
>>> +host.
>>
>> s/path to/file name of/
>>
>>> +The following example shows the definition of 2 machines that are
>>
>> s/2/two/
>>
>>> +vCPUs and 32 GB of RAM on the @code{aarch64} architecture, the second
>>
>> s/@code{aarch64}/AArch64/
>>
>>> +shared vCPUs and 32 GB of RAM on the @code{x86_64} architecture.
>>
>> Drop @code.
>>
>>> +@lisp
>>> +(use-modules (gnu machine)
>>> + (gnu machine hetzner))
>>> +
>>> +(list (machine
>>> + (operating-system %hetzner-os-arm)
>>> + (environment hetzner-environment-type)
>>> + (configuration (hetzner-configuration
>>> + (server-type "cax41")
>>> + (ssh-key "/home/charlie/.ssh/id_rsa"))))
>>> + (machine
>>> + (operating-system %hetzner-os-x86)
>>> + (environment hetzner-environment-type)
>>> + (configuration (hetzner-configuration
>>> + (server-type "cpx51")
>>> + (ssh-key "/home/charlie/.ssh/id_rsa")))))
>>
>> Nice!
>>
>>> +API key} should provision 2 machines for you.
>>
>> s/2/two/
>>
>>> + #:use-module (ice-9 receive)
>>
>> The code base preferable uses SRFI-71 for multiple-value returns.
>>
>>> + (raise (formatted-message
>>> + (G_ "Expected a list of Hetzner API responses")))))
>>
>> Messages should start with a lower-case letter (for all the messages in
>> this file).
>>
>> Please add the file to ‘po/guix/POTFILES.in’ so that it’s actually
>> subject to translation.
>>
>>> +(define (hetzner-api-response-read port)
>>> + "Read the Hetzner API response from PORT."
>>> + (let* ((response (read-response port))
>>> + (body (read-response-body response)))
>>> + (hetzner-api-response
>>> + (body (json-string->scm (bytevector->string body "UTF-8")))
>>
>> Just ‘string->utf8’ (shorter).
>>
>> More importantly: instead of ‘json-string->scm’ (which gives an alist,
>> leading to ‘assoc-ref’ calls all over the code base along with free-form
>> alists, which is very error-prone), could you use ‘define-json-mapping’?
>>
>> In essence it’s like ‘define-record-type’ but it additionally define how
>> to map a JSON dictionary to a Scheme record. There are several examples
>> in Guix, such as (guix swh).
>>
>> For clarity, it might be useful to move all the hetzner-api-* bits to a
>> separate module, for example (gnu machine hetzner http). WDYT?
>>
>>
>> The rest of the code looks nice to me (modulo alists :-)) but that’s
>> about all I can say. It’s quite a significant body of code. What would
>> you suggest to prevent bitrot and support maintenance? Are there parts
>> of it that could be usefully tested automatically, possibly by mocking
>> part of the Hetzner API? Or are there tips on how you tested it that
>> could be written down in the file itself?
>>
>>
>> Could you move the (guix ssh) bits to a separate patch?
>>
>>> +++ b/guix/ssh.scm
>>> @@ -103,7 +103,8 @@ (define* (open-ssh-session host #:key user port identity
>>> host-key
>>> (compression %compression)
>>> (timeout 3600)
>>> - (connection-timeout 10))
>>> + (connection-timeout 10)
>>> + (stricthostkeycheck #t))
>>> "Open an SSH session for HOST and return it. IDENTITY specifies the file
>>> name of a private key to use for authenticating with the host. When USER,
>>> PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config'
>>
>> Please update the docstring.
>>
>> Rather ‘strict-host-key-check?’ to match naming conventions, even if
>> Guile-SSH calls it that way.
>>
>>> @@ -137,7 +138,8 @@ (define* (open-ssh-session host #:key user port identity
>>>
>>> ;; Speed up RPCs by creating sockets with
>>> ;; TCP_NODELAY.
>>> - #:nodelay #t)))
>>> + #:nodelay #t
>>> + #:stricthostkeycheck stricthostkeycheck)))
>>
>> Not sure what this does actually. Looks like the main part is the
>> “when stricthostkeycheck” condition that comes below, no?
>>
>> Could you send a second version?
>>
>> Thank you!
>>
>> Ludo’.
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 519 bytes --]
^ permalink raw reply [flat|nested] 17+ messages in thread
* [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
2025-01-25 13:37 ` Roman Scherer
@ 2025-01-27 0:45 ` Maxim Cournoyer
2025-01-28 9:37 ` Roman Scherer
0 siblings, 1 reply; 17+ messages in thread
From: Maxim Cournoyer @ 2025-01-27 0:45 UTC (permalink / raw)
To: Roman Scherer
Cc: Josselin Poiret, Simon Tournier, Mathieu Othacehe,
Ludovic Courtès, Tobias Geerinckx-Rice, Christopher Baines,
75144
Hi Roman,
Roman Scherer <roman@burningswell.com> writes:
> I made a `mock*` macro to get around this ugly nesting in the meantime.
>
> https://github.com/r0man/guix/blob/hetzner-machine-v2-mock-star/tests/machine/hetzner.scm#L165-L248
>
> But I'm still wondering why the `mock` in
> `deploy-machine-mock-with-unprovisioned-server` is working in the
> REPL,
> but failing when I run the test with make ...
Could it be that you are tricked by the caching of HTTP queries? I've
been tricked by this before, as if you expect to have to mock each
individual request it may not happen as some will already be cached.
If that's the case, either disabling cache could do, or more easily, use
something like done with mock-http-fetch in the tests/go.scm file.
Hope that helps,
--
Thanks,
Maxim
^ permalink raw reply [flat|nested] 17+ messages in thread
* [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
2025-01-27 0:45 ` Maxim Cournoyer
@ 2025-01-28 9:37 ` Roman Scherer
2025-01-28 10:51 ` Ludovic Courtès
0 siblings, 1 reply; 17+ messages in thread
From: Roman Scherer @ 2025-01-28 9:37 UTC (permalink / raw)
To: Maxim Cournoyer
Cc: Josselin Poiret, Simon Tournier, Mathieu Othacehe,
Ludovic Courtès, Tobias Geerinckx-Rice, Roman Scherer,
Christopher Baines, 75144
[-- Attachment #1: Type: text/plain, Size: 1618 bytes --]
Hi Maxim,
thanks for your help and the tip about caching. Unless I'm missing
something, I don't think the caching of HTTP requests is involved
here.
I'm trying to test the (gnu machine hetzner) module and mock the
functions it uses from the (gnu machine hetzner http) module.
When I run the mocked test I expect no code from the (gnu machine
hetzner http) module to be executed, since I mocked all those
functions. This seems to work in the Geiser REPL, but for some reason it
does not work when I run the test with:
./pre-inst-env make check TESTS="tests/machine/hetzner.scm"
To me it looks like the mock function behaves differently in those 2
situations. In the meaintime I also tried setting -O0, but that didn't
make any difference either. :/
Roman
Maxim Cournoyer <maxim.cournoyer@gmail.com> writes:
> Hi Roman,
>
> Roman Scherer <roman@burningswell.com> writes:
>
>> I made a `mock*` macro to get around this ugly nesting in the meantime.
>>
>> https://github.com/r0man/guix/blob/hetzner-machine-v2-mock-star/tests/machine/hetzner.scm#L165-L248
>>
>> But I'm still wondering why the `mock` in
>> `deploy-machine-mock-with-unprovisioned-server` is working in the
>> REPL,
>> but failing when I run the test with make ...
>
> Could it be that you are tricked by the caching of HTTP queries? I've
> been tricked by this before, as if you expect to have to mock each
> individual request it may not happen as some will already be cached.
>
> If that's the case, either disabling cache could do, or more easily, use
> something like done with mock-http-fetch in the tests/go.scm file.
>
> Hope that helps,
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 519 bytes --]
^ permalink raw reply [flat|nested] 17+ messages in thread
* [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
2025-01-28 9:37 ` Roman Scherer
@ 2025-01-28 10:51 ` Ludovic Courtès
2025-01-28 19:57 ` Roman Scherer
0 siblings, 1 reply; 17+ messages in thread
From: Ludovic Courtès @ 2025-01-28 10:51 UTC (permalink / raw)
To: Roman Scherer
Cc: Josselin Poiret, Maxim Cournoyer, Simon Tournier,
Mathieu Othacehe, Tobias Geerinckx-Rice, Christopher Baines,
75144
Hi,
Roman Scherer <roman@burningswell.com> skribis:
> When I run the mocked test I expect no code from the (gnu machine
> hetzner http) module to be executed, since I mocked all those
> functions. This seems to work in the Geiser REPL, but for some reason it
> does not work when I run the test with:
>
> ./pre-inst-env make check TESTS="tests/machine/hetzner.scm"
>
> To me it looks like the mock function behaves differently in those 2
> situations. In the meaintime I also tried setting -O0, but that didn't
> make any difference either. :/
Hmm. I was going to say that the likely problem is that code from (gnu
machines hetzner http) gets inlined so you cannot really mock it.
To make sure this can be mocked, you can use this trick:
(set! proc proc)
where ‘proc’ is the procedure you want to mock (that statement prevents
the compiler from inlining it).
Ludo’.
^ permalink raw reply [flat|nested] 17+ messages in thread
* [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
2025-01-28 10:51 ` Ludovic Courtès
@ 2025-01-28 19:57 ` Roman Scherer
2025-02-04 19:10 ` Roman Scherer
0 siblings, 1 reply; 17+ messages in thread
From: Roman Scherer @ 2025-01-28 19:57 UTC (permalink / raw)
To: Ludovic Courtès
Cc: Josselin Poiret, Maxim Cournoyer, Simon Tournier,
Mathieu Othacehe, Tobias Geerinckx-Rice, Roman Scherer,
Christopher Baines, 75144
[-- Attachment #1: Type: text/plain, Size: 1137 bytes --]
Hi Ludo,
that's what I was looking for. Now it is working as expected!
I will send an updated patch soon.
Thanks for your help!
Roman
Ludovic Courtès <ludo@gnu.org> writes:
> Hi,
>
> Roman Scherer <roman@burningswell.com> skribis:
>
>> When I run the mocked test I expect no code from the (gnu machine
>> hetzner http) module to be executed, since I mocked all those
>> functions. This seems to work in the Geiser REPL, but for some reason it
>> does not work when I run the test with:
>>
>> ./pre-inst-env make check TESTS="tests/machine/hetzner.scm"
>>
>> To me it looks like the mock function behaves differently in those 2
>> situations. In the meaintime I also tried setting -O0, but that didn't
>> make any difference either. :/
>
> Hmm. I was going to say that the likely problem is that code from (gnu
> machines hetzner http) gets inlined so you cannot really mock it.
>
> To make sure this can be mocked, you can use this trick:
>
> (set! proc proc)
>
> where ‘proc’ is the procedure you want to mock (that statement prevents
> the compiler from inlining it).
>
> Ludo’.
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 519 bytes --]
^ permalink raw reply [flat|nested] 17+ messages in thread
* [bug#75144] [PATCH v3 1/2] guix: ssh: Add strict-host-key-check? option.
2024-12-27 16:46 [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type' Roman Scherer
2025-01-16 21:26 ` Ludovic Courtès
2025-01-16 21:26 ` Ludovic Courtès
@ 2025-02-04 19:01 ` Roman Scherer
2025-02-04 19:01 ` [bug#75144] [PATCH v3 2/2] machine: Implement 'hetzner-environment-type' Roman Scherer
2 siblings, 1 reply; 17+ messages in thread
From: Roman Scherer @ 2025-02-04 19:01 UTC (permalink / raw)
To: 75144
Cc: Roman Scherer, Christopher Baines, Josselin Poiret,
Ludovic Courtès, Mathieu Othacehe, Simon Tournier,
Tobias Geerinckx-Rice
* guix/ssh.scm (open-ssh-session): Add strict-host-key-check? option.
Change-Id: Iae5df5ac8d45033b6b636e9c872f8910d4f6cfe9
---
guix/ssh.scm | 22 ++++++++++++++--------
1 file changed, 14 insertions(+), 8 deletions(-)
diff --git a/guix/ssh.scm b/guix/ssh.scm
index ae506df14c..8decfdbab9 100644
--- a/guix/ssh.scm
+++ b/guix/ssh.scm
@@ -103,7 +103,8 @@ (define* (open-ssh-session host #:key user port identity
host-key
(compression %compression)
(timeout 3600)
- (connection-timeout 10))
+ (connection-timeout 10)
+ (strict-host-key-check? #t))
"Open an SSH session for HOST and return it. IDENTITY specifies the file
name of a private key to use for authenticating with the host. When USER,
PORT, or IDENTITY are #f, use default values or whatever '~/.ssh/config'
@@ -117,6 +118,9 @@ (define* (open-ssh-session host #:key user port identity
seconds. Install TIMEOUT as the maximum time in seconds after which a read or
write operation on a channel of the returned session is considered as failing.
+IF STRICT-HOST-KEY-CHECK? is #f, strict host key checking is turned off for
+the new session.
+
Throw an error on failure."
(let ((session (make-session #:user user
#:identity identity
@@ -137,7 +141,8 @@ (define* (open-ssh-session host #:key user port identity
;; Speed up RPCs by creating sockets with
;; TCP_NODELAY.
- #:nodelay #t)))
+ #:nodelay #t
+ #:stricthostkeycheck strict-host-key-check?)))
;; Honor ~/.ssh/config.
(session-parse-config! session)
@@ -149,13 +154,14 @@ (define* (open-ssh-session host #:key user port identity
(authenticate-server* session host-key)
;; Authenticate against ~/.ssh/known_hosts.
- (match (authenticate-server session)
- ('ok #f)
- (reason
- (raise (formatted-message (G_ "failed to authenticate \
+ (when strict-host-key-check?
+ (match (authenticate-server session)
+ ('ok #f)
+ (reason
+ (raise (formatted-message (G_ "failed to authenticate \
server at '~a': ~a")
- (session-get session 'host)
- reason)))))
+ (session-get session 'host)
+ reason))))))
;; Use public key authentication, via the SSH agent if it's available.
(match (userauth-public-key/auto! session)
base-commit: 97fee203a5441f4d3004ccf43ed72fa3b51a7cdc
--
2.48.1
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [bug#75144] [PATCH v3 2/2] machine: Implement 'hetzner-environment-type'.
2025-02-04 19:01 ` [bug#75144] [PATCH v3 1/2] guix: ssh: Add strict-host-key-check? option Roman Scherer
@ 2025-02-04 19:01 ` Roman Scherer
2025-02-09 16:45 ` Ludovic Courtès
0 siblings, 1 reply; 17+ messages in thread
From: Roman Scherer @ 2025-02-04 19:01 UTC (permalink / raw)
To: 75144
Cc: Roman Scherer, Florian Pelz, Julien Lepiller,
Ludovic Courtès, Maxim Cournoyer
* 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 <roman@burningswell.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu machine hetzner)
+ #:use-module (gnu bootloader grub)
+ #:use-module (gnu bootloader)
+ #:use-module (gnu machine hetzner http)
+ #:use-module (gnu machine ssh)
+ #:use-module (gnu machine)
+ #:use-module (gnu packages ssh)
+ #:use-module (gnu services base)
+ #:use-module (gnu services networking)
+ #:use-module (gnu services ssh)
+ #:use-module (gnu services)
+ #:use-module (gnu system file-systems)
+ #:use-module (gnu system image)
+ #:use-module (gnu system linux-initrd)
+ #:use-module (gnu system pam)
+ #:use-module (gnu system)
+ #:use-module (guix base32)
+ #:use-module (guix colors)
+ #:use-module (guix derivations)
+ #:use-module (guix diagnostics)
+ #:use-module (guix gexp)
+ #:use-module (guix i18n)
+ #:use-module (guix import json)
+ #:use-module (guix monads)
+ #:use-module (guix packages)
+ #:use-module (guix pki)
+ #:use-module (guix records)
+ #:use-module (guix ssh)
+ #:use-module (guix store)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 iconv)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 string-fun)
+ #:use-module (ice-9 textual-ports)
+ #:use-module (json)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-2)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (srfi srfi-71)
+ #:use-module (ssh channel)
+ #:use-module (ssh key)
+ #:use-module (ssh popen)
+ #:use-module (ssh session)
+ #:use-module (ssh sftp)
+ #:use-module (ssh shell)
+ #:export (%hetzner-os-arm
+ %hetzner-os-x86
+ deploy-hetzner
+ hetzner-configuration
+ hetzner-configuration-allow-downgrades?
+ hetzner-configuration-api
+ hetzner-configuration-authorize?
+ hetzner-configuration-build-locally?
+ hetzner-configuration-delete?
+ hetzner-configuration-labels
+ hetzner-configuration-location
+ hetzner-configuration-server-type
+ hetzner-configuration-ssh-key
+ hetzner-configuration?
+ hetzner-environment-type))
+
+;;; Commentary:
+;;;
+;;; This module implements a high-level interface for provisioning machines on
+;;; the Hetzner Cloud service https://docs.hetzner.cloud.
+;;;
+
+\f
+;;;
+;;; 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"))))))
+
+\f
+;;;
+;;; Helper functions.
+;;;
+
+(define (escape-backticks str)
+ "Escape all backticks in STR."
+ (string-replace-substring str "`" "\\`"))
+
+
+\f
+;;;
+;;; Hetzner configuration.
+;;;
+
+(define-record-type* <hetzner-configuration> hetzner-configuration
+ make-hetzner-configuration hetzner-configuration? this-hetzner-configuration
+ (allow-downgrades? hetzner-configuration-allow-downgrades? ; boolean
+ (default #f))
+ (api hetzner-configuration-api ; <hetzner-api>
+ (default (hetzner-api)))
+ (authorize? hetzner-configuration-authorize? ; boolean
+ (default #t))
+ (build-locally? hetzner-configuration-build-locally? ; boolean
+ (default #t))
+ (delete? hetzner-configuration-delete? ; boolean
+ (default #f))
+ (labels hetzner-configuration-labels ; list of strings
+ (default '()))
+ (location hetzner-configuration-location ; #f | string
+ (default "fsn1"))
+ (server-type hetzner-configuration-server-type ; string
+ (default "cx42"))
+ (ssh-key hetzner-configuration-ssh-key)) ; string
+
+(define (hetzner-configuration-ssh-key-fingerprint config)
+ "Return the SSH public key fingerprint of CONFIG as a string."
+ (and-let* ((file-name (hetzner-configuration-ssh-key config))
+ (privkey (private-key-from-file file-name))
+ (pubkey (private-key->public-key privkey))
+ (hash (get-public-key-hash pubkey 'md5)))
+ (bytevector->hex-string hash)))
+
+(define (hetzner-configuration-ssh-key-public config)
+ "Return the SSH public key of CONFIG as a string."
+ (and-let* ((ssh-key (hetzner-configuration-ssh-key config))
+ (public-key (public-key-from-file ssh-key)))
+ (format #f "ssh-~a ~a" (get-key-type public-key)
+ (public-key->string public-key))))
+
+\f
+;;;
+;;; Hetzner Machine.
+;;;
+
+(define (hetzner-machine-delegate target server)
+ "Return the delagate machine that uses SSH for deployment."
+ (let* ((config (machine-configuration target))
+ ;; Get the operating system WITHOUT the provenance service to avoid a
+ ;; duplicate symlink conflict in the store.
+ (os ((@@ (gnu machine) %machine-operating-system) target)))
+ (machine
+ (inherit target)
+ (operating-system
+ (if (hetzner-configuration-authorize? config)
+ (operating-system-authorize os)
+ os))
+ (environment managed-host-environment-type)
+ (configuration
+ (machine-ssh-configuration
+ (allow-downgrades? (hetzner-configuration-allow-downgrades? config))
+ (authorize? (hetzner-configuration-authorize? config))
+ (build-locally? (hetzner-configuration-build-locally? config))
+ (host-name (hetzner-server-public-ipv4 server))
+ (identity (hetzner-configuration-ssh-key config))
+ (system (hetzner-server-system server)))))))
+
+(define (hetzner-machine-location machine)
+ "Find the location of MACHINE on the Hetzner API."
+ (let* ((config (machine-configuration machine))
+ (expected (hetzner-configuration-location config)))
+ (find (lambda (location)
+ (equal? expected (hetzner-location-name location)))
+ (hetzner-api-locations
+ (hetzner-configuration-api config)
+ #:params `(("name" . ,expected))))))
+
+(define (hetzner-machine-server-type machine)
+ "Find the server type of MACHINE on the Hetzner API."
+ (let* ((config (machine-configuration machine))
+ (expected (hetzner-configuration-server-type config)))
+ (find (lambda (server-type)
+ (equal? expected (hetzner-server-type-name server-type)))
+ (hetzner-api-server-types
+ (hetzner-configuration-api config)
+ #:params `(("name" . ,expected))))))
+
+(define (hetzner-machine-validate-api-token machine)
+ "Validate the Hetzner API authentication token of MACHINE."
+ (let* ((config (machine-configuration machine))
+ (api (hetzner-configuration-api config)))
+ (unless (hetzner-api-token api)
+ (raise-exception
+ (formatted-message
+ (G_ "Hetzner Cloud access token was not provided. \
+This may be fixed by setting the environment variable GUIX_HETZNER_API_TOKEN \
+to one procured from \
+https://docs.hetzner.com/cloud/api/getting-started/generating-api-token"))))))
+
+(define (hetzner-machine-validate-configuration-type machine)
+ "Raise an error if MACHINE's configuration is not an instance of
+<hetzner-configuration>."
+ (let ((config (machine-configuration machine))
+ (environment (environment-type-name (machine-environment machine))))
+ (unless (and config (hetzner-configuration? config))
+ (raise-exception
+ (formatted-message (G_ "unsupported machine configuration '~a' \
+for environment of type '~a'")
+ config
+ environment)))))
+
+(define (hetzner-machine-validate-server-type machine)
+ "Raise an error if the server type of MACHINE is not supported."
+ (unless (hetzner-machine-server-type machine)
+ (let* ((config (machine-configuration machine))
+ (api (hetzner-configuration-api config)))
+ (raise-exception
+ (formatted-message
+ (G_ "server type '~a' not supported~%~%\
+Available server types:~%~%~a~%~%For more details and prices, see: ~a")
+ (hetzner-configuration-server-type config)
+ (string-join
+ (map (lambda (type)
+ (format #f " - ~a: ~a, ~a ~a cores, ~a GB mem, ~a GB disk"
+ (colorize-string
+ (hetzner-server-type-name type)
+ (color BOLD))
+ (hetzner-server-type-architecture type)
+ (hetzner-server-type-cores type)
+ (hetzner-server-type-cpu-type type)
+ (hetzner-server-type-memory type)
+ (hetzner-server-type-disk type)))
+ (hetzner-api-server-types api))
+ "\n")
+ "https://www.hetzner.com/cloud#pricing")))))
+
+(define (hetzner-machine-validate-location machine)
+ "Raise an error if the location of MACHINE is not supported."
+ (unless (hetzner-machine-location machine)
+ (let* ((config (machine-configuration machine))
+ (api (hetzner-configuration-api config)))
+ (raise-exception
+ (formatted-message
+ (G_ "server location '~a' not supported~%~%\
+Available locations:~%~%~a~%~%For more details, see: ~a")
+ (hetzner-configuration-location config)
+ (string-join
+ (map (lambda (location)
+ (format #f " - ~a: ~a, ~a"
+ (colorize-string
+ (hetzner-location-name location)
+ (color BOLD))
+ (hetzner-location-description location)
+ (hetzner-location-country location)))
+ (hetzner-api-locations api))
+ "\n")
+ "https://www.hetzner.com/cloud#locations")))))
+
+(define (hetzner-machine-validate machine)
+ "Validate the Hetzner MACHINE."
+ (hetzner-machine-validate-configuration-type machine)
+ (hetzner-machine-validate-api-token machine)
+ (hetzner-machine-validate-location machine)
+ (hetzner-machine-validate-server-type machine))
+
+(define (hetzner-machine-bootstrap-os-form machine server)
+ "Return the form to bootstrap an operating system on SERVER."
+ (let* ((os (machine-operating-system machine))
+ (system (hetzner-server-system server))
+ (arm? (equal? "arm" (hetzner-server-architecture server)))
+ (x86? (equal? "x86" (hetzner-server-architecture server)))
+ (root-fs-type (operating-system-root-file-system-type os)))
+ `(operating-system
+ (host-name ,(operating-system-host-name os))
+ (timezone "Etc/UTC")
+ (bootloader (bootloader-configuration
+ (bootloader ,(cond (arm? 'grub-efi-bootloader)
+ (x86? 'grub-bootloader)))
+ (targets ,(cond (arm? '(list "/boot/efi"))
+ (x86? '(list "/dev/sda"))))
+ (terminal-outputs '(console))))
+ (initrd-modules (append
+ ,(cond (arm? '(list "sd_mod" "virtio_scsi"))
+ (x86? '(list "virtio_scsi")))
+ %base-initrd-modules))
+ (file-systems ,(cond
+ (arm? `(cons* (file-system
+ (mount-point "/")
+ (device "/dev/sda1")
+ (type ,root-fs-type))
+ (file-system
+ (mount-point "/boot/efi")
+ (device "/dev/sda15")
+ (type "vfat"))
+ %base-file-systems))
+ (x86? `(cons* (file-system
+ (mount-point "/")
+ (device "/dev/sda1")
+ (type ,root-fs-type))
+ %base-file-systems))))
+ (services
+ (cons* (service dhcp-client-service-type)
+ (service openssh-service-type
+ (openssh-configuration
+ (openssh openssh-sans-x)
+ (permit-root-login 'prohibit-password)))
+ %base-services)))))
+
+(define (rexec-verbose session cmd)
+ "Execute a command CMD on the remote side and print output. Return two
+values: list of output lines returned by CMD and its exit code."
+ (let* ((channel (open-remote-input-pipe session cmd))
+ (result (let loop ((line (read-line channel))
+ (result '()))
+ (if (eof-object? line)
+ (reverse result)
+ (begin
+ (display line)
+ (newline)
+ (loop (read-line channel)
+ (cons line result))))))
+ (exit-status (channel-get-exit-status channel)))
+ (close channel)
+ (values result exit-status)))
+
+(define (hetzner-machine-ssh-key machine)
+ "Find the SSH key for MACHINE on the Hetzner API."
+ (let* ((config (machine-configuration machine))
+ (expected (hetzner-configuration-ssh-key-fingerprint config)))
+ (find (lambda (ssh-key)
+ (equal? expected (hetzner-ssh-key-fingerprint ssh-key)))
+ (hetzner-api-ssh-keys
+ (hetzner-configuration-api config)
+ #:params `(("fingerprint" . ,expected))))))
+
+(define (hetzner-machine-ssh-key-create machine)
+ "Create the SSH key for MACHINE on the Hetzner API."
+ (let ((name (machine-display-name machine)))
+ (format #t "creating ssh key for '~a'...\n" name)
+ (let* ((config (machine-configuration machine))
+ (api (hetzner-configuration-api config))
+ (ssh-key (hetzner-api-ssh-key-create
+ (hetzner-configuration-api config)
+ (hetzner-configuration-ssh-key-fingerprint config)
+ (hetzner-configuration-ssh-key-public config)
+ #:labels (hetzner-configuration-labels config))))
+ (format #t "successfully created ssh key for '~a'\n" name)
+ ssh-key)))
+
+(define (hetzner-machine-server machine)
+ "Find the Hetzner server for MACHINE."
+ (let ((config (machine-configuration machine)))
+ (find (lambda (server)
+ (equal? (machine-display-name machine)
+ (hetzner-server-name server)))
+ (hetzner-api-servers
+ (hetzner-configuration-api config)
+ #:params `(("name" . ,(machine-display-name machine)))))))
+
+(define (hetzner-machine-create-server machine)
+ "Create the Hetzner server for MACHINE."
+ (let* ((config (machine-configuration machine))
+ (name (machine-display-name machine))
+ (server-type (hetzner-configuration-server-type config)))
+ (format #t "creating '~a' server for '~a'...\n" server-type name)
+ (let* ((ssh-key (hetzner-machine-ssh-key machine))
+ (api (hetzner-configuration-api config))
+ (server (hetzner-api-server-create
+ api
+ (machine-display-name machine)
+ (list ssh-key)
+ #:labels (hetzner-configuration-labels config)
+ #:location (hetzner-configuration-location config)
+ #:server-type (hetzner-configuration-server-type config)))
+ (architecture (hetzner-server-architecture server)))
+ (format #t "successfully created '~a' ~a server for '~a'\n"
+ server-type architecture name)
+ server)))
+
+(define (wait-for-ssh address ssh-key)
+ "Block until a SSH session can be made as 'root' with SSH-KEY at ADDRESS."
+ (format #t "connecting via SSH to '~a' using '~a'...\n" address ssh-key)
+ (let loop ()
+ (catch #t
+ (lambda ()
+ (open-ssh-session address #:user "root" #:identity ssh-key
+ #:strict-host-key-check? #f))
+ (lambda args
+ (let ((msg (cadr args)))
+ (if (formatted-message? msg)
+ (format #t "~a\n"
+ (string-trim-right
+ (apply format #f
+ (formatted-message-string msg)
+ (formatted-message-arguments msg))
+ #\newline))
+ (format #t "~a" args))
+ (sleep 5)
+ (loop))))))
+
+(define (hetzner-machine-wait-for-ssh machine server)
+ "Wait for SSH connection to be established with the specified machine."
+ (wait-for-ssh (hetzner-server-public-ipv4 server)
+ (hetzner-configuration-ssh-key
+ (machine-configuration machine))))
+
+(define (hetzner-machine-authenticate-host machine server)
+ "Add the host key of MACHINE to the list of known hosts."
+ (let ((ssh-session (hetzner-machine-wait-for-ssh machine server)))
+ (write-known-host! ssh-session)))
+
+(define (hetzner-machine-enable-rescue-system machine server)
+ "Enable the rescue system on the Hetzner SERVER for MACHINE."
+ (let* ((name (machine-display-name machine))
+ (config (machine-configuration machine))
+ (api (hetzner-configuration-api config))
+ (ssh-keys (list (hetzner-machine-ssh-key machine))))
+ (format #t "enabling rescue system on '~a'...\n" name)
+ (let ((action (hetzner-api-server-enable-rescue-system api server ssh-keys)))
+ (format #t "successfully enabled rescue system on '~a'\n" name)
+ action)))
+
+(define (hetzner-machine-power-on machine server)
+ "Power on the Hetzner SERVER for MACHINE."
+ (let* ((name (machine-display-name machine))
+ (config (machine-configuration machine))
+ (api (hetzner-configuration-api config)))
+ (format #t "powering on server for '~a'...\n" name)
+ (let ((action (hetzner-api-server-power-on api server)))
+ (format #t "successfully powered on server for '~a'\n" name)
+ action)))
+
+(define (hetzner-machine-ssh-run-script ssh-session name content)
+ (let ((sftp-session (make-sftp-session ssh-session)))
+ (rexec ssh-session (format #f "rm -f ~a" name))
+ (rexec ssh-session (format #f "mkdir -p ~a" (dirname name)))
+ (call-with-remote-output-file
+ sftp-session name
+ (lambda (port)
+ (display content port)))
+ (sftp-chmod sftp-session name 755)
+ (let ((lines exit-code (rexec-verbose ssh-session
+ (format #f "~a 2>&1" name))))
+ (if (zero? exit-code)
+ lines
+ (raise-exception
+ (formatted-message
+ (G_ "failed to run script '~a' on machine, exit code: '~a'")
+ name exit-code))))))
+
+;; Prevent compiler from inlining this function, so we can mock it in tests.
+(set! hetzner-machine-ssh-run-script hetzner-machine-ssh-run-script)
+
+(define (hetzner-machine-rescue-install-os machine ssh-session server)
+ (let ((name (machine-display-name machine))
+ (os (hetzner-machine-bootstrap-os-form machine server)))
+ (format #t "installing guix operating system on '~a'...\n" name)
+ (hetzner-machine-ssh-run-script
+ ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-install-os"
+ (format #f "#!/usr/bin/env bash
+set -eo pipefail
+mount /dev/sda1 /mnt
+mkdir -p /mnt/boot/efi
+mount /dev/sda15 /mnt/boot/efi
+
+mkdir --parents /mnt/root/.ssh
+chmod 700 /mnt/root/.ssh
+cp /root/.ssh/authorized_keys /mnt/root/.ssh/authorized_keys
+chmod 600 /mnt/root/.ssh/authorized_keys
+
+cat > /tmp/guix/deploy/hetzner-os.scm << EOF
+(use-modules (gnu) (guix utils))
+(use-package-modules ssh)
+(use-service-modules base networking ssh)
+(use-system-modules linux-initrd)
+~a
+EOF
+guix system init --verbosity=2 /tmp/guix/deploy/hetzner-os.scm /mnt"
+ (escape-backticks (format #f "~y" os))))
+ (format #t "successfully installed guix operating system on '~a'\n" name)))
+
+(define (hetzner-machine-reboot machine server)
+ "Reboot the Hetzner SERVER for MACHINE."
+ (let* ((name (machine-display-name machine))
+ (config (machine-configuration machine))
+ (api (hetzner-configuration-api config)))
+ (format #t "rebooting server for '~a'...\n" name)
+ (let ((action (hetzner-api-server-reboot api server)))
+ (format #t "successfully rebooted server for '~a'\n" name)
+ action)))
+
+(define (hetzner-machine-rescue-partition machine ssh-session)
+ "Setup the partitions of the Hetzner server for MACHINE using SSH-SESSION."
+ (let* ((name (machine-display-name machine))
+ (os (machine-operating-system machine))
+ (root-fs-type (operating-system-root-file-system-type os)))
+ (format #t "setting up partitions on '~a'...\n" name)
+ (hetzner-machine-ssh-run-script
+ ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-partition"
+ (format #f "#!/usr/bin/env bash
+set -eo pipefail
+growpart /dev/sda 1 || true
+~a
+fdisk -l /dev/sda"
+ (cond
+ ((equal? "btrfs" root-fs-type)
+ (format #f "mkfs.btrfs -L ~a -f /dev/sda1" root-label))
+ ((equal? "ext4" root-fs-type)
+ (format #f "mkfs.ext4 -L ~a -F /dev/sda1" root-label))
+ (else (raise-exception
+ (formatted-message
+ (G_ "unsupported root file system type '~a'")
+ root-fs-type))))))
+ (format #t "successfully setup partitions on '~a'\n" name)))
+
+(define (hetzner-machine-rescue-install-packages machine ssh-session)
+ "Install packages on the Hetzner server for MACHINE using SSH-SESSION."
+ (let ((name (machine-display-name machine)))
+ (format #t "installing rescue system packages on '~a'...\n" name)
+ (hetzner-machine-ssh-run-script
+ ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-install-packages"
+ (format #f "#!/usr/bin/env bash
+set -eo pipefail
+apt-get update
+apt-get install guix cloud-initramfs-growroot --assume-yes"))
+ (format #t "successfully installed rescue system packages on '~a'\n" name)))
+
+(define (hetzner-machine-delete machine server)
+ "Delete the Hetzner server for MACHINE."
+ (let* ((name (machine-display-name machine))
+ (config (machine-configuration machine))
+ (api (hetzner-configuration-api config)))
+ (format #t "deleting server for '~a'...\n" name)
+ (let ((action (hetzner-api-server-delete api server)))
+ (format #t "successfully deleted server for '~a'\n" name)
+ action)))
+
+(define (hetzner-machine-provision machine)
+ "Provision a server for MACHINE on the Hetzner Cloud service."
+ (with-exception-handler
+ (lambda (exception)
+ (let ((config (machine-configuration machine))
+ (server (hetzner-machine-server machine)))
+ (when (and server (hetzner-configuration-delete? config))
+ (hetzner-machine-delete machine server))
+ (raise-exception exception)))
+ (lambda ()
+ (let ((server (hetzner-machine-create-server machine)))
+ (hetzner-machine-enable-rescue-system machine server)
+ (hetzner-machine-power-on machine server)
+ (let ((ssh-session (hetzner-machine-wait-for-ssh machine server)))
+ (hetzner-machine-rescue-install-packages machine ssh-session)
+ (hetzner-machine-rescue-partition machine ssh-session)
+ (hetzner-machine-rescue-install-os machine ssh-session server)
+ (hetzner-machine-reboot machine server)
+ (sleep 5)
+ (hetzner-machine-authenticate-host machine server)
+ server)))
+ #:unwind? #t))
+
+(define (machine-not-provisioned machine)
+ (formatted-message
+ (G_ "no server provisioned for machine '~a' on the Hetzner Cloud service")
+ (machine-display-name machine)))
+
+\f
+;;;
+;;; 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)))
+
+
+\f
+;;;
+;;; 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))))
+
+
+\f
+;;;
+;;; 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))))
+
+
+\f
+;;;
+;;; 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 <roman@burningswell.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu machine hetzner http)
+ #:use-module (guix diagnostics)
+ #:use-module (guix i18n)
+ #:use-module (guix records)
+ #:use-module (ice-9 iconv)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 pretty-print)
+ #:use-module (ice-9 textual-ports)
+ #:use-module (json)
+ #:use-module (rnrs bytevectors)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-2)
+ #:use-module (ssh key)
+ #:use-module (web client)
+ #:use-module (web request)
+ #:use-module (web response)
+ #:use-module (web uri)
+ #:export (%hetzner-default-api-token
+ %hetzner-default-server-image
+ %hetzner-default-server-location
+ %hetzner-default-server-type
+ hetzner-action
+ hetzner-action-command
+ hetzner-action-error
+ hetzner-action-finished
+ hetzner-action-id
+ hetzner-action-progress
+ hetzner-action-resources
+ hetzner-action-started
+ hetzner-action-status
+ hetzner-action?
+ hetzner-api
+ hetzner-api-action-wait
+ hetzner-api-actions
+ hetzner-api-create-ssh-key
+ hetzner-api-locations
+ hetzner-api-request-body
+ hetzner-api-request-headers
+ hetzner-api-request-method
+ hetzner-api-request-params
+ hetzner-api-request-send
+ hetzner-api-request-url
+ hetzner-api-request?
+ hetzner-api-response
+ hetzner-api-response-body
+ hetzner-api-response-headers
+ hetzner-api-response-status
+ hetzner-api-response?
+ hetzner-api-server-create
+ hetzner-api-server-delete
+ hetzner-api-server-enable-rescue-system
+ hetzner-api-server-power-off
+ hetzner-api-server-power-on
+ hetzner-api-server-reboot
+ hetzner-api-server-types
+ hetzner-api-servers
+ hetzner-api-ssh-key-create
+ hetzner-api-ssh-key-delete
+ hetzner-api-ssh-keys
+ hetzner-api-token
+ hetzner-api?
+ hetzner-error-code
+ hetzner-error-message
+ hetzner-error?
+ hetzner-ipv4-blocked?
+ hetzner-ipv4-dns-ptr
+ hetzner-ipv4-id
+ hetzner-ipv4-ip
+ hetzner-ipv4?
+ hetzner-ipv6-blocked?
+ hetzner-ipv6-dns-ptr
+ hetzner-ipv6-id
+ hetzner-ipv6-ip
+ hetzner-ipv6?
+ hetzner-location
+ hetzner-location-city
+ hetzner-location-country
+ hetzner-location-description
+ hetzner-location-id
+ hetzner-location-latitude
+ hetzner-location-longitude
+ hetzner-location-name
+ hetzner-location-network-zone
+ hetzner-location?
+ hetzner-public-net
+ hetzner-public-net-ipv4
+ hetzner-public-net-ipv6
+ hetzner-resource
+ hetzner-resource-id
+ hetzner-resource-type
+ hetzner-resource?
+ hetzner-server-architecture
+ hetzner-server-created
+ hetzner-server-id
+ hetzner-server-labels
+ hetzner-server-name
+ hetzner-server-public-ipv4
+ hetzner-server-public-net
+ hetzner-server-rescue-enabled?
+ hetzner-server-system
+ hetzner-server-type
+ hetzner-server-type-architecture
+ hetzner-server-type-cores
+ hetzner-server-type-cpu-type
+ hetzner-server-type-deprecated
+ hetzner-server-type-deprecation
+ hetzner-server-type-description
+ hetzner-server-type-disk
+ hetzner-server-type-id
+ hetzner-server-type-memory
+ hetzner-server-type-name
+ hetzner-server-type-storage-type
+ hetzner-server-type?
+ hetzner-server?
+ hetzner-ssh-key-created
+ hetzner-ssh-key-fingerprint
+ hetzner-ssh-key-id
+ hetzner-ssh-key-labels
+ hetzner-ssh-key-name
+ hetzner-ssh-key-public-key
+ hetzner-ssh-key-read-file
+ hetzner-ssh-key?
+ make-hetzner-action
+ make-hetzner-error
+ make-hetzner-ipv4
+ make-hetzner-ipv6
+ make-hetzner-location
+ make-hetzner-public-net
+ make-hetzner-resource
+ make-hetzner-server
+ make-hetzner-server-type
+ make-hetzner-ssh-key))
+
+;;; Commentary:
+;;;
+;;; This module implements a lower-level interface for interacting with the
+;;; Hetzner Cloud API https://docs.hetzner.cloud.
+;;;
+
+(define %hetzner-default-api-token
+ (make-parameter (getenv "GUIX_HETZNER_API_TOKEN")))
+
+;; Ideally this would be a Guix image. Maybe one day.
+(define %hetzner-default-server-image "debian-11")
+
+;; Falkenstein, Germany
+(define %hetzner-default-server-location "fsn1")
+
+;; x86, 8 VCPUs, 16 GB mem, 160 GB disk
+(define %hetzner-default-server-type "cx42")
+
+\f
+;;;
+;;; 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)))
+
+\f
+;;;
+;;; Domain models.
+;;;
+
+(define-json-mapping <hetzner-action>
+ make-hetzner-action hetzner-action? json->hetzner-action
+ (command hetzner-action-command) ; string
+ (error hetzner-action-error "error"
+ json->maybe-hetzner-error) ; <hetzner-error> | #f
+ (finished hetzner-action-finished "finished" string->time) ; time
+ (id hetzner-action-id) ; integer
+ (progress hetzner-action-progress) ; integer
+ (resources hetzner-action-resources "resources"
+ json->hetzner-resources) ; list of <hetzner-resource>
+ (started hetzner-action-started "started" string->time) ; time
+ (status hetzner-action-status))
+
+(define-json-mapping <hetzner-deprecation>
+ make-hetzner-deprecation hetzner-deprecation? json->hetzner-deprecation
+ (announced hetzner-deprecation-announced) ; string
+ (unavailable-after hetzner-deprecation-unavailable-after
+ "unavailable_after")) ; string
+
+(define-json-mapping <hetzner-dns>
+ make-hetzner-dns hetzner-dns? json->hetzner-dns
+ (ip hetzner-dns-ip) ; string
+ (ptr hetzner-dns-ptr "dns_ptr")) ; string
+
+(define-json-mapping <hetzner-error>
+ make-hetzner-error hetzner-error? json->hetzner-error
+ (code hetzner-error-code) ; string
+ (message hetzner-error-message)) ; <string>
+
+(define-json-mapping <hetzner-ipv4>
+ make-hetzner-ipv4 hetzner-ipv4? json->hetzner-ipv4
+ (blocked? hetzner-ipv4-blocked? "blocked") ; boolean
+ (dns-ptr hetzner-ipv4-dns-ptr "dns_ptr") ; string
+ (id hetzner-ipv4-id) ; integer
+ (ip hetzner-ipv4-ip)) ; string
+
+(define-json-mapping <hetzner-ipv6>
+ make-hetzner-ipv6 hetzner-ipv6? json->hetzner-ipv6
+ (blocked? hetzner-ipv6-blocked? "blocked") ; boolean
+ (dns-ptr hetzner-ipv6-dns-ptr "dns_ptr"
+ json->hetzner-dnses) ; list of <hetzner-dns>
+ (id hetzner-ipv6-id) ; integer
+ (ip hetzner-ipv6-ip)) ; string
+
+(define-json-mapping <hetzner-location>
+ make-hetzner-location hetzner-location? json->hetzner-location
+ (city hetzner-location-city) ; string
+ (country hetzner-location-country) ; string
+ (description hetzner-location-description) ; string
+ (id hetzner-location-id) ; integer
+ (latitude hetzner-location-latitude) ; decimal
+ (longitude hetzner-location-longitude) ; decimal
+ (name hetzner-location-name) ; string
+ (network-zone hetzner-location-network-zone "network_zone"))
+
+(define-json-mapping <hetzner-public-net>
+ make-hetzner-public-net hetzner-public-net? json->hetzner-public-net
+ (ipv4 hetzner-public-net-ipv4 "ipv4" json->hetzner-ipv4) ; <hetzner-ipv4>
+ (ipv6 hetzner-public-net-ipv6 "ipv6" json->hetzner-ipv6)) ; <hetzner-ipv6>
+
+(define-json-mapping <hetzner-resource>
+ make-hetzner-resource hetzner-resource? json->hetzner-resource
+ (id hetzner-resource-id) ; integer
+ (type hetzner-resource-type)) ; string
+
+(define-json-mapping <hetzner-server>
+ make-hetzner-server hetzner-server? json->hetzner-server
+ (created hetzner-server-created) ; time
+ (id hetzner-server-id) ; integer
+ (labels hetzner-server-labels) ; alist of string/string
+ (name hetzner-server-name) ; string
+ (public-net hetzner-server-public-net "public_net"
+ json->hetzner-public-net) ; <hetzner-public-net>
+ (rescue-enabled? hetzner-server-rescue-enabled? "rescue_enabled") ; boolean
+ (server-type hetzner-server-type "server_type"
+ json->hetzner-server-type)) ; <hetzner-server-type>
+
+(define-json-mapping <hetzner-server-type>
+ make-hetzner-server-type hetzner-server-type? json->hetzner-server-type
+ (architecture hetzner-server-type-architecture) ; string
+ (cores hetzner-server-type-cores) ; integer
+ (cpu-type hetzner-server-type-cpu-type "cpu_type") ; string
+ (deprecated hetzner-server-type-deprecated) ; boolean
+ (deprecation hetzner-server-type-deprecation
+ json->hetzner-deprecation) ; <hetzner-deprecation>
+ (description hetzner-server-type-description) ; string
+ (disk hetzner-server-type-disk) ; integer
+ (id hetzner-server-type-id) ; integer
+ (memory hetzner-server-type-memory) ; integer
+ (name hetzner-server-type-name) ; string
+ (storage-type hetzner-server-type-storage-type "storage_type")) ; string
+
+(define-json-mapping <hetzner-ssh-key>
+ make-hetzner-ssh-key hetzner-ssh-key? json->hetzner-ssh-key
+ (created hetzner-ssh-key-created "created" string->time) ; time
+ (fingerprint hetzner-ssh-key-fingerprint) ; string
+ (id hetzner-ssh-key-id) ; integer
+ (labels hetzner-ssh-key-labels) ; alist of string/string
+ (name hetzner-ssh-key-name) ; string
+ (public_key hetzner-ssh-key-public-key "public_key")) ; string
+
+(define (hetzner-server-architecture server)
+ "Return the architecture of the Hetzner SERVER."
+ (hetzner-server-type-architecture (hetzner-server-type server)))
+
+(define* (hetzner-server-path server #:optional (path ""))
+ "Return the PATH of the Hetzner SERVER."
+ (format #f "/servers/~a~a" (hetzner-server-id server) path))
+
+(define (hetzner-server-public-ipv4 server)
+ "Return the public IPv4 address of the SERVER."
+ (and-let* ((public-net (hetzner-server-public-net server))
+ (ipv4 (hetzner-public-net-ipv4 public-net)))
+ (hetzner-ipv4-ip ipv4)))
+
+(define (hetzner-server-system server)
+ "Return the Guix system architecture of the Hetzner SERVER."
+ (match (hetzner-server-architecture server)
+ ("arm" "aarch64-linux")
+ ("x86" "x86_64-linux")))
+
+(define* (hetzner-ssh-key-path ssh-key #:optional (path ""))
+ "Return the PATH of the Hetzner SSH-KEY."
+ (format #f "/ssh_keys/~a~a" (hetzner-ssh-key-id ssh-key) path))
+
+(define (hetzner-ssh-key-read-file file)
+ "Read the SSH private key from FILE and return a Hetzner SSH key."
+ (let* ((privkey (private-key-from-file file))
+ (pubkey (private-key->public-key privkey))
+ (hash (get-public-key-hash pubkey 'md5))
+ (fingerprint (bytevector->hex-string hash))
+ (public-key (format #f "ssh-~a ~a" (get-key-type pubkey)
+ (public-key->string pubkey))))
+ (make-hetzner-ssh-key #f fingerprint #f '() (basename file) public-key)))
+
+\f
+;;;
+;;; Hetzner API response.
+;;;
+
+(define-record-type* <hetzner-api-response>
+ hetzner-api-response make-hetzner-api-response hetzner-api-response?
+ (body hetzner-api-response-body (default *unspecified*))
+ (headers hetzner-api-response-headers (default '()))
+ (status hetzner-api-response-status (default 200)))
+
+(define (hetzner-api-response-meta response)
+ "Return the meta information of the Hetzner API response."
+ (assoc-ref (hetzner-api-response-body response) "meta"))
+
+(define (hetzner-api-response-pagination response)
+ "Return the meta information of the Hetzner API response."
+ (assoc-ref (hetzner-api-response-meta response) "pagination"))
+
+(define (hetzner-api-response-pagination-combine resource responses)
+ "Combine multiple Hetzner API pagination responses into a single response."
+ (if (positive? (length responses))
+ (let* ((response (car responses))
+ (pagination (hetzner-api-response-pagination response))
+ (total-entries (assoc-ref pagination "total_entries")))
+ (hetzner-api-response
+ (inherit response)
+ (body `(("meta"
+ ("pagination"
+ ("last_page" . 1)
+ ("next_page" . null)
+ ("page" . 1)
+ ("per_page" . ,total-entries)
+ ("previous_page" . null)
+ ("total_entries" . ,total-entries)))
+ (,resource . ,(append-map
+ (lambda (body)
+ (vector->list (assoc-ref body resource)))
+ (map hetzner-api-response-body responses)))))))
+ (raise-exception
+ (formatted-message
+ (G_ "expected a list of Hetzner API responses")))))
+
+(define (hetzner-api-body-action body)
+ "Return the Hetzner API action from BODY."
+ (let ((json (assoc-ref body "action")))
+ (and json (json->hetzner-action json))))
+
+(define (hetzner-api-response-read port)
+ "Read the Hetzner API response from PORT."
+ (let* ((response (read-response port))
+ (body (read-response-body response)))
+ (hetzner-api-response
+ (body (and body (json-string->scm (utf8->string body))))
+ (headers (response-headers response))
+ (status (response-code response)))))
+
+(define (hetzner-api-response-validate-status response expected)
+ "Raise an error if the HTTP status code of RESPONSE is not in EXPECTED."
+ (when (not (member (hetzner-api-response-status response) expected))
+ (raise-exception
+ (formatted-message
+ (G_ "unexpected HTTP status code: ~a, expected: ~a~%~a")
+ (hetzner-api-response-status response)
+ expected
+ (with-output-to-string
+ (lambda ()
+ (pretty-print (hetzner-api-response-body response))))))))
+
+\f
+;;;
+;;; Hetzner API request.
+;;;
+
+(define-record-type* <hetzner-api-request>
+ hetzner-api-request make-hetzner-api-request hetzner-api-request?
+ (body hetzner-api-request-body (default *unspecified*))
+ (headers hetzner-api-request-headers (default '()))
+ (method hetzner-api-request-method (default 'GET))
+ (params hetzner-api-request-params (default '()))
+ (url hetzner-api-request-url))
+
+(define (hetzner-api-request-uri request)
+ "Return the URI object of the Hetzner API request."
+ (let ((params (hetzner-api-request-params request)))
+ (string->uri (string-append (hetzner-api-request-url request)
+ (format-query-params params)))))
+
+(define (hetzner-api-request-body-bytevector request)
+ "Return the body of the Hetzner API REQUEST as a bytevector."
+ (let ((body (hetzner-api-request-body request)))
+ (string->utf8 (if (unspecified? body) "" (scm->json-string body)))))
+
+(define (hetzner-api-request-write port request)
+ "Write the Hetzner API REQUEST to PORT."
+ (let* ((body (hetzner-api-request-body-bytevector request))
+ (request (build-request
+ (hetzner-api-request-uri request)
+ #:method (hetzner-api-request-method request)
+ #:version '(1 . 1)
+ #:headers (cons* `(Content-Length
+ . ,(number->string
+ (if (unspecified? body)
+ 0 (bytevector-length body))))
+ (hetzner-api-request-headers request))
+ #:port port))
+ (request (write-request request port)))
+ (unless (unspecified? body)
+ (write-request-body request body))
+ (force-output (request-port request))))
+
+(define* (hetzner-api-request-send request #:key (expected (list 200 201 204)))
+ "Send the Hetzner API REQUEST via HTTP."
+ (let ((port (open-socket-for-uri (hetzner-api-request-uri request))))
+ (hetzner-api-request-write port request)
+ (let ((response (hetzner-api-response-read port)))
+ (close-port port)
+ (hetzner-api-response-validate-status response expected)
+ response)))
+
+;; Prevent compiler from inlining this function, so we can mock it in tests.
+(set! hetzner-api-request-send hetzner-api-request-send)
+
+(define (hetzner-api-request-next-params request)
+ "Return the pagination params for the next page of the REQUEST."
+ (let* ((params (hetzner-api-request-params request))
+ (page (or (assoc-ref params "page") 1)))
+ (map (lambda (param)
+ (if (equal? "page" (car param))
+ (cons (car param) (+ page 1))
+ param))
+ params)))
+
+(define (hetzner-api-request-paginate request)
+ "Fetch all pages of the REQUEST via pagination and return all responses."
+ (let* ((response (hetzner-api-request-send request))
+ (pagination (hetzner-api-response-pagination response))
+ (next-page (assoc-ref pagination "next_page")))
+ (if (number? next-page)
+ (cons response
+ (hetzner-api-request-paginate
+ (hetzner-api-request
+ (inherit request)
+ (params (hetzner-api-request-next-params request)))))
+ (list response))))
+
+
+\f
+;;;
+;;; Hetzner API.
+;;;
+
+(define-record-type* <hetzner-api>
+ hetzner-api make-hetzner-api hetzner-api?
+ (base-url hetzner-api-base-url ; string
+ (default "https://api.hetzner.cloud/v1"))
+ (token hetzner-api-token ; string
+ (default (%hetzner-default-api-token))))
+
+(define (hetzner-api-authorization-header api)
+ "Return the authorization header for the Hetzner API."
+ (format #f "Bearer ~a" (hetzner-api-token api)))
+
+(define (hetzner-api-default-headers api)
+ "Returns the default headers of the Hetzner API."
+ `((user-agent . "Guix Deploy")
+ (Accept . "application/json")
+ (Authorization . ,(hetzner-api-authorization-header api))
+ (Content-Type . "application/json")))
+
+(define (hetzner-api-url api path)
+ "Append PATH to the base url of the Hetzner API."
+ (string-append (hetzner-api-base-url api) path))
+
+(define (hetzner-api-delete api path)
+ "Delelte the resource at PATH with the Hetzner API."
+ (hetzner-api-response-body
+ (hetzner-api-request-send
+ (hetzner-api-request
+ (headers (hetzner-api-default-headers api))
+ (method 'DELETE)
+ (url (hetzner-api-url api path))))))
+
+(define* (hetzner-api-list api path resources json->object #:key (params '()))
+ "Fetch all objects of RESOURCE from the Hetzner API."
+ (let ((body (hetzner-api-response-body
+ (hetzner-api-response-pagination-combine
+ resources (hetzner-api-request-paginate
+ (hetzner-api-request
+ (url (hetzner-api-url api path))
+ (headers (hetzner-api-default-headers api))
+ (params (cons '("page" . 1) params))))))))
+ (map json->object (assoc-ref body resources))))
+
+(define* (hetzner-api-post api path #:key (body *unspecified*))
+ "Send a POST request to the Hetzner API at PATH using BODY."
+ (hetzner-api-response-body
+ (hetzner-api-request-send
+ (hetzner-api-request
+ (body body)
+ (method 'POST)
+ (url (hetzner-api-url api path))
+ (headers (hetzner-api-default-headers api))))))
+
+(define (hetzner-api-actions api ids)
+ "Get actions from the Hetzner API."
+ (if (zero? (length ids))
+ (raise-exception
+ (formatted-message
+ (G_ "expected at least one action id, but got '~a'")
+ (length ids)))
+ (hetzner-api-list
+ api "/actions" "actions" json->hetzner-action
+ #:params `(("id" . ,(string-join (map number->string ids) ","))))))
+
+(define* (hetzner-api-action-wait api action #:optional (status "success"))
+ "Wait until the ACTION has reached STATUS on the Hetzner API."
+ (let ((id (hetzner-action-id action)))
+ (let loop ()
+ (let ((actions (hetzner-api-actions api (list id))))
+ (cond
+ ((zero? (length actions))
+ (raise-exception
+ (formatted-message (G_ "server action '~a' not found") id)))
+ ((not (= 1 (length actions)))
+ (raise-exception
+ (formatted-message
+ (G_ "expected one server action, but got '~a'")
+ (length actions))))
+ ((string= status (hetzner-action-status (car actions)))
+ (car actions))
+ (else
+ (sleep 5)
+ (loop)))))))
+
+(define* (hetzner-api-locations api . options)
+ "Get deployment locations from the Hetzner API."
+ (apply hetzner-api-list api "/locations" "locations" json->hetzner-location options))
+
+(define* (hetzner-api-server-create
+ api name ssh-keys
+ #:key
+ (enable-ipv4? #t)
+ (enable-ipv6? #t)
+ (image %hetzner-default-server-image)
+ (labels '())
+ (location %hetzner-default-server-location)
+ (public-net #f)
+ (server-type %hetzner-default-server-type)
+ (start-after-create? #f))
+ "Create a server with the Hetzner API."
+ (let ((body (hetzner-api-post
+ api "/servers"
+ #:body `(("image" . ,image)
+ ("labels" . ,labels)
+ ("name" . ,name)
+ ("public_net"
+ . (("enable_ipv4" . ,enable-ipv4?)
+ ("enable_ipv6" . ,enable-ipv6?)))
+ ("location" . ,location)
+ ("server_type" . ,server-type)
+ ("ssh_keys" . ,(apply vector (map hetzner-ssh-key-id ssh-keys)))
+ ("start_after_create" . ,start-after-create?)))))
+ (hetzner-api-action-wait api (hetzner-api-body-action body))
+ (json->hetzner-server (assoc-ref body "server"))))
+
+(define (hetzner-api-server-delete api server)
+ "Delete the SERVER with the Hetzner API."
+ (let ((body (hetzner-api-delete api (hetzner-server-path server))))
+ (hetzner-api-action-wait api (hetzner-api-body-action body))))
+
+(define* (hetzner-api-server-enable-rescue-system
+ api server ssh-keys #:key (type "linux64"))
+ "Enable the rescue system for SERVER with the Hetzner API."
+ (let* ((ssh-keys (apply vector (map hetzner-ssh-key-id ssh-keys)))
+ (body (hetzner-api-post
+ api (hetzner-server-path server "/actions/enable_rescue")
+ #:body `(("ssh_keys" . ,ssh-keys)
+ ("type" . ,type)))))
+ (hetzner-api-action-wait api (hetzner-api-body-action body))))
+
+(define* (hetzner-api-servers api . options)
+ "Get servers from the Hetzner API."
+ (apply hetzner-api-list api "/servers" "servers" json->hetzner-server options))
+
+(define (hetzner-api-server-power-on api server)
+ "Send a power on request for SERVER to the Hetzner API."
+ (let ((body (hetzner-api-post api (hetzner-server-path server "/actions/poweron"))))
+ (hetzner-api-action-wait api (hetzner-api-body-action body))))
+
+(define (hetzner-api-server-power-off api server)
+ "Send a power off request for SERVER to the Hetzner API."
+ (let ((body (hetzner-api-post api (hetzner-server-path server "/actions/poweroff"))))
+ (hetzner-api-action-wait api (hetzner-api-body-action body))))
+
+(define (hetzner-api-server-reboot api server)
+ "Send a reboot request for SERVER to the Hetzner API."
+ (let ((body (hetzner-api-post api (hetzner-server-path server "/actions/reboot"))))
+ (hetzner-api-action-wait api (hetzner-api-body-action body))))
+
+(define* (hetzner-api-ssh-key-create api name public-key #:key (labels '()))
+ "Create a SSH key with the Hetzner API."
+ (let ((body (hetzner-api-post
+ api "/ssh_keys"
+ #:body `(("name" . ,name)
+ ("public_key" . ,public-key)
+ ("labels" . ,labels)))))
+ (json->hetzner-ssh-key (assoc-ref body "ssh_key"))))
+
+(define (hetzner-api-ssh-key-delete api ssh-key)
+ "Delete the SSH key on the Hetzner API."
+ (hetzner-api-delete api (hetzner-ssh-key-path ssh-key))
+ #t)
+
+(define* (hetzner-api-ssh-keys api . options)
+ "Get SSH keys from the Hetzner API."
+ (apply hetzner-api-list api "/ssh_keys" "ssh_keys"
+ json->hetzner-ssh-key options))
+
+(define* (hetzner-api-server-types api . options)
+ "Get server types from the Hetzner API."
+ (apply hetzner-api-list api "/server_types" "server_types"
+ json->hetzner-server-type options))
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 <roman@burningswell.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (tests machine hetzner)
+ #:use-module (gnu machine hetzner http)
+ #:use-module (gnu machine hetzner)
+ #:use-module (gnu machine ssh)
+ #:use-module (gnu machine)
+ #:use-module (gnu system)
+ #:use-module (guix build utils)
+ #:use-module (guix records)
+ #:use-module (guix ssh)
+ #:use-module (guix tests)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-64)
+ #:use-module (ssh key)
+ #:use-module (ssh session))
+
+;;; Unit and integration tests for the (gnu machine hetzner) module.
+
+;; Integration tests require the GUIX_HETZNER_API_TOKEN environment variable.
+;; https://docs.hetzner.com/cloud/api/getting-started/generating-api-token
+
+;; The integration tests sometimes fail due to the Hetzner API not being able
+;; to allocate a resource. Switching to a different location might help.
+
+(define %labels
+ '(("guix.gnu.org/test" . "true")))
+
+(define %ssh-key-name
+ "guix-hetzner-machine-test-key")
+
+(define %ssh-key-file
+ (string-append "/tmp/" %ssh-key-name))
+
+(unless (file-exists? %ssh-key-file)
+ (private-key-to-file (make-keypair 'rsa 2048) %ssh-key-file))
+
+(define %when-no-token
+ (if (hetzner-api-token (hetzner-api)) 0 1))
+
+(define %arm-machine
+ (machine
+ (operating-system
+ (operating-system
+ (inherit %hetzner-os-arm)
+ (host-name "guix-deploy-hetzner-test-arm")))
+ (environment hetzner-environment-type)
+ (configuration (hetzner-configuration
+ (labels %labels)
+ (server-type "cax41")
+ (ssh-key %ssh-key-file)))))
+
+(define %x86-machine
+ (machine
+ (operating-system
+ (operating-system
+ (inherit %hetzner-os-x86)
+ (host-name "guix-deploy-hetzner-test-x86")))
+ (environment hetzner-environment-type)
+ (configuration (hetzner-configuration
+ (labels %labels)
+ (server-type "cpx51")
+ (ssh-key %ssh-key-file)))))
+
+(define (cleanup machine)
+ (let* ((config (machine-configuration machine))
+ (api (hetzner-configuration-api config)))
+ (for-each (lambda (server)
+ (hetzner-api-server-delete api server))
+ (hetzner-api-servers
+ api #:params `(("label_selector" . "guix.gnu.org/test=true"))))
+ (for-each (lambda (ssh-key)
+ (hetzner-api-ssh-key-delete api ssh-key))
+ (hetzner-api-ssh-keys
+ api #:params `(("label_selector" . "guix.gnu.org/test=true"))))
+ machine))
+
+(define-syntax-rule (with-cleanup (machine-sym machine-init) body ...)
+ (let ((machine-sym (cleanup machine-init)))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ body ...)
+ (lambda ()
+ (cleanup machine-sym)))))
+
+(define (mock-action command)
+ (make-hetzner-action
+ command #f
+ (localtime (current-time))
+ 1
+ 100
+ '()
+ (localtime (current-time))
+ "success"))
+
+(define (mock-location machine)
+ (let* ((config (machine-configuration machine))
+ (name (hetzner-configuration-location config)))
+ (make-hetzner-location
+ "Falkenstein" "DE" "Falkenstein DC Park 1"
+ 1 50.47612 12.370071 name "eu-central")))
+
+(define (mock-server-type machine)
+ (let* ((config (machine-configuration machine))
+ (name (hetzner-configuration-server-type config)))
+ (make-hetzner-server-type
+ "x86" 8 "shared" #f #f (string-upcase name)
+ 160 106 16 name "local")))
+
+(define (mock-server machine)
+ (let* ((config (machine-configuration machine))
+ (name (hetzner-configuration-location config)))
+ (make-hetzner-server
+ 1
+ (localtime (current-time))
+ '()
+ (operating-system-host-name (machine-operating-system machine))
+ (make-hetzner-public-net
+ (make-hetzner-ipv4 #f "server.example.com" 1 "1.2.3.4")
+ (make-hetzner-ipv6 #f "server.example.com" 1 "2001:db8::1"))
+ #f
+ (mock-server-type machine))))
+
+(define (mock-ssh-key machine)
+ (let ((config (machine-configuration machine)))
+ (hetzner-ssh-key-read-file (hetzner-configuration-ssh-key config))))
+
+(define (expected-ssh-machine? machine ssh-machine)
+ (let ((config (machine-configuration machine))
+ (ssh-config (machine-configuration ssh-machine)))
+ (and (equal? (hetzner-configuration-authorize? config)
+ (machine-ssh-configuration-authorize? ssh-config))
+ (equal? (hetzner-configuration-allow-downgrades? config)
+ (machine-ssh-configuration-allow-downgrades? ssh-config))
+ (equal? (hetzner-configuration-build-locally? config)
+ (machine-ssh-configuration-build-locally? ssh-config))
+ (equal? (hetzner-server-public-ipv4 (mock-server machine))
+ (machine-ssh-configuration-host-name ssh-config)))))
+
+(define-syntax mock*
+ (syntax-rules ()
+ ((mock* () body1 body2 ...)
+ (let () body1 body2 ...))
+ ((mock* ((mod1 sym1 fn1) (mod2 sym2 fn2) ...)
+ body1 body2 ...)
+ (mock (mod1 sym1 fn1)
+ (mock* ((mod2 sym2 fn2) ...)
+ body1) body2 ...))))
+
+(test-begin "machine-hetzner")
+
+;; The following tests deploy real machines using the Hetzner API and shut
+;; them down afterwards.
+
+(test-skip %when-no-token)
+(test-assert "deploy-arm-machine"
+ (with-cleanup (machine %arm-machine)
+ (deploy-hetzner machine)))
+
+(test-skip %when-no-token)
+(test-assert "deploy-x86-machine"
+ (with-cleanup (machine %x86-machine)
+ (deploy-hetzner machine)))
+
+;; The following tests simulate a deployment, they mock out the actual calls
+;; to the Hetzner API.
+
+;; Note: In order for mocking to work, the Guile compiler should not inline
+;; the mocked functions. To prevent this it was necessary to set!
+;; hetzner-machine-ssh-run-script in (gnu machine hetzner) like this:
+
+;; (set! hetzner-machine-ssh-run-script hetzner-machine-ssh-run-script)
+
+(test-assert "deploy-machine-mock-with-provisioned-server"
+ (let ((machine (machine
+ (operating-system %hetzner-os-x86)
+ (environment hetzner-environment-type)
+ (configuration (hetzner-configuration
+ (api (hetzner-api (token "mock")))
+ (ssh-key %ssh-key-file))))))
+ (mock* (((gnu machine hetzner http) hetzner-api-locations
+ (lambda* (api . options)
+ (list (mock-location machine))))
+ ((gnu machine hetzner http) hetzner-api-server-types
+ (lambda* (api . options)
+ (list (mock-server-type machine))))
+ ((gnu machine hetzner http) hetzner-api-ssh-keys
+ (lambda* (api . options)
+ (list (mock-ssh-key machine))))
+ ((gnu machine hetzner http) hetzner-api-servers
+ (lambda* (api . options)
+ (list (mock-server machine))))
+ ((gnu machine) deploy-machine
+ (lambda* (ssh-machine)
+ (expected-ssh-machine? machine ssh-machine))))
+ (deploy-hetzner machine))))
+
+(test-assert "deploy-machine-mock-with-unprovisioned-server"
+ (let ((machine (machine
+ (operating-system %hetzner-os-x86)
+ (environment hetzner-environment-type)
+ (configuration (hetzner-configuration
+ (api (hetzner-api (token "mock")))
+ (ssh-key %ssh-key-file)))))
+ (servers '()))
+ (mock* (((gnu machine hetzner http) hetzner-api-locations
+ (lambda* (api . options)
+ (list (mock-location machine))))
+ ((gnu machine hetzner http) hetzner-api-server-types
+ (lambda* (api . options)
+ (list (mock-server-type machine))))
+ ((gnu machine hetzner http) hetzner-api-ssh-keys
+ (lambda* (api . options)
+ (list (mock-ssh-key machine))))
+ ((gnu machine hetzner http) hetzner-api-servers
+ (lambda* (api . options)
+ servers))
+ ((gnu machine hetzner http) hetzner-api-server-create
+ (lambda* (api name ssh-keys . options)
+ (set! servers (list (mock-server machine)))
+ (car servers)))
+ ((gnu machine hetzner http) hetzner-api-server-enable-rescue-system
+ (lambda (api server ssh-keys)
+ (mock-action "enable_rescue")))
+ ((gnu machine hetzner http) hetzner-api-server-power-on
+ (lambda (api server)
+ (mock-action "start_server")))
+ ((gnu machine hetzner) hetzner-machine-ssh-run-script
+ (lambda (ssh-session name content)
+ #t))
+ ((guix ssh) open-ssh-session
+ (lambda* (host . options)
+ (make-session #:host host)))
+ ((gnu machine hetzner http) hetzner-api-server-reboot
+ (lambda (api server)
+ (mock-action "reboot_server")))
+ ((ssh session) write-known-host!
+ (lambda (session)
+ #t))
+ ((gnu machine) deploy-machine
+ (lambda* (ssh-machine)
+ (expected-ssh-machine? machine ssh-machine))))
+ (deploy-hetzner machine))))
+
+(test-end "machine-hetzner")
+
+;; Local Variables:
+;; eval: (put 'with-cleanup 'scheme-indent-function 1)
+;; End:
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 <roman@burningswell.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (tests machine hetzner http)
+ #:use-module (debugging assert)
+ #:use-module (gnu machine hetzner http)
+ #:use-module (guix build utils)
+ #:use-module (guix tests)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-64)
+ #:use-module (ssh key))
+
+;; Unit and integration tests the (gnu machine hetzner http) module.
+
+;; Integration tests require the GUIX_HETZNER_API_TOKEN environment variable.
+;; https://docs.hetzner.com/cloud/api/getting-started/generating-api-token
+
+;; The integration tests sometimes fail due to the Hetzner API not being able
+;; to allocate a resource. Switching to a different location might help.
+
+(define %labels
+ '(("guix.gnu.org/test" . "true")))
+
+(define %server-name
+ "guix-hetzner-api-test-server")
+
+(define %ssh-key-name
+ "guix-hetzner-api-test-key")
+
+(define %ssh-key-file
+ (string-append "/tmp/" %ssh-key-name))
+
+(unless (file-exists? %ssh-key-file)
+ (private-key-to-file (make-keypair 'rsa 2048) %ssh-key-file))
+
+(define %ssh-key
+ (hetzner-ssh-key-read-file %ssh-key-file))
+
+(define %when-no-token
+ (if (hetzner-api-token (hetzner-api)) 0 1))
+
+(define action-create-server
+ (make-hetzner-action
+ "create_server" #f *unspecified* 1896091819 0
+ (list (make-hetzner-resource 59570198 "server"))
+ #(0 17 11 2 1 125 0 32 -1 0 #f) "running"))
+
+(define action-create-server-alist
+ '(("command" . "create_server")
+ ("error" . null)
+ ("finished" . null)
+ ("id" . 1896091819)
+ ("progress" . 0)
+ ("resources" . #((("type" . "server") ("id" . 59570198))))
+ ("started" . "2025-02-02T11:17:00+00:00")
+ ("status" . "running")))
+
+(define action-delete-server
+ (make-hetzner-action
+ "delete_server" #f *unspecified* 1896091928 0
+ (list (make-hetzner-resource 59570198 "server"))
+ #(10 17 11 2 1 125 0 32 -1 0 #f) "running"))
+
+(define action-delete-server-alist
+ '(("command" . "delete_server")
+ ("error" . null)
+ ("finished" . null)
+ ("id" . 1896091928)
+ ("progress" . 0)
+ ("resources" . #((("type" . "server") ("id" . 59570198))))
+ ("started" . "2025-02-02T11:17:10+00:00")
+ ("status" . "running")))
+
+(define action-enable-rescue
+ (make-hetzner-action
+ "enable_rescue" #f *unspecified* 1896091721 0
+ (list (make-hetzner-resource 59570198 "server"))
+ #(10 17 11 2 1 125 0 32 -1 0 #f) "success"))
+
+(define action-enable-rescue-alist
+ '(("command" . "enable_rescue")
+ ("error" . null)
+ ("finished" . null)
+ ("id" . 1896091721)
+ ("progress" . 0)
+ ("resources" . #((("type" . "server") ("id" . 59570198))))
+ ("started" . "2025-02-02T11:17:10+00:00")
+ ("status" . "running")))
+
+(define action-power-off
+ (make-hetzner-action
+ "stop_server" #f *unspecified* 1896091721 0
+ (list (make-hetzner-resource 59570198 "server"))
+ #(10 17 11 2 1 125 0 32 -1 0 #f) "success"))
+
+(define action-power-off-alist
+ '(("command" . "stop_server")
+ ("error" . null)
+ ("finished" . null)
+ ("id" . 1896091721)
+ ("progress" . 0)
+ ("resources" . #((("type" . "server") ("id" . 59570198))))
+ ("started" . "2025-02-02T11:17:10+00:00")
+ ("status" . "running")))
+
+(define action-power-on
+ (make-hetzner-action
+ "start_server" #f *unspecified* 1896091721 0
+ (list (make-hetzner-resource 59570198 "server"))
+ #(10 17 11 2 1 125 0 32 -1 0 #f) "success"))
+
+(define action-power-on-alist
+ '(("command" . "start_server")
+ ("error" . null)
+ ("finished" . null)
+ ("id" . 1896091721)
+ ("progress" . 0)
+ ("resources" . #((("type" . "server") ("id" . 59570198))))
+ ("started" . "2025-02-02T11:17:10+00:00")
+ ("status" . "running")))
+
+(define action-reboot
+ (make-hetzner-action
+ "reboot_server" #f *unspecified* 1896091721 0
+ (list (make-hetzner-resource 59570198 "server"))
+ #(10 17 11 2 1 125 0 32 -1 0 #f) "success"))
+
+(define action-reboot-alist
+ '(("command" . "reboot_server")
+ ("error" . null)
+ ("finished" . null)
+ ("id" . 1896091721)
+ ("progress" . 0)
+ ("resources" . #((("type" . "server") ("id" . 59570198))))
+ ("started" . "2025-02-02T11:17:10+00:00")
+ ("status" . "running")))
+
+(define meta-page-alist
+ '("pagination"
+ ("last_page" . 1)
+ ("next_page" . null)
+ ("page" . 1)
+ ("per_page" . 25)
+ ("previous_page" . null)
+ ("total_entries" . 1)))
+
+(define location-falkenstein
+ (make-hetzner-location
+ "Falkenstein" "DE" "Falkenstein DC Park 1"
+ 1 50.47612 12.370071 "fsn1" "eu-central"))
+
+(define location-falkenstein-alist
+ `(("city" . "Falkenstein")
+ ("country" . "DE")
+ ("description" . "Falkenstein DC Park 1")
+ ("id" . 1)
+ ("latitude" . 50.47612)
+ ("longitude" . 12.370071)
+ ("name" . "fsn1")
+ ("network_zone" . "eu-central")))
+
+(define server-type-cpx-11
+ (make-hetzner-server-type
+ "x86" 2 "shared" #f *unspecified*
+ "CPX 11" 40 22 2 "cpx11" "local"))
+
+(define server-type-cpx-11-alist
+ `(("architecture" . "x86")
+ ("cores" . 2)
+ ("cpu_type" . "shared")
+ ("deprecated" . #f)
+ ("deprecation" . null)
+ ("description" . "CPX 11")
+ ("disk" . 40)
+ ("id" . 22)
+ ("memory" . 2)
+ ("name" . "cpx11")
+ ("storage_type" . "local")))
+
+(define server-x86
+ (make-hetzner-server
+ "2024-12-30T16:38:11+00:00"
+ 59570198
+ '()
+ "guix-x86"
+ (make-hetzner-public-net
+ (make-hetzner-ipv4 #f "static.218.128.13.49.clients.your-server.de" 78014457 "49.13.128.218")
+ (make-hetzner-ipv6 #f '() 78014458 "2a01:4f8:c17:293e::/64"))
+ #f
+ server-type-cpx-11))
+
+(define server-x86-alist
+ `(("backup_window" . null)
+ ("created" . "2024-12-30T16:38:11+00:00")
+ ("id" . 59570198)
+ ("included_traffic" . 21990232555520)
+ ("ingoing_traffic" . 124530000)
+ ("iso" . null)
+ ("labels")
+ ("load_balancers" . #())
+ ("locked" . #f)
+ ("name" . "guix-x86")
+ ("outgoing_traffic" . 1391250000)
+ ("placement_group" . null)
+ ("primary_disk_size" . 320)
+ ("private_net" . #())
+ ("protection" ("rebuild" . #f) ("delete" . #f))
+ ("public_net"
+ ("firewalls" . #())
+ ("floating_ips" . #())
+ ("ipv6"
+ ("id" . 78014458)
+ ("dns_ptr" . #())
+ ("blocked" . #f)
+ ("ip" . "2a01:4f8:c17:293e::/64"))
+ ("ipv4"
+ ("id" . 78014457)
+ ("dns_ptr" . "static.218.128.13.49.clients.your-server.de")
+ ("blocked" . #f)
+ ("ip" . "49.13.128.218")))
+ ("rescue_enabled" . #f)
+ ("server_type" ,@server-type-cpx-11-alist)
+ ("status" . "running")
+ ("volumes" . #())))
+
+(define ssh-key-root
+ (make-hetzner-ssh-key
+ #(55 2 19 28 9 123 6 300 -1 0 #f)
+ "8c:25:09:8f:37:0f:d8:f0:99:4e:ab:c7:5c:1b:c6:53"
+ 16510983 '() "root@example.com"
+ "ssh-ed25519 ABCAC3NzaC1lZDI1NTE5AAAAIBT3lLYPfOZV9NNrNk0jGCufWmXbFSz+ORxowJdHoSIM"))
+
+(define ssh-key-root-alist
+ `(("created" . "2023-10-28T19:02:55+00:00")
+ ("fingerprint" . "8c:25:09:8f:37:0f:d8:f0:99:4e:ab:c7:5c:1b:c6:53")
+ ("id" . 16510983)
+ ("labels")
+ ("name" . "root@example.com")
+ ("public_key" . "ssh-ed25519 ABCAC3NzaC1lZDI1NTE5AAAAIBT3lLYPfOZV9NNrNk0jGCufWmXbFSz+ORxowJdHoSIM")))
+
+(define* (create-ssh-key api ssh-key #:key (labels %labels))
+ (hetzner-api-ssh-key-create
+ api
+ (hetzner-ssh-key-name ssh-key)
+ (hetzner-ssh-key-public-key ssh-key)
+ #:labels labels))
+
+(define* (create-server api ssh-key #:key (labels %labels))
+ (hetzner-api-server-create api %server-name (list ssh-key)
+ #:labels labels
+ #:server-type "cpx31"))
+
+(define (cleanup api)
+ (for-each (lambda (server)
+ (hetzner-api-server-delete api server))
+ (hetzner-api-servers
+ api #:params `(("label_selector" . "guix.gnu.org/test=true"))))
+ (for-each (lambda (ssh-key)
+ (hetzner-api-ssh-key-delete api ssh-key))
+ (hetzner-api-ssh-keys
+ api #:params `(("label_selector" . "guix.gnu.org/test=true"))))
+ api)
+
+(define-syntax-rule (with-cleanup-api (api-sym api-init) body ...)
+ (let ((api-sym (cleanup api-init)))
+ (dynamic-wind
+ (const #t)
+ (lambda ()
+ body ...)
+ (lambda ()
+ (cleanup api-sym)))))
+
+(test-begin "machine-hetzner-api")
+
+;; Unit Tests
+
+(test-equal "hetzner-api-actions-unit"
+ (list action-create-server action-delete-server)
+ (let ((actions (list action-create-server-alist action-delete-server-alist)))
+ (mock ((gnu machine hetzner http) hetzner-api-request-send
+ (lambda* (request #:key expected)
+ (assert (equal? 'GET (hetzner-api-request-method request)))
+ (assert (equal? "https://api.hetzner.cloud/v1/actions"
+ (hetzner-api-request-url request)))
+ (assert (unspecified? (hetzner-api-request-body request)))
+ (assert (equal? `(("page" . 1)
+ ("id" . ,(string-join
+ (map (lambda (action)
+ (number->string (assoc-ref action "id")))
+ actions)
+ ",")))
+ (hetzner-api-request-params request)))
+ (hetzner-api-response
+ (body `(("meta" . ,meta-page-alist)
+ ("actions" . #(,action-create-server-alist ,action-delete-server-alist)))))))
+ (hetzner-api-actions (hetzner-api)
+ (map (lambda (action)
+ (assoc-ref action "id"))
+ actions)))))
+
+(test-equal "hetzner-api-locations-unit"
+ (list location-falkenstein)
+ (mock ((gnu machine hetzner http) hetzner-api-request-send
+ (lambda* (request #:key expected)
+ (assert (equal? 'GET (hetzner-api-request-method request)))
+ (assert (equal? "https://api.hetzner.cloud/v1/locations"
+ (hetzner-api-request-url request)))
+ (assert (unspecified? (hetzner-api-request-body request)))
+ (assert (equal? '(("page" . 1)) (hetzner-api-request-params request)))
+ (hetzner-api-response
+ (body `(("meta" . ,meta-page-alist)
+ ("locations" . #(,location-falkenstein-alist)))))))
+ (hetzner-api-locations (hetzner-api))))
+
+(test-equal "hetzner-api-server-types-unit"
+ (list server-type-cpx-11)
+ (mock ((gnu machine hetzner http) hetzner-api-request-send
+ (lambda* (request #:key expected)
+ (assert (equal? 'GET (hetzner-api-request-method request)))
+ (assert (equal? "https://api.hetzner.cloud/v1/server_types"
+ (hetzner-api-request-url request)))
+ (assert (unspecified? (hetzner-api-request-body request)))
+ (assert (equal? '(("page" . 1)) (hetzner-api-request-params request)))
+ (hetzner-api-response
+ (body `(("meta" . ,meta-page-alist)
+ ("server_types" . #(,server-type-cpx-11-alist)))))))
+ (hetzner-api-server-types (hetzner-api))))
+
+(test-equal "hetzner-api-server-create-unit"
+ server-x86
+ (mock ((gnu machine hetzner http) hetzner-api-request-send
+ (lambda* (request #:key expected)
+ (cond
+ ((equal? "https://api.hetzner.cloud/v1/servers"
+ (hetzner-api-request-url request))
+ (assert (equal? 'POST (hetzner-api-request-method request)))
+ (hetzner-api-response
+ (body `(("action" . ,action-create-server-alist)
+ ("server" . ,server-x86-alist)))))
+ ((equal? "https://api.hetzner.cloud/v1/actions"
+ (hetzner-api-request-url request))
+ (assert (equal? 'GET (hetzner-api-request-method request)))
+ (hetzner-api-response
+ (body `(("actions" . ,(vector (cons `("status" . "success")
+ action-create-server-alist)))
+ ("meta" . ,meta-page-alist))))))))
+ (hetzner-api-server-create (hetzner-api) %server-name (list ssh-key-root))))
+
+(test-equal "hetzner-api-server-delete-unit"
+ (make-hetzner-action
+ "delete_server" #f *unspecified* 1896091928 0
+ (list (make-hetzner-resource 59570198 "server"))
+ #(10 17 11 2 1 125 0 32 -1 0 #f) "success")
+ (mock ((gnu machine hetzner http) hetzner-api-request-send
+ (lambda* (request #:key expected)
+ (cond
+ ((equal? "https://api.hetzner.cloud/v1/servers/59570198"
+ (hetzner-api-request-url request))
+ (assert (equal? 'DELETE (hetzner-api-request-method request)))
+ (hetzner-api-response
+ (body `(("action" . ,action-delete-server-alist)))))
+ ((equal? "https://api.hetzner.cloud/v1/actions"
+ (hetzner-api-request-url request))
+ (assert (equal? 'GET (hetzner-api-request-method request)))
+ (hetzner-api-response
+ (body `(("actions" . ,(vector (cons `("status" . "success")
+ action-delete-server-alist)))
+ ("meta" . ,meta-page-alist))))))))
+ (hetzner-api-server-delete (hetzner-api) server-x86)))
+
+(test-equal "hetzner-api-server-enable-rescue-system-unit"
+ action-enable-rescue
+ (mock ((gnu machine hetzner http) hetzner-api-request-send
+ (lambda* (request #:key expected)
+ (cond
+ ((equal? "https://api.hetzner.cloud/v1/servers/59570198/actions/enable_rescue"
+ (hetzner-api-request-url request))
+ (assert (equal? 'POST (hetzner-api-request-method request)))
+ (hetzner-api-response
+ (body `(("action" . ,action-enable-rescue-alist)))))
+ ((equal? "https://api.hetzner.cloud/v1/actions"
+ (hetzner-api-request-url request))
+ (assert (equal? 'GET (hetzner-api-request-method request)))
+ (hetzner-api-response
+ (body `(("actions" . ,(vector (cons `("status" . "success")
+ action-enable-rescue-alist)))
+ ("meta" . ,meta-page-alist))))))))
+ (hetzner-api-server-enable-rescue-system (hetzner-api) server-x86 (list ssh-key-root))))
+
+(test-equal "hetzner-api-server-power-on-unit"
+ action-power-on
+ (mock ((gnu machine hetzner http) hetzner-api-request-send
+ (lambda* (request #:key expected)
+ (cond
+ ((equal? "https://api.hetzner.cloud/v1/servers/59570198/actions/poweron"
+ (hetzner-api-request-url request))
+ (assert (equal? 'POST (hetzner-api-request-method request)))
+ (hetzner-api-response
+ (body `(("action" . ,action-power-on-alist)))))
+ ((equal? "https://api.hetzner.cloud/v1/actions"
+ (hetzner-api-request-url request))
+ (assert (equal? 'GET (hetzner-api-request-method request)))
+ (hetzner-api-response
+ (body `(("actions" . ,(vector (cons `("status" . "success")
+ action-power-on-alist)))
+ ("meta" . ,meta-page-alist))))))))
+ (hetzner-api-server-power-on (hetzner-api) server-x86)))
+
+(test-equal "hetzner-api-server-power-off-unit"
+ action-power-off
+ (mock ((gnu machine hetzner http) hetzner-api-request-send
+ (lambda* (request #:key expected)
+ (cond
+ ((equal? "https://api.hetzner.cloud/v1/servers/59570198/actions/poweroff"
+ (hetzner-api-request-url request))
+ (assert (equal? 'POST (hetzner-api-request-method request)))
+ (hetzner-api-response
+ (body `(("action" . ,action-power-off-alist)))))
+ ((equal? "https://api.hetzner.cloud/v1/actions"
+ (hetzner-api-request-url request))
+ (assert (equal? 'GET (hetzner-api-request-method request)))
+ (hetzner-api-response
+ (body `(("actions" . ,(vector (cons `("status" . "success")
+ action-power-off-alist)))
+ ("meta" . ,meta-page-alist))))))))
+ (hetzner-api-server-power-off (hetzner-api) server-x86)))
+
+(test-equal "hetzner-api-server-reboot-unit"
+ action-reboot
+ (mock ((gnu machine hetzner http) hetzner-api-request-send
+ (lambda* (request #:key expected)
+ (cond
+ ((equal? "https://api.hetzner.cloud/v1/servers/59570198/actions/reboot"
+ (hetzner-api-request-url request))
+ (assert (equal? 'POST (hetzner-api-request-method request)))
+ (hetzner-api-response
+ (body `(("action" . ,action-reboot-alist)))))
+ ((equal? "https://api.hetzner.cloud/v1/actions"
+ (hetzner-api-request-url request))
+ (assert (equal? 'GET (hetzner-api-request-method request)))
+ (hetzner-api-response
+ (body `(("actions" . ,(vector (cons `("status" . "success")
+ action-reboot-alist)))
+ ("meta" . ,meta-page-alist))))))))
+ (hetzner-api-server-reboot (hetzner-api) server-x86)))
+
+(test-equal "hetzner-api-servers-unit"
+ (list server-x86)
+ (mock ((gnu machine hetzner http) hetzner-api-request-send
+ (lambda* (request #:key expected)
+ (hetzner-api-response
+ (body `(("meta" . ,meta-page-alist)
+ ("servers" . #(,server-x86-alist)))))))
+ (hetzner-api-servers (hetzner-api))))
+
+(test-equal "hetzner-api-ssh-key-create-unit"
+ ssh-key-root
+ (mock ((gnu machine hetzner http) hetzner-api-request-send
+ (lambda* (request #:key expected)
+ (assert (equal? 'POST (hetzner-api-request-method request)))
+ (assert (equal? "https://api.hetzner.cloud/v1/ssh_keys"
+ (hetzner-api-request-url request)))
+ (assert (equal? `(("name" . "guix-hetzner-api-test-key")
+ ("public_key" . "ssh-ed25519 ABCAC3NzaC1lZDI1NTE5AAAAIBT3lLYPfOZV9NNrNk0jGCufWmXbFSz+ORxowJdHoSIM")
+ ("labels" . (("a" . "1"))))
+ (hetzner-api-request-body request)))
+ (assert (equal? `() (hetzner-api-request-params request)))
+ (hetzner-api-response
+ (body `(("ssh_key" . ,ssh-key-root-alist))))))
+ (hetzner-api-ssh-key-create
+ (hetzner-api)
+ "guix-hetzner-api-test-key"
+ "ssh-ed25519 ABCAC3NzaC1lZDI1NTE5AAAAIBT3lLYPfOZV9NNrNk0jGCufWmXbFSz+ORxowJdHoSIM"
+ #:labels '(("a" . "1")))))
+
+(test-assert "hetzner-api-ssh-key-delete-unit"
+ (mock ((gnu machine hetzner http) hetzner-api-request-send
+ (lambda* (request #:key expected)
+ (assert (equal? "https://api.hetzner.cloud/v1/ssh_keys/16510983"
+ (hetzner-api-request-url request)))
+ (assert (equal? 'DELETE (hetzner-api-request-method request)))
+ (hetzner-api-response)))
+ (hetzner-api-ssh-key-delete (hetzner-api) ssh-key-root)))
+
+(test-equal "hetzner-api-ssh-keys-unit"
+ (list ssh-key-root)
+ (mock ((gnu machine hetzner http) hetzner-api-request-send
+ (lambda* (request #:key expected)
+ (assert (equal? 'GET (hetzner-api-request-method request)))
+ (assert (equal? "https://api.hetzner.cloud/v1/ssh_keys"
+ (hetzner-api-request-url request)))
+ (assert (unspecified? (hetzner-api-request-body request)))
+ (assert (equal? '(("page" . 1)) (hetzner-api-request-params request)))
+ (hetzner-api-response
+ (body `(("meta" . ,meta-page-alist)
+ ("ssh_keys" . #(,ssh-key-root-alist)))))))
+ (hetzner-api-ssh-keys (hetzner-api))))
+
+;; Integration tests
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-actions-integration"
+ (with-cleanup-api (api (hetzner-api))
+ (let* ((ssh-key (create-ssh-key api %ssh-key))
+ (server (create-server api ssh-key))
+ (action (hetzner-api-server-enable-rescue-system api server (list ssh-key))))
+ (member action (hetzner-api-actions api (list (hetzner-action-id action)))))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-locations-integration"
+ (let ((locations (hetzner-api-locations (hetzner-api))))
+ (and (> (length locations) 0)
+ (every hetzner-location? locations))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-types-integration"
+ (let ((server-types (hetzner-api-server-types (hetzner-api))))
+ (and (> (length server-types) 0)
+ (every hetzner-server-type? server-types))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-create-integration"
+ (with-cleanup-api (api (hetzner-api))
+ (let* ((ssh-key (create-ssh-key api %ssh-key))
+ (server (create-server api ssh-key)))
+ (and (hetzner-server? server)
+ (equal? %server-name (hetzner-server-name server))))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-delete-integration"
+ (with-cleanup-api (api (hetzner-api))
+ (let* ((ssh-key (create-ssh-key api %ssh-key))
+ (server (create-server api ssh-key))
+ (action (hetzner-api-server-delete api server)))
+ (and (hetzner-action? action)
+ (equal? "delete_server"
+ (hetzner-action-command action))))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-enable-rescue-system-integration"
+ (with-cleanup-api (api (hetzner-api))
+ (let* ((ssh-key (create-ssh-key api %ssh-key))
+ (server (create-server api ssh-key))
+ (action (hetzner-api-server-enable-rescue-system api server (list ssh-key))))
+ (and (hetzner-action? action)
+ (equal? "enable_rescue"
+ (hetzner-action-command action))))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-power-on-integration"
+ (with-cleanup-api (api (hetzner-api))
+ (let* ((ssh-key (create-ssh-key api %ssh-key))
+ (server (create-server api ssh-key))
+ (action (hetzner-api-server-power-on api server)))
+ (and (hetzner-action? action)
+ (equal? "start_server"
+ (hetzner-action-command action))))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-power-off-integration"
+ (with-cleanup-api (api (hetzner-api))
+ (let* ((ssh-key (create-ssh-key api %ssh-key))
+ (server (create-server api ssh-key))
+ (action (hetzner-api-server-power-off api server)))
+ (and (hetzner-action? action)
+ (equal? "stop_server"
+ (hetzner-action-command action))))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-server-reboot-integration"
+ (with-cleanup-api (api (hetzner-api))
+ (let* ((ssh-key (create-ssh-key api %ssh-key))
+ (server (create-server api ssh-key))
+ (action (hetzner-api-server-reboot api server)))
+ (and (hetzner-action? action)
+ (equal? "reboot_server"
+ (hetzner-action-command action))))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-servers-integration"
+ (with-cleanup-api (api (hetzner-api))
+ (let* ((ssh-key (create-ssh-key api %ssh-key))
+ (server (create-server api ssh-key)))
+ (member server (hetzner-api-servers api)))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-ssh-key-create-integration"
+ (with-cleanup-api (api (hetzner-api))
+ (let ((ssh-key (create-ssh-key api %ssh-key)))
+ (and (hetzner-ssh-key? ssh-key)
+ (equal? (hetzner-ssh-key-fingerprint %ssh-key)
+ (hetzner-ssh-key-fingerprint ssh-key))
+ (equal? (hetzner-ssh-key-name %ssh-key)
+ (hetzner-ssh-key-name ssh-key))
+ (equal? (hetzner-ssh-key-public-key %ssh-key)
+ (hetzner-ssh-key-public-key ssh-key))))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-ssh-key-delete-integration"
+ (with-cleanup-api (api (hetzner-api))
+ (let ((ssh-key (create-ssh-key api %ssh-key)))
+ (and (equal? #t (hetzner-api-ssh-key-delete api ssh-key))
+ (not (member ssh-key (hetzner-api-ssh-keys api)))))))
+
+(test-skip %when-no-token)
+(test-assert "hetzner-api-ssh-keys-integration"
+ (with-cleanup-api (api (hetzner-api))
+ (let ((ssh-key (create-ssh-key api %ssh-key)))
+ (member ssh-key (hetzner-api-ssh-keys api)))))
+
+(test-end "machine-hetzner-api")
+
+;; Local Variables:
+;; eval: (put 'with-cleanup-api 'scheme-indent-function 1)
+;; End:
--
2.48.1
^ permalink raw reply related [flat|nested] 17+ messages in thread
* [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
2025-01-28 19:57 ` Roman Scherer
@ 2025-02-04 19:10 ` Roman Scherer
2025-02-07 12:45 ` Maxim Cournoyer
0 siblings, 1 reply; 17+ messages in thread
From: Roman Scherer @ 2025-02-04 19:10 UTC (permalink / raw)
To: Roman Scherer
Cc: Josselin Poiret, Maxim Cournoyer, Simon Tournier,
Mathieu Othacehe, Ludovic Courtès, Tobias Geerinckx-Rice,
Christopher Baines, 75144
[-- Attachment #1: Type: text/plain, Size: 2656 bytes --]
References: <6ff52cb81582c81835e39beebc7e6f7f3ecfd81d.1735317980.git.roman@burningswell.com>
<8734hi1mdh.fsf@gnu.org> <868qr6n3j9.fsf@burningswell.com>
<87ed0rt3oz.fsf@burningswell.com> <87o6zt5bjs.fsf@gmail.com>
<87tt9je0sr.fsf@burningswell.com> <87y0yvdxej.fsf@gnu.org>
<867c6e90ei.fsf@burningswell.com>
User-Agent: mu4e 1.12.8; emacs 29.4
Hi Ludo,
I just sent v3 of the patch series in which I added test. There are now unit
and integration tests. You can run them with:
./pre-inst-env make check TESTS="tests/machine/hetzner/http.scm"
./pre-inst-env make check TESTS="tests/machine/hetzner.scm"
The integration tests require network access and the GUIX_HETZNER_API_TOKEN
environment variable to be set, otherwise they are skipped.
Can you have another look please?
And Christopher Baines, since Ludo mentioned you have a Hetzner account, would
you be interested in trying this out and provide some feedback?
Things to improve another day:
- Get Hetzner to add a Guix image to their collectin of supported images. That
would remove the need for using the rescue system to install an initial Guix system.
- Installing the initial Guix system via the rescue system is kind of slow
(especially if there are no substituyes), and done in sequence. I'm not sure
how this could be parallelized with how things are invoke by guix deploy.
Roman
Date: Tue, 04 Feb 2025 20:10:53 +0100
Roman Scherer <roman@burningswell.com> writes:
> Hi Ludo,
>
> that's what I was looking for. Now it is working as expected!
>
> I will send an updated patch soon.
>
> Thanks for your help!
>
> Roman
>
> Ludovic Courtès <ludo@gnu.org> writes:
>
>> Hi,
>>
>> Roman Scherer <roman@burningswell.com> skribis:
>>
>>> When I run the mocked test I expect no code from the (gnu machine
>>> hetzner http) module to be executed, since I mocked all those
>>> functions. This seems to work in the Geiser REPL, but for some reason it
>>> does not work when I run the test with:
>>>
>>> ./pre-inst-env make check TESTS="tests/machine/hetzner.scm"
>>>
>>> To me it looks like the mock function behaves differently in those 2
>>> situations. In the meaintime I also tried setting -O0, but that didn't
>>> make any difference either. :/
>>
>> Hmm. I was going to say that the likely problem is that code from (gnu
>> machines hetzner http) gets inlined so you cannot really mock it.
>>
>> To make sure this can be mocked, you can use this trick:
>>
>> (set! proc proc)
>>
>> where ‘proc’ is the procedure you want to mock (that statement prevents
>> the compiler from inlining it).
>>
>> Ludo’.
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 519 bytes --]
^ permalink raw reply [flat|nested] 17+ messages in thread
* [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
2025-02-04 19:10 ` Roman Scherer
@ 2025-02-07 12:45 ` Maxim Cournoyer
2025-02-07 13:00 ` Roman Scherer
0 siblings, 1 reply; 17+ messages in thread
From: Maxim Cournoyer @ 2025-02-07 12:45 UTC (permalink / raw)
To: Roman Scherer
Cc: Josselin Poiret, Simon Tournier, Mathieu Othacehe,
Ludovic Courtès, Tobias Geerinckx-Rice, Christopher Baines,
75144
Hi Roman,
Roman Scherer <roman@burningswell.com> writes:
[...]
> Things to improve another day:
>
> - Get Hetzner to add a Guix image to their collectin of supported images. That
> would remove the need for using the rescue system to install an initial Guix system.
>
> - Installing the initial Guix system via the rescue system is kind of slow
> (especially if there are no substituyes), and done in sequence. I'm not sure
> how this could be parallelized with how things are invoke by guix deploy.
Forgive my ignorance, but I thought the idea of a deploy <machine>
environment type was to allow fully provisioning the OS via the service
API?
I haven't reviewed the change yet; perhaps you mean that currently such
provision must happen by going through the rescue system path (but is
still automated by this new environment type?)
--
Thanks,
Maxim
^ permalink raw reply [flat|nested] 17+ messages in thread
* [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
2025-02-07 12:45 ` Maxim Cournoyer
@ 2025-02-07 13:00 ` Roman Scherer
2025-02-07 14:08 ` Maxim Cournoyer
0 siblings, 1 reply; 17+ messages in thread
From: Roman Scherer @ 2025-02-07 13:00 UTC (permalink / raw)
To: Maxim Cournoyer
Cc: Josselin Poiret, Simon Tournier, Mathieu Othacehe,
Ludovic Courtès, Tobias Geerinckx-Rice, Roman Scherer,
Christopher Baines, 75144
[-- Attachment #1: Type: text/plain, Size: 1734 bytes --]
Hi Maxim,
yes, it is fully automated. What happens is:
- a server is provisioned through the Hetzner API
- the the server is booted into the rescue system via the API
- partitions are setup in the rescue system (enlarged)
- a minimal Guix system is installed
- then the server re-booted, starting the minimal Guix system
- then the machine-ssh-environment takes over and applies the final system configuration
- this all is done once, when the server is initially provisioned
Previsouly I tried the guix-infect.sh approach that installs a Guix
system on top of a debian/ubuntu image, but I found this was very
brittle (issues with dns when you remove /etc, etc.). From my experience
working with this I found the approach with the rescue system both more
reliable and faster.
Does this mnake sense?
Roman
Maxim Cournoyer <maxim.cournoyer@gmail.com> writes:
> Hi Roman,
>
> Roman Scherer <roman@burningswell.com> writes:
>
> [...]
>
>> Things to improve another day:
>>
>> - Get Hetzner to add a Guix image to their collectin of supported images. That
>> would remove the need for using the rescue system to install an initial Guix system.
>>
>> - Installing the initial Guix system via the rescue system is kind of slow
>> (especially if there are no substituyes), and done in sequence. I'm not sure
>> how this could be parallelized with how things are invoke by guix deploy.
>
> Forgive my ignorance, but I thought the idea of a deploy <machine>
> environment type was to allow fully provisioning the OS via the service
> API?
>
> I haven't reviewed the change yet; perhaps you mean that currently such
> provision must happen by going through the rescue system path (but is
> still automated by this new environment type?)
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 519 bytes --]
^ permalink raw reply [flat|nested] 17+ messages in thread
* [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
2025-02-07 13:00 ` Roman Scherer
@ 2025-02-07 14:08 ` Maxim Cournoyer
2025-02-07 16:58 ` Roman Scherer
0 siblings, 1 reply; 17+ messages in thread
From: Maxim Cournoyer @ 2025-02-07 14:08 UTC (permalink / raw)
To: Roman Scherer
Cc: Josselin Poiret, Simon Tournier, Mathieu Othacehe,
Ludovic Courtès, Tobias Geerinckx-Rice, Christopher Baines,
75144
Hi Roman,
Roman Scherer <roman@burningswell.com> writes:
> Hi Maxim,
>
> yes, it is fully automated. What happens is:
>
> - a server is provisioned through the Hetzner API
> - the the server is booted into the rescue system via the API
> - partitions are setup in the rescue system (enlarged)
> - a minimal Guix system is installed
> - then the server re-booted, starting the minimal Guix system
> - then the machine-ssh-environment takes over and applies the final system configuration
> - this all is done once, when the server is initially provisioned
>
> Previsouly I tried the guix-infect.sh approach that installs a Guix
> system on top of a debian/ubuntu image, but I found this was very
> brittle (issues with dns when you remove /etc, etc.). From my experience
> working with this I found the approach with the rescue system both more
> reliable and faster.
>
> Does this mnake sense?
Thanks for the clear explanation, it makes a lot of sense and it's
awesome that you could automate all that! It looks a lot like the
manual steps I had to go through to install Guix System on a cheap OVH
VPS [0]. It'd be fun to review if their API would allow automating all
that as what you did here for Hetzner. The nice thing with OVH is that
they do not place any upper limit on the amount of bandwidth consumed
(no extra billing), and it's quite inexpensive (I currently pay less
than 2 CAD/month, although that's only for the first year -- after it's
similar to Hetzner, about 6 CAD/month IIRC).
[0] https://lists.gnu.org/archive/html/help-guix/2024-08/msg00125.html
--
Thanks,
Maxim
^ permalink raw reply [flat|nested] 17+ messages in thread
* [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type'.
2025-02-07 14:08 ` Maxim Cournoyer
@ 2025-02-07 16:58 ` Roman Scherer
0 siblings, 0 replies; 17+ messages in thread
From: Roman Scherer @ 2025-02-07 16:58 UTC (permalink / raw)
To: Maxim Cournoyer
Cc: Josselin Poiret, Simon Tournier, Mathieu Othacehe,
Ludovic Courtès, Tobias Geerinckx-Rice, Roman Scherer,
Christopher Baines, 75144
[-- Attachment #1: Type: text/plain, Size: 2232 bytes --]
Hi Maxim,
I'm not really familiar with the OVH rescue mode. But a quick search
showed up this:
https://support.us.ovhcloud.com/hc/en-us/articles/20041782509203-Activating-Rescue-Mode-on-a-Public-Cloud-Instance
https://eu.api.ovh.com/console/?section=%2Fcloud&branch=v1#post-/cloud/project/-serviceName-/instance/-instanceId-/rescueMode
So, if it works similar to the Hetzner rescue system, which I think it
does, and you can install guix on it (the package manager is enough) I
don't see why this approach should not work there as well.
Thanks, Roman
Maxim Cournoyer <maxim.cournoyer@gmail.com> writes:
> Hi Roman,
>
> Roman Scherer <roman@burningswell.com> writes:
>
>> Hi Maxim,
>>
>> yes, it is fully automated. What happens is:
>>
>> - a server is provisioned through the Hetzner API
>> - the the server is booted into the rescue system via the API
>> - partitions are setup in the rescue system (enlarged)
>> - a minimal Guix system is installed
>> - then the server re-booted, starting the minimal Guix system
>> - then the machine-ssh-environment takes over and applies the final system configuration
>> - this all is done once, when the server is initially provisioned
>>
>> Previsouly I tried the guix-infect.sh approach that installs a Guix
>> system on top of a debian/ubuntu image, but I found this was very
>> brittle (issues with dns when you remove /etc, etc.). From my experience
>> working with this I found the approach with the rescue system both more
>> reliable and faster.
>>
>> Does this mnake sense?
>
> Thanks for the clear explanation, it makes a lot of sense and it's
> awesome that you could automate all that! It looks a lot like the
> manual steps I had to go through to install Guix System on a cheap OVH
> VPS [0]. It'd be fun to review if their API would allow automating all
> that as what you did here for Hetzner. The nice thing with OVH is that
> they do not place any upper limit on the amount of bandwidth consumed
> (no extra billing), and it's quite inexpensive (I currently pay less
> than 2 CAD/month, although that's only for the first year -- after it's
> similar to Hetzner, about 6 CAD/month IIRC).
>
> [0] https://lists.gnu.org/archive/html/help-guix/2024-08/msg00125.html
[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 519 bytes --]
^ permalink raw reply [flat|nested] 17+ messages in thread
* [bug#75144] [PATCH v3 2/2] machine: Implement 'hetzner-environment-type'.
2025-02-04 19:01 ` [bug#75144] [PATCH v3 2/2] machine: Implement 'hetzner-environment-type' Roman Scherer
@ 2025-02-09 16:45 ` Ludovic Courtès
0 siblings, 0 replies; 17+ messages in thread
From: Ludovic Courtès @ 2025-02-09 16:45 UTC (permalink / raw)
To: Roman Scherer; +Cc: Julien Lepiller, Maxim Cournoyer, Florian Pelz, 75144
Hello Roman,
Applied with the one-line change below.
I wasn’t able to run tests that require an API token because I don’t
have one (but I may well give that a try eventually); other tests went
well.
Feel free to submit an entry for ‘etc/news.scm’ (make sure to provide
enough context so users can tell whether this is something of interest
to them). A blog post for guix.gnu.org/blog showing how you use it and
how it’s implemented would also be welcome if you feel so inclined!
Thanks for all the work!
Ludo’.
^ permalink raw reply [flat|nested] 17+ messages in thread
end of thread, other threads:[~2025-02-09 16:46 UTC | newest]
Thread overview: 17+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2024-12-27 16:46 [bug#75144] [PATCH] machine: Implement 'hetzner-environment-type' Roman Scherer
2025-01-16 21:26 ` Ludovic Courtès
2025-01-19 16:59 ` Roman Scherer
2025-01-25 13:37 ` Roman Scherer
2025-01-27 0:45 ` Maxim Cournoyer
2025-01-28 9:37 ` Roman Scherer
2025-01-28 10:51 ` Ludovic Courtès
2025-01-28 19:57 ` Roman Scherer
2025-02-04 19:10 ` Roman Scherer
2025-02-07 12:45 ` Maxim Cournoyer
2025-02-07 13:00 ` Roman Scherer
2025-02-07 14:08 ` Maxim Cournoyer
2025-02-07 16:58 ` Roman Scherer
2025-01-16 21:26 ` Ludovic Courtès
2025-02-04 19:01 ` [bug#75144] [PATCH v3 1/2] guix: ssh: Add strict-host-key-check? option Roman Scherer
2025-02-04 19:01 ` [bug#75144] [PATCH v3 2/2] machine: Implement 'hetzner-environment-type' Roman Scherer
2025-02-09 16:45 ` Ludovic Courtès
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).