projects/guix·blob python-team · refs

939 lines · 34.2 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2019, 2021, 2023 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 (gnu build accounts)
21 #:use-module (guix records)
22 #:use-module (guix combinators)
23 #:use-module (gnu system accounts)
24 #:use-module (srfi srfi-1)
25 #:use-module (srfi srfi-11)
26 #:use-module (srfi srfi-19)
27 #:use-module (srfi srfi-26)
28 #:use-module (srfi srfi-34)
29 #:use-module (srfi srfi-35)
30 #:use-module (ice-9 match)
31 #:use-module (ice-9 vlist)
32 #:use-module (ice-9 receive)
33 #:use-module (ice-9 rdelim)
34 #:export (password-entry
35 password-entry?
36 password-entry-name
37 password-entry-uid
38 password-entry-gid
39 password-entry-real-name
40 password-entry-directory
41 password-entry-shell
42
43 shadow-entry
44 shadow-entry?
45 shadow-entry-name
46 shadow-entry-minimum-change-period
47 shadow-entry-maximum-change-period
48 shadow-entry-change-warning-time
49 shadow-entry-maximum-inactivity
50 shadow-entry-expiration
51
52 group-entry
53 group-entry?
54 group-entry-name
55 group-entry-gid
56 group-entry-members
57
58 subid-entry
59 subid-entry?
60 subid-entry-name
61 subid-entry-start
62 subid-entry-count
63
64 %password-lock-file
65 write-group
66 write-passwd
67 write-shadow
68 write-subgid
69 write-subuid
70 read-group
71 read-passwd
72 read-shadow
73 read-subgid
74 read-subuid
75
76 %id-min
77 %id-max
78 %system-id-min
79 %system-id-max
80 %subordinate-id-min
81 %subordinate-id-max
82 %subordinate-id-count
83
84 &subordinate-id-error
85 subordinate-id-error?
86 &subordinate-id-overflow-error
87 subordinate-id-overflow-error?
88 subordinate-id-overflow-error-range
89 &invalid-subid-range-error
90 invalid-subid-range-error?
91 invalid-subid-range-error-range
92 &specific-subid-range-expected-error
93 specific-subid-range-expected-error?
94 specific-subid-range-expected-error-range
95 &generic-subid-range-expected-error
96 generic-subid-range-expected-error?
97 generic-subid-range-expected-error-range
98
99 user+group-databases
100 subuid+subgid-databases))
101
102;;; Commentary:
103;;;
104;;; This module provides functionality equivalent to the C library's
105;;; <shadow.h>, <pwd.h>, and <grp.h> routines, as well as a subset of the
106;;; functionality of the Shadow command-line tools. It can parse and write
107;;; /etc/passwd, /etc/shadow, /etc/group, /etc/subuid and /etc/subgid. It can
108;;; also take care of UID and GID allocation in a way similar to what 'useradd'
109;;; does. The same goes for sub UID and sub GID allocation.
110;;;
111;;; The benefit is twofold: less code is involved, and the ID allocation
112;;; strategy and state preservation is made explicit.
113;;;
114;;; Code:
115
116
117;;;
118;;; Machinery to define user and group databases.
119;;;
120
121(define-syntax serialize-field
122 (syntax-rules (serialization)
123 ((_ entry (field get (serialization ->string string->) _ ...))
124 (->string (get entry)))
125 ((_ entry (field get _ ...))
126 (get entry))))
127
128(define-syntax deserialize-field
129 (syntax-rules (serialization)
130 ((_ str (field get (serialization ->string string->) _ ...))
131 (string-> str))
132 ((_ str (field get _ ...))
133 str)))
134
135(define-syntax let/fields
136 (syntax-rules ()
137 ((_ (((name get attributes ...) rest ...) lst) body ...)
138 (let ((l lst))
139 (let ((name (deserialize-field (car l)
140 (name get attributes ...))))
141 (let/fields ((rest ...) (cdr l)) body ...))))
142 ((_ (() lst) body ...)
143 (begin body ...))))
144
145(define-syntax define-database-entry
146 (syntax-rules (serialization)
147 "Define a record data type, as per 'define-record-type*', with additional
148information on how to serialize and deserialize the whole database as well as
149each field."
150 ((_ <record> record make-record record?
151 (serialization separator entry->string string->entry)
152 fields ...)
153 (let-syntax ((field-name
154 (syntax-rules ()
155 ((_ (name _ (... ...))) name))))
156 (define-record-type* <record> record make-record
157 record?
158 fields ...)
159
160 (define (entry->string entry)
161 (string-join (list (serialize-field entry fields) ...)
162 (string separator)))
163
164 (define (string->entry str)
165 (let/fields ((fields ...) (string-split str #\:))
166 (make-record (field-name fields) ...)))))))
167
168
169(define number->string*
170 (match-lambda
171 ((? number? number) (number->string number))
172 (_ "")))
173
174(define (false-if-string=? false-string)
175 (lambda (str)
176 (if (string=? str false-string)
177 #f
178 str)))
179
180(define (string-if-false str)
181 (lambda (obj)
182 (if (not obj) str obj)))
183
184(define (comma-separated->list str)
185 (string-tokenize str (char-set-complement (char-set #\,))))
186
187(define (list->comma-separated lst)
188 (string-join lst ","))
189
190
191;;;
192;;; Database definitions.
193;;;
194
195(define-database-entry <password-entry> ;<pwd.h>
196 password-entry make-password-entry
197 password-entry?
198 (serialization #\: password-entry->string string->password-entry)
199
200 (name password-entry-name)
201 (password password-entry-password
202 (serialization (const "x") (const #f))
203 (default "x"))
204 (uid password-entry-uid
205 (serialization number->string string->number))
206 (gid password-entry-gid
207 (serialization number->string string->number))
208 (real-name password-entry-real-name
209 (default ""))
210 (directory password-entry-directory)
211 (shell password-entry-shell
212 (default "/bin/sh")))
213
214(define-database-entry <shadow-entry> ;<shadow.h>
215 shadow-entry make-shadow-entry
216 shadow-entry?
217 (serialization #\: shadow-entry->string string->shadow-entry)
218
219 (name shadow-entry-name) ;string
220 (password shadow-entry-password ;string | #f
221 (serialization (string-if-false "!")
222 (false-if-string=? "!"))
223 (default #f))
224 (last-change shadow-entry-last-change ;days since 1970-01-01
225 (serialization number->string* string->number)
226 (default 0))
227 (minimum-change-period shadow-entry-minimum-change-period
228 (serialization number->string* string->number)
229 (default #f)) ;days | #f
230 (maximum-change-period shadow-entry-maximum-change-period
231 (serialization number->string* string->number)
232 (default #f)) ;days | #f
233 (change-warning-time shadow-entry-change-warning-time
234 (serialization number->string* string->number)
235 (default #f)) ;days | #f
236 (maximum-inactivity shadow-entry-maximum-inactivity
237 (serialization number->string* string->number)
238 (default #f)) ;days | #f
239 (expiration shadow-entry-expiration
240 (serialization number->string* string->number)
241 (default #f)) ;days since 1970-01-01 | #f
242 (flags shadow-entry-flags ;"reserved"
243 (serialization number->string* string->number)
244 (default #f)))
245
246(define-database-entry <group-entry> ;<grp.h>
247 group-entry make-group-entry
248 group-entry?
249 (serialization #\: group-entry->string string->group-entry)
250
251 (name group-entry-name)
252 (password group-entry-password
253 (serialization (string-if-false "x")
254 (false-if-string=? "x"))
255 (default #f))
256 (gid group-entry-gid
257 (serialization number->string string->number))
258 (members group-entry-members
259 (serialization list->comma-separated comma-separated->list)
260 (default '())))
261
262(define-database-entry <subid-entry> ;<subid.h>
263 subid-entry make-subid-entry
264 subid-entry?
265 (serialization #\: subid-entry->string string->subid-entry)
266
267 (name subid-entry-name)
268 (start subid-entry-start
269 (serialization number->string string->number))
270 (count subid-entry-count
271 (serialization number->string string->number)))
272
273(define %password-lock-file
274 ;; The password database lock file used by libc's 'lckpwdf'. Users should
275 ;; grab this lock with 'with-file-lock' when they access the databases.
276 "/etc/.pwd.lock")
277
278(define (database-writer file mode entry->string)
279 (lambda* (entries #:optional (file-or-port file))
280 "Write ENTRIES to FILE-OR-PORT. When FILE-OR-PORT is a file name, write
281to it atomically and set the appropriate permissions."
282 (define (write-entries port)
283 (for-each (lambda (entry)
284 (display (entry->string entry) port)
285 (newline port))
286 (delete-duplicates entries)))
287
288 (if (port? file-or-port)
289 (write-entries file-or-port)
290 (let* ((template (string-append file-or-port ".XXXXXX"))
291 (port (mkstemp! template)))
292 (dynamic-wind
293 (const #t)
294 (lambda ()
295 (chmod port mode)
296 (write-entries port)
297
298 (fsync port)
299 (close-port port)
300 (rename-file template file-or-port))
301 (lambda ()
302 (unless (port-closed? port)
303 (close-port port))
304 (when (file-exists? template)
305 (delete-file template))))))))
306
307(define write-passwd
308 (database-writer "/etc/passwd" #o644 password-entry->string))
309(define write-shadow
310 (database-writer "/etc/shadow" #o600 shadow-entry->string))
311(define write-group
312 (database-writer "/etc/group" #o644 group-entry->string))
313(define write-subuid
314 (database-writer "/etc/subuid" #o644 subid-entry->string))
315(define write-subgid
316 (database-writer "/etc/subgid" #o644 subid-entry->string))
317
318(define (database-reader file string->entry)
319 (lambda* (#:optional (file-or-port file))
320 (define (read-entries port)
321 (let loop ((entries '()))
322 (match (read-line port)
323 ((? eof-object?)
324 (reverse entries))
325 (line
326 (loop (cons (string->entry line) entries))))))
327
328 (if (port? file-or-port)
329 (read-entries file-or-port)
330 (call-with-input-file file-or-port
331 read-entries))))
332
333(define read-passwd
334 (database-reader "/etc/passwd" string->password-entry))
335(define read-shadow
336 (database-reader "/etc/shadow" string->shadow-entry))
337(define read-group
338 (database-reader "/etc/group" string->group-entry))
339(define read-subuid
340 (database-reader "/etc/subuid" string->subid-entry))
341(define read-subgid
342 (database-reader "/etc/subgid" string->subid-entry))
343
344
345;;;
346;;; Building databases.
347;;;
348
349(define-record-type* <allocation>
350 allocation make-allocation
351 allocation?
352 (ids allocation-ids (default vlist-null))
353 (next-id allocation-next-id (default %id-min))
354 (next-system-id allocation-next-system-id (default %system-id-max)))
355
356(define-record-type* <unused-subid-range>
357 unused-subid-range make-unused-subid-range
358 unused-subid-range?
359 (left unused-subid-range-left ;previous unused subuid range or #f
360 (default #f))
361 (min unused-subid-range-min ;lower bound of this unused subuid range
362 (default 0))
363 (max unused-subid-range-max ;upper bound
364 (default %subordinate-id-max))
365 (right unused-subid-range-right ;next unused subuid range or #f
366 (default #f)))
367
368;; Trick to avoid name clashes...
369(define-syntax %allocation (identifier-syntax allocation))
370
371;; Minimum and maximum UIDs and GIDs (from find_new_uid.c and find_new_gid.c
372;; in Shadow.)
373(define %id-min 1000)
374(define %id-max 60000)
375
376(define %system-id-min 100)
377(define %system-id-max 999)
378
379;; According to Shadow's libmisc/find_new_sub_uids.c and
380;; libmisc/find_new_sub_gids.c.
381(define %subordinate-id-min 100000)
382(define %subordinate-id-max 600100000)
383(define %subordinate-id-count 65536)
384
385(define-condition-type &subordinate-id-error &error
386 subordinate-id-error?)
387(define-condition-type &subordinate-id-overflow-error &subordinate-id-error
388 subordinate-id-overflow-error?
389 (range subordinate-id-overflow-error))
390(define-condition-type &invalid-subid-range-error &subordinate-id-error
391 invalid-subid-range-error?
392 (range invalid-subid-range-error-range))
393(define-condition-type &specific-subid-range-expected-error &subordinate-id-error
394 specific-subid-range-expected-error?
395 (range specific-subid-range-expected-error-range))
396(define-condition-type &generic-subid-range-expected-error &subordinate-id-error
397 generic-subid-range-expected-error?
398 (range generic-subid-range-expected-error-range))
399
400(define (system-id? id)
401 (and (> id %system-id-min)
402 (<= id %system-id-max)))
403
404(define (user-id? id)
405 (and (>= id %id-min)
406 (< id %id-max)))
407
408(define (subordinate-id? id)
409 (and (>= id %subordinate-id-min)
410 (< id %subordinate-id-max)))
411
412(define* (allocate-id assignment #:key system?)
413 "Return two values: a newly allocated ID, and an updated <allocation> record
414based on ASSIGNMENT. If SYSTEM? is true, return a system ID."
415 (define next
416 ;; Return the next available ID, looping if necessary.
417 (if system?
418 (lambda (id)
419 (let ((next-id (- id 1)))
420 (if (< next-id %system-id-min)
421 %system-id-max
422 next-id)))
423 (lambda (id)
424 (let ((next-id (+ id 1)))
425 (if (>= next-id %id-max)
426 %id-min
427 next-id)))))
428
429 (let loop ((id (if system?
430 (allocation-next-system-id assignment)
431 (allocation-next-id assignment))))
432 (if (vhash-assv id (allocation-ids assignment))
433 (loop (next id))
434 (let ((taken (vhash-consv id #t (allocation-ids assignment))))
435 (values (if system?
436 (allocation (inherit assignment)
437 (next-system-id (next id))
438 (ids taken))
439 (allocation (inherit assignment)
440 (next-id (next id))
441 (ids taken)))
442 id)))))
443
444(define* (reserve-ids allocation ids #:key (skip? #t))
445 "Mark the numbers listed in IDS as reserved in ALLOCATION. When SKIP? is
446true, start allocation after the highest (or lowest, depending on whether it's
447a system ID allocation) number among IDS."
448 (%allocation
449 (inherit allocation)
450 (next-id (if skip?
451 (+ (reduce max
452 (- (allocation-next-id allocation) 1)
453 (filter user-id? ids))
454 1)
455 (allocation-next-id allocation)))
456 (next-system-id
457 (if skip?
458 (- (reduce min
459 (+ 1 (allocation-next-system-id allocation))
460 (filter system-id? ids))
461 1)
462 (allocation-next-system-id allocation)))
463 (ids (fold (cut vhash-consv <> #t <>)
464 (allocation-ids allocation)
465 ids))))
466
467(define (within-interval? allocation range)
468 "Returns #t when RANGE is included in the ALLOCATION.
469Both ends of the ALLOCATION are included in the comparison."
470 (define allocation-start
471 (unused-subid-range-min allocation))
472 (define allocation-end
473 (unused-subid-range-max allocation))
474 (unless (subid-range-has-start? range)
475 (raise
476 (condition
477 (&specific-subid-range-expected-error
478 (range range)))))
479 (and (<= allocation-start
480 (subid-range-start range))
481 (<= (subid-range-end range)
482 allocation-end)))
483
484(define (allocate-unused-range allocation actual-range)
485 "Allocates RANGE inside ALLOCATION. RANGE is assumed to be
486@code{within-interval?} of ALLOCATION, a new @code{unused-subid-range} record is
487returned with all the subids contained in RANGE marked as used."
488 (define allocation-start
489 (unused-subid-range-min allocation))
490 (define allocation-end
491 (unused-subid-range-max allocation))
492 (define allocation-left
493 (unused-subid-range-left allocation))
494 (define allocation-right
495 (unused-subid-range-left allocation))
496 (define range-start
497 (subid-range-start actual-range))
498 (define range-end
499 (subid-range-end actual-range))
500 (define new-start
501 (+ 1 range-end))
502 (define new-end
503 (- range-start 1))
504 (if (or (= allocation-start range-start)
505 (= allocation-end range-end))
506 (unused-subid-range
507 (inherit allocation)
508 (min (if (= allocation-start range-start)
509 new-start
510 allocation-start))
511 (max (if (= allocation-end range-end)
512 new-end
513 allocation-end)))
514 (let* ((left-child?
515 (<= (- range-start allocation-start)
516 (- allocation-end range-end)))
517 (child
518 (unused-subid-range
519 (min allocation-start)
520 (max new-end)
521 (left
522 (and left-child?
523 allocation-left))
524 (right
525 (and (not left-child?)
526 allocation-right)))))
527 (unused-subid-range
528 (inherit allocation)
529 (min new-start)
530 (max allocation-end)
531 (left
532 (if left-child?
533 child
534 allocation-left))
535 (right
536 (if left-child?
537 allocation-right
538 child))))))
539
540(define (allocate-generic-range allocation range)
541 "Allocates a range of subids in ALLOCATION, based on RANGE. RANGE is expected
542to be a generic range i.e. to not have an explicit start subordinate id. All
543nodes in ALLOCATION are visited and the first where RANGE is
544@code{within-interval?} will be selected, the subordinate ids contained in RANGE
545will be marked as used in it."
546 (when (subid-range-has-start? range)
547 (raise
548 (condition
549 (&generic-subid-range-expected-error
550 (ranges range)))))
551 (define left (unused-subid-range-left allocation))
552 (define right (unused-subid-range-right allocation))
553 (define allocation-start
554 (unused-subid-range-min allocation))
555 (define actual-range
556 (subid-range
557 (inherit range)
558 ;; New IDs are only allocated between %subordinate-id-min and
559 ;; %subordinate-id-max.
560 (start
561 (max allocation-start %subordinate-id-min))))
562
563 (if (within-interval? allocation actual-range)
564 (values
565 (allocate-unused-range allocation actual-range)
566 actual-range)
567 (if left
568 (let-values (((new-left new-range)
569 (allocate-generic-range left range)))
570 (values (unused-subid-range
571 (inherit allocation)
572 (left new-left))
573 new-range))
574 (if right
575 (let-values (((new-right new-range)
576 (allocate-generic-range right range)))
577 (values (unused-subid-range
578 (inherit allocation)
579 (left new-right))
580 new-range))
581 (raise
582 (condition
583 (&subordinate-id-overflow-error
584 (range range))))))))
585
586(define (allocate-specific-range allocation range)
587 "Allocates a range of subids in ALLOCATION, based on RANGE. RANGE is expected
588to be a specific range i.e. to have an explicit start subordinate id. ALLOCATION
589is visited to find the best unused range that can hold RANGE."
590 (unless (subid-range-has-start? range)
591 (raise
592 (condition
593 (&specific-subid-range-expected-error
594 (range range)))))
595 (define allocation-left
596 (unused-subid-range-left allocation))
597 (define allocation-right
598 (unused-subid-range-right allocation))
599 (define allocation-start
600 (unused-subid-range-min allocation))
601 (define allocation-end
602 (unused-subid-range-max allocation))
603
604 (define range-start
605 (subid-range-start range))
606 (define range-end
607 (subid-range-end range))
608
609 (define less?
610 (< range-end allocation-start))
611 (define more?
612 (> range-start allocation-end))
613
614 (cond ((within-interval? allocation range)
615 (values (allocate-unused-range allocation range)
616 range))
617 ((and allocation-left less?)
618 (let-values (((new-left _)
619 (allocate-specific-range allocation-left range)))
620 (values (unused-subid-range
621 (inherit allocation)
622 (left new-left))
623 range)))
624 ((and allocation-right more?)
625 (let-values (((new-right _)
626 (allocate-specific-range allocation-right range)))
627 (values (unused-subid-range
628 (inherit allocation)
629 (right new-right))
630 range)))
631 (else
632 (raise
633 (condition
634 (&subordinate-id-overflow-error
635 (range range)))))))
636
637(define* (reserve-subids allocation ranges)
638 "Mark the subid ranges listed in RANGES as reserved in ALLOCATION."
639 (fold (lambda (range state)
640 (define-values (new-allocation actual-range)
641 ((if (subid-range-has-start? range)
642 allocate-specific-range
643 allocate-generic-range)
644 (first state)
645 range))
646 (list new-allocation
647 (cons actual-range
648 (second state))))
649 (list allocation '()) ranges))
650
651(define (allocated? allocation id)
652 "Return true if ID is already allocated as part of ALLOCATION."
653 (->bool (vhash-assv id (allocation-ids allocation))))
654
655(define (lookup-procedure lst key)
656 "Return a lookup procedure for the elements of LST, calling KEY to obtain
657the key of each element."
658 (let ((table (fold (lambda (obj table)
659 (vhash-cons (key obj) obj table))
660 vlist-null
661 lst)))
662 (lambda (key)
663 (match (vhash-assoc key table)
664 (#f #f)
665 ((_ . value) value)))))
666
667(define* (allocate-groups groups members
668 #:optional (current-groups '()))
669 "Return a list of group entries for GROUPS, a list of <user-group>. Members
670for each group are taken from MEMBERS, a vhash that maps group names to member
671names. GIDs and passwords found in CURRENT-GROUPS, a list of group entries,
672are reused."
673 (define gids
674 ;; Mark all the currently-used GIDs and the explicitly requested GIDs as
675 ;; reserved.
676 (reserve-ids (reserve-ids (allocation)
677 (map group-entry-gid current-groups))
678 (filter-map user-group-id groups)
679 #:skip? #f))
680
681 (define previous-entry
682 (lookup-procedure current-groups group-entry-name))
683
684 (reverse
685 (fold2 (lambda (group result allocation)
686 (let ((name (user-group-name group))
687 (password (user-group-password group))
688 (requested-id (user-group-id group))
689 (system? (user-group-system? group)))
690 (let*-values (((previous)
691 (previous-entry name))
692 ((allocation id)
693 (cond
694 ((number? requested-id)
695 (values (reserve-ids allocation
696 (list requested-id))
697 requested-id))
698 (previous
699 (values allocation
700 (group-entry-gid previous)))
701 (else
702 (allocate-id allocation
703 #:system? system?)))))
704 (values (cons (group-entry
705 (name name)
706 (password
707 (if previous
708 (group-entry-password previous)
709 password))
710 (gid id)
711 (members (vhash-fold* cons '() name members)))
712 result)
713 allocation))))
714 '()
715 gids
716 groups)))
717
718(define* (allocate-passwd users groups #:optional (current-passwd '()))
719 "Return a list of password entries for USERS, a list of <user-account>.
720Take GIDs from GROUPS, a list of group entries. Reuse UIDs from
721CURRENT-PASSWD, a list of password entries, when possible; otherwise allocate
722new UIDs."
723 (define uids
724 (reserve-ids (reserve-ids (allocation)
725 (map password-entry-uid current-passwd))
726 (filter-map user-account-uid users)
727 #:skip? #f))
728
729 (define previous-entry
730 (lookup-procedure current-passwd password-entry-name))
731
732 (define (group-id name)
733 (or (any (lambda (entry)
734 (and (string=? (group-entry-name entry) name)
735 (group-entry-gid entry)))
736 groups)
737 (error "group not found" name)))
738
739 (reverse
740 (fold2 (lambda (user result allocation)
741 (let ((name (user-account-name user))
742 (requested-id (user-account-uid user))
743 (group (user-account-group user))
744 (real-name (user-account-comment user))
745 (directory (user-account-home-directory user))
746 (shell (user-account-shell user))
747 (system? (user-account-system? user)))
748 (let*-values (((previous)
749 (previous-entry name))
750 ((allocation id)
751 (cond
752 ((number? requested-id)
753 (values (reserve-ids allocation
754 (list requested-id))
755 requested-id))
756 (previous
757 (values allocation
758 (password-entry-uid previous)))
759 (else
760 (allocate-id allocation
761 #:system? system?)))))
762 (values (cons (password-entry
763 (name name)
764 (uid id)
765 (directory directory)
766 (gid (if (number? group) group (group-id group)))
767
768 ;; Users might change their name to something
769 ;; other than what the sysadmin chose, with
770 ;; 'chfn'. Thus consider it "stateful".
771 (real-name (if (and previous (not system?))
772 (password-entry-real-name previous)
773 real-name))
774
775 ;; Do not reuse the shell of PREVIOUS since (1)
776 ;; that could lead to confusion, and (2) the
777 ;; shell might have been GC'd. See
778 ;; <https://lists.gnu.org/archive/html/guix-devel/2019-04/msg00478.html>.
779 (shell shell))
780 result)
781 allocation))))
782 '()
783 uids
784 users)))
785
786(define (range->entry range)
787 (subid-entry
788 (name (subid-range-name range))
789 (start (subid-range-start range))
790 (count (subid-range-count range))))
791
792(define (entry->range entry)
793 (subid-range
794 (name (subid-entry-name entry))
795 (start (subid-entry-start entry))
796 (count (subid-entry-count entry))))
797
798(define* (allocate-subids ranges #:optional (current-ranges '()))
799 "Return a list of subids entries for RANGES, a list of <subid-range>. IDs
800found in CURRENT-RANGES, a list of subid entries, are reused."
801 ;; Ranges from disk must always have a start.
802 (let ((generic (any (compose not subid-range-has-start?) current-ranges)))
803 (when generic
804 (raise
805 (condition
806 (&specific-subid-range-expected-error
807 (range generic))))))
808 (for-each
809 (lambda (range)
810 ;; New ranges must always be included in the current supported set.
811 (unless (or (not (subid-range-has-start? range))
812 (and (subordinate-id? (subid-range-start range))
813 (subordinate-id? (subid-range-end range))))
814 (raise
815 (condition (&invalid-subid-range-error (range range))))))
816 ranges)
817
818 (define sorted-ranges
819 (stable-sort ranges
820 subid-range-less))
821 (define current-allocation+subids
822 (reserve-subids (unused-subid-range)
823 current-ranges))
824 (define subids
825 ;; Reserve first specific subid-ranges
826 ;; and later generic ones.
827 (second
828 (reserve-subids (first
829 current-allocation+subids)
830 sorted-ranges)))
831
832 (map range->entry
833 ;; Produce deterministic subid collections.
834 (stable-sort
835 (append (second current-allocation+subids)
836 subids)
837 subid-range-less)))
838
839(define* (days-since-epoch #:optional (current-time current-time))
840 "Return the number of days elapsed since the 1st of January, 1970."
841 (let* ((now (current-time time-utc))
842 (epoch (make-time time-utc 0 0))
843 (diff (time-difference now epoch)))
844 (quotient (time-second diff) (* 24 3600))))
845
846(define* (passwd->shadow users passwd #:optional (current-shadow '())
847 #:key (current-time current-time))
848 "Return a list of shadow entries for the password entries listed in PASSWD.
849Reuse shadow entries from CURRENT-SHADOW when they exist, and take the initial
850password from USERS."
851 (define previous-entry
852 (lookup-procedure current-shadow shadow-entry-name))
853
854 (define now
855 ;; On machines without a real-time clock (typically Arm SBCs), the system
856 ;; clock may be at 1970-01-01 while booting, which would lead us to define
857 ;; NOW as zero.
858 ;;
859 ;; However, the 'isexpired' function in Shadow interprets the combination
860 ;; uninitialized password + last-change = 0 as "The password has expired,
861 ;; it must be changed", which prevents logins altogether. To avoid that,
862 ;; never set 'last-change' to zero.
863 (max (days-since-epoch current-time) 1))
864
865 (map (lambda (user passwd)
866 (or (previous-entry (password-entry-name passwd))
867 (shadow-entry (name (password-entry-name passwd))
868 (password (user-account-password user))
869 (last-change now))))
870 users passwd))
871
872(define (empty-if-not-found thunk)
873 "Call THUNK and return the empty list if that throws to ENOENT."
874 (catch 'system-error
875 thunk
876 (lambda args
877 (if (= ENOENT (system-error-errno args))
878 '()
879 (apply throw args)))))
880
881(define* (user+group-databases users groups
882 #:key
883 (current-passwd
884 (empty-if-not-found read-passwd))
885 (current-groups
886 (empty-if-not-found read-group))
887 (current-shadow
888 (empty-if-not-found read-shadow))
889 (current-time current-time))
890 "Return three values: the list of group entries, the list of password
891entries, and the list of shadow entries corresponding to USERS and GROUPS.
892Preserve stateful bits from CURRENT-PASSWD, CURRENT-GROUPS, and
893CURRENT-SHADOW: UIDs, GIDs, passwords, user shells, etc."
894 (define members
895 ;; Map group name to user names.
896 (fold (lambda (user members)
897 (fold (cute vhash-cons <> (user-account-name user) <>)
898 members
899 (user-account-supplementary-groups user)))
900 vlist-null
901 users))
902
903 (define group-entries
904 (allocate-groups groups members current-groups))
905
906 (define passwd-entries
907 (allocate-passwd users group-entries current-passwd))
908
909 (define shadow-entries
910 (passwd->shadow users passwd-entries current-shadow
911 #:current-time current-time))
912
913 (values group-entries passwd-entries shadow-entries))
914
915(define* (subuid+subgid-databases subuids subgids
916 #:key
917 (current-subuids
918 (map entry->range
919 (empty-if-not-found read-subuid)))
920 (current-subgids
921 (map entry->range
922 (empty-if-not-found read-subgid))))
923 "Return two values: the list of subgid entries, and the list of subuid entries
924corresponding to SUBUIDS and SUBGIDS.
925Preserve stateful bits from CURRENT-SUBUIDS and CURRENT-SUBGIDS."
926
927 (define (range-eqv? a b)
928 (string=? (subid-range-name a)
929 (subid-range-name b)))
930
931 (define subuid-entries
932 (allocate-subids
933 (lset-difference range-eqv? subuids current-subuids) current-subuids))
934
935 (define subgid-entries
936 (allocate-subids
937 (lset-difference range-eqv? subgids current-subgids) current-subgids))
938
939 (values subuid-entries subgid-entries))