path: root/tests/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 (tests machine hetzner)
  #:use-module (gnu machine hetzner http)
  #:use-module (gnu machine hetzner)
  #:use-module (gnu machine ssh)
  #:use-module (gnu machine)
  #:use-module (gnu system)
  #:use-module (guix build utils)
  #:use-module (guix records)
  #:use-module (guix ssh)
  #:use-module (guix tests)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-64)
  #:use-module (ssh key)
  #:use-module (ssh session))

;;; Unit and integration tests for the (gnu machine hetzner) module.

;; Integration tests require the GUIX_HETZNER_API_TOKEN environment variable.
;; https://docs.hetzner.com/cloud/api/getting-started/generating-api-token

;; The integration tests sometimes fail due to the Hetzner API not being able
;; to allocate a resource.  Switching to a different location might help.

(define %labels
  '(("guix.gnu.org/test" . "true")))

(define %ssh-key-name
  "guix-hetzner-machine-test-key")

(define %ssh-key-file
  (string-append "/tmp/" %ssh-key-name))

(unless (file-exists? %ssh-key-file)
  (private-key-to-file (make-keypair 'rsa 2048) %ssh-key-file))

(define %when-no-token
  (if (hetzner-api-token (hetzner-api)) 0 1))

(define %arm-machine
  (machine
   (operating-system
     (operating-system
       (inherit %hetzner-os-arm)
       (host-name "guix-deploy-hetzner-test-arm")))
   (environment hetzner-environment-type)
   (configuration (hetzner-configuration
                   (labels %labels)
                   (server-type "cax11")
                   (ssh-key %ssh-key-file)))))

(define %x86-machine
  (machine
   (operating-system
     (operating-system
       (inherit %hetzner-os-x86)
       (host-name "guix-deploy-hetzner-test-x86")))
   (environment hetzner-environment-type)
   (configuration (hetzner-configuration
                   (labels %labels)
                   (server-type "cx22")
                   (ssh-key %ssh-key-file)))))

(define (cleanup machine)
  (let* ((config (machine-configuration machine))
         (api (hetzner-configuration-api config)))
    (for-each (lambda (server)
                (hetzner-api-server-delete api server))
              (hetzner-api-servers
               api #:params `(("label_selector" . "guix.gnu.org/test=true"))))
    (for-each (lambda (ssh-key)
                (hetzner-api-ssh-key-delete api ssh-key))
              (hetzner-api-ssh-keys
               api #:params `(("label_selector" . "guix.gnu.org/test=true"))))
    machine))

(define-syntax-rule (with-cleanup (machine-sym machine-init) body ...)
  (let ((machine-sym (cleanup machine-init)))
    (dynamic-wind
      (const #t)
      (lambda ()
        body ...)
      (lambda ()
        (cleanup machine-sym)))))

(define (mock-action command)
  (make-hetzner-action
   command #f
   (localtime (current-time))
   1
   100
   '()
   (localtime (current-time))
   "success"))

(define (mock-location machine)
  (let* ((config (machine-configuration machine))
         (name (hetzner-configuration-location config)))
    (make-hetzner-location
     "Falkenstein" "DE" "Falkenstein DC Park 1"
     1 50.47612 12.370071 name "eu-central")))

(define (mock-server-type machine)
  (let* ((config (machine-configuration machine))
         (name (hetzner-configuration-server-type config)))
    (make-hetzner-server-type
     "x86" 8 "shared" #f  #f (string-upcase name)
     160 106 16 name "local")))

(define (mock-server machine)
  (let* ((config (machine-configuration machine))
         (name (hetzner-configuration-location config)))
    (make-hetzner-server
     1
     (localtime (current-time))
     '()
     (operating-system-host-name (machine-operating-system machine))
     (make-hetzner-public-net
      (make-hetzner-ipv4 #f "server.example.com" 1 "1.2.3.4")
      (make-hetzner-ipv6 #f "server.example.com" 1 "2001:db8::1"))
     #f
     (mock-server-type machine))))

(define (mock-ssh-key machine)
  (let ((config (machine-configuration machine)))
    (hetzner-ssh-key-read-file  (hetzner-configuration-ssh-key config))))

(define (expected-ssh-machine? machine ssh-machine)
  (let ((config (machine-configuration machine))
        (ssh-config (machine-configuration ssh-machine)))
    (and (equal? (hetzner-configuration-authorize? config)
                 (machine-ssh-configuration-authorize? ssh-config))
         (equal? (hetzner-configuration-allow-downgrades? config)
                 (machine-ssh-configuration-allow-downgrades? ssh-config))
         (equal? (hetzner-configuration-build-locally? config)
                 (machine-ssh-configuration-build-locally? ssh-config))
         (equal? (hetzner-server-public-ipv4 (mock-server machine))
                 (machine-ssh-configuration-host-name ssh-config)))))

(define-syntax mock*
  (syntax-rules ()
    ((mock* () body1 body2 ...)
     (let () body1 body2 ...))
    ((mock* ((mod1 sym1 fn1) (mod2 sym2 fn2) ...)
            body1 body2 ...)
     (mock (mod1 sym1 fn1)
           (mock* ((mod2 sym2 fn2) ...)
                  body1) body2 ...))))

(test-begin "machine-hetzner")

;; The following tests deploy real machines using the Hetzner API and shut
;; them down afterwards.

(test-skip %when-no-token)
(test-assert "deploy-arm-machine"
  (with-cleanup (machine %arm-machine)
    (deploy-hetzner machine)))

(test-skip %when-no-token)
(test-assert "deploy-x86-machine"
  (with-cleanup (machine %x86-machine)
    (deploy-hetzner machine)))

;; The following tests simulate a deployment, they mock out the actual calls
;; to the Hetzner API.

;; Note: In order for mocking to work, the Guile compiler should not inline
;; the mocked functions. To prevent this it was necessary to set!
;; hetzner-machine-ssh-run-script in (gnu machine hetzner) like this:

;; (set! hetzner-machine-ssh-run-script hetzner-machine-ssh-run-script)

(test-assert "deploy-machine-mock-with-provisioned-server"
  (let ((machine (machine
                  (operating-system %hetzner-os-x86)
                  (environment hetzner-environment-type)
                  (configuration (hetzner-configuration
                                  (api (hetzner-api (token "mock")))
                                  (ssh-key %ssh-key-file))))))
    (mock* (((gnu machine hetzner http) hetzner-api-locations
             (lambda* (api . options)
               (list (mock-location machine))))
            ((gnu machine hetzner http) hetzner-api-server-types
             (lambda* (api . options)
               (list (mock-server-type machine))))
            ((gnu machine hetzner http) hetzner-api-ssh-keys
             (lambda* (api . options)
               (list (mock-ssh-key machine))))
            ((gnu machine hetzner http) hetzner-api-servers
             (lambda* (api . options)
               (list (mock-server machine))))
            ((gnu machine) deploy-machine
             (lambda* (ssh-machine)
               (expected-ssh-machine? machine ssh-machine))))
           (deploy-hetzner machine))))

(test-assert "deploy-machine-mock-with-unprovisioned-server"
  (let ((machine (machine
                  (operating-system %hetzner-os-x86)
                  (environment hetzner-environment-type)
                  (configuration (hetzner-configuration
                                  (api (hetzner-api (token "mock")))
                                  (ssh-key %ssh-key-file)))))
        (servers '()))
    (mock* (((gnu machine hetzner http) hetzner-api-locations
             (lambda* (api . options)
               (list (mock-location machine))))
            ((gnu machine hetzner http) hetzner-api-server-types
             (lambda* (api . options)
               (list (mock-server-type machine))))
            ((gnu machine hetzner http) hetzner-api-ssh-keys
             (lambda* (api . options)
               (list (mock-ssh-key machine))))
            ((gnu machine hetzner http) hetzner-api-servers
             (lambda* (api . options)
               servers))
            ((gnu machine hetzner http) hetzner-api-server-create
             (lambda* (api name ssh-keys . options)
               (set! servers (list (mock-server machine)))
               (car servers)))
            ((gnu machine hetzner http) hetzner-api-server-enable-rescue-system
             (lambda (api server ssh-keys)
               (mock-action "enable_rescue")))
            ((gnu machine hetzner http) hetzner-api-server-power-on
             (lambda (api server)
               (mock-action "start_server")))
            ((gnu machine hetzner) hetzner-machine-ssh-run-script
             (lambda (ssh-session name content)
               #t))
            ((guix ssh) open-ssh-session
             (lambda* (host . options)
               (make-session #:host host)))
            ((gnu machine hetzner http) hetzner-api-server-reboot
             (lambda (api server)
               (mock-action "reboot_server")))
            ((ssh session) write-known-host!
             (lambda (session)
               #t))
            ((gnu machine) deploy-machine
             (lambda* (ssh-machine)
               (expected-ssh-machine? machine ssh-machine))))
           (deploy-hetzner machine))))

(test-end "machine-hetzner")

;; Local Variables:
;; eval: (put 'with-cleanup 'scheme-indent-function 1)
;; End: