;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2024 Roman Scherer ;;; ;;; 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 . (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: