projects/guix·blob python-team · refs

771 lines · 29.9 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2024 Roman Scherer <[email protected]>
3;;; Copyright © 2026 Maxim Cournoyer <[email protected]>
4;;;
5;;; This file is part of GNU Guix.
6;;;
7;;; GNU Guix is free software; you can redistribute it and/or modify it
8;;; under the terms of the GNU General Public License as published by
9;;; the Free Software Foundation; either version 3 of the License, or (at
10;;; your option) any later version.
11;;;
12;;; GNU Guix is distributed in the hope that it will be useful, but
13;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;;; GNU General Public License for more details.
16;;;
17;;; You should have received a copy of the GNU General Public License
18;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19
20;;; Commentary:
21;;;
22;;; This module implements a lower-level interface for interacting with the
23;;; Hetzner Cloud API https://docs.hetzner.cloud.
24;;;
25
26(define-module (gnu machine hetzner http)
27 #:use-module (guix diagnostics)
28 #:use-module (guix i18n)
29 #:use-module (guix memoization)
30 #:use-module (guix records)
31 #:use-module (ice-9 iconv)
32 #:use-module (ice-9 match)
33 #:use-module (ice-9 pretty-print)
34 #:use-module (ice-9 textual-ports)
35 #:use-module (json)
36 #:use-module (rnrs bytevectors)
37 #:use-module (srfi srfi-1)
38 #:use-module (srfi srfi-2)
39 #:use-module (ssh key)
40 #:use-module (web client)
41 #:use-module (web request)
42 #:use-module (web response)
43 #:use-module (web uri)
44 #:export (%hetzner-default-api-token
45 %hetzner-default-server-image
46 %hetzner-default-server-location
47 %hetzner-default-server-type
48 hetzner-action
49 hetzner-action-command
50 hetzner-action-error
51 hetzner-action-finished
52 hetzner-action-id
53 hetzner-action-progress
54 hetzner-action-resources
55 hetzner-action-started
56 hetzner-action-status
57 hetzner-action?
58 hetzner-api
59 hetzner-api-action-wait
60 hetzner-api-actions
61 hetzner-api-create-ssh-key
62 hetzner-api-images
63 hetzner-api-locations
64 hetzner-api-primary-ips
65 hetzner-api-request-body
66 hetzner-api-request-headers
67 hetzner-api-request-method
68 hetzner-api-request-params
69 hetzner-api-request-send
70 hetzner-api-request-url
71 hetzner-api-request?
72 hetzner-api-response
73 hetzner-api-response-body
74 hetzner-api-response-headers
75 hetzner-api-response-status
76 hetzner-api-response?
77 hetzner-api-server-create
78 hetzner-api-server-delete
79 hetzner-api-server-enable-rescue-system
80 hetzner-api-server-power-off
81 hetzner-api-server-power-on
82 hetzner-api-server-reboot
83 hetzner-api-server-types
84 hetzner-api-servers
85 hetzner-api-ssh-key-create
86 hetzner-api-ssh-key-delete
87 hetzner-api-ssh-keys
88 hetzner-api-token
89 hetzner-api?
90 hetzner-error-code
91 hetzner-error-message
92 hetzner-error?
93 hetzner-image?
94 hetzner-image-id
95 hetzner-image-type
96 hetzner-image-status
97 hetzner-image-name
98 hetzner-image-description
99 hetzner-image-disk-size
100 hetzner-image-created
101 hetzner-image-created-from
102 hetzner-image-bound-to
103 hetzner-image-os-flavor
104 hetzner-image-os-version
105 hetzner-image-rapid-deploy
106 hetzner-image-protection
107 hetzner-image-deprecated
108 hetzner-image-deleted
109 hetzner-image-architecture
110 hetzner-ipv4-blocked?
111 hetzner-ipv4-dns-ptr
112 hetzner-ipv4-id
113 hetzner-ipv4-ip
114 hetzner-ipv4?
115 hetzner-ipv6-blocked?
116 hetzner-ipv6-dns-ptr
117 hetzner-ipv6-id
118 hetzner-ipv6-ip
119 hetzner-ipv6?
120 hetzner-location
121 hetzner-location-city
122 hetzner-location-country
123 hetzner-location-description
124 hetzner-location-id
125 hetzner-location-latitude
126 hetzner-location-longitude
127 hetzner-location-name
128 hetzner-location-network-zone
129 hetzner-location?
130 hetzner-primary-ip
131 hetzner-primary-ip-created
132 hetzner-primary-ip-id
133 hetzner-primary-ip-ip
134 hetzner-primary-ip-labels
135 hetzner-primary-ip-name
136 hetzner-primary-ip-type
137 hetzner-public-net
138 hetzner-public-net-ipv4
139 hetzner-public-net-ipv6
140 hetzner-resource
141 hetzner-resource-id
142 hetzner-resource-type
143 hetzner-resource?
144 hetzner-server-architecture
145 hetzner-server-created
146 hetzner-server-id
147 hetzner-server-labels
148 hetzner-server-name
149 hetzner-server-public-ipv4
150 hetzner-server-public-net
151 hetzner-server-rescue-enabled?
152 hetzner-server-system
153 hetzner-server-type
154 hetzner-server-type-architecture
155 hetzner-server-type-cores
156 hetzner-server-type-cpu-type
157 hetzner-server-type-deprecated
158 hetzner-server-type-deprecation
159 hetzner-server-type-description
160 hetzner-server-type-disk
161 hetzner-server-type-id
162 hetzner-server-type-memory
163 hetzner-server-type-name
164 hetzner-server-type-storage-type
165 hetzner-server-type?
166 hetzner-server?
167 hetzner-ssh-key-created
168 hetzner-ssh-key-fingerprint
169 hetzner-ssh-key-id
170 hetzner-ssh-key-labels
171 hetzner-ssh-key-name
172 hetzner-ssh-key-public-key
173 hetzner-ssh-key-read-file
174 hetzner-ssh-key?
175 make-hetzner-action
176 make-hetzner-error
177 make-hetzner-image
178 make-hetzner-ipv4
179 make-hetzner-ipv6
180 make-hetzner-location
181 make-hetzner-public-net
182 make-hetzner-primary-ip
183 make-hetzner-resource
184 make-hetzner-server
185 make-hetzner-server-type
186 make-hetzner-ssh-key))
187
188(define %hetzner-default-api-token
189 (make-parameter (getenv "GUIX_HETZNER_API_TOKEN")))
190
191;; Ideally this would be a Guix image. Maybe one day.
192(define %hetzner-default-server-image
193 (mlambda (api)
194 "Return the latest Debian image available. This image gets used for the
195initial system provisioning phase, before Guix System takes over."
196 (let ((debian-images (filter (lambda (image)
197 (string=? "debian"
198 (hetzner-image-os-flavor image)))
199 (hetzner-api-images api))))
200 (hetzner-image-name
201 (last (sort debian-images
202 (lambda (x y)
203 (< (string->number (hetzner-image-os-version x))
204 (string->number (hetzner-image-os-version y))))))))))
205
206;; Falkenstein, Germany
207(define %hetzner-default-server-location "fsn1")
208
209;; x86, 8 VCPUs, 16 GB mem, 160 GB disk
210(define %hetzner-default-server-type "cx42")
211
212
213;;;
214;;; Helper functions.
215;;;
216
217(define (format-query-param param)
218 "Format the query PARAM as a string."
219 (string-append (uri-encode (format #f "~a" (car param))) "="
220 (uri-encode (format #f "~a" (cdr param)))))
221
222(define (format-query-params params)
223 "Format the query PARAMS as a string."
224 (if (> (length params) 0)
225 (string-append
226 "?"
227 (string-join
228 (map format-query-param params)
229 "&"))
230 ""))
231
232(define (json->maybe-hetzner-error json)
233 (and (list? json) (json->hetzner-error json)))
234
235(define (string->time s)
236 (when (string? s) (car (strptime "%FT%T%z" s))))
237
238(define (json->hetzner-dnses vector)
239 (map json->hetzner-dns (vector->list vector)))
240
241(define (json->hetzner-resources vector)
242 (map json->hetzner-resource (vector->list vector)))
243
244
245;;;
246;;; Domain models.
247;;;
248
249(define-json-mapping <hetzner-action>
250 make-hetzner-action hetzner-action? json->hetzner-action
251 (command hetzner-action-command) ; string
252 (error hetzner-action-error "error"
253 json->maybe-hetzner-error) ; <hetzner-error> | #f
254 (finished hetzner-action-finished "finished" string->time) ; time
255 (id hetzner-action-id) ; integer
256 (progress hetzner-action-progress) ; integer
257 (resources hetzner-action-resources "resources"
258 json->hetzner-resources) ; list of <hetzner-resource>
259 (started hetzner-action-started "started" string->time) ; time
260 (status hetzner-action-status))
261
262(define-json-mapping <hetzner-deprecation>
263 make-hetzner-deprecation hetzner-deprecation? json->hetzner-deprecation
264 (announced hetzner-deprecation-announced) ; string
265 (unavailable-after hetzner-deprecation-unavailable-after
266 "unavailable_after")) ; string
267
268(define-json-mapping <hetzner-dns>
269 make-hetzner-dns hetzner-dns? json->hetzner-dns
270 (ip hetzner-dns-ip) ; string
271 (ptr hetzner-dns-ptr "dns_ptr")) ; string
272
273(define-json-mapping <hetzner-error>
274 make-hetzner-error hetzner-error? json->hetzner-error
275 (code hetzner-error-code) ; string
276 (message hetzner-error-message)) ; <string>
277
278(define-json-mapping <hetzner-ipv4>
279 make-hetzner-ipv4 hetzner-ipv4? json->hetzner-ipv4
280 (blocked? hetzner-ipv4-blocked? "blocked") ; boolean
281 (dns-ptr hetzner-ipv4-dns-ptr "dns_ptr") ; string
282 (id hetzner-ipv4-id) ; integer
283 (ip hetzner-ipv4-ip)) ; string
284
285(define-json-mapping <hetzner-ipv6>
286 make-hetzner-ipv6 hetzner-ipv6? json->hetzner-ipv6
287 (blocked? hetzner-ipv6-blocked? "blocked") ; boolean
288 (dns-ptr hetzner-ipv6-dns-ptr "dns_ptr"
289 json->hetzner-dnses) ; list of <hetzner-dns>
290 (id hetzner-ipv6-id) ; integer
291 (ip hetzner-ipv6-ip)) ; string
292
293(define-json-mapping <hetzner-location>
294 make-hetzner-location hetzner-location? json->hetzner-location
295 (city hetzner-location-city) ; string
296 (country hetzner-location-country) ; string
297 (description hetzner-location-description) ; string
298 (id hetzner-location-id) ; integer
299 (latitude hetzner-location-latitude) ; decimal
300 (longitude hetzner-location-longitude) ; decimal
301 (name hetzner-location-name) ; string
302 (network-zone hetzner-location-network-zone "network_zone"))
303
304(define-json-mapping <hetzner-public-net>
305 make-hetzner-public-net hetzner-public-net? json->hetzner-public-net
306 (ipv4 hetzner-public-net-ipv4 "ipv4" json->hetzner-ipv4) ; <hetzner-ipv4>
307 (ipv6 hetzner-public-net-ipv6 "ipv6" json->hetzner-ipv6)) ; <hetzner-ipv6>
308
309(define-json-mapping <hetzner-resource>
310 make-hetzner-resource hetzner-resource? json->hetzner-resource
311 (id hetzner-resource-id) ; integer
312 (type hetzner-resource-type)) ; string
313
314(define-json-mapping <hetzner-server>
315 make-hetzner-server hetzner-server? json->hetzner-server
316 (created hetzner-server-created) ; time
317 (id hetzner-server-id) ; integer
318 (labels hetzner-server-labels) ; alist of string/string
319 (name hetzner-server-name) ; string
320 (public-net hetzner-server-public-net "public_net"
321 json->hetzner-public-net) ; <hetzner-public-net>
322 (rescue-enabled? hetzner-server-rescue-enabled? "rescue_enabled") ; boolean
323 (server-type hetzner-server-type "server_type"
324 json->hetzner-server-type)) ; <hetzner-server-type>
325
326(define-json-mapping <hetzner-image>
327 make-hetzner-image hetzner-image? json->hetzner-image
328 (id hetzner-image-id) ;integer
329 (type hetzner-image-type) ;string
330 (status hetzner-image-status) ;string
331 (name hetzner-image-name "name" (null-or identity)) ;string | null
332 (description hetzner-image-description) ;string
333 (image-size hetzner-image-size "image_size" ;number | null (GiB)
334 (null-or identity))
335 (disk-size hetzner-image-disk-size "disk_size") ;number (GiB)
336 (created hetzner-image-created) ;string (date)
337 (created-from hetzner-image-created-from "created_from" ;object | null
338 (null-or json->hetzner-image-created-from))
339 (bound-to hetzner-image-bound-to "bound_to" (null-or identity)) ;integer | null
340 (os-flavor hetzner-image-os-flavor "os_flavor") ;string
341 (os-version hetzner-image-os-version "os_version" ;string | null
342 (null-or identity))
343 (rapid-deploy hetzner-image-rapid-deploy "rapid_deploy") ;boolean
344 (protection hetzner-image-protection "protection" ;object
345 json->hetzner-image-protection)
346 (deprecated hetzner-image-deprecated) ;string
347 (deleted hetzner-image-deleted "deleted" (null-or identity)) ;null | string
348 (architecture hetzner-image-architecture)) ;string
349
350(define (null-or parser)
351 (lambda (value)
352 (if (eq? 'null value)
353 *unspecified*
354 (parser value))))
355
356(define-json-type <hetzner-image-created-from>
357 (id) ;integer
358 (name)) ;string
359
360(define-json-type <hetzner-image-protection>
361 (delete)) ;boolean
362
363(define-json-mapping <hetzner-server-type>
364 make-hetzner-server-type hetzner-server-type? json->hetzner-server-type
365 (architecture hetzner-server-type-architecture) ; string
366 (cores hetzner-server-type-cores) ; integer
367 (cpu-type hetzner-server-type-cpu-type "cpu_type") ; string
368 (deprecated hetzner-server-type-deprecated) ; boolean
369 (deprecation hetzner-server-type-deprecation
370 json->hetzner-deprecation) ; <hetzner-deprecation>
371 (description hetzner-server-type-description) ; string
372 (disk hetzner-server-type-disk) ; integer
373 (id hetzner-server-type-id) ; integer
374 (memory hetzner-server-type-memory) ; integer
375 (name hetzner-server-type-name) ; string
376 (storage-type hetzner-server-type-storage-type "storage_type")) ; string
377
378;; Reserved IP address. https://docs.hetzner.cloud/#primary-ips
379(define-json-mapping <hetzner-primary-ip>
380 make-hetzner-primary-ip hetzner-primary-ip? json->hetzner-primary-ip
381 (created hetzner-primary-ip-created "created" string->time) ; time
382 (id hetzner-primary-ip-id) ; integer
383 (ip hetzner-primary-ip-ip) ; string
384 (labels hetzner-primary-ip-labels) ; alist of string/string
385 (name hetzner-primary-ip-name) ; string
386 (type hetzner-primary-ip-type)) ; string
387
388(define-json-mapping <hetzner-ssh-key>
389 make-hetzner-ssh-key hetzner-ssh-key? json->hetzner-ssh-key
390 (created hetzner-ssh-key-created "created" string->time) ; time
391 (fingerprint hetzner-ssh-key-fingerprint) ; string
392 (id hetzner-ssh-key-id) ; integer
393 (labels hetzner-ssh-key-labels) ; alist of string/string
394 (name hetzner-ssh-key-name) ; string
395 (public_key hetzner-ssh-key-public-key "public_key")) ; string
396
397(define (hetzner-server-architecture server)
398 "Return the architecture of the Hetzner SERVER."
399 (hetzner-server-type-architecture (hetzner-server-type server)))
400
401(define* (hetzner-server-path server #:optional (path ""))
402 "Return the PATH of the Hetzner SERVER."
403 (format #f "/servers/~a~a" (hetzner-server-id server) path))
404
405(define (hetzner-server-public-ipv4 server)
406 "Return the public IPv4 address of the SERVER."
407 (and-let* ((public-net (hetzner-server-public-net server))
408 (ipv4 (hetzner-public-net-ipv4 public-net)))
409 (hetzner-ipv4-ip ipv4)))
410
411(define (hetzner-server-system server)
412 "Return the Guix system architecture of the Hetzner SERVER."
413 (match (hetzner-server-architecture server)
414 ("arm" "aarch64-linux")
415 ("x86" "x86_64-linux")))
416
417(define* (hetzner-ssh-key-path ssh-key #:optional (path ""))
418 "Return the PATH of the Hetzner SSH-KEY."
419 (format #f "/ssh_keys/~a~a" (hetzner-ssh-key-id ssh-key) path))
420
421(define (hetzner-ssh-key-read-file file)
422 "Read the SSH private key from FILE and return a Hetzner SSH key."
423 (let* ((privkey (private-key-from-file file))
424 (pubkey (private-key->public-key privkey))
425 (hash (get-public-key-hash pubkey 'md5))
426 (fingerprint (bytevector->hex-string hash))
427 (public-key (format #f "ssh-~a ~a" (get-key-type pubkey)
428 (public-key->string pubkey))))
429 (make-hetzner-ssh-key #f fingerprint #f '() (basename file) public-key)))
430
431
432;;;
433;;; Hetzner API response.
434;;;
435
436(define-record-type* <hetzner-api-response>
437 hetzner-api-response make-hetzner-api-response hetzner-api-response?
438 (body hetzner-api-response-body (default *unspecified*))
439 (headers hetzner-api-response-headers (default '()))
440 (status hetzner-api-response-status (default 200)))
441
442(define (hetzner-api-response-meta response)
443 "Return the meta information of the Hetzner API response."
444 (assoc-ref (hetzner-api-response-body response) "meta"))
445
446(define (hetzner-api-response-pagination response)
447 "Return the meta information of the Hetzner API response."
448 (assoc-ref (hetzner-api-response-meta response) "pagination"))
449
450(define (hetzner-api-response-pagination-combine resource responses)
451 "Combine multiple Hetzner API pagination responses into a single response."
452 (if (positive? (length responses))
453 (let* ((response (car responses))
454 (pagination (hetzner-api-response-pagination response))
455 (total-entries (assoc-ref pagination "total_entries")))
456 (hetzner-api-response
457 (inherit response)
458 (body `(("meta"
459 ("pagination"
460 ("last_page" . 1)
461 ("next_page" . null)
462 ("page" . 1)
463 ("per_page" . ,total-entries)
464 ("previous_page" . null)
465 ("total_entries" . ,total-entries)))
466 (,resource . ,(append-map
467 (lambda (body)
468 (vector->list (assoc-ref body resource)))
469 (map hetzner-api-response-body responses)))))))
470 (raise-exception
471 (formatted-message
472 (G_ "expected a list of Hetzner API responses")))))
473
474(define (hetzner-api-body-action body)
475 "Return the Hetzner API action from BODY."
476 (let ((json (assoc-ref body "action")))
477 (and json (json->hetzner-action json))))
478
479(define (hetzner-api-response-read port)
480 "Read the Hetzner API response from PORT."
481 (let* ((response (read-response port))
482 (body (read-response-body response)))
483 (hetzner-api-response
484 (body (and body (json-string->scm (utf8->string body))))
485 (headers (response-headers response))
486 (status (response-code response)))))
487
488(define (hetzner-api-response-validate-status response expected)
489 "Raise an error if the HTTP status code of RESPONSE is not in EXPECTED."
490 (when (not (member (hetzner-api-response-status response) expected))
491 (raise-exception
492 (formatted-message
493 (G_ "unexpected HTTP status code: ~a, expected: ~a~%~a")
494 (hetzner-api-response-status response)
495 expected
496 (with-output-to-string
497 (lambda ()
498 (pretty-print (hetzner-api-response-body response))))))))
499
500
501;;;
502;;; Hetzner API request.
503;;;
504
505(define-record-type* <hetzner-api-request>
506 hetzner-api-request make-hetzner-api-request hetzner-api-request?
507 (body hetzner-api-request-body (default *unspecified*))
508 (headers hetzner-api-request-headers (default '()))
509 (method hetzner-api-request-method (default 'GET))
510 (params hetzner-api-request-params (default '()))
511 (url hetzner-api-request-url))
512
513(define (hetzner-api-request-uri request)
514 "Return the URI object of the Hetzner API request."
515 (let ((params (hetzner-api-request-params request)))
516 (string->uri (string-append (hetzner-api-request-url request)
517 (format-query-params params)))))
518
519(define (hetzner-api-request-body-bytevector request)
520 "Return the body of the Hetzner API REQUEST as a bytevector."
521 (let ((body (hetzner-api-request-body request)))
522 (string->utf8 (if (unspecified? body) "" (scm->json-string body)))))
523
524(define (hetzner-api-request-write port request)
525 "Write the Hetzner API REQUEST to PORT."
526 (let* ((body (hetzner-api-request-body-bytevector request))
527 (request (build-request
528 (hetzner-api-request-uri request)
529 #:method (hetzner-api-request-method request)
530 #:version '(1 . 1)
531 #:headers (cons* `(Content-Length
532 . ,(number->string
533 (if (unspecified? body)
534 0 (bytevector-length body))))
535 (hetzner-api-request-headers request))
536 #:port port))
537 (request (write-request request port)))
538 (unless (unspecified? body)
539 (write-request-body request body))
540 (force-output (request-port request))))
541
542(define* (hetzner-api-request-send request #:key (expected (list 200 201 204)))
543 "Send the Hetzner API REQUEST via HTTP."
544 (let ((port (open-socket-for-uri (hetzner-api-request-uri request))))
545 (hetzner-api-request-write port request)
546 (let ((response (hetzner-api-response-read port)))
547 (close-port port)
548 (hetzner-api-response-validate-status response expected)
549 response)))
550
551;; Prevent compiler from inlining this function, so we can mock it in tests.
552(set! hetzner-api-request-send hetzner-api-request-send)
553
554(define (hetzner-api-request-next-params request)
555 "Return the pagination params for the next page of the REQUEST."
556 (let* ((params (hetzner-api-request-params request))
557 (page (or (assoc-ref params "page") 1)))
558 (map (lambda (param)
559 (if (equal? "page" (car param))
560 (cons (car param) (+ page 1))
561 param))
562 params)))
563
564(define (hetzner-api-request-paginate request)
565 "Fetch all pages of the REQUEST via pagination and return all responses."
566 (let* ((response (hetzner-api-request-send request))
567 (pagination (hetzner-api-response-pagination response))
568 (next-page (assoc-ref pagination "next_page")))
569 (if (number? next-page)
570 (cons response
571 (hetzner-api-request-paginate
572 (hetzner-api-request
573 (inherit request)
574 (params (hetzner-api-request-next-params request)))))
575 (list response))))
576
577
578
579;;;
580;;; Hetzner API.
581;;;
582
583(define-record-type* <hetzner-api>
584 hetzner-api make-hetzner-api hetzner-api?
585 (base-url hetzner-api-base-url ; string
586 (default "https://api.hetzner.cloud/v1"))
587 (token hetzner-api-token ; string
588 (default (%hetzner-default-api-token))))
589
590(define (hetzner-api-authorization-header api)
591 "Return the authorization header for the Hetzner API."
592 (format #f "Bearer ~a" (hetzner-api-token api)))
593
594(define (hetzner-api-default-headers api)
595 "Returns the default headers of the Hetzner API."
596 `((user-agent . "Guix Deploy")
597 (Accept . "application/json")
598 (Authorization . ,(hetzner-api-authorization-header api))
599 (Content-Type . "application/json")))
600
601(define (hetzner-api-url api path)
602 "Append PATH to the base url of the Hetzner API."
603 (string-append (hetzner-api-base-url api) path))
604
605(define (hetzner-api-delete api path)
606 "Delete the resource at PATH with the Hetzner API."
607 (hetzner-api-response-body
608 (hetzner-api-request-send
609 (hetzner-api-request
610 (headers (hetzner-api-default-headers api))
611 (method 'DELETE)
612 (url (hetzner-api-url api path))))))
613
614(define* (hetzner-api-list api path resources json->object #:key (params '()))
615 "Fetch all objects of RESOURCE from the Hetzner API."
616 (let ((body (hetzner-api-response-body
617 (hetzner-api-response-pagination-combine
618 resources (hetzner-api-request-paginate
619 (hetzner-api-request
620 (url (hetzner-api-url api path))
621 (headers (hetzner-api-default-headers api))
622 (params (cons '("page" . 1) params))))))))
623 (map json->object (assoc-ref body resources))))
624
625(define* (hetzner-api-post api path #:key (body *unspecified*))
626 "Send a POST request to the Hetzner API at PATH using BODY."
627 (hetzner-api-response-body
628 (hetzner-api-request-send
629 (hetzner-api-request
630 (body body)
631 (method 'POST)
632 (url (hetzner-api-url api path))
633 (headers (hetzner-api-default-headers api))))))
634
635(define (hetzner-api-actions api ids)
636 "Get actions from the Hetzner API."
637 (if (zero? (length ids))
638 (raise-exception
639 (formatted-message
640 (G_ "expected at least one action id, but got '~a'")
641 (length ids)))
642 (hetzner-api-list
643 api "/actions" "actions" json->hetzner-action
644 #:params `(("id" . ,(string-join (map number->string ids) ","))))))
645
646(define* (hetzner-api-action-wait api action #:optional (status "success"))
647 "Wait until the ACTION has reached STATUS on the Hetzner API."
648 (let ((id (hetzner-action-id action)))
649 (let loop ()
650 (let ((actions (hetzner-api-actions api (list id))))
651 (cond
652 ((zero? (length actions))
653 (raise-exception
654 (formatted-message (G_ "server action '~a' not found") id)))
655 ((not (= 1 (length actions)))
656 (raise-exception
657 (formatted-message
658 (G_ "expected one server action, but got '~a'")
659 (length actions))))
660 ((string= status (hetzner-action-status (car actions)))
661 (car actions))
662 (else
663 (sleep 5)
664 (loop)))))))
665
666(define* (hetzner-api-locations api . options)
667 "Get deployment locations from the Hetzner API."
668 (apply hetzner-api-list api "/locations" "locations" json->hetzner-location options))
669
670(define* (hetzner-api-server-create
671 api name #:key
672 ssh-keys
673 (ipv4 #f)
674 (ipv6 #f)
675 (image (%hetzner-default-server-image api))
676 (labels '())
677 (location %hetzner-default-server-location)
678 (server-type %hetzner-default-server-type)
679 (start-after-create? #f))
680 "Create a server with the Hetzner API."
681 (let ((body (hetzner-api-post
682 api "/servers"
683 #:body `(("image" . ,image)
684 ("labels" . ,labels)
685 ("name" . ,name)
686 ("public_net" .
687 (("enable_ipv4" . ,(and ipv4 #t))
688 ("enable_ipv6" . ,(and ipv6 #t))
689 ,@(if (integer? ipv4) `(("ipv4" . ,ipv4)) '())
690 ,@(if (integer? ipv6) `(("ipv6" . ,ipv6)) '())))
691 ("location" . ,location)
692 ("server_type" . ,server-type)
693 ,@(if ssh-keys
694 `(("ssh_keys" .
695 ,(apply vector (map hetzner-ssh-key-id
696 ssh-keys))))
697 '())
698 ("start_after_create" . ,start-after-create?)))))
699 (hetzner-api-action-wait api (hetzner-api-body-action body))
700 (json->hetzner-server (assoc-ref body "server"))))
701
702(define (hetzner-api-server-delete api server)
703 "Delete the SERVER with the Hetzner API."
704 (let ((body (hetzner-api-delete api (hetzner-server-path server))))
705 (hetzner-api-action-wait api (hetzner-api-body-action body))))
706
707(define* (hetzner-api-server-enable-rescue-system
708 api server #:key ssh-keys (type "linux64"))
709 "Enable the rescue system for SERVER with the Hetzner API."
710 (let* ((ssh-keys (and ssh-keys
711 (apply vector (map hetzner-ssh-key-id ssh-keys))))
712 (body (hetzner-api-post
713 api (hetzner-server-path server "/actions/enable_rescue")
714 #:body `(,@(if ssh-keys
715 `(("ssh_keys" . ,ssh-keys))
716 '())
717 ("type" . ,type)))))
718 (hetzner-api-action-wait api (hetzner-api-body-action body))))
719
720(define* (hetzner-api-servers api . options)
721 "Get servers from the Hetzner API."
722 (apply hetzner-api-list api "/servers" "servers" json->hetzner-server options))
723
724(define (hetzner-api-server-power-on api server)
725 "Send a power on request for SERVER to the Hetzner API."
726 (let ((body (hetzner-api-post api (hetzner-server-path server "/actions/poweron"))))
727 (hetzner-api-action-wait api (hetzner-api-body-action body))))
728
729(define (hetzner-api-server-power-off api server)
730 "Send a power off request for SERVER to the Hetzner API."
731 (let ((body (hetzner-api-post api (hetzner-server-path server "/actions/poweroff"))))
732 (hetzner-api-action-wait api (hetzner-api-body-action body))))
733
734(define (hetzner-api-server-reboot api server)
735 "Send a reboot request for SERVER to the Hetzner API."
736 (let ((body (hetzner-api-post api (hetzner-server-path server "/actions/reboot"))))
737 (hetzner-api-action-wait api (hetzner-api-body-action body))))
738
739(define* (hetzner-api-ssh-key-create api name public-key #:key (labels '()))
740 "Create a SSH key with the Hetzner API."
741 (let ((body (hetzner-api-post
742 api "/ssh_keys"
743 #:body `(("name" . ,name)
744 ("public_key" . ,public-key)
745 ("labels" . ,labels)))))
746 (json->hetzner-ssh-key (assoc-ref body "ssh_key"))))
747
748(define (hetzner-api-ssh-key-delete api ssh-key)
749 "Delete the SSH key on the Hetzner API."
750 (hetzner-api-delete api (hetzner-ssh-key-path ssh-key))
751 #t)
752
753(define* (hetzner-api-ssh-keys api . options)
754 "Get SSH keys from the Hetzner API."
755 (apply hetzner-api-list api "/ssh_keys" "ssh_keys"
756 json->hetzner-ssh-key options))
757
758(define* (hetzner-api-primary-ips api . options)
759 "Get Primary IPs from the Hetzner API."
760 (apply hetzner-api-list api "/primary_ips" "primary_ips"
761 json->hetzner-primary-ip options))
762
763(define* (hetzner-api-server-types api . options)
764 "Get server types from the Hetzner API."
765 (apply hetzner-api-list api "/server_types" "server_types"
766 json->hetzner-server-type options))
767
768(define* (hetzner-api-images api . options)
769 "Get image types from the Hetzner API."
770 (apply hetzner-api-list api "/images" "images"
771 json->hetzner-image options))