machine: Implement 'hetzner-environment-type'.

* Makefile.am (SCM_TESTS): Add test modules.
* doc/guix.texi: Add documentation.
* gnu/local.mk (GNU_SYSTEM_MODULES): Add modules.
* gnu/machine/hetzner.scm: Add hetzner-environment-type.
* gnu/machine/hetzner/http.scm: Add HTTP API.
* po/guix/POTFILES.in: Add Hetzner modules.
* tests/machine/hetzner.scm: Add machine tests.
* tests/machine/hetzner/http.scm Add HTTP API tests.

Change-Id: I276ed5afed676bbccc6c852c56ee4db57ce3c1ea
Signed-off-by: Ludovic Courtès <ludo@gnu.org>

1 files changed, 267 insertions, 0 deletions

diff --git a/tests/machine/hetzner.scm b/tests/machine/hetzner.scm
new file mode 100644
index 00000000000..39eac4a4d5f
--- /dev/null
+++ b/tests/machine/hetzner.scm
@@ -0,0 +1,267 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Roman Scherer <roman@burningswell.com>
+;;;
+;;; 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 "cax41")
+                   (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 "cpx51")
+                   (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: