gtk and wayland update
[jackhill/guix/guix.git] / tests / services.scm
CommitLineData
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)