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