projects/guix·blob python-team · refs

267 lines · 9.9 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2024 Roman Scherer <[email protected]>
3;;;
4;;; This file is part of GNU Guix.
5;;;
6;;; GNU Guix is free software; you can redistribute it and/or modify it
7;;; under the terms of the GNU General Public License as published by
8;;; the Free Software Foundation; either version 3 of the License, or (at
9;;; your option) any later version.
10;;;
11;;; GNU Guix is distributed in the hope that it will be useful, but
12;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14;;; GNU General Public License for more details.
15;;;
16;;; You should have received a copy of the GNU General Public License
17;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
18
19(define-module (tests machine hetzner)
20 #:use-module (gnu machine hetzner http)
21 #:use-module (gnu machine hetzner)
22 #:use-module (gnu machine ssh)
23 #:use-module (gnu machine)
24 #:use-module (gnu system)
25 #:use-module (guix build utils)
26 #:use-module (guix records)
27 #:use-module (guix ssh)
28 #:use-module (guix tests)
29 #:use-module (srfi srfi-1)
30 #:use-module (srfi srfi-34)
31 #:use-module (srfi srfi-64)
32 #:use-module (ssh key)
33 #:use-module (ssh session))
34
35;;; Unit and integration tests for the (gnu machine hetzner) module.
36
37;; Integration tests require the GUIX_HETZNER_API_TOKEN environment variable.
38;; https://docs.hetzner.com/cloud/api/getting-started/generating-api-token
39
40;; The integration tests sometimes fail due to the Hetzner API not being able
41;; to allocate a resource. Switching to a different location might help.
42
43(define %labels
44 '(("guix.gnu.org/test" . "true")))
45
46(define %ssh-key-name
47 "guix-hetzner-machine-test-key")
48
49(define %ssh-key-file
50 (string-append "/tmp/" %ssh-key-name))
51
52(unless (file-exists? %ssh-key-file)
53 (private-key-to-file (make-keypair 'rsa 2048) %ssh-key-file))
54
55(define %when-no-token
56 (if (hetzner-api-token (hetzner-api)) 0 1))
57
58(define %arm-machine
59 (machine
60 (operating-system
61 (operating-system
62 (inherit %hetzner-os-arm)
63 (host-name "guix-deploy-hetzner-test-arm")))
64 (environment hetzner-environment-type)
65 (configuration (hetzner-configuration
66 (labels %labels)
67 (server-type "cax11")
68 (ssh-key %ssh-key-file)))))
69
70(define %x86-machine
71 (machine
72 (operating-system
73 (operating-system
74 (inherit %hetzner-os-x86)
75 (host-name "guix-deploy-hetzner-test-x86")))
76 (environment hetzner-environment-type)
77 (configuration (hetzner-configuration
78 (labels %labels)
79 (server-type "cx22")
80 (ssh-key %ssh-key-file)))))
81
82(define (cleanup machine)
83 (let* ((config (machine-configuration machine))
84 (api (hetzner-configuration-api config)))
85 (for-each (lambda (server)
86 (hetzner-api-server-delete api server))
87 (hetzner-api-servers
88 api #:params `(("label_selector" . "guix.gnu.org/test=true"))))
89 (for-each (lambda (ssh-key)
90 (hetzner-api-ssh-key-delete api ssh-key))
91 (hetzner-api-ssh-keys
92 api #:params `(("label_selector" . "guix.gnu.org/test=true"))))
93 machine))
94
95(define-syntax-rule (with-cleanup (machine-sym machine-init) body ...)
96 (let ((machine-sym (cleanup machine-init)))
97 (dynamic-wind
98 (const #t)
99 (lambda ()
100 body ...)
101 (lambda ()
102 (cleanup machine-sym)))))
103
104(define (mock-action command)
105 (make-hetzner-action
106 command #f
107 (localtime (current-time))
108 1
109 100
110 '()
111 (localtime (current-time))
112 "success"))
113
114(define (mock-location machine)
115 (let* ((config (machine-configuration machine))
116 (name (hetzner-configuration-location config)))
117 (make-hetzner-location
118 "Falkenstein" "DE" "Falkenstein DC Park 1"
119 1 50.47612 12.370071 name "eu-central")))
120
121(define (mock-server-type machine)
122 (let* ((config (machine-configuration machine))
123 (name (hetzner-configuration-server-type config)))
124 (make-hetzner-server-type
125 "x86" 8 "shared" #f #f (string-upcase name)
126 160 106 16 name "local")))
127
128(define (mock-server machine)
129 (let* ((config (machine-configuration machine))
130 (name (hetzner-configuration-location config)))
131 (make-hetzner-server
132 1
133 (localtime (current-time))
134 '()
135 (operating-system-host-name (machine-operating-system machine))
136 (make-hetzner-public-net
137 (make-hetzner-ipv4 #f "server.example.com" 1 "1.2.3.4")
138 (make-hetzner-ipv6 #f "server.example.com" 1 "2001:db8::1"))
139 #f
140 (mock-server-type machine))))
141
142(define (mock-ssh-key machine)
143 (let ((config (machine-configuration machine)))
144 (hetzner-ssh-key-read-file (hetzner-configuration-ssh-key config))))
145
146(define (expected-ssh-machine? machine ssh-machine)
147 (let ((config (machine-configuration machine))
148 (ssh-config (machine-configuration ssh-machine)))
149 (and (equal? (hetzner-configuration-authorize? config)
150 (machine-ssh-configuration-authorize? ssh-config))
151 (equal? (hetzner-configuration-allow-downgrades? config)
152 (machine-ssh-configuration-allow-downgrades? ssh-config))
153 (equal? (hetzner-configuration-build-locally? config)
154 (machine-ssh-configuration-build-locally? ssh-config))
155 (equal? (hetzner-server-public-ipv4 (mock-server machine))
156 (machine-ssh-configuration-host-name ssh-config)))))
157
158(define-syntax mock*
159 (syntax-rules ()
160 ((mock* () body1 body2 ...)
161 (let () body1 body2 ...))
162 ((mock* ((mod1 sym1 fn1) (mod2 sym2 fn2) ...)
163 body1 body2 ...)
164 (mock (mod1 sym1 fn1)
165 (mock* ((mod2 sym2 fn2) ...)
166 body1) body2 ...))))
167
168(test-begin "machine-hetzner")
169
170;; The following tests deploy real machines using the Hetzner API and shut
171;; them down afterwards.
172
173(test-skip %when-no-token)
174(test-assert "deploy-arm-machine"
175 (with-cleanup (machine %arm-machine)
176 (deploy-hetzner machine)))
177
178(test-skip %when-no-token)
179(test-assert "deploy-x86-machine"
180 (with-cleanup (machine %x86-machine)
181 (deploy-hetzner machine)))
182
183;; The following tests simulate a deployment, they mock out the actual calls
184;; to the Hetzner API.
185
186;; Note: In order for mocking to work, the Guile compiler should not inline
187;; the mocked functions. To prevent this it was necessary to set!
188;; hetzner-machine-ssh-run-script in (gnu machine hetzner) like this:
189
190;; (set! hetzner-machine-ssh-run-script hetzner-machine-ssh-run-script)
191
192(test-assert "deploy-machine-mock-with-provisioned-server"
193 (let ((machine (machine
194 (operating-system %hetzner-os-x86)
195 (environment hetzner-environment-type)
196 (configuration (hetzner-configuration
197 (api (hetzner-api (token "mock")))
198 (ssh-key %ssh-key-file))))))
199 (mock* (((gnu machine hetzner http) hetzner-api-locations
200 (lambda* (api . options)
201 (list (mock-location machine))))
202 ((gnu machine hetzner http) hetzner-api-server-types
203 (lambda* (api . options)
204 (list (mock-server-type machine))))
205 ((gnu machine hetzner http) hetzner-api-ssh-keys
206 (lambda* (api . options)
207 (list (mock-ssh-key machine))))
208 ((gnu machine hetzner http) hetzner-api-servers
209 (lambda* (api . options)
210 (list (mock-server machine))))
211 ((gnu machine) deploy-machine
212 (lambda* (ssh-machine)
213 (expected-ssh-machine? machine ssh-machine))))
214 (deploy-hetzner machine))))
215
216(test-assert "deploy-machine-mock-with-unprovisioned-server"
217 (let ((machine (machine
218 (operating-system %hetzner-os-x86)
219 (environment hetzner-environment-type)
220 (configuration (hetzner-configuration
221 (api (hetzner-api (token "mock")))
222 (ssh-key %ssh-key-file)))))
223 (servers '()))
224 (mock* (((gnu machine hetzner http) hetzner-api-locations
225 (lambda* (api . options)
226 (list (mock-location machine))))
227 ((gnu machine hetzner http) hetzner-api-server-types
228 (lambda* (api . options)
229 (list (mock-server-type machine))))
230 ((gnu machine hetzner http) hetzner-api-ssh-keys
231 (lambda* (api . options)
232 (list (mock-ssh-key machine))))
233 ((gnu machine hetzner http) hetzner-api-servers
234 (lambda* (api . options)
235 servers))
236 ((gnu machine hetzner http) hetzner-api-server-create
237 (lambda* (api name #:key ssh-keys #:allow-other-keys)
238 (set! servers (list (mock-server machine)))
239 (car servers)))
240 ((gnu machine hetzner http) hetzner-api-server-enable-rescue-system
241 (lambda* (api server #:key ssh-keys #:allow-other-keys)
242 (mock-action "enable_rescue")))
243 ((gnu machine hetzner http) hetzner-api-server-power-on
244 (lambda (api server)
245 (mock-action "start_server")))
246 ((gnu machine hetzner) hetzner-machine-ssh-run-script
247 (lambda (ssh-session name content)
248 #t))
249 ((guix ssh) open-ssh-session
250 (lambda* (host . options)
251 (make-session #:host host)))
252 ((gnu machine hetzner http) hetzner-api-server-reboot
253 (lambda (api server)
254 (mock-action "reboot_server")))
255 ((ssh session) write-known-host!
256 (lambda (session)
257 #t))
258 ((gnu machine) deploy-machine
259 (lambda* (ssh-machine)
260 (expected-ssh-machine? machine ssh-machine))))
261 (deploy-hetzner machine))))
262
263(test-end "machine-hetzner")
264
265;; Local Variables:
266;; eval: (put 'with-cleanup 'scheme-indent-function 1)
267;; End: