mirror of
https://git.savannah.gnu.org/git/guix.git
synced 2026-06-25 03:34:08 +02:00
Maxim Cournoyer
3777bf133e
This fixes a regression introduced in commit a2ef2bcbfd ("machine: hetzner:
Allow connections using ssh-agent"), where having no ssh-key would cause the
early Hetzner provisioning to fail due to the lack of SSH authentication.
* gnu/machine/hetzner.scm (%hetzner-ssh-key-file): New parameter.
(<hetzner-configuration>) [ssh-public-key]: Compute default according to the
value of the private ssh-key field. Introduce an indirection via...
(hetzner-configuration-ssh-public-key): ... this new procedure, to honor
%hetzner-ssh-key-file.
(hetzner-configuration-ssh-key): Likewise for the private ssh-key.
(hetzner-configuration-ssh-key-fingerprint): Rename to...
(public-key->fingerprint): ... this, taking just the public key as argument.
Update doc.
(hetzner-configuration-ssh-key-public): Rename to...
(public-key->string-with-type): ...this, for clarity, and accept just a
public-key object. Update doc.
(hetzner-machine-ssh-key): Exit early with #f when no ssh key is provided.
(temporary-ssh-key-file): New procedure.
(hetzner-machine-ssh-key-create): Assert a public key is defined. Adjust
calls to renamed procedures, and adjust for the `hetzner-api-server-create'
API change.
(hetzner-machine-enable-rescue-system): Refine doc and fix code path when
ssh-key is #f.
(hetzner-machine-rescue-install-os): Document.
(hetzner-machine-provision): Refine doc. Remove extraneous sleep and #:unwind
argument. Limit ssh-session dynamic scope to where it's needed.
(cleanup-temporary-ssh-key/maybe): New procedure.
(deploy-hetzner): Create and use a temporary SSH key when none is defined, and
clean it up when done or on errors.
* gnu/machine/hetzner/http.scm (hetzner-api-server-create): Make ssh-keys a
keyword argument, and fix execution when it's #f.
(hetzner-api-server-enable-rescue-system): Likewise.
* tests/machine/hetzner.scm ("deploy-machine-mock-with-unprovisioned-server"):
Adjust test.
* tests/machine/hetzner/http.scm (create-server)
("hetzner-api-server-create-unit")
("hetzner-api-server-enable-rescue-system-unit")
("hetzner-api-actions-integration")
("hetzner-api-server-enable-rescue-system-integration"): Likewise.
* doc/guix.texi (Invoking guix deploy): Precise what happens when 'ssh-key' is
#f in hetzner-configuration, and suggest declaratively authorizing your SSH
key.
Change-Id: I812b348fb553f3b5aebd0bf66850c6ecb9e06653
871 lines
34 KiB
Scheme
871 lines
34 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
|
;;; Copyright © 2024 Roman Scherer <roman@burningswell.com>
|
|
;;; Copyright © 2025 Owen T. Heisler <writer@owenh.net>
|
|
;;; Copyright © 2025 Remco van 't Veer <remco@remworks.net>
|
|
;;; Copyright © 2026 Maxim Cournoyer <maxim@guixotic.coop>
|
|
;;;
|
|
;;; This file is part of GNU Guix.
|
|
;;;
|
|
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
|
;;; under the terms of the GNU General Public License as published by
|
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
|
;;; your option) any later version.
|
|
;;;
|
|
;;; GNU Guix is distributed in the hope that it will be useful, but
|
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;;; GNU General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU General Public License
|
|
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
(define-module (gnu machine hetzner)
|
|
#:use-module (gnu bootloader grub)
|
|
#:use-module (gnu bootloader)
|
|
#:use-module (gnu machine hetzner http)
|
|
#:use-module (gnu machine ssh)
|
|
#:use-module (gnu machine)
|
|
#:use-module (gnu packages ssh)
|
|
#:use-module (gnu services base)
|
|
#:use-module (gnu services networking)
|
|
#:use-module (gnu services ssh)
|
|
#:use-module (gnu services)
|
|
#:use-module (gnu system file-systems)
|
|
#:use-module (gnu system image)
|
|
#:use-module (gnu system linux-initrd)
|
|
#:use-module (gnu system pam)
|
|
#:use-module (gnu system)
|
|
#:use-module (guix base32)
|
|
#:use-module (guix colors)
|
|
#:use-module (guix deprecation)
|
|
#:use-module (guix derivations)
|
|
#:use-module (guix diagnostics)
|
|
#:use-module (guix gexp)
|
|
#:use-module (guix i18n)
|
|
#:use-module (guix import json)
|
|
#:use-module (guix monads)
|
|
#:use-module (guix packages)
|
|
#:use-module (guix pki)
|
|
#:use-module (guix records)
|
|
#:use-module (guix ssh)
|
|
#:use-module (guix store)
|
|
#:use-module (ice-9 format)
|
|
#:use-module (ice-9 iconv)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (ice-9 popen)
|
|
#:use-module (ice-9 rdelim)
|
|
#:use-module (ice-9 string-fun)
|
|
#:use-module (ice-9 textual-ports)
|
|
#:use-module (json)
|
|
#:use-module ((rnrs base) #:select (assert))
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-2)
|
|
#:use-module (srfi srfi-34)
|
|
#:use-module (srfi srfi-35)
|
|
#:use-module (srfi srfi-71)
|
|
#:use-module (ssh channel)
|
|
#:use-module (ssh key)
|
|
#:use-module (ssh popen)
|
|
#:use-module (ssh session)
|
|
#:use-module (ssh sftp)
|
|
#:use-module (ssh shell)
|
|
#:export (%hetzner-os-arm ;deprecated
|
|
%hetzner-os-x86 ;deprecated
|
|
make-hetzner-os
|
|
|
|
deploy-hetzner
|
|
hetzner-configuration
|
|
hetzner-configuration-allow-downgrades?
|
|
hetzner-configuration-api
|
|
hetzner-configuration-authorize?
|
|
hetzner-configuration-build-locally?
|
|
hetzner-configuration-delete?
|
|
hetzner-configuration-ipv4
|
|
hetzner-configuration-ipv6
|
|
hetzner-configuration-labels
|
|
hetzner-configuration-location
|
|
hetzner-configuration-server-type
|
|
hetzner-configuration-ssh-key
|
|
hetzner-configuration-ssh-public-key
|
|
hetzner-configuration-user
|
|
hetzner-configuration?
|
|
hetzner-environment-type))
|
|
|
|
;;; Commentary:
|
|
;;;
|
|
;;; This module implements a high-level interface for provisioning machines on
|
|
;;; the Hetzner Cloud service https://docs.hetzner.cloud.
|
|
;;;
|
|
|
|
|
|
;;;
|
|
;;; Hetzner operating systems.
|
|
;;;
|
|
|
|
;; Operating system for arm servers using UEFI boot mode.
|
|
|
|
(define %hetzner-os-arm/efi
|
|
(operating-system
|
|
(host-name "guix-arm")
|
|
(bootloader
|
|
(bootloader-configuration
|
|
(bootloader grub-efi-bootloader)
|
|
(targets (list "/boot/efi"))
|
|
(terminal-outputs '(console))))
|
|
(file-systems
|
|
(cons* (file-system
|
|
(mount-point "/")
|
|
(device "/dev/sda1")
|
|
(type "ext4"))
|
|
(file-system
|
|
(mount-point "/boot/efi")
|
|
(device "/dev/sda15")
|
|
(type "vfat"))
|
|
%base-file-systems))
|
|
(initrd-modules
|
|
(cons* "sd_mod" "virtio_scsi" %base-initrd-modules))
|
|
(services
|
|
(cons* (service dhcpcd-service-type)
|
|
(service openssh-service-type
|
|
(openssh-configuration
|
|
(openssh openssh-sans-x)
|
|
(permit-root-login 'prohibit-password)))
|
|
%base-services))))
|
|
|
|
;; Operating system for x86 servers using BIOS boot mode.
|
|
|
|
(define %hetzner-os-x86/bios
|
|
(operating-system
|
|
(inherit %hetzner-os-arm/efi)
|
|
(host-name "guix-x86")
|
|
(bootloader
|
|
(bootloader-configuration
|
|
(bootloader grub-bootloader)
|
|
(targets (list "/dev/sda"))
|
|
(terminal-outputs '(console))))
|
|
(initrd-modules
|
|
(cons "virtio_scsi" %base-initrd-modules))
|
|
(file-systems
|
|
(cons (file-system
|
|
(mount-point "/")
|
|
(device "/dev/sda1")
|
|
(type "ext4"))
|
|
%base-file-systems))))
|
|
|
|
(define %hetzner-os-x86/efi
|
|
(operating-system
|
|
(inherit %hetzner-os-arm/efi)
|
|
(host-name "guix-x86")
|
|
(initrd-modules
|
|
(cons "virtio_scsi" %base-initrd-modules))))
|
|
|
|
(define (server-type-name->arch type-name)
|
|
"Return a symbol corresponding to the server type architecture, e.g.
|
|
@code{'x86} or @code{'arm}."
|
|
(cond
|
|
((string-prefix-ci? "cax" type-name)
|
|
'arm)
|
|
(else
|
|
'x86)))
|
|
|
|
(define (server-type-name->bootloader type-name)
|
|
"Return a symbol corresponding to the bootloader type, e.g.
|
|
@code{'efi} or @code{'bios}."
|
|
(if (eq? 'arm (server-type-name->arch type-name))
|
|
'efi
|
|
(cond
|
|
((string-prefix-ci? "cx" type-name)
|
|
'bios) ;old, cost-optimized x86 servers
|
|
(else
|
|
'efi)))) ;newer, regular performance/general purpose servers
|
|
|
|
(define* (make-hetzner-os server-type-name)
|
|
"Return an operating server customized for SERVER-TYPE-NAME, a string like
|
|
\"cx23\" or \"cax11\", denoting the Hetzner virtual server type."
|
|
(match (server-type-name->arch server-type-name)
|
|
('arm %hetzner-os-arm/efi)
|
|
('x86
|
|
(match (server-type-name->bootloader server-type-name)
|
|
('bios %hetzner-os-x86/bios)
|
|
('efi %hetzner-os-x86/efi)))))
|
|
|
|
(define-deprecated %hetzner-os-x86
|
|
make-hetzner-os
|
|
%hetzner-os-x86/bios)
|
|
|
|
(define-deprecated %hetzner-os-arm
|
|
make-hetzner-os
|
|
%hetzner-os-arm/efi)
|
|
|
|
(define (operating-system-authorize os)
|
|
"Authorize the OS with the public signing key of the current machine."
|
|
(if (file-exists? %public-key-file)
|
|
(operating-system
|
|
(inherit os)
|
|
(services
|
|
(modify-services services
|
|
(guix-service-type
|
|
config => (guix-configuration
|
|
(inherit config)
|
|
(authorized-keys
|
|
(cons*
|
|
(local-file %public-key-file)
|
|
(guix-configuration-authorized-keys config))))))))
|
|
(raise-exception
|
|
(formatted-message (G_ "no signing key '~a'. \
|
|
Have you run 'guix archive --generate-key'?")
|
|
%public-key-file))))
|
|
|
|
(define (operating-system-root-file-system-type os)
|
|
"Return the root file system type of the operating system OS."
|
|
(let ((root-fs (find (lambda (file-system)
|
|
(equal? "/" (file-system-mount-point file-system)))
|
|
(operating-system-file-systems os))))
|
|
(if (file-system? root-fs)
|
|
(file-system-type root-fs)
|
|
(raise-exception
|
|
(formatted-message
|
|
(G_ "could not determine root file system type"))))))
|
|
|
|
|
|
;;;
|
|
;;; Helper functions.
|
|
;;;
|
|
|
|
(define (escape-backticks str)
|
|
"Escape all backticks in STR."
|
|
(string-replace-substring str "`" "\\`"))
|
|
|
|
|
|
|
|
;;;
|
|
;;; Hetzner configuration.
|
|
;;;
|
|
|
|
;;; This parameter overrides the value returned by
|
|
;;; `hetzner-configuration-ssh-key'.
|
|
(define %hetzner-ssh-key-file
|
|
(make-parameter #f))
|
|
|
|
(define-record-type* <hetzner-configuration> hetzner-configuration
|
|
make-hetzner-configuration hetzner-configuration? this-hetzner-configuration
|
|
(allow-downgrades? hetzner-configuration-allow-downgrades? ; boolean
|
|
(default #f))
|
|
(api hetzner-configuration-api ; <hetzner-api>
|
|
(default (hetzner-api)))
|
|
(authorize? hetzner-configuration-authorize? ; boolean
|
|
(default #t))
|
|
(build-locally? hetzner-configuration-build-locally? ; boolean
|
|
(default #t))
|
|
(delete? hetzner-configuration-delete? ; boolean
|
|
(default #t))
|
|
(labels hetzner-configuration-labels ; list of strings
|
|
(default '()))
|
|
(location hetzner-configuration-location ; #f | string
|
|
(default "fsn1"))
|
|
(server-type hetzner-configuration-server-type ; string
|
|
(default "cx42"))
|
|
(ipv4 hetzner-configuration-ipv4 ; boolean | string
|
|
(default #t))
|
|
(ipv6 hetzner-configuration-ipv6 ; boolean | string
|
|
(default #t))
|
|
(ssh-public-key hetzner-configuration-ssh-public-key* ; #f | public-key | string
|
|
(thunked)
|
|
(default (and=> (hetzner-configuration-ssh-key
|
|
this-hetzner-configuration)
|
|
public-key-from-file))
|
|
(sanitize (lambda (value)
|
|
(if (string? value)
|
|
(public-key-from-file value)
|
|
value))))
|
|
(ssh-key hetzner-configuration-ssh-key* ; #f | string
|
|
(default #f))
|
|
(user hetzner-configuration-user ;string
|
|
(default "root")))
|
|
|
|
(define (hetzner-configuration-ssh-key config)
|
|
(or (%hetzner-ssh-key-file)
|
|
(hetzner-configuration-ssh-key* config)))
|
|
|
|
(define (hetzner-configuration-ssh-public-key config)
|
|
(or (and=> (%hetzner-ssh-key-file) public-key-from-file)
|
|
(hetzner-configuration-ssh-public-key* config)))
|
|
|
|
(define (public-key->fingerprint public-key)
|
|
"Return the SSH public key fingerprint of PUBLIC-KEY, a Guile-SSH public key
|
|
object, in the expected format for the Hetzner API."
|
|
(let ((hash (get-public-key-hash public-key 'md5)))
|
|
(bytevector->hex-string hash)))
|
|
|
|
(define (public-key->string-with-type public-key)
|
|
"Return the SSH public key string of PUBLIC-KEY, a Guile-SSH public key
|
|
object, in the expected format for the Hetzner API."
|
|
(format #f "ssh-~a ~a" (get-key-type public-key)
|
|
(public-key->string public-key)))
|
|
|
|
|
|
;;;
|
|
;;; Hetzner Machine.
|
|
;;;
|
|
|
|
(define (hetzner-machine-delegate target server)
|
|
"Return the delegate machine that uses SSH for deployment."
|
|
(let* ((config (machine-configuration target))
|
|
;; Get the operating system WITHOUT the provenance service to avoid a
|
|
;; duplicate symlink conflict in the store.
|
|
(os ((@@ (gnu machine) %machine-operating-system) target)))
|
|
(match-record config <hetzner-configuration>
|
|
( authorize? allow-downgrades? build-locally? user)
|
|
(machine
|
|
(inherit target)
|
|
(operating-system
|
|
(if authorize?
|
|
(operating-system-authorize os)
|
|
os))
|
|
(environment managed-host-environment-type)
|
|
(configuration
|
|
(machine-ssh-configuration
|
|
(allow-downgrades? allow-downgrades?)
|
|
(authorize? authorize?)
|
|
(build-locally? build-locally?)
|
|
(host-name (hetzner-server-public-ipv4 server))
|
|
;; XXX: match-record doesn't make use of custom accessors to obtain
|
|
;; the value, so we can't bind SSH-KEY with it.
|
|
(identity (hetzner-configuration-ssh-key config))
|
|
(system (hetzner-server-system server))
|
|
(user user)))))))
|
|
|
|
(define (hetzner-machine-location machine)
|
|
"Find the location of MACHINE on the Hetzner API."
|
|
(let* ((config (machine-configuration machine))
|
|
(expected (hetzner-configuration-location config)))
|
|
(find (lambda (location)
|
|
(equal? expected (hetzner-location-name location)))
|
|
(hetzner-api-locations
|
|
(hetzner-configuration-api config)
|
|
#:params `(("name" . ,expected))))))
|
|
|
|
(define (hetzner-machine-server-type machine)
|
|
"Find the server type of MACHINE on the Hetzner API."
|
|
(let* ((config (machine-configuration machine))
|
|
(expected (hetzner-configuration-server-type config)))
|
|
(find (lambda (server-type)
|
|
(equal? expected (hetzner-server-type-name server-type)))
|
|
(hetzner-api-server-types
|
|
(hetzner-configuration-api config)
|
|
#:params `(("name" . ,expected))))))
|
|
|
|
(define (hetzner-machine-validate-api-token machine)
|
|
"Validate the Hetzner API authentication token of MACHINE."
|
|
(let* ((config (machine-configuration machine))
|
|
(api (hetzner-configuration-api config)))
|
|
(unless (hetzner-api-token api)
|
|
(raise-exception
|
|
(formatted-message
|
|
(G_ "Hetzner Cloud access token was not provided. \
|
|
This may be fixed by setting the environment variable GUIX_HETZNER_API_TOKEN \
|
|
to one procured from \
|
|
https://docs.hetzner.com/cloud/api/getting-started/generating-api-token"))))))
|
|
|
|
(define (hetzner-machine-validate-configuration-type machine)
|
|
"Raise an error if MACHINE's configuration is not an instance of
|
|
<hetzner-configuration>."
|
|
(let ((config (machine-configuration machine))
|
|
(environment (environment-type-name (machine-environment machine))))
|
|
(unless (and config (hetzner-configuration? config))
|
|
(raise-exception
|
|
(formatted-message (G_ "unsupported machine configuration '~a' \
|
|
for environment of type '~a'")
|
|
config
|
|
environment)))))
|
|
|
|
(define (hetzner-machine-validate-server-type machine)
|
|
"Raise an error if the server type of MACHINE is not supported."
|
|
(unless (hetzner-machine-server-type machine)
|
|
(let* ((config (machine-configuration machine))
|
|
(api (hetzner-configuration-api config)))
|
|
(raise-exception
|
|
(formatted-message
|
|
(G_ "server type '~a' not supported~%~%\
|
|
Available server types:~%~%~a~%~%For more details and prices, see: ~a")
|
|
(hetzner-configuration-server-type config)
|
|
(string-join
|
|
(map (lambda (type)
|
|
(format #f " - ~a: ~a, ~a ~a cores, ~a GB mem, ~a GB disk"
|
|
(colorize-string
|
|
(hetzner-server-type-name type)
|
|
(color BOLD))
|
|
(hetzner-server-type-architecture type)
|
|
(hetzner-server-type-cores type)
|
|
(hetzner-server-type-cpu-type type)
|
|
(hetzner-server-type-memory type)
|
|
(hetzner-server-type-disk type)))
|
|
(hetzner-api-server-types api))
|
|
"\n")
|
|
"https://www.hetzner.com/cloud#pricing")))))
|
|
|
|
(define (hetzner-machine-validate-location machine)
|
|
"Raise an error if the location of MACHINE is not supported."
|
|
(unless (hetzner-machine-location machine)
|
|
(let* ((config (machine-configuration machine))
|
|
(api (hetzner-configuration-api config)))
|
|
(raise-exception
|
|
(formatted-message
|
|
(G_ "server location '~a' not supported~%~%\
|
|
Available locations:~%~%~a~%~%For more details, see: ~a")
|
|
(hetzner-configuration-location config)
|
|
(string-join
|
|
(map (lambda (location)
|
|
(format #f " - ~a: ~a, ~a"
|
|
(colorize-string
|
|
(hetzner-location-name location)
|
|
(color BOLD))
|
|
(hetzner-location-description location)
|
|
(hetzner-location-country location)))
|
|
(hetzner-api-locations api))
|
|
"\n")
|
|
"https://www.hetzner.com/cloud#locations")))))
|
|
|
|
(define (hetzner-machine-validate machine)
|
|
"Validate the Hetzner MACHINE."
|
|
(hetzner-machine-validate-configuration-type machine)
|
|
(hetzner-machine-validate-api-token machine)
|
|
(hetzner-machine-validate-location machine)
|
|
(hetzner-machine-validate-server-type machine))
|
|
|
|
(define (hetzner-machine-bootstrap-os-form machine server)
|
|
"Return the form to bootstrap an operating system on SERVER."
|
|
(let* ((os (machine-operating-system machine))
|
|
(system (hetzner-server-system server))
|
|
(type-name (hetzner-server-type-name (hetzner-server-type server)))
|
|
(arm? (equal? "arm" (hetzner-server-architecture server)))
|
|
(x86? (equal? "x86" (hetzner-server-architecture server)))
|
|
(efi? (equal? 'efi (server-type-name->bootloader type-name)))
|
|
(root-fs-type (operating-system-root-file-system-type os)))
|
|
`(operating-system
|
|
(host-name ,(operating-system-host-name os))
|
|
(timezone "Etc/UTC")
|
|
(bootloader (bootloader-configuration
|
|
(bootloader ,(if efi?
|
|
'grub-efi-bootloader
|
|
'grub-bootloader))
|
|
(targets ,(if efi?
|
|
'(list "/boot/efi")
|
|
'(list "/dev/sda")))
|
|
(terminal-outputs '(console))))
|
|
(initrd-modules (append
|
|
,(cond (arm? '(list "sd_mod" "virtio_scsi"))
|
|
(x86? '(list "virtio_scsi")))
|
|
%base-initrd-modules))
|
|
(file-systems (cons* (file-system
|
|
(mount-point "/")
|
|
(device "/dev/sda1")
|
|
(type ,root-fs-type))
|
|
,@(if efi?
|
|
'((file-system
|
|
(mount-point "/boot/efi")
|
|
(device "/dev/sda15")
|
|
(type "vfat")))
|
|
'())
|
|
%base-file-systems))
|
|
(services
|
|
(cons* (service dhcpcd-service-type)
|
|
(service openssh-service-type
|
|
(openssh-configuration
|
|
(openssh openssh-sans-x)
|
|
(permit-root-login 'prohibit-password)))
|
|
%base-services)))))
|
|
|
|
(define (rexec-verbose session cmd)
|
|
"Execute a command CMD on the remote side and print output. Return two
|
|
values: list of output lines returned by CMD and its exit code."
|
|
(let* ((channel (open-remote-input-pipe session cmd))
|
|
(result (let loop ((line (read-line channel))
|
|
(result '()))
|
|
(if (eof-object? line)
|
|
(reverse result)
|
|
(begin
|
|
(display line)
|
|
(newline)
|
|
(loop (read-line channel)
|
|
(cons line result))))))
|
|
(exit-status (channel-get-exit-status channel)))
|
|
(close channel)
|
|
(values result exit-status)))
|
|
|
|
(define (hetzner-machine-ssh-key machine)
|
|
"Find the SSH key for MACHINE on the Hetzner API."
|
|
(and-let* ((config (machine-configuration machine))
|
|
(public-key (hetzner-configuration-ssh-public-key config))
|
|
(expected (public-key->fingerprint public-key)))
|
|
(find (lambda (ssh-key)
|
|
(equal? expected (hetzner-ssh-key-fingerprint ssh-key)))
|
|
(hetzner-api-ssh-keys
|
|
(hetzner-configuration-api config)
|
|
#:params `(("fingerprint" . ,expected))))))
|
|
|
|
(define (hetzner-machine-ssh-key-create machine)
|
|
"Create the SSH key for MACHINE on the Hetzner API."
|
|
(let ((name (machine-display-name machine)))
|
|
(format #t "creating ssh key for '~a'...\n" name)
|
|
(let* ((config (machine-configuration machine))
|
|
(api (hetzner-configuration-api config))
|
|
(pubkey (hetzner-configuration-ssh-public-key config))
|
|
(_ (assert pubkey))
|
|
(ssh-key (hetzner-api-ssh-key-create
|
|
api
|
|
(public-key->fingerprint pubkey)
|
|
(public-key->string-with-type pubkey)
|
|
#:labels (hetzner-configuration-labels config))))
|
|
(format #t "successfully created ssh key for '~a'\n" name)
|
|
ssh-key)))
|
|
|
|
(define (hetzner-machine-server machine)
|
|
"Find the Hetzner server for MACHINE."
|
|
(let ((config (machine-configuration machine)))
|
|
(find (lambda (server)
|
|
(equal? (machine-display-name machine)
|
|
(hetzner-server-name server)))
|
|
(hetzner-api-servers
|
|
(hetzner-configuration-api config)
|
|
#:params `(("name" . ,(machine-display-name machine)))))))
|
|
|
|
(define (hetzner-resolve-ip api name)
|
|
"Find the NAME IP address on the Hetzner API."
|
|
(or
|
|
(find (lambda (primary-ip)
|
|
(equal? name (hetzner-primary-ip-name primary-ip)))
|
|
(hetzner-api-primary-ips api #:params `(("name" . ,name))))
|
|
|
|
(raise-exception
|
|
(formatted-message (G_ "primary ip '~a' does not exist.")
|
|
name))))
|
|
|
|
(define temporary-ssh-key-file
|
|
(let ((ssh-key-file (port-filename (mkstemp "/tmp/hetzner-key-XXXXXX")))
|
|
(ssh-key #f))
|
|
(lambda ()
|
|
"Return a dynamically created, temporary private SSH key."
|
|
(unless ssh-key
|
|
(set! ssh-key (make-keypair 'ed25519))
|
|
(private-key-to-file ssh-key ssh-key-file))
|
|
ssh-key-file)))
|
|
|
|
(define (hetzner-machine-create-server machine)
|
|
"Create the Hetzner server for MACHINE."
|
|
(let* ((config (machine-configuration machine))
|
|
(name (machine-display-name machine))
|
|
(server-type (hetzner-configuration-server-type config)))
|
|
(format #t "creating '~a' server for '~a'...\n" server-type name)
|
|
(let* ((ssh-key (hetzner-machine-ssh-key machine))
|
|
(_ (assert ssh-key)) ;required during provisioning
|
|
(ipv4 (hetzner-configuration-ipv4 config))
|
|
(ipv6 (hetzner-configuration-ipv6 config))
|
|
(api (hetzner-configuration-api config))
|
|
(server (hetzner-api-server-create
|
|
api
|
|
(machine-display-name machine)
|
|
#:ssh-keys (list ssh-key)
|
|
#:ipv4 (if (string? ipv4)
|
|
(hetzner-primary-ip-id (hetzner-resolve-ip api ipv4))
|
|
ipv4)
|
|
#:ipv6 (if (string? ipv6)
|
|
(hetzner-primary-ip-id (hetzner-resolve-ip api ipv6))
|
|
ipv6)
|
|
#:labels (hetzner-configuration-labels config)
|
|
#:location (hetzner-configuration-location config)
|
|
#:server-type (hetzner-configuration-server-type config)))
|
|
(architecture (hetzner-server-architecture server)))
|
|
(format #t "successfully created '~a' ~a server for '~a'\n"
|
|
server-type architecture name)
|
|
server)))
|
|
|
|
(define (wait-for-ssh address ssh-key)
|
|
"Block until a SSH session can be made as 'root' with SSH-KEY at ADDRESS."
|
|
(format #t "connecting via SSH to '~a' using '~a'...\n" address ssh-key)
|
|
(let loop ()
|
|
(catch #t
|
|
(lambda ()
|
|
(open-ssh-session address #:user "root" #:identity ssh-key
|
|
#:strict-host-key-check? #f))
|
|
(lambda args
|
|
(let ((msg (cadr args)))
|
|
(if (formatted-message? msg)
|
|
(format #t "~a\n"
|
|
(string-trim-right
|
|
(apply format #f
|
|
(formatted-message-string msg)
|
|
(formatted-message-arguments msg))
|
|
#\newline))
|
|
(format #t "~a" args))
|
|
(sleep 5)
|
|
(loop))))))
|
|
|
|
(define (hetzner-machine-wait-for-ssh machine server)
|
|
"Wait for SSH connection to be established with the specified machine."
|
|
(wait-for-ssh (hetzner-server-public-ipv4 server)
|
|
(hetzner-configuration-ssh-key
|
|
(machine-configuration machine))))
|
|
|
|
(define (hetzner-machine-authenticate-host machine server)
|
|
"Add the host key of MACHINE to the list of known hosts."
|
|
(let ((ssh-session (hetzner-machine-wait-for-ssh machine server)))
|
|
(write-known-host! ssh-session)))
|
|
|
|
(define (hetzner-machine-enable-rescue-system machine server)
|
|
"Enable the rescue system on the Hetzner SERVER for MACHINE, provisioning it
|
|
with the configured SSH key, or a dynamically created temporary one."
|
|
(let* ((name (machine-display-name machine))
|
|
(config (machine-configuration machine))
|
|
(api (hetzner-configuration-api config))
|
|
(ssh-keys (and=> (hetzner-machine-ssh-key machine) list)))
|
|
(format #t "enabling rescue system on '~a'...\n" name)
|
|
(let ((action (hetzner-api-server-enable-rescue-system
|
|
api server #:ssh-keys ssh-keys)))
|
|
(format #t "successfully enabled rescue system on '~a'\n" name)
|
|
action)))
|
|
|
|
(define (hetzner-machine-power-on machine server)
|
|
"Power on the Hetzner SERVER for MACHINE."
|
|
(let* ((name (machine-display-name machine))
|
|
(config (machine-configuration machine))
|
|
(api (hetzner-configuration-api config)))
|
|
(format #t "powering on server for '~a'...\n" name)
|
|
(let ((action (hetzner-api-server-power-on api server)))
|
|
(format #t "successfully powered on server for '~a'\n" name)
|
|
action)))
|
|
|
|
(define (hetzner-machine-ssh-run-script ssh-session name content)
|
|
(let ((sftp-session (make-sftp-session ssh-session)))
|
|
(rexec ssh-session (format #f "rm -f ~a" name))
|
|
(rexec ssh-session (format #f "mkdir -p ~a" (dirname name)))
|
|
(call-with-remote-output-file
|
|
sftp-session name
|
|
(lambda (port)
|
|
(display content port)))
|
|
(sftp-chmod sftp-session name 755)
|
|
(let ((lines exit-code (rexec-verbose ssh-session
|
|
(format #f "~a 2>&1" name))))
|
|
(if (zero? exit-code)
|
|
lines
|
|
(raise-exception
|
|
(formatted-message
|
|
(G_ "failed to run script '~a' on machine, exit code: '~a'")
|
|
name exit-code))))))
|
|
|
|
;; Prevent compiler from inlining this function, so we can mock it in tests.
|
|
(set! hetzner-machine-ssh-run-script hetzner-machine-ssh-run-script)
|
|
|
|
(define (hetzner-machine-rescue-install-os machine ssh-session server)
|
|
"Init a minimal Guix System to bootstrap from."
|
|
(let ((name (machine-display-name machine))
|
|
(os (hetzner-machine-bootstrap-os-form machine server)))
|
|
(format #t "installing guix operating system on '~a'...\n" name)
|
|
(hetzner-machine-ssh-run-script
|
|
ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-install-os"
|
|
(format #f "#!/usr/bin/env bash
|
|
set -eo pipefail
|
|
mount /dev/sda1 /mnt
|
|
mkdir -p /mnt/boot/efi
|
|
mount /dev/sda15 /mnt/boot/efi
|
|
|
|
mkdir --parents /mnt/root/.ssh
|
|
chmod 700 /mnt/root/.ssh
|
|
cp /root/.ssh/authorized_keys /mnt/root/.ssh/authorized_keys
|
|
chmod 600 /mnt/root/.ssh/authorized_keys
|
|
|
|
# Small instance don't have much disk space. Bind mount the store of the
|
|
# rescue system to the tmp directory of the new Guix system.
|
|
mkdir -p /mnt/tmp/gnu
|
|
mkdir -p /gnu
|
|
mount --bind /mnt/tmp/gnu /gnu
|
|
|
|
wget -O /tmp/guix-install.sh https://guix.gnu.org/guix-install.sh
|
|
chmod +x /tmp/guix-install.sh
|
|
set +o pipefail # avoid hangup on 'yes' killing this script
|
|
yes '' | /tmp/guix-install.sh
|
|
set -o pipefail
|
|
|
|
cat > /tmp/guix/deploy/hetzner-os.scm << EOF
|
|
(use-modules (gnu) (guix utils))
|
|
(use-package-modules ssh)
|
|
(use-service-modules base networking ssh)
|
|
(use-system-modules linux-initrd)
|
|
~a
|
|
EOF
|
|
guix system init --verbosity=2 /tmp/guix/deploy/hetzner-os.scm /mnt"
|
|
(escape-backticks (format #f "~y" os))))
|
|
(format #t "successfully installed guix operating system on '~a'\n" name)))
|
|
|
|
(define (hetzner-machine-reboot machine server)
|
|
"Reboot the Hetzner SERVER for MACHINE."
|
|
(let* ((name (machine-display-name machine))
|
|
(config (machine-configuration machine))
|
|
(api (hetzner-configuration-api config)))
|
|
(format #t "rebooting server for '~a'...\n" name)
|
|
(let ((action (hetzner-api-server-reboot api server)))
|
|
(format #t "successfully rebooted server for '~a'\n" name)
|
|
action)))
|
|
|
|
(define (hetzner-machine-rescue-partition machine ssh-session)
|
|
"Setup the partitions of the Hetzner server for MACHINE using SSH-SESSION."
|
|
(let* ((name (machine-display-name machine))
|
|
(os (machine-operating-system machine))
|
|
(root-fs-type (operating-system-root-file-system-type os)))
|
|
(format #t "setting up partitions on '~a'...\n" name)
|
|
(hetzner-machine-ssh-run-script
|
|
ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-partition"
|
|
(format #f "#!/usr/bin/env bash
|
|
set -eo pipefail
|
|
growpart /dev/sda 1 || true
|
|
~a
|
|
fdisk -l /dev/sda"
|
|
(cond
|
|
((equal? "btrfs" root-fs-type)
|
|
(format #f "mkfs.btrfs -L ~a -f /dev/sda1" root-label))
|
|
((equal? "ext4" root-fs-type)
|
|
(format #f "mkfs.ext4 -L ~a -F /dev/sda1" root-label))
|
|
(else (raise-exception
|
|
(formatted-message
|
|
(G_ "unsupported root file system type '~a'")
|
|
root-fs-type))))))
|
|
(format #t "successfully setup partitions on '~a'\n" name)))
|
|
|
|
(define (hetzner-machine-rescue-install-packages machine ssh-session)
|
|
"Install packages on the Hetzner server for MACHINE using SSH-SESSION."
|
|
(let ((name (machine-display-name machine)))
|
|
(format #t "installing rescue system packages on '~a'...\n" name)
|
|
(hetzner-machine-ssh-run-script
|
|
ssh-session "/tmp/guix/deploy/hetzner-machine-rescue-install-packages"
|
|
(format #f "#!/usr/bin/env bash
|
|
set -eo pipefail
|
|
apt-get update
|
|
apt-get install cloud-initramfs-growroot uidmap --assume-yes"))
|
|
(format #t "successfully installed rescue system packages on '~a'\n" name)))
|
|
|
|
(define (hetzner-machine-delete machine server)
|
|
"Delete the Hetzner server for MACHINE."
|
|
(let* ((name (machine-display-name machine))
|
|
(config (machine-configuration machine))
|
|
(api (hetzner-configuration-api config)))
|
|
(format #t "deleting server for '~a'...\n" name)
|
|
(let ((action (hetzner-api-server-delete api server)))
|
|
(format #t "successfully deleted server for '~a'\n" name)
|
|
action)))
|
|
|
|
(define (hetzner-machine-provision machine)
|
|
"Provision a Guix System bootstrap server for MACHINE on the Hetzner Cloud
|
|
service."
|
|
(with-exception-handler
|
|
(lambda (exception)
|
|
(let ((config (machine-configuration machine))
|
|
(server (hetzner-machine-server machine)))
|
|
(when (and server (hetzner-configuration-delete? config))
|
|
(hetzner-machine-delete machine server))
|
|
(raise-exception exception)))
|
|
(lambda ()
|
|
(let ((server (hetzner-machine-create-server machine)))
|
|
(hetzner-machine-enable-rescue-system machine server)
|
|
(hetzner-machine-power-on machine server)
|
|
(let ((ssh-session (hetzner-machine-wait-for-ssh machine server)))
|
|
(hetzner-machine-rescue-install-packages machine ssh-session)
|
|
(hetzner-machine-rescue-partition machine ssh-session)
|
|
(hetzner-machine-rescue-install-os machine ssh-session server))
|
|
(hetzner-machine-reboot machine server)
|
|
(hetzner-machine-authenticate-host machine server)
|
|
server))))
|
|
|
|
(define (machine-not-provisioned machine)
|
|
(formatted-message
|
|
(G_ "no server provisioned for machine '~a' on the Hetzner Cloud service")
|
|
(machine-display-name machine)))
|
|
|
|
|
|
;;;
|
|
;;; Remote evaluation.
|
|
;;;
|
|
|
|
(define (hetzner-remote-eval machine exp)
|
|
"Internal implementation of 'machine-remote-eval' for MACHINE instances with
|
|
an environment type of 'hetzner-environment-type'."
|
|
(hetzner-machine-validate machine)
|
|
(let ((server (hetzner-machine-server machine)))
|
|
(unless server (raise-exception (machine-not-provisioned machine)))
|
|
(machine-remote-eval (hetzner-machine-delegate machine server) exp)))
|
|
|
|
|
|
|
|
;;;
|
|
;;; System deployment.
|
|
;;;
|
|
|
|
(define (cleanup-temporary-ssh-key/maybe api ssh-key)
|
|
"Delete the temporary SSH private key file from the file system and the
|
|
Hetzner API, if one was created used."
|
|
(when (%hetzner-ssh-key-file)
|
|
(format #t "cleaning up temporary ssh key~%")
|
|
(delete-file (%hetzner-ssh-key-file))
|
|
(%hetzner-ssh-key-file #f)
|
|
(hetzner-api-ssh-key-delete api ssh-key)))
|
|
|
|
(define (deploy-hetzner machine)
|
|
"Internal implementation of 'deploy-machine' for 'machine' instances with an
|
|
environment type of 'hetzner-environment-type'."
|
|
(hetzner-machine-validate machine)
|
|
|
|
(define server (hetzner-machine-server machine))
|
|
(define config (machine-configuration machine))
|
|
(define api (hetzner-configuration-api config))
|
|
(define ssh-key #f) ;hetzner API key
|
|
|
|
;; Provisioning requires uploading an SSH key via the Hetzner API to
|
|
;; authenticate non-interactively with the newly created server.
|
|
(unless server ;provisioning?
|
|
(unless (hetzner-configuration-ssh-public-key config)
|
|
(format #t "using a temporary ssh key for provisioning~%")
|
|
(%hetzner-ssh-key-file (temporary-ssh-key-file)))
|
|
(set! ssh-key (or (hetzner-machine-ssh-key machine)
|
|
(hetzner-machine-ssh-key-create machine))))
|
|
|
|
;; Cleaning-up here is a bit tricky, as `deploy-machine' returns a monadic
|
|
;; value immediately, to be executed later; this means the clean-up must be
|
|
;; delayed until monadic evaluation time.
|
|
(let* ((server (or server (hetzner-machine-provision machine)))
|
|
(delegate-machine (hetzner-machine-delegate machine server)))
|
|
;; FIXME: The clean-up in the guard does not run even when
|
|
;; `deploy-machine' fails.
|
|
(guard (c (#t (cleanup-temporary-ssh-key/maybe api ssh-key)
|
|
(raise c)))
|
|
(mlet %store-monad
|
|
((value (deploy-machine delegate-machine)))
|
|
(cleanup-temporary-ssh-key/maybe api ssh-key)
|
|
(return value)))))
|
|
|
|
|
|
;;;
|
|
;;; Roll-back.
|
|
;;;
|
|
|
|
(define (roll-back-hetzner machine)
|
|
"Internal implementation of 'roll-back-machine' for MACHINE instances with an
|
|
environment type of 'hetzner-environment-type'."
|
|
(hetzner-machine-validate machine)
|
|
(let ((server (hetzner-machine-server machine)))
|
|
(unless server (raise-exception (machine-not-provisioned machine)))
|
|
(roll-back-machine (hetzner-machine-delegate machine server))))
|
|
|
|
|
|
|
|
;;;
|
|
;;; Environment type.
|
|
;;;
|
|
|
|
(define hetzner-environment-type
|
|
(environment-type
|
|
(machine-remote-eval hetzner-remote-eval)
|
|
(deploy-machine deploy-hetzner)
|
|
(roll-back-machine roll-back-hetzner)
|
|
(name 'hetzner-environment-type)
|
|
(description "Provisioning of virtual machine servers on the Hetzner Cloud
|
|
service.")))
|