projects/guix·blob python-team · refs

873 lines · 34.1 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2024 Roman Scherer <[email protected]>
3;;; Copyright © 2025 Owen T. Heisler <[email protected]>
4;;; Copyright © 2025 Remco van 't Veer <[email protected]>
5;;; Copyright © 2026 Maxim Cournoyer <[email protected]>
6;;;
7;;; This file is part of GNU Guix.
8;;;
9;;; GNU Guix is free software; you can redistribute it and/or modify it
10;;; under the terms of the GNU General Public License as published by
11;;; the Free Software Foundation; either version 3 of the License, or (at
12;;; your option) any later version.
13;;;
14;;; GNU Guix is distributed in the hope that it will be useful, but
15;;; WITHOUT ANY WARRANTY; without even the implied warranty of
16;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17;;; GNU General Public License for more details.
18;;;
19;;; You should have received a copy of the GNU General Public License
20;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
21
22;;; Commentary:
23;;;
24;;; This module implements a high-level interface for provisioning machines on
25;;; the Hetzner Cloud service https://docs.hetzner.cloud.
26;;;
27
28(define-module (gnu machine hetzner)
29 #:use-module (gnu bootloader grub)
30 #:use-module (gnu bootloader)
31 #:use-module (gnu machine hetzner http)
32 #:use-module (gnu machine ssh)
33 #:use-module (gnu machine)
34 #:use-module (gnu packages ssh)
35 #:use-module (gnu services base)
36 #:use-module (gnu services networking)
37 #:use-module (gnu services ssh)
38 #:use-module (gnu services)
39 #:use-module (gnu system file-systems)
40 #:use-module (gnu system image)
41 #:use-module (gnu system linux-initrd)
42 #:use-module (gnu system pam)
43 #:use-module (gnu system)
44 #:use-module (guix base32)
45 #:use-module (guix colors)
46 #:use-module (guix deprecation)
47 #:use-module (guix derivations)
48 #:use-module (guix diagnostics)
49 #:use-module (guix gexp)
50 #:use-module (guix i18n)
51 #:use-module (guix import json)
52 #:use-module (guix monads)
53 #:use-module (guix packages)
54 #:use-module (guix pki)
55 #:use-module (guix records)
56 #:use-module (guix ssh)
57 #:use-module (guix store)
58 #:use-module (ice-9 format)
59 #:use-module (ice-9 iconv)
60 #:use-module (ice-9 match)
61 #:use-module (ice-9 popen)
62 #:use-module (ice-9 rdelim)
63 #:use-module (ice-9 string-fun)
64 #:use-module (ice-9 textual-ports)
65 #:use-module (json)
66 #:use-module ((rnrs base) #:select (assert))
67 #:use-module (srfi srfi-1)
68 #:use-module (srfi srfi-2)
69 #:use-module (srfi srfi-34)
70 #:use-module (srfi srfi-35)
71 #:use-module (srfi srfi-71)
72 #:use-module (ssh channel)
73 #:use-module (ssh key)
74 #:use-module (ssh popen)
75 #:use-module (ssh session)
76 #:use-module (ssh sftp)
77 #:use-module (ssh shell)
78 #:export (%hetzner-os-arm ;deprecated
79 %hetzner-os-x86 ;deprecated
80 make-hetzner-os
81
82 deploy-hetzner
83 hetzner-configuration
84 hetzner-configuration-allow-downgrades?
85 hetzner-configuration-api
86 hetzner-configuration-authorize?
87 hetzner-configuration-build-locally?
88 hetzner-configuration-delete?
89 hetzner-configuration-ipv4
90 hetzner-configuration-ipv6
91 hetzner-configuration-labels
92 hetzner-configuration-location
93 hetzner-configuration-server-type
94 hetzner-configuration-ssh-key
95 hetzner-configuration-ssh-public-key
96 hetzner-configuration-user
97 hetzner-configuration?
98 hetzner-environment-type))
99
100
101;;;
102;;; Hetzner operating systems.
103;;;
104
105;; Operating system for arm servers using UEFI boot mode.
106
107(define %hetzner-os-arm/efi
108 (operating-system
109 (host-name "guix-arm")
110 (bootloader
111 (bootloader-configuration
112 (bootloader grub-efi-bootloader)
113 (targets (list "/boot/efi"))
114 (terminal-outputs '(console))))
115 (file-systems
116 (cons* (file-system
117 (mount-point "/")
118 (device "/dev/sda1")
119 (type "ext4"))
120 (file-system
121 (mount-point "/boot/efi")
122 (device "/dev/sda15")
123 (type "vfat"))
124 %base-file-systems))
125 (initrd-modules
126 (cons* "sd_mod" "virtio_scsi" %base-initrd-modules))
127 (services
128 (cons* (service dhcpcd-service-type)
129 (service openssh-service-type
130 (openssh-configuration
131 (openssh openssh-sans-x)
132 (permit-root-login 'prohibit-password)))
133 %base-services))))
134
135;; Operating system for x86 servers using BIOS boot mode.
136
137(define %hetzner-os-x86/bios
138 (operating-system
139 (inherit %hetzner-os-arm/efi)
140 (host-name "guix-x86")
141 (bootloader
142 (bootloader-configuration
143 (bootloader grub-bootloader)
144 (targets (list "/dev/sda"))
145 (terminal-outputs '(console))))
146 (initrd-modules
147 (cons "virtio_scsi" %base-initrd-modules))
148 (file-systems
149 (cons (file-system
150 (mount-point "/")
151 (device "/dev/sda1")
152 (type "ext4"))
153 %base-file-systems))))
154
155(define %hetzner-os-x86/efi
156 (operating-system
157 (inherit %hetzner-os-arm/efi)
158 (host-name "guix-x86")
159 (initrd-modules
160 (cons "virtio_scsi" %base-initrd-modules))))
161
162(define (server-type-name->arch type-name)
163 "Return a symbol corresponding to the server type architecture, e.g.
164@code{'x86} or @code{'arm}."
165 (cond
166 ((string-prefix-ci? "cax" type-name)
167 'arm)
168 (else
169 'x86)))
170
171(define (server-type-name->bootloader type-name)
172 "Return a symbol corresponding to the bootloader type, e.g.
173@code{'efi} or @code{'bios}."
174 (if (eq? 'arm (server-type-name->arch type-name))
175 'efi
176 (cond
177 ((string-prefix-ci? "cx" type-name)
178 'bios) ;old, cost-optimized x86 servers
179 ((and (string-prefix-ci? "cpx" type-name)
180 (string-suffix-ci? "1" type-name))
181 'bios) ;cpx?1 types are non-efi
182 (else
183 'efi)))) ;newer, regular performance/general purpose servers
184
185(define* (make-hetzner-os server-type-name)
186 "Return an operating server customized for SERVER-TYPE-NAME, a string like
187\"cx23\" or \"cax11\", denoting the Hetzner virtual server type."
188 (match (server-type-name->arch server-type-name)
189 ('arm %hetzner-os-arm/efi)
190 ('x86
191 (match (server-type-name->bootloader server-type-name)
192 ('bios %hetzner-os-x86/bios)
193 ('efi %hetzner-os-x86/efi)))))
194
195(define-deprecated %hetzner-os-x86
196 make-hetzner-os
197 %hetzner-os-x86/bios)
198
199(define-deprecated %hetzner-os-arm
200 make-hetzner-os
201 %hetzner-os-arm/efi)
202
203(define (operating-system-authorize os)
204 "Authorize the OS with the public signing key of the current machine."
205 (if (file-exists? %public-key-file)
206 (operating-system
207 (inherit os)
208 (services
209 (modify-services services
210 (guix-service-type
211 config => (guix-configuration
212 (inherit config)
213 (authorized-keys
214 (cons*
215 (local-file %public-key-file)
216 (guix-configuration-authorized-keys config))))))))
217 (raise-exception
218 (formatted-message (G_ "no signing key '~a'. \
219Have you run 'guix archive --generate-key'?")
220 %public-key-file))))
221
222(define (operating-system-root-file-system-type os)
223 "Return the root file system type of the operating system OS."
224 (let ((root-fs (find (lambda (file-system)
225 (equal? "/" (file-system-mount-point file-system)))
226 (operating-system-file-systems os))))
227 (if (file-system? root-fs)
228 (file-system-type root-fs)
229 (raise-exception
230 (formatted-message
231 (G_ "could not determine root file system type"))))))
232
233
234;;;
235;;; Helper functions.
236;;;
237
238(define (escape-backticks str)
239 "Escape all backticks in STR."
240 (string-replace-substring str "`" "\\`"))
241
242
243
244;;;
245;;; Hetzner configuration.
246;;;
247
248;;; This parameter overrides the value returned by
249;;; `hetzner-configuration-ssh-key'.
250(define %hetzner-ssh-key-file
251 (make-parameter #f))
252
253(define-record-type* <hetzner-configuration> hetzner-configuration
254 make-hetzner-configuration hetzner-configuration? this-hetzner-configuration
255 (allow-downgrades? hetzner-configuration-allow-downgrades? ; boolean
256 (default #f))
257 (api hetzner-configuration-api ; <hetzner-api>
258 (default (hetzner-api)))
259 (authorize? hetzner-configuration-authorize? ; boolean
260 (default #t))
261 (build-locally? hetzner-configuration-build-locally? ; boolean
262 (default #t))
263 (delete? hetzner-configuration-delete? ; boolean
264 (default #t))
265 (labels hetzner-configuration-labels ; list of strings
266 (default '()))
267 (location hetzner-configuration-location ; #f | string
268 (default "fsn1"))
269 (server-type hetzner-configuration-server-type ; string
270 (default "cx42"))
271 (ipv4 hetzner-configuration-ipv4 ; boolean | string
272 (default #t))
273 (ipv6 hetzner-configuration-ipv6 ; boolean | string
274 (default #t))
275 (ssh-public-key hetzner-configuration-ssh-public-key* ; #f | public-key | string
276 (thunked)
277 (default (and=> (hetzner-configuration-ssh-key
278 this-hetzner-configuration)
279 public-key-from-file))
280 (sanitize (lambda (value)
281 (if (string? value)
282 (public-key-from-file value)
283 value))))
284 (ssh-key hetzner-configuration-ssh-key* ; #f | string
285 (default #f))
286 (user hetzner-configuration-user ;string
287 (default "root")))
288
289(define (hetzner-configuration-ssh-key config)
290 (or (%hetzner-ssh-key-file)
291 (hetzner-configuration-ssh-key* config)))
292
293(define (hetzner-configuration-ssh-public-key config)
294 (or (and=> (%hetzner-ssh-key-file) public-key-from-file)
295 (hetzner-configuration-ssh-public-key* config)))
296
297(define (public-key->fingerprint public-key)
298 "Return the SSH public key fingerprint of PUBLIC-KEY, a Guile-SSH public key
299object, in the expected format for the Hetzner API."
300 (let ((hash (get-public-key-hash public-key 'md5)))
301 (bytevector->hex-string hash)))
302
303(define (public-key->string-with-type public-key)
304 "Return the SSH public key string of PUBLIC-KEY, a Guile-SSH public key
305object, in the expected format for the Hetzner API."
306 (format #f "ssh-~a ~a" (get-key-type public-key)
307 (public-key->string public-key)))
308
309
310;;;
311;;; Hetzner Machine.
312;;;
313
314(define (hetzner-machine-delegate target server)
315 "Return the delegate machine that uses SSH for deployment."
316 (let* ((config (machine-configuration target))
317 ;; Get the operating system WITHOUT the provenance service to avoid a
318 ;; duplicate symlink conflict in the store.
319 (os ((@@ (gnu machine) %machine-operating-system) target)))
320 (match-record config <hetzner-configuration>
321 ( authorize? allow-downgrades? build-locally? user)
322 (machine
323 (inherit target)
324 (operating-system
325 (if authorize?
326 (operating-system-authorize os)
327 os))
328 (environment managed-host-environment-type)
329 (configuration
330 (machine-ssh-configuration
331 (allow-downgrades? allow-downgrades?)
332 (authorize? authorize?)
333 (build-locally? build-locally?)
334 (host-name (hetzner-server-public-ipv4 server))
335 ;; XXX: match-record doesn't make use of custom accessors to obtain
336 ;; the value, so we can't bind SSH-KEY with it.
337 (identity (hetzner-configuration-ssh-key config))
338 (system (hetzner-server-system server))
339 (user user)))))))
340
341(define (hetzner-machine-location machine)
342 "Find the location of MACHINE on the Hetzner API."
343 (let* ((config (machine-configuration machine))
344 (expected (hetzner-configuration-location config)))
345 (find (lambda (location)
346 (equal? expected (hetzner-location-name location)))
347 (hetzner-api-locations
348 (hetzner-configuration-api config)
349 #:params `(("name" . ,expected))))))
350
351(define (hetzner-machine-server-type machine)
352 "Find the server type of MACHINE on the Hetzner API."
353 (let* ((config (machine-configuration machine))
354 (expected (hetzner-configuration-server-type config)))
355 (find (lambda (server-type)
356 (equal? expected (hetzner-server-type-name server-type)))
357 (hetzner-api-server-types
358 (hetzner-configuration-api config)
359 #:params `(("name" . ,expected))))))
360
361(define (hetzner-machine-validate-api-token machine)
362 "Validate the Hetzner API authentication token of MACHINE."
363 (let* ((config (machine-configuration machine))
364 (api (hetzner-configuration-api config)))
365 (unless (hetzner-api-token api)
366 (raise-exception
367 (formatted-message
368 (G_ "Hetzner Cloud access token was not provided. \
369This may be fixed by setting the environment variable GUIX_HETZNER_API_TOKEN \
370to one procured from \
371https://docs.hetzner.com/cloud/api/getting-started/generating-api-token"))))))
372
373(define (hetzner-machine-validate-configuration-type machine)
374 "Raise an error if MACHINE's configuration is not an instance of
375<hetzner-configuration>."
376 (let ((config (machine-configuration machine))
377 (environment (environment-type-name (machine-environment machine))))
378 (unless (and config (hetzner-configuration? config))
379 (raise-exception
380 (formatted-message (G_ "unsupported machine configuration '~a' \
381for environment of type '~a'")
382 config
383 environment)))))
384
385(define (hetzner-machine-validate-server-type machine)
386 "Raise an error if the server type of MACHINE is not supported."
387 (unless (hetzner-machine-server-type machine)
388 (let* ((config (machine-configuration machine))
389 (api (hetzner-configuration-api config)))
390 (raise-exception
391 (formatted-message
392 (G_ "server type '~a' not supported~%~%\
393Available server types:~%~%~a~%~%For more details and prices, see: ~a")
394 (hetzner-configuration-server-type config)
395 (string-join
396 (map (lambda (type)
397 (format #f " - ~a: ~a, ~a ~a cores, ~a GB mem, ~a GB disk"
398 (colorize-string
399 (hetzner-server-type-name type)
400 (color BOLD))
401 (hetzner-server-type-architecture type)
402 (hetzner-server-type-cores type)
403 (hetzner-server-type-cpu-type type)
404 (hetzner-server-type-memory type)
405 (hetzner-server-type-disk type)))
406 (hetzner-api-server-types api))
407 "\n")
408 "https://www.hetzner.com/cloud#pricing")))))
409
410(define (hetzner-machine-validate-location machine)
411 "Raise an error if the location of MACHINE is not supported."
412 (unless (hetzner-machine-location machine)
413 (let* ((config (machine-configuration machine))
414 (api (hetzner-configuration-api config)))
415 (raise-exception
416 (formatted-message
417 (G_ "server location '~a' not supported~%~%\
418Available locations:~%~%~a~%~%For more details, see: ~a")
419 (hetzner-configuration-location config)
420 (string-join
421 (map (lambda (location)
422 (format #f " - ~a: ~a, ~a"
423 (colorize-string
424 (hetzner-location-name location)
425 (color BOLD))
426 (hetzner-location-description location)
427 (hetzner-location-country location)))
428 (hetzner-api-locations api))
429 "\n")
430 "https://www.hetzner.com/cloud#locations")))))
431
432(define (hetzner-machine-validate machine)
433 "Validate the Hetzner MACHINE."
434 (hetzner-machine-validate-configuration-type machine)
435 (hetzner-machine-validate-api-token machine)
436 (hetzner-machine-validate-location machine)
437 (hetzner-machine-validate-server-type machine))
438
439(define (hetzner-machine-bootstrap-os-form machine server)
440 "Return the form to bootstrap an operating system on SERVER."
441 (let* ((os (machine-operating-system machine))
442 (system (hetzner-server-system server))
443 (type-name (hetzner-server-type-name (hetzner-server-type server)))
444 (arm? (equal? "arm" (hetzner-server-architecture server)))
445 (x86? (equal? "x86" (hetzner-server-architecture server)))
446 (efi? (equal? 'efi (server-type-name->bootloader type-name)))
447 (root-fs-type (operating-system-root-file-system-type os)))
448 `(operating-system
449 (host-name ,(operating-system-host-name os))
450 (timezone "Etc/UTC")
451 (bootloader (bootloader-configuration
452 (bootloader ,(if efi?
453 'grub-efi-bootloader
454 'grub-bootloader))
455 (targets ,(if efi?
456 '(list "/boot/efi")
457 '(list "/dev/sda")))
458 (terminal-outputs '(console))))
459 (initrd-modules (append
460 ,(cond (arm? '(list "sd_mod" "virtio_scsi"))
461 (x86? '(list "virtio_scsi")))
462 %base-initrd-modules))
463 (file-systems (cons* (file-system
464 (mount-point "/")
465 (device "/dev/sda1")
466 (type ,root-fs-type))
467 ,@(if efi?
468 '((file-system
469 (mount-point "/boot/efi")
470 (device "/dev/sda15")
471 (type "vfat")))
472 '())
473 %base-file-systems))
474 (services
475 (cons* (service dhcpcd-service-type)
476 (service openssh-service-type
477 (openssh-configuration
478 (openssh openssh-sans-x)
479 (permit-root-login 'prohibit-password)))
480 %base-services)))))
481
482(define (rexec-verbose session cmd)
483 "Execute a command CMD on the remote side and print output. Return two
484values: list of output lines returned by CMD and its exit code."
485 (let* ((channel (open-remote-input-pipe session cmd))
486 (result (let loop ((line (read-line channel))
487 (result '()))
488 (if (eof-object? line)
489 (reverse result)
490 (begin
491 (display line)
492 (newline)
493 (loop (read-line channel)
494 (cons line result))))))
495 (exit-status (channel-get-exit-status channel)))
496 (close channel)
497 (values result exit-status)))
498
499(define (hetzner-machine-ssh-key machine)
500 "Find the SSH key for MACHINE on the Hetzner API."
501 (and-let* ((config (machine-configuration machine))
502 (public-key (hetzner-configuration-ssh-public-key config))
503 (expected (public-key->fingerprint public-key)))
504 (find (lambda (ssh-key)
505 (equal? expected (hetzner-ssh-key-fingerprint ssh-key)))
506 (hetzner-api-ssh-keys
507 (hetzner-configuration-api config)
508 #:params `(("fingerprint" . ,expected))))))
509
510(define (hetzner-machine-ssh-key-create machine)
511 "Create the SSH key for MACHINE on the Hetzner API."
512 (let ((name (machine-display-name machine)))
513 (format #t "creating ssh key for '~a'...\n" name)
514 (let* ((config (machine-configuration machine))
515 (api (hetzner-configuration-api config))
516 (pubkey (hetzner-configuration-ssh-public-key config))
517 (_ (assert pubkey))
518 (ssh-key (hetzner-api-ssh-key-create
519 api
520 (public-key->fingerprint pubkey)
521 (public-key->string-with-type pubkey)
522 #:labels (hetzner-configuration-labels config))))
523 (format #t "successfully created ssh key for '~a'\n" name)
524 ssh-key)))
525
526(define (hetzner-machine-server machine)
527 "Find the Hetzner server for MACHINE."
528 (let ((config (machine-configuration machine)))
529 (find (lambda (server)
530 (equal? (machine-display-name machine)
531 (hetzner-server-name server)))
532 (hetzner-api-servers
533 (hetzner-configuration-api config)
534 #:params `(("name" . ,(machine-display-name machine)))))))
535
536(define (hetzner-resolve-ip api name)
537 "Find the NAME IP address on the Hetzner API."
538 (or
539 (find (lambda (primary-ip)
540 (equal? name (hetzner-primary-ip-name primary-ip)))
541 (hetzner-api-primary-ips api #:params `(("name" . ,name))))
542
543 (raise-exception
544 (formatted-message (G_ "primary ip '~a' does not exist.")
545 name))))
546
547(define temporary-ssh-key-file
548 (let ((ssh-key-file (port-filename (mkstemp "/tmp/hetzner-key-XXXXXX")))
549 (ssh-key #f))
550 (lambda ()
551 "Return a dynamically created, temporary private SSH key."
552 (unless ssh-key
553 (set! ssh-key (make-keypair 'ed25519))
554 (private-key-to-file ssh-key ssh-key-file))
555 ssh-key-file)))
556
557(define (hetzner-machine-create-server machine)
558 "Create the Hetzner server for MACHINE."
559 (let* ((config (machine-configuration machine))
560 (name (machine-display-name machine))
561 (server-type (hetzner-configuration-server-type config)))
562 (format #t "creating '~a' server for '~a'...\n" server-type name)
563 (let* ((ssh-key (hetzner-machine-ssh-key machine))
564 (_ (assert ssh-key)) ;required during provisioning
565 (ipv4 (hetzner-configuration-ipv4 config))
566 (ipv6 (hetzner-configuration-ipv6 config))
567 (api (hetzner-configuration-api config))
568 (server (hetzner-api-server-create
569 api
570 (machine-display-name machine)
571 #:ssh-keys (list ssh-key)
572 #:ipv4 (if (string? ipv4)
573 (hetzner-primary-ip-id (hetzner-resolve-ip api ipv4))
574 ipv4)
575 #:ipv6 (if (string? ipv6)
576 (hetzner-primary-ip-id (hetzner-resolve-ip api ipv6))
577 ipv6)
578 #:labels (hetzner-configuration-labels config)
579 #:location (hetzner-configuration-location config)
580 #:server-type (hetzner-configuration-server-type config)))
581 (architecture (hetzner-server-architecture server)))
582 (format #t "successfully created '~a' ~a server for '~a'\n"
583 server-type architecture name)
584 server)))
585
586(define (wait-for-ssh address ssh-key)
587 "Block until a SSH session can be made as 'root' with SSH-KEY at ADDRESS."
588 (format #t "connecting via SSH to '~a' using '~a'...\n" address ssh-key)
589 (let loop ()
590 (catch #t
591 (lambda ()
592 (open-ssh-session address #:user "root" #:identity ssh-key
593 #:strict-host-key-check? #f))
594 (lambda args
595 (let ((msg (cadr args)))
596 (if (formatted-message? msg)
597 (format #t "~a\n"
598 (string-trim-right
599 (apply format #f
600 (formatted-message-string msg)
601 (formatted-message-arguments msg))
602 #\newline))
603 (format #t "~a" args))
604 (sleep 5)
605 (loop))))))
606
607(define (hetzner-machine-wait-for-ssh machine server)
608 "Wait for SSH connection to be established with the specified machine."
609 (wait-for-ssh (hetzner-server-public-ipv4 server)
610 (hetzner-configuration-ssh-key
611 (machine-configuration machine))))
612
613(define (hetzner-machine-authenticate-host machine server)
614 "Add the host key of MACHINE to the list of known hosts."
615 (let ((ssh-session (hetzner-machine-wait-for-ssh machine server)))
616 (write-known-host! ssh-session)))
617
618(define (hetzner-machine-enable-rescue-system machine server)
619 "Enable the rescue system on the Hetzner SERVER for MACHINE, provisioning it
620with the configured SSH key, or a dynamically created temporary one."
621 (let* ((name (machine-display-name machine))
622 (config (machine-configuration machine))
623 (api (hetzner-configuration-api config))
624 (ssh-keys (and=> (hetzner-machine-ssh-key machine) list)))
625 (format #t "enabling rescue system on '~a'...\n" name)
626 (let ((action (hetzner-api-server-enable-rescue-system
627 api server #:ssh-keys ssh-keys)))
628 (format #t "successfully enabled rescue system on '~a'\n" name)
629 action)))
630
631(define (hetzner-machine-power-on machine server)
632 "Power on the Hetzner SERVER for MACHINE."
633 (let* ((name (machine-display-name machine))
634 (config (machine-configuration machine))
635 (api (hetzner-configuration-api config)))
636 (format #t "powering on server for '~a'...\n" name)
637 (let ((action (hetzner-api-server-power-on api server)))
638 (format #t "successfully powered on server for '~a'\n" name)
639 action)))
640
641(define (hetzner-machine-ssh-run-script ssh-session name content)
642 (let ((sftp-session (make-sftp-session ssh-session)))
643 (rexec ssh-session (format #f "rm -f ~a" name))
644 (rexec ssh-session (format #f "mkdir -p ~a" (dirname name)))
645 (call-with-remote-output-file
646 sftp-session name
647 (lambda (port)
648 (display content port)))
649 (sftp-chmod sftp-session name 755)
650 (let ((lines exit-code (rexec-verbose ssh-session
651 (format #f "~a 2>&1" name))))
652 (if (zero? exit-code)
653 lines
654 (raise-exception
655 (formatted-message
656 (G_ "failed to run script '~a' on machine, exit code: '~a'")
657 name exit-code))))))
658
659;; Prevent compiler from inlining this function, so we can mock it in tests.
660(set! hetzner-machine-ssh-run-script hetzner-machine-ssh-run-script)
661
662(define (hetzner-machine-rescue-install-os machine ssh-session server)
663 "Init a minimal Guix System to bootstrap from."
664 (let ((name (machine-display-name machine))
665 (os (hetzner-machine-bootstrap-os-form machine server)))
666 (format #t "installing guix operating system on '~a'...\n" name)
667 (hetzner-machine-ssh-run-script
668 ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-install-os"
669 (format #f "#!/usr/bin/env bash
670set -eo pipefail
671mount /dev/sda1 /mnt
672mkdir -p /mnt/boot/efi
673mount /dev/sda15 /mnt/boot/efi
674
675mkdir --parents /mnt/root/.ssh
676chmod 700 /mnt/root/.ssh
677cp /root/.ssh/authorized_keys /mnt/root/.ssh/authorized_keys
678chmod 600 /mnt/root/.ssh/authorized_keys
679
680# Small instance don't have much disk space. Bind mount the store of the
681# rescue system to the tmp directory of the new Guix system.
682mkdir -p /mnt/tmp/gnu
683mkdir -p /gnu
684mount --bind /mnt/tmp/gnu /gnu
685
686wget -O /tmp/guix-install.sh https://guix.gnu.org/guix-install.sh
687chmod +x /tmp/guix-install.sh
688set +o pipefail # avoid hangup on 'yes' killing this script
689yes '' | /tmp/guix-install.sh
690set -o pipefail
691
692cat > /tmp/guix/deploy/hetzner-os.scm << EOF
693(use-modules (gnu) (guix utils))
694(use-package-modules ssh)
695(use-service-modules base networking ssh)
696(use-system-modules linux-initrd)
697~a
698EOF
699guix system init --verbosity=2 /tmp/guix/deploy/hetzner-os.scm /mnt"
700 (escape-backticks (format #f "~y" os))))
701 (format #t "successfully installed guix operating system on '~a'\n" name)))
702
703(define (hetzner-machine-reboot machine server)
704 "Reboot the Hetzner SERVER for MACHINE."
705 (let* ((name (machine-display-name machine))
706 (config (machine-configuration machine))
707 (api (hetzner-configuration-api config)))
708 (format #t "rebooting server for '~a'...\n" name)
709 (let ((action (hetzner-api-server-reboot api server)))
710 (format #t "successfully rebooted server for '~a'\n" name)
711 action)))
712
713(define (hetzner-machine-rescue-partition machine ssh-session)
714 "Setup the partitions of the Hetzner server for MACHINE using SSH-SESSION."
715 (let* ((name (machine-display-name machine))
716 (os (machine-operating-system machine))
717 (root-fs-type (operating-system-root-file-system-type os)))
718 (format #t "setting up partitions on '~a'...\n" name)
719 (hetzner-machine-ssh-run-script
720 ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-partition"
721 (format #f "#!/usr/bin/env bash
722set -eo pipefail
723growpart /dev/sda 1 || true
724~a
725fdisk -l /dev/sda"
726 (cond
727 ((equal? "btrfs" root-fs-type)
728 (format #f "mkfs.btrfs -L ~a -f /dev/sda1" root-label))
729 ((equal? "ext4" root-fs-type)
730 (format #f "mkfs.ext4 -L ~a -F /dev/sda1" root-label))
731 (else (raise-exception
732 (formatted-message
733 (G_ "unsupported root file system type '~a'")
734 root-fs-type))))))
735 (format #t "successfully setup partitions on '~a'\n" name)))
736
737(define (hetzner-machine-rescue-install-packages machine ssh-session)
738 "Install packages on the Hetzner server for MACHINE using SSH-SESSION."
739 (let ((name (machine-display-name machine)))
740 (format #t "installing rescue system packages on '~a'...\n" name)
741 (hetzner-machine-ssh-run-script
742 ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-install-packages"
743 (format #f "#!/usr/bin/env bash
744set -eo pipefail
745apt-get update
746apt-get install cloud-initramfs-growroot uidmap --assume-yes"))
747 (format #t "successfully installed rescue system packages on '~a'\n" name)))
748
749(define (hetzner-machine-delete machine server)
750 "Delete the Hetzner server for MACHINE."
751 (let* ((name (machine-display-name machine))
752 (config (machine-configuration machine))
753 (api (hetzner-configuration-api config)))
754 (format #t "deleting server for '~a'...\n" name)
755 (let ((action (hetzner-api-server-delete api server)))
756 (format #t "successfully deleted server for '~a'\n" name)
757 action)))
758
759(define (hetzner-machine-provision machine)
760 "Provision a Guix System bootstrap server for MACHINE on the Hetzner Cloud
761service."
762 (with-exception-handler
763 (lambda (exception)
764 (let ((config (machine-configuration machine))
765 (server (hetzner-machine-server machine)))
766 (when (and server (hetzner-configuration-delete? config))
767 (hetzner-machine-delete machine server))
768 (raise-exception exception)))
769 (lambda ()
770 (let ((server (hetzner-machine-create-server machine)))
771 (hetzner-machine-enable-rescue-system machine server)
772 (hetzner-machine-power-on machine server)
773 (let ((ssh-session (hetzner-machine-wait-for-ssh machine server)))
774 (hetzner-machine-rescue-install-packages machine ssh-session)
775 (hetzner-machine-rescue-partition machine ssh-session)
776 (hetzner-machine-rescue-install-os machine ssh-session server))
777 (hetzner-machine-reboot machine server)
778 (hetzner-machine-authenticate-host machine server)
779 server))))
780
781(define (machine-not-provisioned machine)
782 (formatted-message
783 (G_ "no server provisioned for machine '~a' on the Hetzner Cloud service")
784 (machine-display-name machine)))
785
786
787;;;
788;;; Remote evaluation.
789;;;
790
791(define (hetzner-remote-eval machine exp)
792 "Internal implementation of 'machine-remote-eval' for MACHINE instances with
793an environment type of 'hetzner-environment-type'."
794 (hetzner-machine-validate machine)
795 (let ((server (hetzner-machine-server machine)))
796 (unless server (raise-exception (machine-not-provisioned machine)))
797 (machine-remote-eval (hetzner-machine-delegate machine server) exp)))
798
799
800
801;;;
802;;; System deployment.
803;;;
804
805(define (cleanup-temporary-ssh-key/maybe api ssh-key)
806 "Delete the temporary SSH private key file from the file system and the
807Hetzner API, if one was created used."
808 (when (%hetzner-ssh-key-file)
809 (format #t "cleaning up temporary ssh key~%")
810 (delete-file (%hetzner-ssh-key-file))
811 (%hetzner-ssh-key-file #f)
812 (hetzner-api-ssh-key-delete api ssh-key)))
813
814(define (deploy-hetzner machine)
815 "Internal implementation of 'deploy-machine' for 'machine' instances with an
816environment type of 'hetzner-environment-type'."
817 (hetzner-machine-validate machine)
818
819 (define server (hetzner-machine-server machine))
820 (define config (machine-configuration machine))
821 (define api (hetzner-configuration-api config))
822 (define ssh-key #f) ;hetzner API key
823
824 ;; Provisioning requires uploading an SSH key via the Hetzner API to
825 ;; authenticate non-interactively with the newly created server.
826 (unless server ;provisioning?
827 (unless (hetzner-configuration-ssh-public-key config)
828 (format #t "using a temporary ssh key for provisioning~%")
829 (%hetzner-ssh-key-file (temporary-ssh-key-file)))
830 (set! ssh-key (or (hetzner-machine-ssh-key machine)
831 (hetzner-machine-ssh-key-create machine))))
832
833 ;; Cleaning-up here is a bit tricky, as `deploy-machine' returns a monadic
834 ;; value immediately, to be executed later; this means the clean-up must be
835 ;; delayed until monadic evaluation time.
836 (let* ((server (or server (hetzner-machine-provision machine)))
837 (delegate-machine (hetzner-machine-delegate machine server)))
838 ;; FIXME: The clean-up in the guard does not run even when
839 ;; `deploy-machine' fails.
840 (guard (c (#t (cleanup-temporary-ssh-key/maybe api ssh-key)
841 (raise c)))
842 (mlet %store-monad
843 ((value (deploy-machine delegate-machine)))
844 (cleanup-temporary-ssh-key/maybe api ssh-key)
845 (return value)))))
846
847
848;;;
849;;; Roll-back.
850;;;
851
852(define (roll-back-hetzner machine)
853 "Internal implementation of 'roll-back-machine' for MACHINE instances with an
854environment type of 'hetzner-environment-type'."
855 (hetzner-machine-validate machine)
856 (let ((server (hetzner-machine-server machine)))
857 (unless server (raise-exception (machine-not-provisioned machine)))
858 (roll-back-machine (hetzner-machine-delegate machine server))))
859
860
861
862;;;
863;;; Environment type.
864;;;
865
866(define hetzner-environment-type
867 (environment-type
868 (machine-remote-eval hetzner-remote-eval)
869 (deploy-machine deploy-hetzner)
870 (roll-back-machine roll-back-hetzner)
871 (name 'hetzner-environment-type)
872 (description "Provisioning of virtual machine servers on the Hetzner Cloud
873service.")))