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