projects/guix·blob ruby-team · refs

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