summaryrefslogtreecommitdiff
path: root/gnu
diff options
context:
space:
mode:
authorRoman Scherer <roman@burningswell.com>2025-02-04 20:01:14 +0100
committerLudovic Courtès <ludo@gnu.org>2025-02-09 18:20:42 +0100
commit0753a17ddf6f4fab98b93c25f1a93b97ff9e46bb (patch)
treee56f2bcb4c52186364ee63a065bc6a20a2e252be /gnu
parent96f05f003a862c198e803901abf6f50b23969697 (diff)
machine: Implement 'hetzner-environment-type'.
* Makefile.am (SCM_TESTS): Add test modules. * doc/guix.texi: Add documentation. * gnu/local.mk (GNU_SYSTEM_MODULES): Add modules. * gnu/machine/hetzner.scm: Add hetzner-environment-type. * gnu/machine/hetzner/http.scm: Add HTTP API. * po/guix/POTFILES.in: Add Hetzner modules. * tests/machine/hetzner.scm: Add machine tests. * tests/machine/hetzner/http.scm Add HTTP API tests. Change-Id: I276ed5afed676bbccc6c852c56ee4db57ce3c1ea Signed-off-by: Ludovic Courtès <ludo@gnu.org>
Diffstat (limited to 'gnu')
-rw-r--r--gnu/local.mk2
-rw-r--r--gnu/machine/hetzner.scm705
-rw-r--r--gnu/machine/hetzner/http.scm664
3 files changed, 1371 insertions, 0 deletions
diff --git a/gnu/local.mk b/gnu/local.mk
index 3f18a510331..2d4608378b0 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -921,6 +921,8 @@ if HAVE_GUILE_SSH
921 921
922GNU_SYSTEM_MODULES += \ 922GNU_SYSTEM_MODULES += \
923 %D%/machine/digital-ocean.scm \ 923 %D%/machine/digital-ocean.scm \
924 %D%/machine/hetzner.scm \
925 %D%/machine/hetzner/http.scm \
924 %D%/machine/ssh.scm 926 %D%/machine/ssh.scm
925 927
926endif HAVE_GUILE_SSH 928endif HAVE_GUILE_SSH
diff --git a/gnu/machine/hetzner.scm b/gnu/machine/hetzner.scm
new file mode 100644
index 00000000000..5e17bfae215
--- /dev/null
+++ b/gnu/machine/hetzner.scm
@@ -0,0 +1,705 @@
1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2024 Roman Scherer <roman@burningswell.com>
3;;;
4;;; This file is part of GNU Guix.
5;;;
6;;; GNU Guix is free software; you can redistribute it and/or modify it
7;;; under the terms of the GNU General Public License as published by
8;;; the Free Software Foundation; either version 3 of the License, or (at
9;;; your option) any later version.
10;;;
11;;; GNU Guix is distributed in the hope that it will be useful, but
12;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
18
19(define-module (gnu machine hetzner)
20 #:use-module (gnu bootloader grub)
21 #:use-module (gnu bootloader)
22 #:use-module (gnu machine hetzner http)
23 #:use-module (gnu machine ssh)
24 #:use-module (gnu machine)
25 #:use-module (gnu packages ssh)
26 #:use-module (gnu services base)
27 #:use-module (gnu services networking)
28 #:use-module (gnu services ssh)
29 #:use-module (gnu services)
30 #:use-module (gnu system file-systems)
31 #:use-module (gnu system image)
32 #:use-module (gnu system linux-initrd)
33 #:use-module (gnu system pam)
34 #:use-module (gnu system)
35 #:use-module (guix base32)
36 #:use-module (guix colors)
37 #:use-module (guix derivations)
38 #:use-module (guix diagnostics)
39 #:use-module (guix gexp)
40 #:use-module (guix i18n)
41 #:use-module (guix import json)
42 #:use-module (guix monads)
43 #:use-module (guix packages)
44 #:use-module (guix pki)
45 #:use-module (guix records)
46 #:use-module (guix ssh)
47 #:use-module (guix store)
48 #:use-module (ice-9 format)
49 #:use-module (ice-9 iconv)
50 #:use-module (ice-9 match)
51 #:use-module (ice-9 popen)
52 #:use-module (ice-9 rdelim)
53 #:use-module (ice-9 string-fun)
54 #:use-module (ice-9 textual-ports)
55 #:use-module (json)
56 #:use-module (srfi srfi-1)
57 #:use-module (srfi srfi-2)
58 #:use-module (srfi srfi-34)
59 #:use-module (srfi srfi-35)
60 #:use-module (srfi srfi-71)
61 #:use-module (ssh channel)
62 #:use-module (ssh key)
63 #:use-module (ssh popen)
64 #:use-module (ssh session)
65 #:use-module (ssh sftp)
66 #:use-module (ssh shell)
67 #:export (%hetzner-os-arm
68 %hetzner-os-x86
69 deploy-hetzner
70 hetzner-configuration
71 hetzner-configuration-allow-downgrades?
72 hetzner-configuration-api
73 hetzner-configuration-authorize?
74 hetzner-configuration-build-locally?
75 hetzner-configuration-delete?
76 hetzner-configuration-labels
77 hetzner-configuration-location
78 hetzner-configuration-server-type
79 hetzner-configuration-ssh-key
80 hetzner-configuration?
81 hetzner-environment-type))
82
83;;; Commentary:
84;;;
85;;; This module implements a high-level interface for provisioning machines on
86;;; the Hetzner Cloud service https://docs.hetzner.cloud.
87;;;
88
89
90;;;
91;;; Hetzner operating systems.
92;;;
93
94;; Operating system for arm servers using UEFI boot mode.
95
96(define %hetzner-os-arm
97 (operating-system
98 (host-name "guix-arm")
99 (bootloader
100 (bootloader-configuration
101 (bootloader grub-efi-bootloader)
102 (targets (list "/boot/efi"))
103 (terminal-outputs '(console))))
104 (file-systems
105 (cons* (file-system
106 (mount-point "/")
107 (device "/dev/sda1")
108 (type "ext4"))
109 (file-system
110 (mount-point "/boot/efi")
111 (device "/dev/sda15")
112 (type "vfat"))
113 %base-file-systems))
114 (initrd-modules
115 (cons* "sd_mod" "virtio_scsi" %base-initrd-modules))
116 (services
117 (cons* (service dhcp-client-service-type)
118 (service openssh-service-type
119 (openssh-configuration
120 (openssh openssh-sans-x)
121 (permit-root-login 'prohibit-password)))
122 %base-services))))
123
124;; Operating system for x86 servers using BIOS boot mode.
125
126(define %hetzner-os-x86
127 (operating-system
128 (inherit %hetzner-os-arm)
129 (host-name "guix-x86")
130 (bootloader
131 (bootloader-configuration
132 (bootloader grub-bootloader)
133 (targets (list "/dev/sda"))
134 (terminal-outputs '(console))))
135 (initrd-modules
136 (cons "virtio_scsi" %base-initrd-modules))
137 (file-systems
138 (cons (file-system
139 (mount-point "/")
140 (device "/dev/sda1")
141 (type "ext4"))
142 %base-file-systems))))
143
144(define (operating-system-authorize os)
145 "Authorize the OS with the public signing key of the current machine."
146 (if (file-exists? %public-key-file)
147 (operating-system
148 (inherit os)
149 (services
150 (modify-services (operating-system-user-services os)
151 (guix-service-type
152 config => (guix-configuration
153 (inherit config)
154 (authorized-keys
155 (cons*
156 (local-file %public-key-file)
157 (guix-configuration-authorized-keys config))))))))
158 (raise-exception
159 (formatted-message (G_ "no signing key '~a'. \
160Have you run 'guix archive --generate-key'?")
161 %public-key-file))))
162
163(define (operating-system-root-file-system-type os)
164 "Return the root file system type of the operating system OS."
165 (let ((root-fs (find (lambda (file-system)
166 (equal? "/" (file-system-mount-point file-system)))
167 (operating-system-file-systems os))))
168 (if (file-system? root-fs)
169 (file-system-type root-fs)
170 (raise-exception
171 (formatted-message
172 (G_ "could not determine root file system type"))))))
173
174
175;;;
176;;; Helper functions.
177;;;
178
179(define (escape-backticks str)
180 "Escape all backticks in STR."
181 (string-replace-substring str "`" "\\`"))
182
183
184
185;;;
186;;; Hetzner configuration.
187;;;
188
189(define-record-type* <hetzner-configuration> hetzner-configuration
190 make-hetzner-configuration hetzner-configuration? this-hetzner-configuration
191 (allow-downgrades? hetzner-configuration-allow-downgrades? ; boolean
192 (default #f))
193 (api hetzner-configuration-api ; <hetzner-api>
194 (default (hetzner-api)))
195 (authorize? hetzner-configuration-authorize? ; boolean
196 (default #t))
197 (build-locally? hetzner-configuration-build-locally? ; boolean
198 (default #t))
199 (delete? hetzner-configuration-delete? ; boolean
200 (default #f))
201 (labels hetzner-configuration-labels ; list of strings
202 (default '()))
203 (location hetzner-configuration-location ; #f | string
204 (default "fsn1"))
205 (server-type hetzner-configuration-server-type ; string
206 (default "cx42"))
207 (ssh-key hetzner-configuration-ssh-key)) ; string
208
209(define (hetzner-configuration-ssh-key-fingerprint config)
210 "Return the SSH public key fingerprint of CONFIG as a string."
211 (and-let* ((file-name (hetzner-configuration-ssh-key config))
212 (privkey (private-key-from-file file-name))
213 (pubkey (private-key->public-key privkey))
214 (hash (get-public-key-hash pubkey 'md5)))
215 (bytevector->hex-string hash)))
216
217(define (hetzner-configuration-ssh-key-public config)
218 "Return the SSH public key of CONFIG as a string."
219 (and-let* ((ssh-key (hetzner-configuration-ssh-key config))
220 (public-key (public-key-from-file ssh-key)))
221 (format #f "ssh-~a ~a" (get-key-type public-key)
222 (public-key->string public-key))))
223
224
225;;;
226;;; Hetzner Machine.
227;;;
228
229(define (hetzner-machine-delegate target server)
230 "Return the delagate machine that uses SSH for deployment."
231 (let* ((config (machine-configuration target))
232 ;; Get the operating system WITHOUT the provenance service to avoid a
233 ;; duplicate symlink conflict in the store.
234 (os ((@@ (gnu machine) %machine-operating-system) target)))
235 (machine
236 (inherit target)
237 (operating-system
238 (if (hetzner-configuration-authorize? config)
239 (operating-system-authorize os)
240 os))
241 (environment managed-host-environment-type)
242 (configuration
243 (machine-ssh-configuration
244 (allow-downgrades? (hetzner-configuration-allow-downgrades? config))
245 (authorize? (hetzner-configuration-authorize? config))
246 (build-locally? (hetzner-configuration-build-locally? config))
247 (host-name (hetzner-server-public-ipv4 server))
248 (identity (hetzner-configuration-ssh-key config))
249 (system (hetzner-server-system server)))))))
250
251(define (hetzner-machine-location machine)
252 "Find the location of MACHINE on the Hetzner API."
253 (let* ((config (machine-configuration machine))
254 (expected (hetzner-configuration-location config)))
255 (find (lambda (location)
256 (equal? expected (hetzner-location-name location)))
257 (hetzner-api-locations
258 (hetzner-configuration-api config)
259 #:params `(("name" . ,expected))))))
260
261(define (hetzner-machine-server-type machine)
262 "Find the server type of MACHINE on the Hetzner API."
263 (let* ((config (machine-configuration machine))
264 (expected (hetzner-configuration-server-type config)))
265 (find (lambda (server-type)
266 (equal? expected (hetzner-server-type-name server-type)))
267 (hetzner-api-server-types
268 (hetzner-configuration-api config)
269 #:params `(("name" . ,expected))))))
270
271(define (hetzner-machine-validate-api-token machine)
272 "Validate the Hetzner API authentication token of MACHINE."
273 (let* ((config (machine-configuration machine))
274 (api (hetzner-configuration-api config)))
275 (unless (hetzner-api-token api)
276 (raise-exception
277 (formatted-message
278 (G_ "Hetzner Cloud access token was not provided. \
279This may be fixed by setting the environment variable GUIX_HETZNER_API_TOKEN \
280to one procured from \
281https://docs.hetzner.com/cloud/api/getting-started/generating-api-token"))))))
282
283(define (hetzner-machine-validate-configuration-type machine)
284 "Raise an error if MACHINE's configuration is not an instance of
285<hetzner-configuration>."
286 (let ((config (machine-configuration machine))
287 (environment (environment-type-name (machine-environment machine))))
288 (unless (and config (hetzner-configuration? config))
289 (raise-exception
290 (formatted-message (G_ "unsupported machine configuration '~a' \
291for environment of type '~a'")
292 config
293 environment)))))
294
295(define (hetzner-machine-validate-server-type machine)
296 "Raise an error if the server type of MACHINE is not supported."
297 (unless (hetzner-machine-server-type machine)
298 (let* ((config (machine-configuration machine))
299 (api (hetzner-configuration-api config)))
300 (raise-exception
301 (formatted-message
302 (G_ "server type '~a' not supported~%~%\
303Available server types:~%~%~a~%~%For more details and prices, see: ~a")
304 (hetzner-configuration-server-type config)
305 (string-join
306 (map (lambda (type)
307 (format #f " - ~a: ~a, ~a ~a cores, ~a GB mem, ~a GB disk"
308 (colorize-string
309 (hetzner-server-type-name type)
310 (color BOLD))
311 (hetzner-server-type-architecture type)
312 (hetzner-server-type-cores type)
313 (hetzner-server-type-cpu-type type)
314 (hetzner-server-type-memory type)
315 (hetzner-server-type-disk type)))
316 (hetzner-api-server-types api))
317 "\n")
318 "https://www.hetzner.com/cloud#pricing")))))
319
320(define (hetzner-machine-validate-location machine)
321 "Raise an error if the location of MACHINE is not supported."
322 (unless (hetzner-machine-location machine)
323 (let* ((config (machine-configuration machine))
324 (api (hetzner-configuration-api config)))
325 (raise-exception
326 (formatted-message
327 (G_ "server location '~a' not supported~%~%\
328Available locations:~%~%~a~%~%For more details, see: ~a")
329 (hetzner-configuration-location config)
330 (string-join
331 (map (lambda (location)
332 (format #f " - ~a: ~a, ~a"
333 (colorize-string
334 (hetzner-location-name location)
335 (color BOLD))
336 (hetzner-location-description location)
337 (hetzner-location-country location)))
338 (hetzner-api-locations api))
339 "\n")
340 "https://www.hetzner.com/cloud#locations")))))
341
342(define (hetzner-machine-validate machine)
343 "Validate the Hetzner MACHINE."
344 (hetzner-machine-validate-configuration-type machine)
345 (hetzner-machine-validate-api-token machine)
346 (hetzner-machine-validate-location machine)
347 (hetzner-machine-validate-server-type machine))
348
349(define (hetzner-machine-bootstrap-os-form machine server)
350 "Return the form to bootstrap an operating system on SERVER."
351 (let* ((os (machine-operating-system machine))
352 (system (hetzner-server-system server))
353 (arm? (equal? "arm" (hetzner-server-architecture server)))
354 (x86? (equal? "x86" (hetzner-server-architecture server)))
355 (root-fs-type (operating-system-root-file-system-type os)))
356 `(operating-system
357 (host-name ,(operating-system-host-name os))
358 (timezone "Etc/UTC")
359 (bootloader (bootloader-configuration
360 (bootloader ,(cond (arm? 'grub-efi-bootloader)
361 (x86? 'grub-bootloader)))
362 (targets ,(cond (arm? '(list "/boot/efi"))
363 (x86? '(list "/dev/sda"))))
364 (terminal-outputs '(console))))
365 (initrd-modules (append
366 ,(cond (arm? '(list "sd_mod" "virtio_scsi"))
367 (x86? '(list "virtio_scsi")))
368 %base-initrd-modules))
369 (file-systems ,(cond
370 (arm? `(cons* (file-system
371 (mount-point "/")
372 (device "/dev/sda1")
373 (type ,root-fs-type))
374 (file-system
375 (mount-point "/boot/efi")
376 (device "/dev/sda15")
377 (type "vfat"))
378 %base-file-systems))
379 (x86? `(cons* (file-system
380 (mount-point "/")
381 (device "/dev/sda1")
382 (type ,root-fs-type))
383 %base-file-systems))))
384 (services
385 (cons* (service dhcp-client-service-type)
386 (service openssh-service-type
387 (openssh-configuration
388 (openssh openssh-sans-x)
389 (permit-root-login 'prohibit-password)))
390 %base-services)))))
391
392(define (rexec-verbose session cmd)
393 "Execute a command CMD on the remote side and print output. Return two
394values: list of output lines returned by CMD and its exit code."
395 (let* ((channel (open-remote-input-pipe session cmd))
396 (result (let loop ((line (read-line channel))
397 (result '()))
398 (if (eof-object? line)
399 (reverse result)
400 (begin
401 (display line)
402 (newline)
403 (loop (read-line channel)
404 (cons line result))))))
405 (exit-status (channel-get-exit-status channel)))
406 (close channel)
407 (values result exit-status)))
408
409(define (hetzner-machine-ssh-key machine)
410 "Find the SSH key for MACHINE on the Hetzner API."
411 (let* ((config (machine-configuration machine))
412 (expected (hetzner-configuration-ssh-key-fingerprint config)))
413 (find (lambda (ssh-key)
414 (equal? expected (hetzner-ssh-key-fingerprint ssh-key)))
415 (hetzner-api-ssh-keys
416 (hetzner-configuration-api config)
417 #:params `(("fingerprint" . ,expected))))))
418
419(define (hetzner-machine-ssh-key-create machine)
420 "Create the SSH key for MACHINE on the Hetzner API."
421 (let ((name (machine-display-name machine)))
422 (format #t "creating ssh key for '~a'...\n" name)
423 (let* ((config (machine-configuration machine))
424 (api (hetzner-configuration-api config))
425 (ssh-key (hetzner-api-ssh-key-create
426 (hetzner-configuration-api config)
427 (hetzner-configuration-ssh-key-fingerprint config)
428 (hetzner-configuration-ssh-key-public config)
429 #:labels (hetzner-configuration-labels config))))
430 (format #t "successfully created ssh key for '~a'\n" name)
431 ssh-key)))
432
433(define (hetzner-machine-server machine)
434 "Find the Hetzner server for MACHINE."
435 (let ((config (machine-configuration machine)))
436 (find (lambda (server)
437 (equal? (machine-display-name machine)
438 (hetzner-server-name server)))
439 (hetzner-api-servers
440 (hetzner-configuration-api config)
441 #:params `(("name" . ,(machine-display-name machine)))))))
442
443(define (hetzner-machine-create-server machine)
444 "Create the Hetzner server for MACHINE."
445 (let* ((config (machine-configuration machine))
446 (name (machine-display-name machine))
447 (server-type (hetzner-configuration-server-type config)))
448 (format #t "creating '~a' server for '~a'...\n" server-type name)
449 (let* ((ssh-key (hetzner-machine-ssh-key machine))
450 (api (hetzner-configuration-api config))
451 (server (hetzner-api-server-create
452 api
453 (machine-display-name machine)
454 (list ssh-key)
455 #:labels (hetzner-configuration-labels config)
456 #:location (hetzner-configuration-location config)
457 #:server-type (hetzner-configuration-server-type config)))
458 (architecture (hetzner-server-architecture server)))
459 (format #t "successfully created '~a' ~a server for '~a'\n"
460 server-type architecture name)
461 server)))
462
463(define (wait-for-ssh address ssh-key)
464 "Block until a SSH session can be made as 'root' with SSH-KEY at ADDRESS."
465 (format #t "connecting via SSH to '~a' using '~a'...\n" address ssh-key)
466 (let loop ()
467 (catch #t
468 (lambda ()
469 (open-ssh-session address #:user "root" #:identity ssh-key
470 #:strict-host-key-check? #f))
471 (lambda args
472 (let ((msg (cadr args)))
473 (if (formatted-message? msg)
474 (format #t "~a\n"
475 (string-trim-right
476 (apply format #f
477 (formatted-message-string msg)
478 (formatted-message-arguments msg))
479 #\newline))
480 (format #t "~a" args))
481 (sleep 5)
482 (loop))))))
483
484(define (hetzner-machine-wait-for-ssh machine server)
485 "Wait for SSH connection to be established with the specified machine."
486 (wait-for-ssh (hetzner-server-public-ipv4 server)
487 (hetzner-configuration-ssh-key
488 (machine-configuration machine))))
489
490(define (hetzner-machine-authenticate-host machine server)
491 "Add the host key of MACHINE to the list of known hosts."
492 (let ((ssh-session (hetzner-machine-wait-for-ssh machine server)))
493 (write-known-host! ssh-session)))
494
495(define (hetzner-machine-enable-rescue-system machine server)
496 "Enable the rescue system on the Hetzner SERVER for MACHINE."
497 (let* ((name (machine-display-name machine))
498 (config (machine-configuration machine))
499 (api (hetzner-configuration-api config))
500 (ssh-keys (list (hetzner-machine-ssh-key machine))))
501 (format #t "enabling rescue system on '~a'...\n" name)
502 (let ((action (hetzner-api-server-enable-rescue-system api server ssh-keys)))
503 (format #t "successfully enabled rescue system on '~a'\n" name)
504 action)))
505
506(define (hetzner-machine-power-on machine server)
507 "Power on the Hetzner SERVER for MACHINE."
508 (let* ((name (machine-display-name machine))
509 (config (machine-configuration machine))
510 (api (hetzner-configuration-api config)))
511 (format #t "powering on server for '~a'...\n" name)
512 (let ((action (hetzner-api-server-power-on api server)))
513 (format #t "successfully powered on server for '~a'\n" name)
514 action)))
515
516(define (hetzner-machine-ssh-run-script ssh-session name content)
517 (let ((sftp-session (make-sftp-session ssh-session)))
518 (rexec ssh-session (format #f "rm -f ~a" name))
519 (rexec ssh-session (format #f "mkdir -p ~a" (dirname name)))
520 (call-with-remote-output-file
521 sftp-session name
522 (lambda (port)
523 (display content port)))
524 (sftp-chmod sftp-session name 755)
525 (let ((lines exit-code (rexec-verbose ssh-session
526 (format #f "~a 2>&1" name))))
527 (if (zero? exit-code)
528 lines
529 (raise-exception
530 (formatted-message
531 (G_ "failed to run script '~a' on machine, exit code: '~a'")
532 name exit-code))))))
533
534;; Prevent compiler from inlining this function, so we can mock it in tests.
535(set! hetzner-machine-ssh-run-script hetzner-machine-ssh-run-script)
536
537(define (hetzner-machine-rescue-install-os machine ssh-session server)
538 (let ((name (machine-display-name machine))
539 (os (hetzner-machine-bootstrap-os-form machine server)))
540 (format #t "installing guix operating system on '~a'...\n" name)
541 (hetzner-machine-ssh-run-script
542 ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-install-os"
543 (format #f "#!/usr/bin/env bash
544set -eo pipefail
545mount /dev/sda1 /mnt
546mkdir -p /mnt/boot/efi
547mount /dev/sda15 /mnt/boot/efi
548
549mkdir --parents /mnt/root/.ssh
550chmod 700 /mnt/root/.ssh
551cp /root/.ssh/authorized_keys /mnt/root/.ssh/authorized_keys
552chmod 600 /mnt/root/.ssh/authorized_keys
553
554cat > /tmp/guix/deploy/hetzner-os.scm << EOF
555(use-modules (gnu) (guix utils))
556(use-package-modules ssh)
557(use-service-modules base networking ssh)
558(use-system-modules linux-initrd)
559~a
560EOF
561guix system init --verbosity=2 /tmp/guix/deploy/hetzner-os.scm /mnt"
562 (escape-backticks (format #f "~y" os))))
563 (format #t "successfully installed guix operating system on '~a'\n" name)))
564
565(define (hetzner-machine-reboot machine server)
566 "Reboot the Hetzner SERVER for MACHINE."
567 (let* ((name (machine-display-name machine))
568 (config (machine-configuration machine))
569 (api (hetzner-configuration-api config)))
570 (format #t "rebooting server for '~a'...\n" name)
571 (let ((action (hetzner-api-server-reboot api server)))
572 (format #t "successfully rebooted server for '~a'\n" name)
573 action)))
574
575(define (hetzner-machine-rescue-partition machine ssh-session)
576 "Setup the partitions of the Hetzner server for MACHINE using SSH-SESSION."
577 (let* ((name (machine-display-name machine))
578 (os (machine-operating-system machine))
579 (root-fs-type (operating-system-root-file-system-type os)))
580 (format #t "setting up partitions on '~a'...\n" name)
581 (hetzner-machine-ssh-run-script
582 ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-partition"
583 (format #f "#!/usr/bin/env bash
584set -eo pipefail
585growpart /dev/sda 1 || true
586~a
587fdisk -l /dev/sda"
588 (cond
589 ((equal? "btrfs" root-fs-type)
590 (format #f "mkfs.btrfs -L ~a -f /dev/sda1" root-label))
591 ((equal? "ext4" root-fs-type)
592 (format #f "mkfs.ext4 -L ~a -F /dev/sda1" root-label))
593 (else (raise-exception
594 (formatted-message
595 (G_ "unsupported root file system type '~a'")
596 root-fs-type))))))
597 (format #t "successfully setup partitions on '~a'\n" name)))
598
599(define (hetzner-machine-rescue-install-packages machine ssh-session)
600 "Install packages on the Hetzner server for MACHINE using SSH-SESSION."
601 (let ((name (machine-display-name machine)))
602 (format #t "installing rescue system packages on '~a'...\n" name)
603 (hetzner-machine-ssh-run-script
604 ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-install-packages"
605 (format #f "#!/usr/bin/env bash
606set -eo pipefail
607apt-get update
608apt-get install guix cloud-initramfs-growroot --assume-yes"))
609 (format #t "successfully installed rescue system packages on '~a'\n" name)))
610
611(define (hetzner-machine-delete machine server)
612 "Delete the Hetzner server for MACHINE."
613 (let* ((name (machine-display-name machine))
614 (config (machine-configuration machine))
615 (api (hetzner-configuration-api config)))
616 (format #t "deleting server for '~a'...\n" name)
617 (let ((action (hetzner-api-server-delete api server)))
618 (format #t "successfully deleted server for '~a'\n" name)
619 action)))
620
621(define (hetzner-machine-provision machine)
622 "Provision a server for MACHINE on the Hetzner Cloud service."
623 (with-exception-handler
624 (lambda (exception)
625 (let ((config (machine-configuration machine))
626 (server (hetzner-machine-server machine)))
627 (when (and server (hetzner-configuration-delete? config))
628 (hetzner-machine-delete machine server))
629 (raise-exception exception)))
630 (lambda ()
631 (let ((server (hetzner-machine-create-server machine)))
632 (hetzner-machine-enable-rescue-system machine server)
633 (hetzner-machine-power-on machine server)
634 (let ((ssh-session (hetzner-machine-wait-for-ssh machine server)))
635 (hetzner-machine-rescue-install-packages machine ssh-session)
636 (hetzner-machine-rescue-partition machine ssh-session)
637 (hetzner-machine-rescue-install-os machine ssh-session server)
638 (hetzner-machine-reboot machine server)
639 (sleep 5)
640 (hetzner-machine-authenticate-host machine server)
641 server)))
642 #:unwind? #t))
643
644(define (machine-not-provisioned machine)
645 (formatted-message
646 (G_ "no server provisioned for machine '~a' on the Hetzner Cloud service")
647 (machine-display-name machine)))
648
649
650;;;
651;;; Remote evaluation.
652;;;
653
654(define (hetzner-remote-eval machine exp)
655 "Internal implementation of 'machine-remote-eval' for MACHINE instances with
656an environment type of 'hetzner-environment-type'."
657 (hetzner-machine-validate machine)
658 (let ((server (hetzner-machine-server machine)))
659 (unless server (raise-exception (machine-not-provisioned machine)))
660 (machine-remote-eval (hetzner-machine-delegate machine server) exp)))
661
662
663
664;;;
665;;; System deployment.
666;;;
667
668(define (deploy-hetzner machine)
669 "Internal implementation of 'deploy-machine' for 'machine' instances with an
670environment type of 'hetzner-environment-type'."
671 (hetzner-machine-validate machine)
672 (unless (hetzner-machine-ssh-key machine)
673 (hetzner-machine-ssh-key-create machine))
674 (let ((server (or (hetzner-machine-server machine)
675 (hetzner-machine-provision machine))))
676 (deploy-machine (hetzner-machine-delegate machine server))))
677
678
679
680;;;
681;;; Roll-back.
682;;;
683
684(define (roll-back-hetzner machine)
685 "Internal implementation of 'roll-back-machine' for MACHINE instances with an
686environment type of 'hetzner-environment-type'."
687 (hetzner-machine-validate machine)
688 (let ((server (hetzner-machine-server machine)))
689 (unless server (raise-exception (machine-not-provisioned machine)))
690 (roll-back-machine (hetzner-machine-delegate machine server))))
691
692
693
694;;;
695;;; Environment type.
696;;;
697
698(define hetzner-environment-type
699 (environment-type
700 (machine-remote-eval hetzner-remote-eval)
701 (deploy-machine deploy-hetzner)
702 (roll-back-machine roll-back-hetzner)
703 (name 'hetzner-environment-type)
704 (description "Provisioning of virtual machine servers on the Hetzner Cloud
705service.")))
diff --git a/gnu/machine/hetzner/http.scm b/gnu/machine/hetzner/http.scm
new file mode 100644
index 00000000000..bfd65554721
--- /dev/null
+++ b/gnu/machine/hetzner/http.scm
@@ -0,0 +1,664 @@
1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2024 Roman Scherer <roman@burningswell.com>
3;;;
4;;; This file is part of GNU Guix.
5;;;
6;;; GNU Guix is free software; you can redistribute it and/or modify it
7;;; under the terms of the GNU General Public License as published by
8;;; the Free Software Foundation; either version 3 of the License, or (at
9;;; your option) any later version.
10;;;
11;;; GNU Guix is distributed in the hope that it will be useful, but
12;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
18
19(define-module (gnu machine hetzner http)
20 #:use-module (guix diagnostics)
21 #:use-module (guix i18n)
22 #:use-module (guix records)
23 #:use-module (ice-9 iconv)
24 #:use-module (ice-9 match)
25 #:use-module (ice-9 pretty-print)
26 #:use-module (ice-9 textual-ports)
27 #:use-module (json)
28 #:use-module (rnrs bytevectors)
29 #:use-module (srfi srfi-1)
30 #:use-module (srfi srfi-2)
31 #:use-module (ssh key)
32 #:use-module (web client)
33 #:use-module (web request)
34 #:use-module (web response)
35 #:use-module (web uri)
36 #:export (%hetzner-default-api-token
37 %hetzner-default-server-image
38 %hetzner-default-server-location
39 %hetzner-default-server-type
40 hetzner-action
41 hetzner-action-command
42 hetzner-action-error
43 hetzner-action-finished
44 hetzner-action-id
45 hetzner-action-progress
46 hetzner-action-resources
47 hetzner-action-started
48 hetzner-action-status
49 hetzner-action?
50 hetzner-api
51 hetzner-api-action-wait
52 hetzner-api-actions
53 hetzner-api-create-ssh-key
54 hetzner-api-locations
55 hetzner-api-request-body
56 hetzner-api-request-headers
57 hetzner-api-request-method
58 hetzner-api-request-params
59 hetzner-api-request-send
60 hetzner-api-request-url
61 hetzner-api-request?
62 hetzner-api-response
63 hetzner-api-response-body
64 hetzner-api-response-headers
65 hetzner-api-response-status
66 hetzner-api-response?
67 hetzner-api-server-create
68 hetzner-api-server-delete
69 hetzner-api-server-enable-rescue-system
70 hetzner-api-server-power-off
71 hetzner-api-server-power-on
72 hetzner-api-server-reboot
73 hetzner-api-server-types
74 hetzner-api-servers
75 hetzner-api-ssh-key-create
76 hetzner-api-ssh-key-delete
77 hetzner-api-ssh-keys
78 hetzner-api-token
79 hetzner-api?
80 hetzner-error-code
81 hetzner-error-message
82 hetzner-error?
83 hetzner-ipv4-blocked?
84 hetzner-ipv4-dns-ptr
85 hetzner-ipv4-id
86 hetzner-ipv4-ip
87 hetzner-ipv4?
88 hetzner-ipv6-blocked?
89 hetzner-ipv6-dns-ptr
90 hetzner-ipv6-id
91 hetzner-ipv6-ip
92 hetzner-ipv6?
93 hetzner-location
94 hetzner-location-city
95 hetzner-location-country
96 hetzner-location-description
97 hetzner-location-id
98 hetzner-location-latitude
99 hetzner-location-longitude
100 hetzner-location-name
101 hetzner-location-network-zone
102 hetzner-location?
103 hetzner-public-net
104 hetzner-public-net-ipv4
105 hetzner-public-net-ipv6
106 hetzner-resource
107 hetzner-resource-id
108 hetzner-resource-type
109 hetzner-resource?
110 hetzner-server-architecture
111 hetzner-server-created
112 hetzner-server-id
113 hetzner-server-labels
114 hetzner-server-name
115 hetzner-server-public-ipv4
116 hetzner-server-public-net
117 hetzner-server-rescue-enabled?
118 hetzner-server-system
119 hetzner-server-type
120 hetzner-server-type-architecture
121 hetzner-server-type-cores
122 hetzner-server-type-cpu-type
123 hetzner-server-type-deprecated
124 hetzner-server-type-deprecation
125 hetzner-server-type-description
126 hetzner-server-type-disk
127 hetzner-server-type-id
128 hetzner-server-type-memory
129 hetzner-server-type-name
130 hetzner-server-type-storage-type
131 hetzner-server-type?
132 hetzner-server?
133 hetzner-ssh-key-created
134 hetzner-ssh-key-fingerprint
135 hetzner-ssh-key-id
136 hetzner-ssh-key-labels
137 hetzner-ssh-key-name
138 hetzner-ssh-key-public-key
139 hetzner-ssh-key-read-file
140 hetzner-ssh-key?
141 make-hetzner-action
142 make-hetzner-error
143 make-hetzner-ipv4
144 make-hetzner-ipv6
145 make-hetzner-location
146 make-hetzner-public-net
147 make-hetzner-resource
148 make-hetzner-server
149 make-hetzner-server-type
150 make-hetzner-ssh-key))
151
152;;; Commentary:
153;;;
154;;; This module implements a lower-level interface for interacting with the
155;;; Hetzner Cloud API https://docs.hetzner.cloud.
156;;;
157
158(define %hetzner-default-api-token
159 (make-parameter (getenv "GUIX_HETZNER_API_TOKEN")))
160
161;; Ideally this would be a Guix image. Maybe one day.
162(define %hetzner-default-server-image "debian-11")
163
164;; Falkenstein, Germany
165(define %hetzner-default-server-location "fsn1")
166
167;; x86, 8 VCPUs, 16 GB mem, 160 GB disk
168(define %hetzner-default-server-type "cx42")
169
170
171;;;
172;;; Helper functions.
173;;;
174
175(define (format-query-param param)
176 "Format the query PARAM as a string."
177 (string-append (uri-encode (format #f "~a" (car param))) "="
178 (uri-encode (format #f "~a" (cdr param)))))
179
180(define (format-query-params params)
181 "Format the query PARAMS as a string."
182 (if (> (length params) 0)
183 (string-append
184 "?"
185 (string-join
186 (map format-query-param params)
187 "&"))
188 ""))
189
190(define (json->maybe-hetzner-error json)
191 (and (list? json) (json->hetzner-error json)))
192
193(define (string->time s)
194 (when (string? s) (car (strptime "%FT%T%z" s))))
195
196(define (json->hetzner-dnses vector)
197 (map json->hetzner-dns (vector->list vector)))
198
199(define (json->hetzner-resources vector)
200 (map json->hetzner-resource (vector->list vector)))
201
202
203;;;
204;;; Domain models.
205;;;
206
207(define-json-mapping <hetzner-action>
208 make-hetzner-action hetzner-action? json->hetzner-action
209 (command hetzner-action-command) ; string
210 (error hetzner-action-error "error"
211 json->maybe-hetzner-error) ; <hetzner-error> | #f
212 (finished hetzner-action-finished "finished" string->time) ; time
213 (id hetzner-action-id) ; integer
214 (progress hetzner-action-progress) ; integer
215 (resources hetzner-action-resources "resources"
216 json->hetzner-resources) ; list of <hetzner-resource>
217 (started hetzner-action-started "started" string->time) ; time
218 (status hetzner-action-status))
219
220(define-json-mapping <hetzner-deprecation>
221 make-hetzner-deprecation hetzner-deprecation? json->hetzner-deprecation
222 (announced hetzner-deprecation-announced) ; string
223 (unavailable-after hetzner-deprecation-unavailable-after
224 "unavailable_after")) ; string
225
226(define-json-mapping <hetzner-dns>
227 make-hetzner-dns hetzner-dns? json->hetzner-dns
228 (ip hetzner-dns-ip) ; string
229 (ptr hetzner-dns-ptr "dns_ptr")) ; string
230
231(define-json-mapping <hetzner-error>
232 make-hetzner-error hetzner-error? json->hetzner-error
233 (code hetzner-error-code) ; string
234 (message hetzner-error-message)) ; <string>
235
236(define-json-mapping <hetzner-ipv4>
237 make-hetzner-ipv4 hetzner-ipv4? json->hetzner-ipv4
238 (blocked? hetzner-ipv4-blocked? "blocked") ; boolean
239 (dns-ptr hetzner-ipv4-dns-ptr "dns_ptr") ; string
240 (id hetzner-ipv4-id) ; integer
241 (ip hetzner-ipv4-ip)) ; string
242
243(define-json-mapping <hetzner-ipv6>
244 make-hetzner-ipv6 hetzner-ipv6? json->hetzner-ipv6
245 (blocked? hetzner-ipv6-blocked? "blocked") ; boolean
246 (dns-ptr hetzner-ipv6-dns-ptr "dns_ptr"
247 json->hetzner-dnses) ; list of <hetzner-dns>
248 (id hetzner-ipv6-id) ; integer
249 (ip hetzner-ipv6-ip)) ; string
250
251(define-json-mapping <hetzner-location>
252 make-hetzner-location hetzner-location? json->hetzner-location
253 (city hetzner-location-city) ; string
254 (country hetzner-location-country) ; string
255 (description hetzner-location-description) ; string
256 (id hetzner-location-id) ; integer
257 (latitude hetzner-location-latitude) ; decimal
258 (longitude hetzner-location-longitude) ; decimal
259 (name hetzner-location-name) ; string
260 (network-zone hetzner-location-network-zone "network_zone"))
261
262(define-json-mapping <hetzner-public-net>
263 make-hetzner-public-net hetzner-public-net? json->hetzner-public-net
264 (ipv4 hetzner-public-net-ipv4 "ipv4" json->hetzner-ipv4) ; <hetzner-ipv4>
265 (ipv6 hetzner-public-net-ipv6 "ipv6" json->hetzner-ipv6)) ; <hetzner-ipv6>
266
267(define-json-mapping <hetzner-resource>
268 make-hetzner-resource hetzner-resource? json->hetzner-resource
269 (id hetzner-resource-id) ; integer
270 (type hetzner-resource-type)) ; string
271
272(define-json-mapping <hetzner-server>
273 make-hetzner-server hetzner-server? json->hetzner-server
274 (created hetzner-server-created) ; time
275 (id hetzner-server-id) ; integer
276 (labels hetzner-server-labels) ; alist of string/string
277 (name hetzner-server-name) ; string
278 (public-net hetzner-server-public-net "public_net"
279 json->hetzner-public-net) ; <hetzner-public-net>
280 (rescue-enabled? hetzner-server-rescue-enabled? "rescue_enabled") ; boolean
281 (server-type hetzner-server-type "server_type"
282 json->hetzner-server-type)) ; <hetzner-server-type>
283
284(define-json-mapping <hetzner-server-type>
285 make-hetzner-server-type hetzner-server-type? json->hetzner-server-type
286 (architecture hetzner-server-type-architecture) ; string
287 (cores hetzner-server-type-cores) ; integer
288 (cpu-type hetzner-server-type-cpu-type "cpu_type") ; string
289 (deprecated hetzner-server-type-deprecated) ; boolean
290 (deprecation hetzner-server-type-deprecation
291 json->hetzner-deprecation) ; <hetzner-deprecation>
292 (description hetzner-server-type-description) ; string
293 (disk hetzner-server-type-disk) ; integer
294 (id hetzner-server-type-id) ; integer
295 (memory hetzner-server-type-memory) ; integer
296 (name hetzner-server-type-name) ; string
297 (storage-type hetzner-server-type-storage-type "storage_type")) ; string
298
299(define-json-mapping <hetzner-ssh-key>
300 make-hetzner-ssh-key hetzner-ssh-key? json->hetzner-ssh-key
301 (created hetzner-ssh-key-created "created" string->time) ; time
302 (fingerprint hetzner-ssh-key-fingerprint) ; string
303 (id hetzner-ssh-key-id) ; integer
304 (labels hetzner-ssh-key-labels) ; alist of string/string
305 (name hetzner-ssh-key-name) ; string
306 (public_key hetzner-ssh-key-public-key "public_key")) ; string
307
308(define (hetzner-server-architecture server)
309 "Return the architecture of the Hetzner SERVER."
310 (hetzner-server-type-architecture (hetzner-server-type server)))
311
312(define* (hetzner-server-path server #:optional (path ""))
313 "Return the PATH of the Hetzner SERVER."
314 (format #f "/servers/~a~a" (hetzner-server-id server) path))
315
316(define (hetzner-server-public-ipv4 server)
317 "Return the public IPv4 address of the SERVER."
318 (and-let* ((public-net (hetzner-server-public-net server))
319 (ipv4 (hetzner-public-net-ipv4 public-net)))
320 (hetzner-ipv4-ip ipv4)))
321
322(define (hetzner-server-system server)
323 "Return the Guix system architecture of the Hetzner SERVER."
324 (match (hetzner-server-architecture server)
325 ("arm" "aarch64-linux")
326 ("x86" "x86_64-linux")))
327
328(define* (hetzner-ssh-key-path ssh-key #:optional (path ""))
329 "Return the PATH of the Hetzner SSH-KEY."
330 (format #f "/ssh_keys/~a~a" (hetzner-ssh-key-id ssh-key) path))
331
332(define (hetzner-ssh-key-read-file file)
333 "Read the SSH private key from FILE and return a Hetzner SSH key."
334 (let* ((privkey (private-key-from-file file))
335 (pubkey (private-key->public-key privkey))
336 (hash (get-public-key-hash pubkey 'md5))
337 (fingerprint (bytevector->hex-string hash))
338 (public-key (format #f "ssh-~a ~a" (get-key-type pubkey)
339 (public-key->string pubkey))))
340 (make-hetzner-ssh-key #f fingerprint #f '() (basename file) public-key)))
341
342
343;;;
344;;; Hetzner API response.
345;;;
346
347(define-record-type* <hetzner-api-response>
348 hetzner-api-response make-hetzner-api-response hetzner-api-response?
349 (body hetzner-api-response-body (default *unspecified*))
350 (headers hetzner-api-response-headers (default '()))
351 (status hetzner-api-response-status (default 200)))
352
353(define (hetzner-api-response-meta response)
354 "Return the meta information of the Hetzner API response."
355 (assoc-ref (hetzner-api-response-body response) "meta"))
356
357(define (hetzner-api-response-pagination response)
358 "Return the meta information of the Hetzner API response."
359 (assoc-ref (hetzner-api-response-meta response) "pagination"))
360
361(define (hetzner-api-response-pagination-combine resource responses)
362 "Combine multiple Hetzner API pagination responses into a single response."
363 (if (positive? (length responses))
364 (let* ((response (car responses))
365 (pagination (hetzner-api-response-pagination response))
366 (total-entries (assoc-ref pagination "total_entries")))
367 (hetzner-api-response
368 (inherit response)
369 (body `(("meta"
370 ("pagination"
371 ("last_page" . 1)
372 ("next_page" . null)
373 ("page" . 1)
374 ("per_page" . ,total-entries)
375 ("previous_page" . null)
376 ("total_entries" . ,total-entries)))
377 (,resource . ,(append-map
378 (lambda (body)
379 (vector->list (assoc-ref body resource)))
380 (map hetzner-api-response-body responses)))))))
381 (raise-exception
382 (formatted-message
383 (G_ "expected a list of Hetzner API responses")))))
384
385(define (hetzner-api-body-action body)
386 "Return the Hetzner API action from BODY."
387 (let ((json (assoc-ref body "action")))
388 (and json (json->hetzner-action json))))
389
390(define (hetzner-api-response-read port)
391 "Read the Hetzner API response from PORT."
392 (let* ((response (read-response port))
393 (body (read-response-body response)))
394 (hetzner-api-response
395 (body (and body (json-string->scm (utf8->string body))))
396 (headers (response-headers response))
397 (status (response-code response)))))
398
399(define (hetzner-api-response-validate-status response expected)
400 "Raise an error if the HTTP status code of RESPONSE is not in EXPECTED."
401 (when (not (member (hetzner-api-response-status response) expected))
402 (raise-exception
403 (formatted-message
404 (G_ "unexpected HTTP status code: ~a, expected: ~a~%~a")
405 (hetzner-api-response-status response)
406 expected
407 (with-output-to-string
408 (lambda ()
409 (pretty-print (hetzner-api-response-body response))))))))
410
411
412;;;
413;;; Hetzner API request.
414;;;
415
416(define-record-type* <hetzner-api-request>
417 hetzner-api-request make-hetzner-api-request hetzner-api-request?
418 (body hetzner-api-request-body (default *unspecified*))
419 (headers hetzner-api-request-headers (default '()))
420 (method hetzner-api-request-method (default 'GET))
421 (params hetzner-api-request-params (default '()))
422 (url hetzner-api-request-url))
423
424(define (hetzner-api-request-uri request)
425 "Return the URI object of the Hetzner API request."
426 (let ((params (hetzner-api-request-params request)))
427 (string->uri (string-append (hetzner-api-request-url request)
428 (format-query-params params)))))
429
430(define (hetzner-api-request-body-bytevector request)
431 "Return the body of the Hetzner API REQUEST as a bytevector."
432 (let ((body (hetzner-api-request-body request)))
433 (string->utf8 (if (unspecified? body) "" (scm->json-string body)))))
434
435(define (hetzner-api-request-write port request)
436 "Write the Hetzner API REQUEST to PORT."
437 (let* ((body (hetzner-api-request-body-bytevector request))
438 (request (build-request
439 (hetzner-api-request-uri request)
440 #:method (hetzner-api-request-method request)
441 #:version '(1 . 1)
442 #:headers (cons* `(Content-Length
443 . ,(number->string
444 (if (unspecified? body)
445 0 (bytevector-length body))))
446 (hetzner-api-request-headers request))
447 #:port port))
448 (request (write-request request port)))
449 (unless (unspecified? body)
450 (write-request-body request body))
451 (force-output (request-port request))))
452
453(define* (hetzner-api-request-send request #:key (expected (list 200 201 204)))
454 "Send the Hetzner API REQUEST via HTTP."
455 (let ((port (open-socket-for-uri (hetzner-api-request-uri request))))
456 (hetzner-api-request-write port request)
457 (let ((response (hetzner-api-response-read port)))
458 (close-port port)
459 (hetzner-api-response-validate-status response expected)
460 response)))
461
462;; Prevent compiler from inlining this function, so we can mock it in tests.
463(set! hetzner-api-request-send hetzner-api-request-send)
464
465(define (hetzner-api-request-next-params request)
466 "Return the pagination params for the next page of the REQUEST."
467 (let* ((params (hetzner-api-request-params request))
468 (page (or (assoc-ref params "page") 1)))
469 (map (lambda (param)
470 (if (equal? "page" (car param))
471 (cons (car param) (+ page 1))
472 param))
473 params)))
474
475(define (hetzner-api-request-paginate request)
476 "Fetch all pages of the REQUEST via pagination and return all responses."
477 (let* ((response (hetzner-api-request-send request))
478 (pagination (hetzner-api-response-pagination response))
479 (next-page (assoc-ref pagination "next_page")))
480 (if (number? next-page)
481 (cons response
482 (hetzner-api-request-paginate
483 (hetzner-api-request
484 (inherit request)
485 (params (hetzner-api-request-next-params request)))))
486 (list response))))
487
488
489
490;;;
491;;; Hetzner API.
492;;;
493
494(define-record-type* <hetzner-api>
495 hetzner-api make-hetzner-api hetzner-api?
496 (base-url hetzner-api-base-url ; string
497 (default "https://api.hetzner.cloud/v1"))
498 (token hetzner-api-token ; string
499 (default (%hetzner-default-api-token))))
500
501(define (hetzner-api-authorization-header api)
502 "Return the authorization header for the Hetzner API."
503 (format #f "Bearer ~a" (hetzner-api-token api)))
504
505(define (hetzner-api-default-headers api)
506 "Returns the default headers of the Hetzner API."
507 `((user-agent . "Guix Deploy")
508 (Accept . "application/json")
509 (Authorization . ,(hetzner-api-authorization-header api))
510 (Content-Type . "application/json")))
511
512(define (hetzner-api-url api path)
513 "Append PATH to the base url of the Hetzner API."
514 (string-append (hetzner-api-base-url api) path))
515
516(define (hetzner-api-delete api path)
517 "Delelte the resource at PATH with the Hetzner API."
518 (hetzner-api-response-body
519 (hetzner-api-request-send
520 (hetzner-api-request
521 (headers (hetzner-api-default-headers api))
522 (method 'DELETE)
523 (url (hetzner-api-url api path))))))
524
525(define* (hetzner-api-list api path resources json->object #:key (params '()))
526 "Fetch all objects of RESOURCE from the Hetzner API."
527 (let ((body (hetzner-api-response-body
528 (hetzner-api-response-pagination-combine
529 resources (hetzner-api-request-paginate
530 (hetzner-api-request
531 (url (hetzner-api-url api path))
532 (headers (hetzner-api-default-headers api))
533 (params (cons '("page" . 1) params))))))))
534 (map json->object (assoc-ref body resources))))
535
536(define* (hetzner-api-post api path #:key (body *unspecified*))
537 "Send a POST request to the Hetzner API at PATH using BODY."
538 (hetzner-api-response-body
539 (hetzner-api-request-send
540 (hetzner-api-request
541 (body body)
542 (method 'POST)
543 (url (hetzner-api-url api path))
544 (headers (hetzner-api-default-headers api))))))
545
546(define (hetzner-api-actions api ids)
547 "Get actions from the Hetzner API."
548 (if (zero? (length ids))
549 (raise-exception
550 (formatted-message
551 (G_ "expected at least one action id, but got '~a'")
552 (length ids)))
553 (hetzner-api-list
554 api "/actions" "actions" json->hetzner-action
555 #:params `(("id" . ,(string-join (map number->string ids) ","))))))
556
557(define* (hetzner-api-action-wait api action #:optional (status "success"))
558 "Wait until the ACTION has reached STATUS on the Hetzner API."
559 (let ((id (hetzner-action-id action)))
560 (let loop ()
561 (let ((actions (hetzner-api-actions api (list id))))
562 (cond
563 ((zero? (length actions))
564 (raise-exception
565 (formatted-message (G_ "server action '~a' not found") id)))
566 ((not (= 1 (length actions)))
567 (raise-exception
568 (formatted-message
569 (G_ "expected one server action, but got '~a'")
570 (length actions))))
571 ((string= status (hetzner-action-status (car actions)))
572 (car actions))
573 (else
574 (sleep 5)
575 (loop)))))))
576
577(define* (hetzner-api-locations api . options)
578 "Get deployment locations from the Hetzner API."
579 (apply hetzner-api-list api "/locations" "locations" json->hetzner-location options))
580
581(define* (hetzner-api-server-create
582 api name ssh-keys
583 #:key
584 (enable-ipv4? #t)
585 (enable-ipv6? #t)
586 (image %hetzner-default-server-image)
587 (labels '())
588 (location %hetzner-default-server-location)
589 (public-net #f)
590 (server-type %hetzner-default-server-type)
591 (start-after-create? #f))
592 "Create a server with the Hetzner API."
593 (let ((body (hetzner-api-post
594 api "/servers"
595 #:body `(("image" . ,image)
596 ("labels" . ,labels)
597 ("name" . ,name)
598 ("public_net"
599 . (("enable_ipv4" . ,enable-ipv4?)
600 ("enable_ipv6" . ,enable-ipv6?)))
601 ("location" . ,location)
602 ("server_type" . ,server-type)
603 ("ssh_keys" . ,(apply vector (map hetzner-ssh-key-id ssh-keys)))
604 ("start_after_create" . ,start-after-create?)))))
605 (hetzner-api-action-wait api (hetzner-api-body-action body))
606 (json->hetzner-server (assoc-ref body "server"))))
607
608(define (hetzner-api-server-delete api server)
609 "Delete the SERVER with the Hetzner API."
610 (let ((body (hetzner-api-delete api (hetzner-server-path server))))
611 (hetzner-api-action-wait api (hetzner-api-body-action body))))
612
613(define* (hetzner-api-server-enable-rescue-system
614 api server ssh-keys #:key (type "linux64"))
615 "Enable the rescue system for SERVER with the Hetzner API."
616 (let* ((ssh-keys (apply vector (map hetzner-ssh-key-id ssh-keys)))
617 (body (hetzner-api-post
618 api (hetzner-server-path server "/actions/enable_rescue")
619 #:body `(("ssh_keys" . ,ssh-keys)
620 ("type" . ,type)))))
621 (hetzner-api-action-wait api (hetzner-api-body-action body))))
622
623(define* (hetzner-api-servers api . options)
624 "Get servers from the Hetzner API."
625 (apply hetzner-api-list api "/servers" "servers" json->hetzner-server options))
626
627(define (hetzner-api-server-power-on api server)
628 "Send a power on request for SERVER to the Hetzner API."
629 (let ((body (hetzner-api-post api (hetzner-server-path server "/actions/poweron"))))
630 (hetzner-api-action-wait api (hetzner-api-body-action body))))
631
632(define (hetzner-api-server-power-off api server)
633 "Send a power off request for SERVER to the Hetzner API."
634 (let ((body (hetzner-api-post api (hetzner-server-path server "/actions/poweroff"))))
635 (hetzner-api-action-wait api (hetzner-api-body-action body))))
636
637(define (hetzner-api-server-reboot api server)
638 "Send a reboot request for SERVER to the Hetzner API."
639 (let ((body (hetzner-api-post api (hetzner-server-path server "/actions/reboot"))))
640 (hetzner-api-action-wait api (hetzner-api-body-action body))))
641
642(define* (hetzner-api-ssh-key-create api name public-key #:key (labels '()))
643 "Create a SSH key with the Hetzner API."
644 (let ((body (hetzner-api-post
645 api "/ssh_keys"
646 #:body `(("name" . ,name)
647 ("public_key" . ,public-key)
648 ("labels" . ,labels)))))
649 (json->hetzner-ssh-key (assoc-ref body "ssh_key"))))
650
651(define (hetzner-api-ssh-key-delete api ssh-key)
652 "Delete the SSH key on the Hetzner API."
653 (hetzner-api-delete api (hetzner-ssh-key-path ssh-key))
654 #t)
655
656(define* (hetzner-api-ssh-keys api . options)
657 "Get SSH keys from the Hetzner API."
658 (apply hetzner-api-list api "/ssh_keys" "ssh_keys"
659 json->hetzner-ssh-key options))
660
661(define* (hetzner-api-server-types api . options)
662 "Get server types from the Hetzner API."
663 (apply hetzner-api-list api "/server_types" "server_types"
664 json->hetzner-server-type options))
generated by cgit v1.2.3 (git 2.25.1) at 2026-09-03 08:10:57 +0000