projects/guix·blob python-team · refs

530 lines · 22.4 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2019 Ludovic Courtès <[email protected]>
3;;; Copyright © 2024 Giacomo Leidi <[email protected]>
4;;;
5;;; This file is part of GNU Guix.
6;;;
7;;; GNU Guix is free software; you can redistribute it and/or modify it
8;;; under the terms of the GNU General Public License as published by
9;;; the Free Software Foundation; either version 3 of the License, or (at
10;;; your option) any later version.
11;;;
12;;; GNU Guix is distributed in the hope that it will be useful, but
13;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;;; GNU General Public License for more details.
16;;;
17;;; You should have received a copy of the GNU General Public License
18;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19
20(define-module (test-accounts)
21 #:use-module (gnu build accounts)
22 #:use-module (gnu system accounts)
23 #:use-module (srfi srfi-19)
24 #:use-module (srfi srfi-34)
25 #:use-module (srfi srfi-64)
26 #:use-module (ice-9 vlist)
27 #:use-module (ice-9 match))
28
29(define %passwd-sample
30 "\
31root:x:0:0:Admin:/root:/bin/sh
32charlie:x:1000:998:Charlie:/home/charlie:/bin/sh\n")
33
34(define %group-sample
35 "\
36root:x:0:
37wheel:x:999:alice,bob
38hackers:x:65000:alice,charlie\n")
39
40(define %shadow-sample
41 (string-append "\
42root:" (crypt "secret" "$6$abc") ":17169::::::
43charlie:" (crypt "hey!" "$6$abc") ":17169::::::
44nobody:!:0::::::\n"))
45
46(define %subuid-sample
47 "\
48root:100000:300
49ada:100300:300\n")
50
51(define %subgid-sample
52 "\
53root:100000:600
54ada:100600:300\n")
55
56
57(test-begin "accounts")
58
59(test-equal "write-passwd"
60 %passwd-sample
61 (call-with-output-string
62 (lambda (port)
63 (write-passwd (list (password-entry
64 (name "root")
65 (uid 0) (gid 0)
66 (real-name "Admin")
67 (directory "/root")
68 (shell "/bin/sh"))
69 (password-entry
70 (name "charlie")
71 (uid 1000) (gid 998)
72 (real-name "Charlie")
73 (directory "/home/charlie")
74 (shell "/bin/sh")))
75 port))))
76
77(test-equal "write-passwd with duplicate entry"
78 %passwd-sample
79 (call-with-output-string
80 (lambda (port)
81 (let ((charlie (password-entry
82 (name "charlie")
83 (uid 1000) (gid 998)
84 (real-name "Charlie")
85 (directory "/home/charlie")
86 (shell "/bin/sh"))))
87 (write-passwd (list (password-entry
88 (name "root")
89 (uid 0) (gid 0)
90 (real-name "Admin")
91 (directory "/root")
92 (shell "/bin/sh"))
93 charlie charlie)
94 port)))))
95
96(test-equal "read-passwd + write-passwd"
97 %passwd-sample
98 (call-with-output-string
99 (lambda (port)
100 (write-passwd (call-with-input-string %passwd-sample
101 read-passwd)
102 port))))
103
104(test-equal "write-group"
105 %group-sample
106 (call-with-output-string
107 (lambda (port)
108 (write-group (list (group-entry
109 (name "root") (gid 0))
110 (group-entry
111 (name "wheel") (gid 999)
112 (members '("alice" "bob")))
113 (group-entry
114 (name "hackers") (gid 65000)
115 (members '("alice" "charlie"))))
116 port))))
117
118(test-equal "read-group + write-group"
119 %group-sample
120 (call-with-output-string
121 (lambda (port)
122 (write-group (call-with-input-string %group-sample
123 read-group)
124 port))))
125
126(test-equal "write-shadow"
127 %shadow-sample
128 (call-with-output-string
129 (lambda (port)
130 (write-shadow (list (shadow-entry
131 (name "root")
132 (password (crypt "secret" "$6$abc"))
133 (last-change 17169))
134 (shadow-entry
135 (name "charlie")
136 (password (crypt "hey!" "$6$abc"))
137 (last-change 17169))
138 (shadow-entry
139 (name "nobody")))
140 port))))
141
142(test-equal "read-shadow + write-shadow"
143 %shadow-sample
144 (call-with-output-string
145 (lambda (port)
146 (write-shadow (call-with-input-string %shadow-sample
147 read-shadow)
148 port))))
149
150(test-equal "write-subuid"
151 %subuid-sample
152 (call-with-output-string
153 (lambda (port)
154 (write-subuid (list (subid-entry
155 (name "root")
156 (start 100000)
157 (count 300))
158 (subid-entry
159 (name "ada")
160 (start 100300)
161 (count 300)))
162 port))))
163
164(test-equal "read-subuid + write-subuid"
165 %subuid-sample
166 (call-with-output-string
167 (lambda (port)
168 (write-subuid (call-with-input-string %subuid-sample
169 read-subuid)
170 port))))
171
172(test-equal "write-subgid"
173 %subgid-sample
174 (call-with-output-string
175 (lambda (port)
176 (write-subgid (list (subid-entry
177 (name "root")
178 (start 100000)
179 (count 600))
180 (subid-entry
181 (name "ada")
182 (start 100600)
183 (count 300)))
184 port))))
185
186(test-equal "read-subgid + write-subgid"
187 %subgid-sample
188 (call-with-output-string
189 (lambda (port)
190 (write-subgid (call-with-input-string %subgid-sample
191 read-subgid)
192 port))))
193
194
195(define allocate-groups (@@ (gnu build accounts) allocate-groups))
196(define allocate-passwd (@@ (gnu build accounts) allocate-passwd))
197(define allocate-subids (@@ (gnu build accounts) allocate-subids))
198
199(test-equal "allocate-groups"
200 ;; Allocate GIDs in a stateless fashion.
201 (list (group-entry (name "s") (gid %system-id-max))
202 (group-entry (name "x") (gid 900))
203 (group-entry (name "t") (gid 899))
204 (group-entry (name "a") (gid %id-min) (password "foo")
205 (members '("alice" "bob")))
206 (group-entry (name "b") (gid (+ %id-min 1))
207 (members '("charlie"))))
208 (allocate-groups (list (user-group (name "s") (system? #t))
209 (user-group (name "x") (id 900))
210 (user-group (name "t") (system? #t))
211 (user-group (name "a") (password "foo"))
212 (user-group (name "b")))
213 (alist->vhash `(("a" . "bob")
214 ("a" . "alice")
215 ("b" . "charlie")))))
216
217(test-equal "allocate-groups with requested GIDs"
218 ;; Make sure the requested GID for "b" is honored.
219 (list (group-entry (name "a") (gid (+ 1 %id-min)))
220 (group-entry (name "b") (gid %id-min))
221 (group-entry (name "c") (gid (+ 2 %id-min))))
222 (allocate-groups (list (user-group (name "a"))
223 (user-group (name "b") (id %id-min))
224 (user-group (name "c")))
225 vlist-null))
226
227(test-equal "allocate-groups with previous state"
228 ;; Make sure bits of state are preserved: password, GID, no reuse of
229 ;; previously-used GIDs.
230 (list (group-entry (name "s") (gid (- %system-id-max 1)))
231 (group-entry (name "t") (gid (- %system-id-max 2)))
232 (group-entry (name "a") (gid 30000) (password #f)
233 (members '("alice" "bob")))
234 (group-entry (name "b") (gid 30001) (password "bar")
235 (members '("charlie"))))
236 (allocate-groups (list (user-group (name "s") (system? #t))
237 (user-group (name "t") (system? #t))
238 (user-group (name "a") (password "foo"))
239 (user-group (name "b")))
240 (alist->vhash `(("a" . "bob")
241 ("a" . "alice")
242 ("b" . "charlie")))
243 (list (group-entry (name "a") (gid 30000))
244 (group-entry (name "b") (gid 30001)
245 (password "bar"))
246 (group-entry (name "removed")
247 (gid %system-id-max)))))
248
249(test-equal "allocate-groups with previous state, looping"
250 ;; Check that allocation starts after the highest previously-used GID, and
251 ;; loops back to the lowest GID.
252 (list (group-entry (name "a") (gid (- %id-max 1)))
253 (group-entry (name "b") (gid %id-min))
254 (group-entry (name "c") (gid (+ 1 %id-min))))
255 (allocate-groups (list (user-group (name "a"))
256 (user-group (name "b"))
257 (user-group (name "c")))
258 vlist-null
259 (list (group-entry (name "d")
260 (gid (- %id-max 2))))))
261
262(test-equal "allocate-subids"
263 ;; Allocate sub IDs in a stateless fashion.
264 (list (subid-entry (name "root") (start %subordinate-id-min) (count 100))
265 (subid-entry (name "t") (start 100100) (count 899))
266 (subid-entry (name "x") (start 100999) (count 200)))
267 (allocate-subids (list
268 (subid-range (name "x") (count 200))
269 (subid-range (name "t") (count 899)))
270 (list (subid-range (name "root")
271 (start %subordinate-id-min)
272 (count 100)))))
273
274(test-equal "allocate-subids with externally managed state"
275 (list (subid-entry (name "guix-daemon") (start 904) (count 1))
276 (subid-entry (name "alice") (start 1085) (count 100))
277 (subid-entry (name "t") (start %subordinate-id-min) (count 899))
278 (subid-entry (name "x") (start 100899) (count 200)))
279 (allocate-subids (list
280 (subid-range (name "x") (count 200))
281 (subid-range (name "t") (count 899)))
282 ;; Test use case from
283 ;; https://codeberg.org/guix/guix/issues/3925
284 (list (subid-range (name "guix-daemon")
285 (start 904)
286 (count 1))
287 (subid-range (name "alice")
288 (start 1085)
289 (count 100)))))
290
291(test-equal "allocate-subids with requested IDs ranges"
292 ;; Make sure the requested sub ID for "k" and "root" are honored.
293 (list (subid-entry (name "x") (start %subordinate-id-min) (count 200))
294 (subid-entry (name "k") (start (+ %subordinate-id-min 300)) (count 100))
295 (subid-entry (name "t") (start (+ %subordinate-id-min 500)) (count 899))
296 (subid-entry (name "root") (start (+ %subordinate-id-min 2500)) (count 100)))
297
298 (allocate-subids (list
299 (subid-range (name "root") (start (+ %subordinate-id-min 2500)) (count 100))
300 (subid-range (name "k") (start (+ %subordinate-id-min 300)) (count 100)))
301 (list
302 (subid-range (name "x") (start %subordinate-id-min) (count 200))
303 (subid-range (name "t") (start (+ %subordinate-id-min 500)) (count 899)))))
304
305(test-assert "allocate-subids, impossible allocations - ranges must have start"
306 (guard (c ((specific-subid-range-expected-error? c)
307 #t))
308 (allocate-subids (list (subid-range (name "m"))) (list (subid-range (name "x"))))
309 #f))
310
311(test-assert "allocate-subids, impossible allocations - ranges must fall within allowed max min subids"
312 (guard (c ((invalid-subid-range-error? c)
313 #t))
314 (allocate-subids
315 (list (subid-range (name "m")
316 (start (- %subordinate-id-min 1))
317 (count
318 (+ %subordinate-id-max %subordinate-id-min))))
319 (list
320 (subid-range (name "root") (start %subordinate-id-min))))
321 #f))
322
323(test-equal "allocate-subids with interleaving"
324 ;; Make sure the requested sub ID for "m" is honored and
325 ;; for "l" and "i" are correctly deduced.
326 (list (subid-entry (name "x") (start %subordinate-id-min) (count 200))
327 (subid-entry (name "m") (start (+ %subordinate-id-min 201)) (count 27))
328 (subid-entry (name "root") (start (+ %subordinate-id-min 231)) (count 100))
329 (subid-entry (name "i") (start (+ %subordinate-id-min 331)) (count 2))
330 (subid-entry (name "l") (start (+ %subordinate-id-min 333)) (count 1)))
331 (allocate-subids (list
332 (subid-range (name "m") (start (+ %subordinate-id-min 201)) (count 27))
333 (subid-range (name "l") (count 1))
334 (subid-range (name "i") (count 2)))
335 (list
336 (subid-range (name "x") (start %subordinate-id-min) (count 200))
337 (subid-range (name "root") (start (+ %subordinate-id-min 231)) (count 100)))))
338
339(test-assert "allocate-subids with interleaving, impossible interleaving - before"
340 (guard (c ((subordinate-id-overflow-error? c)
341 #t))
342 (allocate-subids
343 (list (subid-range (name "m") (start %subordinate-id-min) (count 16)))
344 (list
345 (subid-range (name "x") (start (+ 15 %subordinate-id-min)) (count 150))))
346 #f))
347
348(test-assert "allocate-subids with interleaving, impossible interleaving - after"
349 (guard (c ((subordinate-id-overflow-error? c)
350 #t))
351 (allocate-subids
352 (list (subid-range (name "m") (start %subordinate-id-min) (count 30)))
353 (list
354 (subid-range (name "x") (start (+ 29 %subordinate-id-min)) (count 150))))
355 #f))
356
357(test-assert "allocate-subids with interleaving, impossible interleaving - between"
358 (guard (c ((subordinate-id-overflow-error? c)
359 #t))
360 (allocate-subids
361 (list (subid-range (name "m") (start 100200) (count 500)))
362 (list
363 (subid-range (name "root") (start %subordinate-id-min) (count 100))
364 (subid-range (name "x") (start (+ %subordinate-id-min 500)) (count 100))))
365 #f))
366
367(test-equal "allocate-passwd"
368 ;; Allocate UIDs in a stateless fashion.
369 (list (password-entry (name "alice") (uid %id-min) (gid 1000)
370 (real-name "Alice") (shell "/bin/sh")
371 (directory "/home/alice"))
372 (password-entry (name "bob") (uid (+ 1 %id-min)) (gid 1001)
373 (real-name "Bob") (shell "/bin/gash")
374 (directory "/home/bob"))
375 (password-entry (name "sshd") (uid %system-id-max) (gid 500)
376 (real-name "sshd") (shell "/nologin")
377 (directory "/var/empty"))
378 (password-entry (name "guix") (uid 30000) (gid 499)
379 (real-name "Guix") (shell "/nologin")
380 (directory "/var/empty")))
381 (allocate-passwd (list (user-account (name "alice")
382 (comment "Alice")
383 (shell "/bin/sh")
384 (group "users"))
385 (user-account (name "bob")
386 (comment "Bob")
387 (shell "/bin/gash")
388 (group "wheel"))
389 (user-account (name "sshd") (system? #t)
390 (comment "sshd")
391 (home-directory "/var/empty")
392 (shell "/nologin")
393 (group "sshd"))
394 (user-account (name "guix") (system? #t)
395 (comment "Guix")
396 (home-directory "/var/empty")
397 (shell "/nologin")
398 (group "guix")
399 (uid 30000)))
400 (list (group-entry (name "users") (gid 1000))
401 (group-entry (name "wheel") (gid 1001))
402 (group-entry (name "sshd") (gid 500))
403 (group-entry (name "guix") (gid 499)))))
404
405(test-equal "allocate-passwd with previous state"
406 ;; Make sure bits of state are preserved: UID, no reuse of previously-used
407 ;; UIDs, and shell.
408 (list (password-entry (name "alice") (uid 1234) (gid 1000)
409 (real-name "Alice Smith") (shell "/bin/sh")
410 (directory "/home/alice"))
411 (password-entry (name "charlie") (uid 1236) (gid 1000)
412 (real-name "Charlie") (shell "/bin/sh")
413 (directory "/home/charlie")))
414 (allocate-passwd (list (user-account (name "alice")
415 (comment "Alice")
416 (shell "/bin/sh") ;honored
417 (group "users"))
418 (user-account (name "charlie")
419 (comment "Charlie")
420 (shell "/bin/sh")
421 (group "users")))
422 (list (group-entry (name "users") (gid 1000)))
423 (list (password-entry (name "alice") (uid 1234) (gid 9999)
424 (real-name "Alice Smith")
425 (shell "/gnu/.../bin/gash") ;ignored
426 (directory "/home/alice"))
427 (password-entry (name "bob") (uid 1235) (gid 1001)
428 (real-name "Bob") (shell "/bin/sh")
429 (directory "/home/bob")))))
430
431(test-equal "user+group-databases"
432 ;; The whole shebang.
433 (list (list (group-entry (name "a") (gid %id-min)
434 (members '("bob")))
435 (group-entry (name "b") (gid (+ 1 %id-min))
436 (members '("alice")))
437 (group-entry (name "s") (gid %system-id-max)))
438 (list (password-entry (name "alice") (real-name "Alice")
439 (uid %id-min) (gid %id-min)
440 (directory "/a"))
441 (password-entry (name "bob") (real-name "Bob")
442 (uid (+ 1 %id-min)) (gid (+ 1 %id-min))
443 (directory "/b"))
444 (password-entry (name "nobody")
445 (uid 65534) (gid %system-id-max)
446 (directory "/var/empty")))
447 (list (shadow-entry (name "alice") (last-change 100)
448 (password (crypt "initial pass" "$6$")))
449 (shadow-entry (name "bob") (last-change 50)
450 (password (crypt "foo" "$6$")))
451 (shadow-entry (name "nobody") (last-change 100))))
452 (call-with-values
453 (lambda ()
454 (user+group-databases (list (user-account
455 (name "alice")
456 (comment "Alice")
457 (home-directory "/a")
458 (group "a")
459 (supplementary-groups '("b"))
460 (password (crypt "initial pass" "$6$")))
461 (user-account
462 (name "bob")
463 (comment "Bob")
464 (home-directory "/b")
465 (group "b")
466 (supplementary-groups '("a")))
467 (user-account
468 (name "nobody")
469 (group "s")
470 (uid 65534)
471 (home-directory "/var/empty")))
472 (list (user-group (name "a"))
473 (user-group (name "b"))
474 (user-group (name "s") (system? #t)))
475 #:current-passwd '()
476 #:current-shadow
477 (list (shadow-entry (name "bob")
478 (password (crypt "foo" "$6$"))
479 (last-change 50)))
480 #:current-groups '()
481 #:current-time
482 (lambda (type)
483 (make-time type 0 (* 24 3600 100)))))
484 list))
485
486(test-equal "subuid+subgid-databases"
487 ;; The whole process.
488 (list (list (subid-entry (name "root")
489 (start %subordinate-id-min)
490 (count 100))
491 (subid-entry (name "alice")
492 (start (+ %subordinate-id-min 100))
493 (count 200))
494 (subid-entry (name "bob")
495 (start (+ %subordinate-id-min 100 200))
496 (count 200)))
497 (list
498 (subid-entry (name "root")
499 (start %subordinate-id-min)
500 (count 200))
501 (subid-entry (name "alice")
502 (start (+ %subordinate-id-min 200))
503 (count 400))
504 (subid-entry (name "charlie")
505 (start (+ %subordinate-id-min 200 400))
506 (count 300))))
507 (call-with-values
508 (lambda ()
509 (subuid+subgid-databases
510 (list (subid-range (name "root")
511 (start %subordinate-id-min)
512 (count 100))
513 (subid-range (name "alice")
514 (start (+ %subordinate-id-min 100))
515 (count 200))
516 (subid-range (name "bob")
517 (count 200)))
518 (list
519 (subid-range (name "alice")
520 (count 400))
521 (subid-range (name "charlie")
522 (count 300)))
523 #:current-subgids
524 (list (subid-range (name "root")
525 (start %subordinate-id-min)
526 (count 200)))
527 #:current-subuids '()))
528 list))
529
530(test-end "accounts")