path: root/gnu/machine/hetzner.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2024 Roman Scherer <[email protected]>
;;;
;;; 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 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 (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
            %hetzner-os-x86
            deploy-hetzner
            hetzner-configuration
            hetzner-configuration-allow-downgrades?
            hetzner-configuration-api
            hetzner-configuration-authorize?
            hetzner-configuration-build-locally?
            hetzner-configuration-delete?
            hetzner-configuration-labels
            hetzner-configuration-location
            hetzner-configuration-server-type
            hetzner-configuration-ssh-key
            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
  (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 dhcp-client-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
  (operating-system
    (inherit %hetzner-os-arm)
    (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 (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 (operating-system-user-services os)
           (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.
;;;

(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 #f))
  (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"))
  (ssh-key hetzner-configuration-ssh-key)) ; string

(define (hetzner-configuration-ssh-key-fingerprint config)
  "Return the SSH public key fingerprint of CONFIG as a string."
  (and-let* ((file-name (hetzner-configuration-ssh-key config))
             (privkey (private-key-from-file file-name))
             (pubkey (private-key->public-key privkey))
             (hash (get-public-key-hash pubkey 'md5)))
    (bytevector->hex-string hash)))

(define (hetzner-configuration-ssh-key-public config)
  "Return the SSH public key of CONFIG as a string."
  (and-let* ((ssh-key (hetzner-configuration-ssh-key config))
             (public-key (public-key-from-file ssh-key)))
    (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)))
    (machine
     (inherit target)
     (operating-system
       (if (hetzner-configuration-authorize? config)
           (operating-system-authorize os)
           os))
     (environment managed-host-environment-type)
     (configuration
      (machine-ssh-configuration
       (allow-downgrades? (hetzner-configuration-allow-downgrades? config))
       (authorize? (hetzner-configuration-authorize? config))
       (build-locally? (hetzner-configuration-build-locally? config))
       (host-name (hetzner-server-public-ipv4 server))
       (identity (hetzner-configuration-ssh-key config))
       (system (hetzner-server-system server)))))))

(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))
         (arm? (equal? "arm" (hetzner-server-architecture server)))
         (x86? (equal? "x86" (hetzner-server-architecture server)))
         (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 ,(cond (arm? 'grub-efi-bootloader)
                                       (x86? 'grub-bootloader)))
                    (targets ,(cond (arm? '(list "/boot/efi"))
                                    (x86? '(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 ,(cond
                       (arm? `(cons* (file-system
                                       (mount-point "/")
                                       (device "/dev/sda1")
                                       (type ,root-fs-type))
                                     (file-system
                                       (mount-point "/boot/efi")
                                       (device "/dev/sda15")
                                       (type "vfat"))
                                     %base-file-systems))
                       (x86? `(cons* (file-system
                                       (mount-point "/")
                                       (device "/dev/sda1")
                                       (type ,root-fs-type))
                                     %base-file-systems))))
       (services
        (cons* (service dhcp-client-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."
  (let* ((config (machine-configuration machine))
         (expected (hetzner-configuration-ssh-key-fingerprint config)))
    (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))
           (ssh-key (hetzner-api-ssh-key-create
                     (hetzner-configuration-api config)
                     (hetzner-configuration-ssh-key-fingerprint config)
                     (hetzner-configuration-ssh-key-public config)
                     #: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-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))
           (api (hetzner-configuration-api config))
           (server (hetzner-api-server-create
                    api
                    (machine-display-name machine)
                    (list ssh-key)
                    #: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."
  (let* ((name (machine-display-name machine))
         (config (machine-configuration machine))
         (api (hetzner-configuration-api config))
         (ssh-keys (list (hetzner-machine-ssh-key machine))))
    (format #t "enabling rescue system on '~a'...\n" name)
    (let ((action (hetzner-api-server-enable-rescue-system api server 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)
  (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/store
mkdir -p /gnu/store
mount --bind /mnt/tmp/gnu/store /gnu/store

apt-get install guix --assume-yes
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 --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 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)
          (sleep 5)
          (hetzner-machine-authenticate-host machine server)
          server)))
    #:unwind? #t))

(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 (deploy-hetzner machine)
  "Internal implementation of 'deploy-machine' for 'machine' instances with an
environment type of 'hetzner-environment-type'."
  (hetzner-machine-validate machine)
  (unless (hetzner-machine-ssh-key machine)
    (hetzner-machine-ssh-key-create machine))
  (let ((server (or (hetzner-machine-server machine)
                    (hetzner-machine-provision machine))))
    (deploy-machine (hetzner-machine-delegate machine server))))



;;;
;;; 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.")))