projects/guix·blob master · refs

458 lines · 19.0 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2015-2019, 2022-2023, 2025 Ludovic Courtès <[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 (test-services)
20 #:use-module (gnu services)
21 #:use-module (gnu services herd)
22 #:use-module (gnu services shepherd)
23 #:use-module (srfi srfi-1)
24 #:use-module (srfi srfi-26)
25 #:use-module (srfi srfi-34)
26 #:use-module (srfi srfi-64)
27 #:use-module (ice-9 match))
28
29(test-begin "services")
30
31(test-equal "services, default value"
32 '(42 123 234 error)
33 (let* ((t1 (service-type (name 't1) (extensions '())
34 (description "")))
35 (t2 (service-type (name 't2) (extensions '())
36 (description "")
37 (default-value 42))))
38 (list (service-value (service t2))
39 (service-value (service t2 123))
40 (service-value (service t1 234))
41 (guard (c ((missing-value-service-error? c) 'error))
42 (service t1)))))
43
44(test-assert "service-back-edges"
45 (let* ((t1 (service-type (name 't1) (extensions '()) (description "")
46 (compose +) (extend *)))
47 (t2 (service-type (name 't2) (description "")
48 (extensions
49 (list (service-extension t1 (const '()))))
50 (compose +) (extend *)))
51 (t3 (service-type (name 't3) (description "")
52 (extensions
53 (list (service-extension t2 identity)
54 (service-extension t1 list)))))
55 (s1 (service t1 #t))
56 (s2 (service t2 #t))
57 (s3 (service t3 #t))
58 (e (service-back-edges (list s1 s2 s3))))
59 (and (lset= eq? (e s1) (list s2 s3))
60 (lset= eq? (e s2) (list s3))
61 (null? (e s3)))))
62
63(test-equal "fold-services"
64 ;; Make sure 'fold-services' returns the right result. The numbers come
65 ;; from services of type T3; 'xyz 60' comes from the service of type T2,
66 ;; where 60 = 15 × 4 = (1 + 2 + 3 + 4 + 5) × 4.
67 '(initial-value 5 4 3 2 1 xyz 60)
68 (let* ((t1 (service-type (name 't1) (extensions '()) (description "")
69 (compose concatenate)
70 (extend cons)))
71 (t2 (service-type (name 't2) (description "")
72 (extensions
73 (list (service-extension t1
74 (cut list 'xyz <>))))
75 (compose (cut reduce + 0 <>))
76 (extend *)))
77 (t3 (service-type (name 't3) (description "")
78 (extensions
79 (list (service-extension t2 identity)
80 (service-extension t1 list)))))
81 (r (fold-services (cons* (service t1 'initial-value)
82 (service t2 4)
83 (map (lambda (x)
84 (service t3 x))
85 (iota 5 1)))
86 #:target-type t1)))
87 (and (eq? (service-kind r) t1)
88 (service-value r))))
89
90(test-assert "fold-services, ambiguity"
91 (let* ((t1 (service-type (name 't1) (extensions '()) (description "")
92 (compose concatenate)
93 (extend cons)))
94 (t2 (service-type (name 't2) (description "")
95 (extensions
96 (list (service-extension t1 list)))))
97 (s (service t2 42)))
98 (guard (c ((ambiguous-target-service-error? c)
99 (and (eq? (ambiguous-target-service-error-target-type c)
100 t1)
101 (eq? (ambiguous-target-service-error-service c)
102 s))))
103 (fold-services (list (service t1 'first)
104 (service t1 'second)
105 s)
106 #:target-type t1)
107 #f)))
108
109(test-assert "fold-services, missing target"
110 (let* ((t1 (service-type (name 't1) (extensions '()) (description "")))
111 (t2 (service-type (name 't2) (description "")
112 (extensions
113 (list (service-extension t1 list)))))
114 (s (service t2 42)))
115 (guard (c ((missing-target-service-error? c)
116 (and (eq? (missing-target-service-error-target-type c)
117 t1)
118 (eq? (missing-target-service-error-service c)
119 s))))
120 (fold-services (list s) #:target-type t1)
121 #f)))
122
123(test-assert "instantiate-missing-services"
124 (let* ((t1 (service-type (name 't1) (extensions '()) (description "")
125 (default-value 'dflt)
126 (compose concatenate)
127 (extend cons)))
128 (t2 (service-type (name 't2) (description "")
129 (extensions
130 (list (service-extension t1 list)))))
131 (s1 (service t1 'hey!))
132 (s2 (service t2 42)))
133 (and (lset= equal?
134 (list (service t1) s2)
135 (instantiate-missing-services (list s2)))
136 (equal? (list s1 s2)
137 (instantiate-missing-services (list s1 s2))))))
138
139(test-assert "instantiate-missing-services, indirect"
140 (let* ((t1 (service-type (name 't1) (extensions '()) (description "")
141 (default-value 'dflt)
142 (compose concatenate)
143 (extend cons)))
144 (t2 (service-type (name 't2) (description "")
145 (default-value 'dflt2)
146 (compose concatenate)
147 (extend cons)
148 (extensions
149 (list (service-extension t1 list)))))
150 (t3 (service-type (name 't3) (description "")
151 (extensions
152 (list (service-extension t2 list)))))
153 (s1 (service t1))
154 (s2 (service t2))
155 (s3 (service t3 42))
156 (== (cut lset= equal? <...>)))
157 (and (== (list s1 s2 s3)
158 (instantiate-missing-services (list s3)))
159 (== (list s1 s2 s3)
160 (instantiate-missing-services (list s1 s3)))
161 (== (list s1 s2 s3)
162 (instantiate-missing-services (list s2 s3))))))
163
164(test-assert "instantiate-missing-services, no default value"
165 (let* ((t1 (service-type (name 't1) (extensions '()) (description "")))
166 (t2 (service-type (name 't2) (description "")
167 (extensions
168 (list (service-extension t1 list)))))
169 (s (service t2 42)))
170 (guard (c ((missing-target-service-error? c)
171 (and (eq? (missing-target-service-error-target-type c)
172 t1)
173 (eq? (missing-target-service-error-service c)
174 s))))
175 (instantiate-missing-services (list s))
176 #f)))
177
178(test-assert "shepherd-service-lookup-procedure"
179 (let* ((s1 (shepherd-service (provision '(s1 s1b)) (start #f)))
180 (s2 (shepherd-service (provision '(s2 s2b)) (start #f)))
181 (s3 (shepherd-service (provision '(s3 s3b s3c)) (start #f)))
182 (lookup (shepherd-service-lookup-procedure (list s1 s2 s3))))
183 (and (eq? (lookup 's1) (lookup 's1b) s1)
184 (eq? (lookup 's2) (lookup 's2b) s2)
185 (eq? (lookup 's3) (lookup 's3b) s3))))
186
187(test-assert "shepherd-service-back-edges"
188 (let* ((s1 (shepherd-service (provision '(s1)) (start #f)))
189 (s2 (shepherd-service (provision '(s2))
190 (requirement '(s1))
191 (start #f)))
192 (s3 (shepherd-service (provision '(s3))
193 (requirement '(s1 s2))
194 (start #f)))
195 (e (shepherd-service-back-edges (list s1 s2 s3))))
196 (and (lset= eq? (e s1) (list s2 s3))
197 (lset= eq? (e s2) (list s3))
198 (null? (e s3)))))
199
200(test-equal "shepherd-service-upgrade: nothing to do"
201 '(() ())
202 (call-with-values
203 (lambda ()
204 (shepherd-service-upgrade '() '()))
205 list))
206
207(test-equal "shepherd-service-upgrade: one unchanged, one upgraded, one new"
208 '(() ;unload
209 ((foo))) ;restart
210 (call-with-values
211 (lambda ()
212 ;; Here 'foo' is replaced and must be explicitly restarted later
213 ;; because it is still running, whereas 'bar' is upgraded right away
214 ;; because it is not currently running. 'baz' is loaded because it's
215 ;; a new service.
216 (shepherd-service-upgrade
217 (list (live-service '(foo) '() #f #t)
218 (live-service '(bar) '() #f #f)
219 (live-service '(root) '() #f #t)) ;essential!
220 (list (shepherd-service (provision '(foo))
221 (start #t))
222 (shepherd-service (provision '(bar))
223 (start #t))
224 (shepherd-service (provision '(baz))
225 (start #t)))))
226 (lambda (unload restart)
227 (list (map live-service-provision unload)
228 (map live-service-provision restart)))))
229
230(test-equal "shepherd-service-upgrade: service depended on is not unloaded"
231 '(((baz)) ;unload
232 ((foo))) ;restart
233 (call-with-values
234 (lambda ()
235 ;; Service 'bar' is not among the target services; yet, it must not be
236 ;; unloaded because 'foo' depends on it. 'foo' gets replaced but it
237 ;; must be restarted manually.
238 (shepherd-service-upgrade
239 (list (live-service '(foo) '(bar) #f #t)
240 (live-service '(bar) '() #f #t) ;still used!
241 (live-service '(baz) '() #f #t))
242 (list (shepherd-service (provision '(foo))
243 (start #t)))))
244 (lambda (unload restart)
245 (list (map live-service-provision unload)
246 (map live-service-provision restart)))))
247
248(test-equal "shepherd-service-upgrade: obsolete services that depend on each other"
249 '(((foo) (bar) (baz)) ;unload
250 ()) ;restart
251 (call-with-values
252 (lambda ()
253 ;; 'foo', 'bar', and 'baz' depend on each other, but all of them are
254 ;; obsolete, and thus should be unloaded.
255 (shepherd-service-upgrade
256 (list (live-service '(foo) '(bar) #f #t) ;obsolete
257 (live-service '(bar) '(baz) #f #t) ;obsolete
258 (live-service '(baz) '() #f #t)) ;obsolete
259 (list (shepherd-service (provision '(qux))
260 (start #t)))))
261 (lambda (unload restart)
262 (list (map live-service-provision unload)
263 (map live-service-provision restart)))))
264
265(test-equal "shepherd-service-upgrade: transient service"
266 ;; Transient service must not be unloaded:
267 ;; <https://issues.guix.gnu.org/54812>.
268 '(((foo)) ;unload
269 ((qux))) ;restart
270 (call-with-values
271 (lambda ()
272 (shepherd-service-upgrade
273 (list (live-service '(sshd-42) '() #t 42) ;transient
274 (live-service '(foo) '() #f #t) ;obsolete
275 (live-service '(qux) '() #f #t)) ;running
276 (list (shepherd-service (provision '(qux))
277 (start #t)))))
278 (lambda (unload restart)
279 (list (map live-service-provision unload)
280 (map live-service-provision restart)))))
281
282(test-equal "shepherd-service-upgrade: service has new canonical name"
283 '(((qux)) ;unload
284 ((ssh) (foo))) ;restart
285 (call-with-values
286 (lambda ()
287 (shepherd-service-upgrade
288 (list (live-service '(ssh) '() #f 42) ;running
289 (live-service '(foo) '() #f #t) ;changed canonical name
290 (live-service '(qux) '() #f #t)) ;obsolete
291 (list (shepherd-service (provision '(ssh))
292 (start #t))
293 (shepherd-service (provision '(bar foo))
294 (start #t)))))
295 (lambda (unload restart)
296 (list (map live-service-provision unload)
297 (map live-service-provision restart)))))
298
299(test-eq "lookup-service-types"
300 system-service-type
301 (and (null? (lookup-service-types 'does-not-exist-at-all))
302 (match (lookup-service-types 'system)
303 ((one) one)
304 (x x))))
305
306(test-equal "modify-services: do nothing"
307 '(1 2 3) ;note: service order must be preserved
308 (let* ((t1 (service-type (name 't1)
309 (extensions '())
310 (description "")))
311 (t2 (service-type (name 't2)
312 (extensions '())
313 (description "")))
314 (t3 (service-type (name 't3)
315 (extensions '())
316 (description "")))
317 (services (list (service t1 1) (service t2 2) (service t3 3))))
318 (map service-value
319 (modify-services services))))
320
321(test-equal "modify-services: delete service"
322 '(1 4) ;note: service order must be preserved
323 (let* ((t1 (service-type (name 't1)
324 (extensions '())
325 (description "")))
326 (t2 (service-type (name 't2)
327 (extensions '())
328 (description "")))
329 (t3 (service-type (name 't3)
330 (extensions '())
331 (description "")))
332 (t4 (service-type (name 't4)
333 (extensions '())
334 (description "")))
335 (services (list (service t1 1) (service t2 2)
336 (service t3 3) (service t4 4))))
337 (map service-value
338 (modify-services services
339 (delete t3)
340 (delete t2)))))
341
342(test-error "modify-services: delete non-existing service"
343 #t
344 (let* ((t1 (service-type (name 't1)
345 (extensions '())
346 (description "")))
347 (t2 (service-type (name 't2)
348 (extensions '())
349 (description "")))
350 (t3 (service-type (name 't2)
351 (extensions '())
352 (description "")))
353 (services (list (service t1 1) (service t2 2))))
354 (modify-services services
355 (delete t3))))
356
357(test-equal "modify-services: change value"
358 '(11 2 33) ;note: service order must be preserved
359 (let* ((t1 (service-type (name 't1)
360 (extensions '())
361 (description "")))
362 (t2 (service-type (name 't2)
363 (extensions '())
364 (description "")))
365 (t3 (service-type (name 't3)
366 (extensions '())
367 (description "")))
368 (services (list (service t1 1) (service t2 2) (service t3 3))))
369 (map service-value
370 (modify-services services
371 (t1 value => 11)
372 (t3 value => 33)))))
373
374(test-error "modify-services: change value for non-existing service"
375 #t
376 (let* ((t1 (service-type (name 't1)
377 (extensions '())
378 (description "")))
379 (t2 (service-type (name 't2)
380 (extensions '())
381 (description "")))
382 (t3 (service-type (name 't3)
383 (extensions '())
384 (description "")))
385 (services (list (service t1 1) (service t3 3))))
386 (map service-value
387 (modify-services services
388 (t2 value => 22)))))
389
390(test-error "modify-services: delete then modify"
391 #t
392 (let* ((t1 (service-type (name 't1)
393 (extensions '())
394 (description "")))
395 (t2 (service-type (name 't2)
396 (extensions '())
397 (description "")))
398 (t3 (service-type (name 't3)
399 (extensions '())
400 (description "")))
401 (services (list (service t1 1) (service t2 2) (service t3 3))))
402 (map service-value
403 (modify-services services
404 (delete t2)
405 (t2 value => 22)))))
406
407(test-equal "modify-services: modify then delete"
408 '(2 3)
409 (let* ((t1 (service-type (name 't1)
410 (extensions '())
411 (description "")))
412 (t2 (service-type (name 't2)
413 (extensions '())
414 (description "")))
415 (t3 (service-type (name 't3)
416 (extensions '())
417 (description "")))
418 (services (list (service t1 1) (service t2 2) (service t3 3))))
419 (map service-value
420 (modify-services services
421 (t1 value => 11)
422 (delete t1)))))
423
424(test-equal "modify-services: delete multiple services of the same type"
425 '(1 3)
426 (let* ((t1 (service-type (name 't1)
427 (extensions '())
428 (description "")))
429 (t2 (service-type (name 't2)
430 (extensions '())
431 (description "")))
432 (t3 (service-type (name 't3)
433 (extensions '())
434 (description "")))
435 (services (list (service t1 1) (service t2 2)
436 (service t2 2) (service t3 3))))
437 (map service-value
438 (modify-services services
439 (delete t2)))))
440
441(test-equal "modify-services: modify multiple services of the same type"
442 '(1 12 13 4)
443 (let* ((t1 (service-type (name 't1)
444 (extensions '())
445 (description "")))
446 (t2 (service-type (name 't2)
447 (extensions '())
448 (description "")))
449 (t3 (service-type (name 't3)
450 (extensions '())
451 (description "")))
452 (services (list (service t1 1) (service t2 2)
453 (service t2 3) (service t3 4))))
454 (map service-value
455 (modify-services services
456 (t2 value => (+ value 10))))))
457
458(test-end)