Commit | Line | Data |
---|---|---|
0adfe95a | 1 | ;;; GNU Guix --- Functional package management for GNU |
e25eca35 | 2 | ;;; Copyright © 2015-2019, 2022 Ludovic Courtès <ludo@gnu.org> |
0adfe95a LC |
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) | |
7b44cae5 | 21 | #:use-module (gnu services herd) |
0190c1c0 | 22 | #:use-module (gnu services shepherd) |
0adfe95a LC |
23 | #:use-module (srfi srfi-1) |
24 | #:use-module (srfi srfi-26) | |
25 | #:use-module (srfi srfi-34) | |
49483f71 LC |
26 | #:use-module (srfi srfi-64) |
27 | #:use-module (ice-9 match)) | |
0adfe95a LC |
28 | |
29 | (test-begin "services") | |
30 | ||
1bb895ea LC |
31 | (test-equal "services, default value" |
32 | '(42 123 234 error) | |
3948ac25 LC |
33 | (let* ((t1 (service-type (name 't1) (extensions '()) |
34 | (description ""))) | |
1bb895ea | 35 | (t2 (service-type (name 't2) (extensions '()) |
3948ac25 | 36 | (description "") |
1bb895ea LC |
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 | ||
5152d13b | 44 | (test-assert "service-back-edges" |
3948ac25 | 45 | (let* ((t1 (service-type (name 't1) (extensions '()) (description "") |
5152d13b | 46 | (compose +) (extend *))) |
3948ac25 | 47 | (t2 (service-type (name 't2) (description "") |
5152d13b LC |
48 | (extensions |
49 | (list (service-extension t1 (const '())))) | |
50 | (compose +) (extend *))) | |
3948ac25 | 51 | (t3 (service-type (name 't3) (description "") |
5152d13b LC |
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 | ||
0adfe95a LC |
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) | |
3948ac25 | 68 | (let* ((t1 (service-type (name 't1) (extensions '()) (description "") |
0adfe95a LC |
69 | (compose concatenate) |
70 | (extend cons))) | |
3948ac25 | 71 | (t2 (service-type (name 't2) (description "") |
0adfe95a LC |
72 | (extensions |
73 | (list (service-extension t1 | |
74 | (cut list 'xyz <>)))) | |
75 | (compose (cut reduce + 0 <>)) | |
76 | (extend *))) | |
3948ac25 | 77 | (t3 (service-type (name 't3) (description "") |
0adfe95a LC |
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) | |
efe7d19a | 88 | (service-value r)))) |
0adfe95a LC |
89 | |
90 | (test-assert "fold-services, ambiguity" | |
3948ac25 | 91 | (let* ((t1 (service-type (name 't1) (extensions '()) (description "") |
0adfe95a LC |
92 | (compose concatenate) |
93 | (extend cons))) | |
3948ac25 | 94 | (t2 (service-type (name 't2) (description "") |
0adfe95a LC |
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" | |
3948ac25 LC |
110 | (let* ((t1 (service-type (name 't1) (extensions '()) (description ""))) |
111 | (t2 (service-type (name 't2) (description "") | |
0adfe95a LC |
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 | ||
d466b1fc | 123 | (test-assert "instantiate-missing-services" |
3948ac25 | 124 | (let* ((t1 (service-type (name 't1) (extensions '()) (description "") |
d466b1fc LC |
125 | (default-value 'dflt) |
126 | (compose concatenate) | |
127 | (extend cons))) | |
3948ac25 | 128 | (t2 (service-type (name 't2) (description "") |
d466b1fc LC |
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 | ||
9b6c4355 | 139 | (test-assert "instantiate-missing-services, indirect" |
3948ac25 | 140 | (let* ((t1 (service-type (name 't1) (extensions '()) (description "") |
9b6c4355 LC |
141 | (default-value 'dflt) |
142 | (compose concatenate) | |
143 | (extend cons))) | |
3948ac25 | 144 | (t2 (service-type (name 't2) (description "") |
9b6c4355 LC |
145 | (default-value 'dflt2) |
146 | (compose concatenate) | |
147 | (extend cons) | |
148 | (extensions | |
149 | (list (service-extension t1 list))))) | |
3948ac25 | 150 | (t3 (service-type (name 't3) (description "") |
9b6c4355 LC |
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 | ||
d466b1fc | 164 | (test-assert "instantiate-missing-services, no default value" |
3948ac25 LC |
165 | (let* ((t1 (service-type (name 't1) (extensions '()) (description ""))) |
166 | (t2 (service-type (name 't2) (description "") | |
d466b1fc LC |
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 | ||
a5d78eb6 LC |
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 | ||
d4053c71 AK |
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)))) | |
80a67734 LC |
196 | (and (lset= eq? (e s1) (list s2 s3)) |
197 | (lset= eq? (e s2) (list s3)) | |
198 | (null? (e s3))))) | |
199 | ||
7b44cae5 LC |
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" | |
7fed9353 LC |
208 | '(() ;unload |
209 | ((foo))) ;restart | |
7b44cae5 LC |
210 | (call-with-values |
211 | (lambda () | |
7fed9353 LC |
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. | |
7b44cae5 | 216 | (shepherd-service-upgrade |
e25eca35 LC |
217 | (list (live-service '(foo) '() #f #t) |
218 | (live-service '(bar) '() #f #f) | |
219 | (live-service '(root) '() #f #t)) ;essential! | |
7b44cae5 LC |
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))))) | |
7fed9353 | 226 | (lambda (unload restart) |
7b44cae5 | 227 | (list (map live-service-provision unload) |
7fed9353 | 228 | (map shepherd-service-provision restart))))) |
7b44cae5 LC |
229 | |
230 | (test-equal "shepherd-service-upgrade: service depended on is not unloaded" | |
231 | '(((baz)) ;unload | |
7fed9353 | 232 | ((foo))) ;restart |
7b44cae5 LC |
233 | (call-with-values |
234 | (lambda () | |
235 | ;; Service 'bar' is not among the target services; yet, it must not be | |
7fed9353 LC |
236 | ;; unloaded because 'foo' depends on it. 'foo' gets replaced but it |
237 | ;; must be restarted manually. | |
7b44cae5 | 238 | (shepherd-service-upgrade |
e25eca35 LC |
239 | (list (live-service '(foo) '(bar) #f #t) |
240 | (live-service '(bar) '() #f #t) ;still used! | |
241 | (live-service '(baz) '() #f #t)) | |
7b44cae5 LC |
242 | (list (shepherd-service (provision '(foo)) |
243 | (start #t))))) | |
7fed9353 | 244 | (lambda (unload restart) |
7b44cae5 | 245 | (list (map live-service-provision unload) |
7fed9353 | 246 | (map shepherd-service-provision restart))))) |
7b44cae5 LC |
247 | |
248 | (test-equal "shepherd-service-upgrade: obsolete services that depend on each other" | |
249 | '(((foo) (bar) (baz)) ;unload | |
7fed9353 | 250 | ()) ;restart |
7b44cae5 LC |
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 | |
e25eca35 LC |
256 | (list (live-service '(foo) '(bar) #f #t) ;obsolete |
257 | (live-service '(bar) '(baz) #f #t) ;obsolete | |
258 | (live-service '(baz) '() #f #t)) ;obsolete | |
7b44cae5 LC |
259 | (list (shepherd-service (provision '(qux)) |
260 | (start #t))))) | |
7fed9353 | 261 | (lambda (unload restart) |
7b44cae5 | 262 | (list (map live-service-provision unload) |
7fed9353 | 263 | (map shepherd-service-provision restart))))) |
7b44cae5 | 264 | |
ec6a585e LC |
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 shepherd-service-provision restart))))) | |
281 | ||
49483f71 LC |
282 | (test-eq "lookup-service-types" |
283 | system-service-type | |
284 | (and (null? (lookup-service-types 'does-not-exist-at-all)) | |
285 | (match (lookup-service-types 'system) | |
286 | ((one) one) | |
287 | (x x)))) | |
288 | ||
0adfe95a | 289 | (test-end) |