mirror of
https://codeberg.org/guix/guix.git
synced 2025-10-02 02:15:12 +00:00
7a4193ec4a
* gnu/machine/hetzner.scm (hetzner-configuration): Add ipv4 and ipv6 fields. Export accessors. * gnu/machine/hetzner/http.scm (hetnzer-api-primary-ips): New function. (<hetzner-primary-ip>): New json mapping. (hetzner-api-server-create): Pass IP addresses in request. * doc/guix.texi (Invoking guix deploy): Document it. Change-Id: I44509cc98e041762dc483e876566e79bde85b26a Signed-off-by: Ludovic Courtès <ludo@gnu.org>
689 lines
26 KiB
Scheme
689 lines
26 KiB
Scheme
;;; 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-primary-ips
|
||
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-primary-ip
|
||
hetzner-primary-ip-created
|
||
hetzner-primary-ip-id
|
||
hetzner-primary-ip-ip
|
||
hetzner-primary-ip-labels
|
||
hetzner-primary-ip-name
|
||
hetzner-primary-ip-type
|
||
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-primary-ip
|
||
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
|
||
|
||
;; Reserved IP address. https://docs.hetzner.cloud/#primary-ips
|
||
(define-json-mapping <hetzner-primary-ip>
|
||
make-hetzner-primary-ip hetzner-primary-ip? json->hetzner-primary-ip
|
||
(created hetzner-primary-ip-created "created" string->time) ; time
|
||
(id hetzner-primary-ip-id) ; integer
|
||
(ip hetzner-primary-ip-ip) ; string
|
||
(labels hetzner-primary-ip-labels) ; alist of string/string
|
||
(name hetzner-primary-ip-name) ; string
|
||
(type hetzner-primary-ip-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)
|
||
"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
|
||
(ipv4 #f)
|
||
(ipv6 #f)
|
||
(image %hetzner-default-server-image)
|
||
(labels '())
|
||
(location %hetzner-default-server-location)
|
||
(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" . ,(and ipv4 #t))
|
||
("enable_ipv6" . ,(and ipv6 #t))
|
||
,@(if (integer? ipv4) `(("ipv4" . ,ipv4)) '())
|
||
,@(if (integer? ipv6) `(("ipv6" . ,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-primary-ips api . options)
|
||
"Get Primary IPs from the Hetzner API."
|
||
(apply hetzner-api-list api "/primary_ips" "primary_ips"
|
||
json->hetzner-primary-ip 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))
|