Roman Scherer wrote 3 months ago
(address . guix-patches@gnu.org)(name . Roman Scherer)(address . roman@burningswell.com)
6ff52cb81582c81835e39beebc7e6f7f3ecfd81d.1735317980.git.roman@burningswell.com
* 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
Toggle diff (514 lines)
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")))
+
+
+;;;
+;;; 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"))))))
+
+
+;;;
+;;; 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)
+ "&"))
+ ""))
+
+
+
+;;;
+;;; 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)))))
+
+
+
+;;;
+;;; 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))))
+
+
+
+;;;
+;;; 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 (hetz
This message was truncated. Download the full message here.