summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Makefile.am2
-rw-r--r--doc/guix.texi129
-rw-r--r--gnu/local.mk2
-rw-r--r--gnu/machine/hetzner.scm705
-rw-r--r--gnu/machine/hetzner/http.scm664
-rw-r--r--po/guix/POTFILES.in2
-rw-r--r--tests/machine/hetzner.scm267
-rw-r--r--tests/machine/hetzner/http.scm631
8 files changed, 2402 insertions, 0 deletions
diff --git a/Makefile.am b/Makefile.am
index de884548188..edcc392492b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -567,6 +567,8 @@ SCM_TESTS = \
567 tests/import-utils.scm \ 567 tests/import-utils.scm \
568 tests/inferior.scm \ 568 tests/inferior.scm \
569 tests/lint.scm \ 569 tests/lint.scm \
570 tests/machine/hetzner.scm \
571 tests/machine/hetzner/http.scm \
570 tests/minetest.scm \ 572 tests/minetest.scm \
571 tests/modules.scm \ 573 tests/modules.scm \
572 tests/monads.scm \ 574 tests/monads.scm \
diff --git a/doc/guix.texi b/doc/guix.texi
index 6d966ddb992..ce780682ed0 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -44877,6 +44877,135 @@ Whether or not the droplet should be created with IPv6 networking.
44877@end table 44877@end table
44878@end deftp 44878@end deftp
44879 44879
44880@deftp {Data Type} hetzner-configuration
44881This is the data type describing the server that should be created for a
44882machine with an @code{environment} of
44883@code{hetzner-environment-type}. It allows you to configure deployment
44884to a @acronym{VPS, virtual private server} hosted by
44885@uref{https://www.hetzner.com, Hetzner}.
44886
44887@table @asis
44888
44889@item @code{allow-downgrades?} (default: @code{#f})
44890Whether to allow potential downgrades.
44891
44892@item @code{authorize?} (default: @code{#t})
44893If true, the public signing key @code{"/etc/guix/signing-key.pub"} of
44894the machine that invokes @command{guix deploy} will be added to the
44895operating system ACL keyring of the target machine.
44896
44897@item @code{build-locally?} (default: @code{#t})
44898If true, system derivations will be built on the machine that invokes
44899@command{guix deploy}, otherwise derivations are build on the target
44900machine. Set this to @code{#f} if the machine you are deploying from
44901has a different architecture than the target machine and you can't build
44902derivations for the target architecture by other means, like offloading
44903(@pxref{Daemon Offload Setup}) or emulation
44904(@pxref{transparent-emulation-qemu, Transparent Emulation with QEMU}).
44905
44906@item @code{delete?} (default: @code{#t})
44907If true, the server will be deleted when an error happens in the
44908provisioning phase. If false, the server will be kept in order to debug
44909any issues.
44910
44911@item @code{labels} (default: @code{'()})
44912A user defined alist of key/value pairs attached to the SSH key and the
44913server on the Hetzner API. Keys and values must be strings,
44914e.g. @code{'(("environment" . "development"))}. For more information,
44915see @uref{https://docs.hetzner.cloud/#labels, Labels}.
44916
44917@item @code{location} (default: @code{"fsn1"})
44918The name of a @uref{https://docs.hetzner.com/cloud/general/locations,
44919location} to create the server in. For example, @code{"fsn1"}
44920corresponds to the Hetzner site in Falkenstein, Germany, while
44921@code{"sin"} corresponds to its site in Singapore.
44922
44923@item @code{server-type} (default: @code{"cx42"})
44924The name of the
44925@uref{https://docs.hetzner.com/cloud/servers/overview#server-types,
44926server type} this virtual server should be created with. For example,
44927@code{"cx42"} corresponds to a x86_64 server that has 8 VCPUs, 16 GB of
44928memory and 160 GB of storage, while @code{"cax31"} to the AArch64
44929equivalent. Other server types and their current prices can be found
44930@uref{https://www.hetzner.com/cloud/#pricing, here}.
44931
44932@item @code{ssh-key}
44933The file name of the SSH private key to use to authenticate with the
44934remote host.
44935
44936@end table
44937
44938When deploying a machine for the first time, the following steps are
44939taken to provision a server for the machine on the
44940@uref{https://www.hetzner.com/cloud, Hetzner Cloud} service:
44941
44942@itemize
44943
44944@item
44945Create the SSH key of the machine on the Hetzner API.
44946
44947@item
44948Create a server for the machine on the Hetzner API.
44949
44950@item
44951Format the root partition of the disk using the file system of the
44952machine's operating system. Supported file systems are btrfs and ext4.
44953
44954@item
44955Install a minimal Guix operating system on the server using the
44956@uref{https://docs.hetzner.com/cloud/servers/getting-started/rescue-system,
44957rescue mode}. This minimal system is used to install the machine's
44958operating system, after rebooting.
44959
44960@item
44961Reboot the server and apply the machine's operating system on the
44962server.
44963
44964@end itemize
44965
44966Once the server has been provisioned and SSH is available, deployment
44967continues by delegating it to the @code{managed-host-environment-type}.
44968
44969Servers on the Hetzner Cloud service can be provisioned on the AArch64
44970architecture using UEFI boot mode, or on the x86_64 architecture using
44971BIOS boot mode. The @code{(gnu machine hetzner)} module exports the
44972@code{%hetzner-os-arm} and @code{%hetzner-os-x86} operating systems that
44973are compatible with those two architectures, and can be used as a base
44974for defining your custom operating system.
44975
44976The following example shows the definition of two machines that are
44977deployed on the Hetzner Cloud service. The first one uses the
44978@code{%hetzner-os-arm} operating system to run a server with 16 shared
44979vCPUs and 32 GB of RAM on the @code{aarch64} architecture, the second
44980one uses the @code{%hetzner-os-x86} operating system on a server with 16
44981shared vCPUs and 32 GB of RAM on the @code{x86_64} architecture.
44982
44983@lisp
44984(use-modules (gnu machine)
44985 (gnu machine hetzner))
44986
44987(list (machine
44988 (operating-system %hetzner-os-arm)
44989 (environment hetzner-environment-type)
44990 (configuration (hetzner-configuration
44991 (server-type "cax41")
44992 (ssh-key "/home/charlie/.ssh/id_rsa"))))
44993 (machine
44994 (operating-system %hetzner-os-x86)
44995 (environment hetzner-environment-type)
44996 (configuration (hetzner-configuration
44997 (server-type "cpx51")
44998 (ssh-key "/home/charlie/.ssh/id_rsa")))))
44999@end lisp
45000
45001@vindex GUIX_HETZNER_API_TOKEN
45002Passing this file to @command{guix deploy} with the environment variable
45003@env{GUIX_HETZNER_API_TOKEN} set to a valid Hetzner
45004@uref{https://docs.hetzner.com/cloud/api/getting-started/generating-api-token,
45005API key} should provision two machines for you.
45006
45007@end deftp
45008
44880@node Running Guix in a VM 45009@node Running Guix in a VM
44881@section Running Guix in a Virtual Machine 45010@section Running Guix in a Virtual Machine
44882 45011
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))
diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in
index e37da506fc2..d68fad4e8c4 100644
--- a/po/guix/POTFILES.in
+++ b/po/guix/POTFILES.in
@@ -81,6 +81,8 @@ gnu/installer/steps.scm
81gnu/installer/timezone.scm 81gnu/installer/timezone.scm
82gnu/installer/user.scm 82gnu/installer/user.scm
83gnu/installer/utils.scm 83gnu/installer/utils.scm
84gnu/machine/hetzner.scm
85gnu/machine/hetzner/http.scm
84gnu/machine/ssh.scm 86gnu/machine/ssh.scm
85gnu/packages/bootstrap.scm 87gnu/packages/bootstrap.scm
86guix/build/utils.scm 88guix/build/utils.scm
diff --git a/tests/machine/hetzner.scm b/tests/machine/hetzner.scm
new file mode 100644
index 00000000000..39eac4a4d5f
--- /dev/null
+++ b/tests/machine/hetzner.scm
@@ -0,0 +1,267 @@
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 (tests machine hetzner)
20 #:use-module (gnu machine hetzner http)
21 #:use-module (gnu machine hetzner)
22 #:use-module (gnu machine ssh)
23 #:use-module (gnu machine)
24 #:use-module (gnu system)
25 #:use-module (guix build utils)
26 #:use-module (guix records)
27 #:use-module (guix ssh)
28 #:use-module (guix tests)
29 #:use-module (srfi srfi-1)
30 #:use-module (srfi srfi-34)
31 #:use-module (srfi srfi-64)
32 #:use-module (ssh key)
33 #:use-module (ssh session))
34
35;;; Unit and integration tests for the (gnu machine hetzner) module.
36
37;; Integration tests require the GUIX_HETZNER_API_TOKEN environment variable.
38;; https://docs.hetzner.com/cloud/api/getting-started/generating-api-token
39
40;; The integration tests sometimes fail due to the Hetzner API not being able
41;; to allocate a resource. Switching to a different location might help.
42
43(define %labels
44 '(("guix.gnu.org/test" . "true")))
45
46(define %ssh-key-name
47 "guix-hetzner-machine-test-key")
48
49(define %ssh-key-file
50 (string-append "/tmp/" %ssh-key-name))
51
52(unless (file-exists? %ssh-key-file)
53 (private-key-to-file (make-keypair 'rsa 2048) %ssh-key-file))
54
55(define %when-no-token
56 (if (hetzner-api-token (hetzner-api)) 0 1))
57
58(define %arm-machine
59 (machine
60 (operating-system
61 (operating-system
62 (inherit %hetzner-os-arm)
63 (host-name "guix-deploy-hetzner-test-arm")))
64 (environment hetzner-environment-type)
65 (configuration (hetzner-configuration
66 (labels %labels)
67 (server-type "cax41")
68 (ssh-key %ssh-key-file)))))
69
70(define %x86-machine
71 (machine
72 (operating-system
73 (operating-system
74 (inherit %hetzner-os-x86)
75 (host-name "guix-deploy-hetzner-test-x86")))
76 (environment hetzner-environment-type)
77 (configuration (hetzner-configuration
78 (labels %labels)
79 (server-type "cpx51")
80 (ssh-key %ssh-key-file)))))
81
82(define (cleanup machine)
83 (let* ((config (machine-configuration machine))
84 (api (hetzner-configuration-api config)))
85 (for-each (lambda (server)
86 (hetzner-api-server-delete api server))
87 (hetzner-api-servers
88 api #:params `(("label_selector" . "guix.gnu.org/test=true"))))
89 (for-each (lambda (ssh-key)
90 (hetzner-api-ssh-key-delete api ssh-key))
91 (hetzner-api-ssh-keys
92 api #:params `(("label_selector" . "guix.gnu.org/test=true"))))
93 machine))
94
95(define-syntax-rule (with-cleanup (machine-sym machine-init) body ...)
96 (let ((machine-sym (cleanup machine-init)))
97 (dynamic-wind
98 (const #t)
99 (lambda ()
100 body ...)
101 (lambda ()
102 (cleanup machine-sym)))))
103
104(define (mock-action command)
105 (make-hetzner-action
106 command #f
107 (localtime (current-time))
108 1
109 100
110 '()
111 (localtime (current-time))
112 "success"))
113
114(define (mock-location machine)
115 (let* ((config (machine-configuration machine))
116 (name (hetzner-configuration-location config)))
117 (make-hetzner-location
118 "Falkenstein" "DE" "Falkenstein DC Park 1"
119 1 50.47612 12.370071 name "eu-central")))
120
121(define (mock-server-type machine)
122 (let* ((config (machine-configuration machine))
123 (name (hetzner-configuration-server-type config)))
124 (make-hetzner-server-type
125 "x86" 8 "shared" #f #f (string-upcase name)
126 160 106 16 name "local")))
127
128(define (mock-server machine)
129 (let* ((config (machine-configuration machine))
130 (name (hetzner-configuration-location config)))
131 (make-hetzner-server
132 1
133 (localtime (current-time))
134 '()
135 (operating-system-host-name (machine-operating-system machine))
136 (make-hetzner-public-net
137 (make-hetzner-ipv4 #f "server.example.com" 1 "1.2.3.4")
138 (make-hetzner-ipv6 #f "server.example.com" 1 "2001:db8::1"))
139 #f
140 (mock-server-type machine))))
141
142(define (mock-ssh-key machine)
143 (let ((config (machine-configuration machine)))
144 (hetzner-ssh-key-read-file (hetzner-configuration-ssh-key config))))
145
146(define (expected-ssh-machine? machine ssh-machine)
147 (let ((config (machine-configuration machine))
148 (ssh-config (machine-configuration ssh-machine)))
149 (and (equal? (hetzner-configuration-authorize? config)
150 (machine-ssh-configuration-authorize? ssh-config))
151 (equal? (hetzner-configuration-allow-downgrades? config)
152 (machine-ssh-configuration-allow-downgrades? ssh-config))
153 (equal? (hetzner-configuration-build-locally? config)
154 (machine-ssh-configuration-build-locally? ssh-config))
155 (equal? (hetzner-server-public-ipv4 (mock-server machine))
156 (machine-ssh-configuration-host-name ssh-config)))))
157
158(define-syntax mock*
159 (syntax-rules ()
160 ((mock* () body1 body2 ...)
161 (let () body1 body2 ...))
162 ((mock* ((mod1 sym1 fn1) (mod2 sym2 fn2) ...)
163 body1 body2 ...)
164 (mock (mod1 sym1 fn1)
165 (mock* ((mod2 sym2 fn2) ...)
166 body1) body2 ...))))
167
168(test-begin "machine-hetzner")
169
170;; The following tests deploy real machines using the Hetzner API and shut
171;; them down afterwards.
172
173(test-skip %when-no-token)
174(test-assert "deploy-arm-machine"
175 (with-cleanup (machine %arm-machine)
176 (deploy-hetzner machine)))
177
178(test-skip %when-no-token)
179(test-assert "deploy-x86-machine"
180 (with-cleanup (machine %x86-machine)
181 (deploy-hetzner machine)))
182
183;; The following tests simulate a deployment, they mock out the actual calls
184;; to the Hetzner API.
185
186;; Note: In order for mocking to work, the Guile compiler should not inline
187;; the mocked functions. To prevent this it was necessary to set!
188;; hetzner-machine-ssh-run-script in (gnu machine hetzner) like this:
189
190;; (set! hetzner-machine-ssh-run-script hetzner-machine-ssh-run-script)
191
192(test-assert "deploy-machine-mock-with-provisioned-server"
193 (let ((machine (machine
194 (operating-system %hetzner-os-x86)
195 (environment hetzner-environment-type)
196 (configuration (hetzner-configuration
197 (api (hetzner-api (token "mock")))
198 (ssh-key %ssh-key-file))))))
199 (mock* (((gnu machine hetzner http) hetzner-api-locations
200 (lambda* (api . options)
201 (list (mock-location machine))))
202 ((gnu machine hetzner http) hetzner-api-server-types
203 (lambda* (api . options)
204 (list (mock-server-type machine))))
205 ((gnu machine hetzner http) hetzner-api-ssh-keys
206 (lambda* (api . options)
207 (list (mock-ssh-key machine))))
208 ((gnu machine hetzner http) hetzner-api-servers
209 (lambda* (api . options)
210 (list (mock-server machine))))
211 ((gnu machine) deploy-machine
212 (lambda* (ssh-machine)
213 (expected-ssh-machine? machine ssh-machine))))
214 (deploy-hetzner machine))))
215
216(test-assert "deploy-machine-mock-with-unprovisioned-server"
217 (let ((machine (machine
218 (operating-system %hetzner-os-x86)
219 (environment hetzner-environment-type)
220 (configuration (hetzner-configuration
221 (api (hetzner-api (token "mock")))
222 (ssh-key %ssh-key-file)))))
223 (servers '()))
224 (mock* (((gnu machine hetzner http) hetzner-api-locations
225 (lambda* (api . options)
226 (list (mock-location machine))))
227 ((gnu machine hetzner http) hetzner-api-server-types
228 (lambda* (api . options)
229 (list (mock-server-type machine))))
230 ((gnu machine hetzner http) hetzner-api-ssh-keys
231 (lambda* (api . options)
232 (list (mock-ssh-key machine))))
233 ((gnu machine hetzner http) hetzner-api-servers
234 (lambda* (api . options)
235 servers))
236 ((gnu machine hetzner http) hetzner-api-server-create
237 (lambda* (api name ssh-keys . options)
238 (set! servers (list (mock-server machine)))
239 (car servers)))
240 ((gnu machine hetzner http) hetzner-api-server-enable-rescue-system
241 (lambda (api server ssh-keys)
242 (mock-action "enable_rescue")))
243 ((gnu machine hetzner http) hetzner-api-server-power-on
244 (lambda (api server)
245 (mock-action "start_server")))
246 ((gnu machine hetzner) hetzner-machine-ssh-run-script
247 (lambda (ssh-session name content)
248 #t))
249 ((guix ssh) open-ssh-session
250 (lambda* (host . options)
251 (make-session #:host host)))
252 ((gnu machine hetzner http) hetzner-api-server-reboot
253 (lambda (api server)
254 (mock-action "reboot_server")))
255 ((ssh session) write-known-host!
256 (lambda (session)
257 #t))
258 ((gnu machine) deploy-machine
259 (lambda* (ssh-machine)
260 (expected-ssh-machine? machine ssh-machine))))
261 (deploy-hetzner machine))))
262
263(test-end "machine-hetzner")
264
265;; Local Variables:
266;; eval: (put 'with-cleanup 'scheme-indent-function 1)
267;; End:
diff --git a/tests/machine/hetzner/http.scm b/tests/machine/hetzner/http.scm
new file mode 100644
index 00000000000..618d9a4c94e
--- /dev/null
+++ b/tests/machine/hetzner/http.scm
@@ -0,0 +1,631 @@
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 (tests machine hetzner http)
20 #:use-module (debugging assert)
21 #:use-module (gnu machine hetzner http)
22 #:use-module (guix build utils)
23 #:use-module (guix tests)
24 #:use-module (srfi srfi-1)
25 #:use-module (srfi srfi-34)
26 #:use-module (srfi srfi-64)
27 #:use-module (ssh key))
28
29;; Unit and integration tests the (gnu machine hetzner http) module.
30
31;; Integration tests require the GUIX_HETZNER_API_TOKEN environment variable.
32;; https://docs.hetzner.com/cloud/api/getting-started/generating-api-token
33
34;; The integration tests sometimes fail due to the Hetzner API not being able
35;; to allocate a resource. Switching to a different location might help.
36
37(define %labels
38 '(("guix.gnu.org/test" . "true")))
39
40(define %server-name
41 "guix-hetzner-api-test-server")
42
43(define %ssh-key-name
44 "guix-hetzner-api-test-key")
45
46(define %ssh-key-file
47 (string-append "/tmp/" %ssh-key-name))
48
49(unless (file-exists? %ssh-key-file)
50 (private-key-to-file (make-keypair 'rsa 2048) %ssh-key-file))
51
52(define %ssh-key
53 (hetzner-ssh-key-read-file %ssh-key-file))
54
55(define %when-no-token
56 (if (hetzner-api-token (hetzner-api)) 0 1))
57
58(define action-create-server
59 (make-hetzner-action
60 "create_server" #f *unspecified* 1896091819 0
61 (list (make-hetzner-resource 59570198 "server"))
62 #(0 17 11 2 1 125 0 32 -1 0 #f) "running"))
63
64(define action-create-server-alist
65 '(("command" . "create_server")
66 ("error" . null)
67 ("finished" . null)
68 ("id" . 1896091819)
69 ("progress" . 0)
70 ("resources" . #((("type" . "server") ("id" . 59570198))))
71 ("started" . "2025-02-02T11:17:00+00:00")
72 ("status" . "running")))
73
74(define action-delete-server
75 (make-hetzner-action
76 "delete_server" #f *unspecified* 1896091928 0
77 (list (make-hetzner-resource 59570198 "server"))
78 #(10 17 11 2 1 125 0 32 -1 0 #f) "running"))
79
80(define action-delete-server-alist
81 '(("command" . "delete_server")
82 ("error" . null)
83 ("finished" . null)
84 ("id" . 1896091928)
85 ("progress" . 0)
86 ("resources" . #((("type" . "server") ("id" . 59570198))))
87 ("started" . "2025-02-02T11:17:10+00:00")
88 ("status" . "running")))
89
90(define action-enable-rescue
91 (make-hetzner-action
92 "enable_rescue" #f *unspecified* 1896091721 0
93 (list (make-hetzner-resource 59570198 "server"))
94 #(10 17 11 2 1 125 0 32 -1 0 #f) "success"))
95
96(define action-enable-rescue-alist
97 '(("command" . "enable_rescue")
98 ("error" . null)
99 ("finished" . null)
100 ("id" . 1896091721)
101 ("progress" . 0)
102 ("resources" . #((("type" . "server") ("id" . 59570198))))
103 ("started" . "2025-02-02T11:17:10+00:00")
104 ("status" . "running")))
105
106(define action-power-off
107 (make-hetzner-action
108 "stop_server" #f *unspecified* 1896091721 0
109 (list (make-hetzner-resource 59570198 "server"))
110 #(10 17 11 2 1 125 0 32 -1 0 #f) "success"))
111
112(define action-power-off-alist
113 '(("command" . "stop_server")
114 ("error" . null)
115 ("finished" . null)
116 ("id" . 1896091721)
117 ("progress" . 0)
118 ("resources" . #((("type" . "server") ("id" . 59570198))))
119 ("started" . "2025-02-02T11:17:10+00:00")
120 ("status" . "running")))
121
122(define action-power-on
123 (make-hetzner-action
124 "start_server" #f *unspecified* 1896091721 0
125 (list (make-hetzner-resource 59570198 "server"))
126 #(10 17 11 2 1 125 0 32 -1 0 #f) "success"))
127
128(define action-power-on-alist
129 '(("command" . "start_server")
130 ("error" . null)
131 ("finished" . null)
132 ("id" . 1896091721)
133 ("progress" . 0)
134 ("resources" . #((("type" . "server") ("id" . 59570198))))
135 ("started" . "2025-02-02T11:17:10+00:00")
136 ("status" . "running")))
137
138(define action-reboot
139 (make-hetzner-action
140 "reboot_server" #f *unspecified* 1896091721 0
141 (list (make-hetzner-resource 59570198 "server"))
142 #(10 17 11 2 1 125 0 32 -1 0 #f) "success"))
143
144(define action-reboot-alist
145 '(("command" . "reboot_server")
146 ("error" . null)
147 ("finished" . null)
148 ("id" . 1896091721)
149 ("progress" . 0)
150 ("resources" . #((("type" . "server") ("id" . 59570198))))
151 ("started" . "2025-02-02T11:17:10+00:00")
152 ("status" . "running")))
153
154(define meta-page-alist
155 '("pagination"
156 ("last_page" . 1)
157 ("next_page" . null)
158 ("page" . 1)
159 ("per_page" . 25)
160 ("previous_page" . null)
161 ("total_entries" . 1)))
162
163(define location-falkenstein
164 (make-hetzner-location
165 "Falkenstein" "DE" "Falkenstein DC Park 1"
166 1 50.47612 12.370071 "fsn1" "eu-central"))
167
168(define location-falkenstein-alist
169 `(("city" . "Falkenstein")
170 ("country" . "DE")
171 ("description" . "Falkenstein DC Park 1")
172 ("id" . 1)
173 ("latitude" . 50.47612)
174 ("longitude" . 12.370071)
175 ("name" . "fsn1")
176 ("network_zone" . "eu-central")))
177
178(define server-type-cpx-11
179 (make-hetzner-server-type
180 "x86" 2 "shared" #f *unspecified*
181 "CPX 11" 40 22 2 "cpx11" "local"))
182
183(define server-type-cpx-11-alist
184 `(("architecture" . "x86")
185 ("cores" . 2)
186 ("cpu_type" . "shared")
187 ("deprecated" . #f)
188 ("deprecation" . null)
189 ("description" . "CPX 11")
190 ("disk" . 40)
191 ("id" . 22)
192 ("memory" . 2)
193 ("name" . "cpx11")
194 ("storage_type" . "local")))
195
196(define server-x86
197 (make-hetzner-server
198 "2024-12-30T16:38:11+00:00"
199 59570198
200 '()
201 "guix-x86"
202 (make-hetzner-public-net
203 (make-hetzner-ipv4 #f "static.218.128.13.49.clients.your-server.de" 78014457 "49.13.128.218")
204 (make-hetzner-ipv6 #f '() 78014458 "2a01:4f8:c17:293e::/64"))
205 #f
206 server-type-cpx-11))
207
208(define server-x86-alist
209 `(("backup_window" . null)
210 ("created" . "2024-12-30T16:38:11+00:00")
211 ("id" . 59570198)
212 ("included_traffic" . 21990232555520)
213 ("ingoing_traffic" . 124530000)
214 ("iso" . null)
215 ("labels")
216 ("load_balancers" . #())
217 ("locked" . #f)
218 ("name" . "guix-x86")
219 ("outgoing_traffic" . 1391250000)
220 ("placement_group" . null)
221 ("primary_disk_size" . 320)
222 ("private_net" . #())
223 ("protection" ("rebuild" . #f) ("delete" . #f))
224 ("public_net"
225 ("firewalls" . #())
226 ("floating_ips" . #())
227 ("ipv6"
228 ("id" . 78014458)
229 ("dns_ptr" . #())
230 ("blocked" . #f)
231 ("ip" . "2a01:4f8:c17:293e::/64"))
232 ("ipv4"
233 ("id" . 78014457)
234 ("dns_ptr" . "static.218.128.13.49.clients.your-server.de")
235 ("blocked" . #f)
236 ("ip" . "49.13.128.218")))
237 ("rescue_enabled" . #f)
238 ("server_type" ,@server-type-cpx-11-alist)
239 ("status" . "running")
240 ("volumes" . #())))
241
242(define ssh-key-root
243 (make-hetzner-ssh-key
244 #(55 2 19 28 9 123 6 300 -1 0 #f)
245 "8c:25:09:8f:37:0f:d8:f0:99:4e:ab:c7:5c:1b:c6:53"
246 16510983 '() "root@example.com"
247 "ssh-ed25519 ABCAC3NzaC1lZDI1NTE5AAAAIBT3lLYPfOZV9NNrNk0jGCufWmXbFSz+ORxowJdHoSIM"))
248
249(define ssh-key-root-alist
250 `(("created" . "2023-10-28T19:02:55+00:00")
251 ("fingerprint" . "8c:25:09:8f:37:0f:d8:f0:99:4e:ab:c7:5c:1b:c6:53")
252 ("id" . 16510983)
253 ("labels")
254 ("name" . "root@example.com")
255 ("public_key" . "ssh-ed25519 ABCAC3NzaC1lZDI1NTE5AAAAIBT3lLYPfOZV9NNrNk0jGCufWmXbFSz+ORxowJdHoSIM")))
256
257(define* (create-ssh-key api ssh-key #:key (labels %labels))
258 (hetzner-api-ssh-key-create
259 api
260 (hetzner-ssh-key-name ssh-key)
261 (hetzner-ssh-key-public-key ssh-key)
262 #:labels labels))
263
264(define* (create-server api ssh-key #:key (labels %labels))
265 (hetzner-api-server-create api %server-name (list ssh-key)
266 #:labels labels
267 #:server-type "cpx31"))
268
269(define (cleanup api)
270 (for-each (lambda (server)
271 (hetzner-api-server-delete api server))
272 (hetzner-api-servers
273 api #:params `(("label_selector" . "guix.gnu.org/test=true"))))
274 (for-each (lambda (ssh-key)
275 (hetzner-api-ssh-key-delete api ssh-key))
276 (hetzner-api-ssh-keys
277 api #:params `(("label_selector" . "guix.gnu.org/test=true"))))
278 api)
279
280(define-syntax-rule (with-cleanup-api (api-sym api-init) body ...)
281 (let ((api-sym (cleanup api-init)))
282 (dynamic-wind
283 (const #t)
284 (lambda ()
285 body ...)
286 (lambda ()
287 (cleanup api-sym)))))
288
289(test-begin "machine-hetzner-api")
290
291;; Unit Tests
292
293(test-equal "hetzner-api-actions-unit"
294 (list action-create-server action-delete-server)
295 (let ((actions (list action-create-server-alist action-delete-server-alist)))
296 (mock ((gnu machine hetzner http) hetzner-api-request-send
297 (lambda* (request #:key expected)
298 (assert (equal? 'GET (hetzner-api-request-method request)))
299 (assert (equal? "https://api.hetzner.cloud/v1/actions"
300 (hetzner-api-request-url request)))
301 (assert (unspecified? (hetzner-api-request-body request)))
302 (assert (equal? `(("page" . 1)
303 ("id" . ,(string-join
304 (map (lambda (action)
305 (number->string (assoc-ref action "id")))
306 actions)
307 ",")))
308 (hetzner-api-request-params request)))
309 (hetzner-api-response
310 (body `(("meta" . ,meta-page-alist)
311 ("actions" . #(,action-create-server-alist ,action-delete-server-alist)))))))
312 (hetzner-api-actions (hetzner-api)
313 (map (lambda (action)
314 (assoc-ref action "id"))
315 actions)))))
316
317(test-equal "hetzner-api-locations-unit"
318 (list location-falkenstein)
319 (mock ((gnu machine hetzner http) hetzner-api-request-send
320 (lambda* (request #:key expected)
321 (assert (equal? 'GET (hetzner-api-request-method request)))
322 (assert (equal? "https://api.hetzner.cloud/v1/locations"
323 (hetzner-api-request-url request)))
324 (assert (unspecified? (hetzner-api-request-body request)))
325 (assert (equal? '(("page" . 1)) (hetzner-api-request-params request)))
326 (hetzner-api-response
327 (body `(("meta" . ,meta-page-alist)
328 ("locations" . #(,location-falkenstein-alist)))))))
329 (hetzner-api-locations (hetzner-api))))
330
331(test-equal "hetzner-api-server-types-unit"
332 (list server-type-cpx-11)
333 (mock ((gnu machine hetzner http) hetzner-api-request-send
334 (lambda* (request #:key expected)
335 (assert (equal? 'GET (hetzner-api-request-method request)))
336 (assert (equal? "https://api.hetzner.cloud/v1/server_types"
337 (hetzner-api-request-url request)))
338 (assert (unspecified? (hetzner-api-request-body request)))
339 (assert (equal? '(("page" . 1)) (hetzner-api-request-params request)))
340 (hetzner-api-response
341 (body `(("meta" . ,meta-page-alist)
342 ("server_types" . #(,server-type-cpx-11-alist)))))))
343 (hetzner-api-server-types (hetzner-api))))
344
345(test-equal "hetzner-api-server-create-unit"
346 server-x86
347 (mock ((gnu machine hetzner http) hetzner-api-request-send
348 (lambda* (request #:key expected)
349 (cond
350 ((equal? "https://api.hetzner.cloud/v1/servers"
351 (hetzner-api-request-url request))
352 (assert (equal? 'POST (hetzner-api-request-method request)))
353 (hetzner-api-response
354 (body `(("action" . ,action-create-server-alist)
355 ("server" . ,server-x86-alist)))))
356 ((equal? "https://api.hetzner.cloud/v1/actions"
357 (hetzner-api-request-url request))
358 (assert (equal? 'GET (hetzner-api-request-method request)))
359 (hetzner-api-response
360 (body `(("actions" . ,(vector (cons `("status" . "success")
361 action-create-server-alist)))
362 ("meta" . ,meta-page-alist))))))))
363 (hetzner-api-server-create (hetzner-api) %server-name (list ssh-key-root))))
364
365(test-equal "hetzner-api-server-delete-unit"
366 (make-hetzner-action
367 "delete_server" #f *unspecified* 1896091928 0
368 (list (make-hetzner-resource 59570198 "server"))
369 #(10 17 11 2 1 125 0 32 -1 0 #f) "success")
370 (mock ((gnu machine hetzner http) hetzner-api-request-send
371 (lambda* (request #:key expected)
372 (cond
373 ((equal? "https://api.hetzner.cloud/v1/servers/59570198"
374 (hetzner-api-request-url request))
375 (assert (equal? 'DELETE (hetzner-api-request-method request)))
376 (hetzner-api-response
377 (body `(("action" . ,action-delete-server-alist)))))
378 ((equal? "https://api.hetzner.cloud/v1/actions"
379 (hetzner-api-request-url request))
380 (assert (equal? 'GET (hetzner-api-request-method request)))
381 (hetzner-api-response
382 (body `(("actions" . ,(vector (cons `("status" . "success")
383 action-delete-server-alist)))
384 ("meta" . ,meta-page-alist))))))))
385 (hetzner-api-server-delete (hetzner-api) server-x86)))
386
387(test-equal "hetzner-api-server-enable-rescue-system-unit"
388 action-enable-rescue
389 (mock ((gnu machine hetzner http) hetzner-api-request-send
390 (lambda* (request #:key expected)
391 (cond
392 ((equal? "https://api.hetzner.cloud/v1/servers/59570198/actions/enable_rescue"
393 (hetzner-api-request-url request))
394 (assert (equal? 'POST (hetzner-api-request-method request)))
395 (hetzner-api-response
396 (body `(("action" . ,action-enable-rescue-alist)))))
397 ((equal? "https://api.hetzner.cloud/v1/actions"
398 (hetzner-api-request-url request))
399 (assert (equal? 'GET (hetzner-api-request-method request)))
400 (hetzner-api-response
401 (body `(("actions" . ,(vector (cons `("status" . "success")
402 action-enable-rescue-alist)))
403 ("meta" . ,meta-page-alist))))))))
404 (hetzner-api-server-enable-rescue-system (hetzner-api) server-x86 (list ssh-key-root))))
405
406(test-equal "hetzner-api-server-power-on-unit"
407 action-power-on
408 (mock ((gnu machine hetzner http) hetzner-api-request-send
409 (lambda* (request #:key expected)
410 (cond
411 ((equal? "https://api.hetzner.cloud/v1/servers/59570198/actions/poweron"
412 (hetzner-api-request-url request))
413 (assert (equal? 'POST (hetzner-api-request-method request)))
414 (hetzner-api-response
415 (body `(("action" . ,action-power-on-alist)))))
416 ((equal? "https://api.hetzner.cloud/v1/actions"
417 (hetzner-api-request-url request))
418 (assert (equal? 'GET (hetzner-api-request-method request)))
419 (hetzner-api-response
420 (body `(("actions" . ,(vector (cons `("status" . "success")
421 action-power-on-alist)))
422 ("meta" . ,meta-page-alist))))))))
423 (hetzner-api-server-power-on (hetzner-api) server-x86)))
424
425(test-equal "hetzner-api-server-power-off-unit"
426 action-power-off
427 (mock ((gnu machine hetzner http) hetzner-api-request-send
428 (lambda* (request #:key expected)
429 (cond
430 ((equal? "https://api.hetzner.cloud/v1/servers/59570198/actions/poweroff"
431 (hetzner-api-request-url request))
432 (assert (equal? 'POST (hetzner-api-request-method request)))
433 (hetzner-api-response
434 (body `(("action" . ,action-power-off-alist)))))
435 ((equal? "https://api.hetzner.cloud/v1/actions"
436 (hetzner-api-request-url request))
437 (assert (equal? 'GET (hetzner-api-request-method request)))
438 (hetzner-api-response
439 (body `(("actions" . ,(vector (cons `("status" . "success")
440 action-power-off-alist)))
441 ("meta" . ,meta-page-alist))))))))
442 (hetzner-api-server-power-off (hetzner-api) server-x86)))
443
444(test-equal "hetzner-api-server-reboot-unit"
445 action-reboot
446 (mock ((gnu machine hetzner http) hetzner-api-request-send
447 (lambda* (request #:key expected)
448 (cond
449 ((equal? "https://api.hetzner.cloud/v1/servers/59570198/actions/reboot"
450 (hetzner-api-request-url request))
451 (assert (equal? 'POST (hetzner-api-request-method request)))
452 (hetzner-api-response
453 (body `(("action" . ,action-reboot-alist)))))
454 ((equal? "https://api.hetzner.cloud/v1/actions"
455 (hetzner-api-request-url request))
456 (assert (equal? 'GET (hetzner-api-request-method request)))
457 (hetzner-api-response
458 (body `(("actions" . ,(vector (cons `("status" . "success")
459 action-reboot-alist)))
460 ("meta" . ,meta-page-alist))))))))
461 (hetzner-api-server-reboot (hetzner-api) server-x86)))
462
463(test-equal "hetzner-api-servers-unit"
464 (list server-x86)
465 (mock ((gnu machine hetzner http) hetzner-api-request-send
466 (lambda* (request #:key expected)
467 (hetzner-api-response
468 (body `(("meta" . ,meta-page-alist)
469 ("servers" . #(,server-x86-alist)))))))
470 (hetzner-api-servers (hetzner-api))))
471
472(test-equal "hetzner-api-ssh-key-create-unit"
473 ssh-key-root
474 (mock ((gnu machine hetzner http) hetzner-api-request-send
475 (lambda* (request #:key expected)
476 (assert (equal? 'POST (hetzner-api-request-method request)))
477 (assert (equal? "https://api.hetzner.cloud/v1/ssh_keys"
478 (hetzner-api-request-url request)))
479 (assert (equal? `(("name" . "guix-hetzner-api-test-key")
480 ("public_key" . "ssh-ed25519 ABCAC3NzaC1lZDI1NTE5AAAAIBT3lLYPfOZV9NNrNk0jGCufWmXbFSz+ORxowJdHoSIM")
481 ("labels" . (("a" . "1"))))
482 (hetzner-api-request-body request)))
483 (assert (equal? `() (hetzner-api-request-params request)))
484 (hetzner-api-response
485 (body `(("ssh_key" . ,ssh-key-root-alist))))))
486 (hetzner-api-ssh-key-create
487 (hetzner-api)
488 "guix-hetzner-api-test-key"
489 "ssh-ed25519 ABCAC3NzaC1lZDI1NTE5AAAAIBT3lLYPfOZV9NNrNk0jGCufWmXbFSz+ORxowJdHoSIM"
490 #:labels '(("a" . "1")))))
491
492(test-assert "hetzner-api-ssh-key-delete-unit"
493 (mock ((gnu machine hetzner http) hetzner-api-request-send
494 (lambda* (request #:key expected)
495 (assert (equal? "https://api.hetzner.cloud/v1/ssh_keys/16510983"
496 (hetzner-api-request-url request)))
497 (assert (equal? 'DELETE (hetzner-api-request-method request)))
498 (hetzner-api-response)))
499 (hetzner-api-ssh-key-delete (hetzner-api) ssh-key-root)))
500
501(test-equal "hetzner-api-ssh-keys-unit"
502 (list ssh-key-root)
503 (mock ((gnu machine hetzner http) hetzner-api-request-send
504 (lambda* (request #:key expected)
505 (assert (equal? 'GET (hetzner-api-request-method request)))
506 (assert (equal? "https://api.hetzner.cloud/v1/ssh_keys"
507 (hetzner-api-request-url request)))
508 (assert (unspecified? (hetzner-api-request-body request)))
509 (assert (equal? '(("page" . 1)) (hetzner-api-request-params request)))
510 (hetzner-api-response
511 (body `(("meta" . ,meta-page-alist)
512 ("ssh_keys" . #(,ssh-key-root-alist)))))))
513 (hetzner-api-ssh-keys (hetzner-api))))
514
515;; Integration tests
516
517(test-skip %when-no-token)
518(test-assert "hetzner-api-actions-integration"
519 (with-cleanup-api (api (hetzner-api))
520 (let* ((ssh-key (create-ssh-key api %ssh-key))
521 (server (create-server api ssh-key))
522 (action (hetzner-api-server-enable-rescue-system api server (list ssh-key))))
523 (member action (hetzner-api-actions api (list (hetzner-action-id action)))))))
524
525(test-skip %when-no-token)
526(test-assert "hetzner-api-locations-integration"
527 (let ((locations (hetzner-api-locations (hetzner-api))))
528 (and (> (length locations) 0)
529 (every hetzner-location? locations))))
530
531(test-skip %when-no-token)
532(test-assert "hetzner-api-server-types-integration"
533 (let ((server-types (hetzner-api-server-types (hetzner-api))))
534 (and (> (length server-types) 0)
535 (every hetzner-server-type? server-types))))
536
537(test-skip %when-no-token)
538(test-assert "hetzner-api-server-create-integration"
539 (with-cleanup-api (api (hetzner-api))
540 (let* ((ssh-key (create-ssh-key api %ssh-key))
541 (server (create-server api ssh-key)))
542 (and (hetzner-server? server)
543 (equal? %server-name (hetzner-server-name server))))))
544
545(test-skip %when-no-token)
546(test-assert "hetzner-api-server-delete-integration"
547 (with-cleanup-api (api (hetzner-api))
548 (let* ((ssh-key (create-ssh-key api %ssh-key))
549 (server (create-server api ssh-key))
550 (action (hetzner-api-server-delete api server)))
551 (and (hetzner-action? action)
552 (equal? "delete_server"
553 (hetzner-action-command action))))))
554
555(test-skip %when-no-token)
556(test-assert "hetzner-api-server-enable-rescue-system-integration"
557 (with-cleanup-api (api (hetzner-api))
558 (let* ((ssh-key (create-ssh-key api %ssh-key))
559 (server (create-server api ssh-key))
560 (action (hetzner-api-server-enable-rescue-system api server (list ssh-key))))
561 (and (hetzner-action? action)
562 (equal? "enable_rescue"
563 (hetzner-action-command action))))))
564
565(test-skip %when-no-token)
566(test-assert "hetzner-api-server-power-on-integration"
567 (with-cleanup-api (api (hetzner-api))
568 (let* ((ssh-key (create-ssh-key api %ssh-key))
569 (server (create-server api ssh-key))
570 (action (hetzner-api-server-power-on api server)))
571 (and (hetzner-action? action)
572 (equal? "start_server"
573 (hetzner-action-command action))))))
574
575(test-skip %when-no-token)
576(test-assert "hetzner-api-server-power-off-integration"
577 (with-cleanup-api (api (hetzner-api))
578 (let* ((ssh-key (create-ssh-key api %ssh-key))
579 (server (create-server api ssh-key))
580 (action (hetzner-api-server-power-off api server)))
581 (and (hetzner-action? action)
582 (equal? "stop_server"
583 (hetzner-action-command action))))))
584
585(test-skip %when-no-token)
586(test-assert "hetzner-api-server-reboot-integration"
587 (with-cleanup-api (api (hetzner-api))
588 (let* ((ssh-key (create-ssh-key api %ssh-key))
589 (server (create-server api ssh-key))
590 (action (hetzner-api-server-reboot api server)))
591 (and (hetzner-action? action)
592 (equal? "reboot_server"
593 (hetzner-action-command action))))))
594
595(test-skip %when-no-token)
596(test-assert "hetzner-api-servers-integration"
597 (with-cleanup-api (api (hetzner-api))
598 (let* ((ssh-key (create-ssh-key api %ssh-key))
599 (server (create-server api ssh-key)))
600 (member server (hetzner-api-servers api)))))
601
602(test-skip %when-no-token)
603(test-assert "hetzner-api-ssh-key-create-integration"
604 (with-cleanup-api (api (hetzner-api))
605 (let ((ssh-key (create-ssh-key api %ssh-key)))
606 (and (hetzner-ssh-key? ssh-key)
607 (equal? (hetzner-ssh-key-fingerprint %ssh-key)
608 (hetzner-ssh-key-fingerprint ssh-key))
609 (equal? (hetzner-ssh-key-name %ssh-key)
610 (hetzner-ssh-key-name ssh-key))
611 (equal? (hetzner-ssh-key-public-key %ssh-key)
612 (hetzner-ssh-key-public-key ssh-key))))))
613
614(test-skip %when-no-token)
615(test-assert "hetzner-api-ssh-key-delete-integration"
616 (with-cleanup-api (api (hetzner-api))
617 (let ((ssh-key (create-ssh-key api %ssh-key)))
618 (and (equal? #t (hetzner-api-ssh-key-delete api ssh-key))
619 (not (member ssh-key (hetzner-api-ssh-keys api)))))))
620
621(test-skip %when-no-token)
622(test-assert "hetzner-api-ssh-keys-integration"
623 (with-cleanup-api (api (hetzner-api))
624 (let ((ssh-key (create-ssh-key api %ssh-key)))
625 (member ssh-key (hetzner-api-ssh-keys api)))))
626
627(test-end "machine-hetzner-api")
628
629;; Local Variables:
630;; eval: (put 'with-cleanup-api 'scheme-indent-function 1)
631;; End:
generated by cgit v1.2.3 (git 2.25.1) at 2026-09-03 08:28:59 +0000