1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
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.
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.
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/>.
19 (define-module (gnu build accounts)
20 #:use-module (guix records)
21 #:use-module (guix combinators)
22 #:use-module (gnu system accounts)
23 #:use-module (srfi srfi-1)
24 #:use-module (srfi srfi-11)
25 #:use-module (srfi srfi-19)
26 #:use-module (srfi srfi-26)
27 #:use-module (ice-9 match)
28 #:use-module (ice-9 vlist)
29 #:use-module (ice-9 rdelim)
30 #:export (password-entry
35 password-entry-real-name
36 password-entry-directory
42 shadow-entry-minimum-change-period
43 shadow-entry-maximum-change-period
44 shadow-entry-change-warning-time
45 shadow-entry-maximum-inactivity
46 shadow-entry-expiration
67 user+group-databases))
71 ;;; This modules provides functionality equivalent to the C library's
72 ;;; <shadow.h>, <pwd.h>, and <grp.h> routines, as well as a subset of the
73 ;;; functionality of the Shadow command-line tools. It can parse and write
74 ;;; /etc/passwd, /etc/shadow, and /etc/group. It can also take care of UID
75 ;;; and GID allocation in a way similar to what 'useradd' does.
77 ;;; The benefit is twofold: less code is involved, and the ID allocation
78 ;;; strategy and state preservation is made explicit.
84 ;;; Machinery to define user and group databases.
87 (define-syntax serialize-field
88 (syntax-rules (serialization)
89 ((_ entry (field get (serialization ->string string->) _ ...))
90 (->string (get entry)))
91 ((_ entry (field get _ ...))
94 (define-syntax deserialize-field
95 (syntax-rules (serialization)
96 ((_ str (field get (serialization ->string string->) _ ...))
98 ((_ str (field get _ ...))
101 (define-syntax let/fields
103 ((_ (((name get attributes ...) rest ...) lst) body ...)
105 (let ((name (deserialize-field (car l)
106 (name get attributes ...))))
107 (let/fields ((rest ...) (cdr l)) body ...))))
108 ((_ (() lst) body ...)
111 (define-syntax define-database-entry
112 (syntax-rules (serialization)
113 "Define a record data type, as per 'define-record-type*', with additional
114 information on how to serialize and deserialize the whole database as well as
116 ((_ <record> record make-record record?
117 (serialization separator entry->string string->entry)
119 (let-syntax ((field-name
121 ((_ (name _ (... ...))) name))))
122 (define-record-type* <record> record make-record
126 (define (entry->string entry)
127 (string-join (list (serialize-field entry fields) ...)
130 (define (string->entry str)
131 (let/fields ((fields ...) (string-split str #\:))
132 (make-record (field-name fields) ...)))))))
135 (define number->string*
137 ((? number? number) (number->string number))
140 (define (false-if-string=? false-string)
142 (if (string=? str false-string)
146 (define (string-if-false str)
148 (if (not obj) str obj)))
150 (define (comma-separated->list str)
151 (string-tokenize str (char-set-complement (char-set #\,))))
153 (define (list->comma-separated lst)
154 (string-join lst ","))
158 ;;; Database definitions.
161 (define-database-entry <password-entry> ;<pwd.h>
162 password-entry make-password-entry
164 (serialization #\: password-entry->string string->password-entry)
166 (name password-entry-name)
167 (password password-entry-password
168 (serialization (const "x") (const #f))
170 (uid password-entry-uid
171 (serialization number->string string->number))
172 (gid password-entry-gid
173 (serialization number->string string->number))
174 (real-name password-entry-real-name
176 (directory password-entry-directory)
177 (shell password-entry-shell
178 (default "/bin/sh")))
180 (define-database-entry <shadow-entry> ;<shadow.h>
181 shadow-entry make-shadow-entry
183 (serialization #\: shadow-entry->string string->shadow-entry)
185 (name shadow-entry-name) ;string
186 (password shadow-entry-password ;string | #f
187 (serialization (string-if-false "!")
188 (false-if-string=? "!"))
190 (last-change shadow-entry-last-change ;days since 1970-01-01
191 (serialization number->string* string->number)
193 (minimum-change-period shadow-entry-minimum-change-period
194 (serialization number->string* string->number)
195 (default #f)) ;days | #f
196 (maximum-change-period shadow-entry-maximum-change-period
197 (serialization number->string* string->number)
198 (default #f)) ;days | #f
199 (change-warning-time shadow-entry-change-warning-time
200 (serialization number->string* string->number)
201 (default #f)) ;days | #f
202 (maximum-inactivity shadow-entry-maximum-inactivity
203 (serialization number->string* string->number)
204 (default #f)) ;days | #f
205 (expiration shadow-entry-expiration
206 (serialization number->string* string->number)
207 (default #f)) ;days since 1970-01-01 | #f
208 (flags shadow-entry-flags ;"reserved"
209 (serialization number->string* string->number)
212 (define-database-entry <group-entry> ;<grp.h>
213 group-entry make-group-entry
215 (serialization #\: group-entry->string string->group-entry)
217 (name group-entry-name)
218 (password group-entry-password
219 (serialization (string-if-false "x")
220 (false-if-string=? "x"))
223 (serialization number->string string->number))
224 (members group-entry-members
225 (serialization list->comma-separated comma-separated->list)
228 (define %password-lock-file
229 ;; The password database lock file used by libc's 'lckpwdf'. Users should
230 ;; grab this lock with 'with-file-lock' when they access the databases.
233 (define (database-writer file mode entry->string)
234 (lambda* (entries #:optional (file-or-port file))
235 "Write ENTRIES to FILE-OR-PORT. When FILE-OR-PORT is a file name, write
236 to it atomically and set the appropriate permissions."
237 (define (write-entries port)
238 (for-each (lambda (entry)
239 (display (entry->string entry) port)
241 (delete-duplicates entries)))
243 (if (port? file-or-port)
244 (write-entries file-or-port)
245 (let* ((template (string-append file-or-port ".XXXXXX"))
246 (port (mkstemp! template)))
255 (rename-file template file-or-port))
257 (unless (port-closed? port)
259 (when (file-exists? template)
260 (delete-file template))))))))
263 (database-writer "/etc/passwd" #o644 password-entry->string))
265 (database-writer "/etc/shadow" #o600 shadow-entry->string))
267 (database-writer "/etc/group" #o644 group-entry->string))
269 (define (database-reader file string->entry)
270 (lambda* (#:optional (file-or-port file))
271 (define (read-entries port)
272 (let loop ((entries '()))
273 (match (read-line port)
277 (loop (cons (string->entry line) entries))))))
279 (if (port? file-or-port)
280 (read-entries file-or-port)
281 (call-with-input-file file-or-port
285 (database-reader "/etc/passwd" string->password-entry))
287 (database-reader "/etc/shadow" string->shadow-entry))
289 (database-reader "/etc/group" string->group-entry))
293 ;;; Building databases.
296 (define-record-type* <allocation>
297 allocation make-allocation
299 (ids allocation-ids (default vlist-null))
300 (next-id allocation-next-id (default %id-min))
301 (next-system-id allocation-next-system-id (default %system-id-max)))
303 ;; Trick to avoid name clashes...
304 (define-syntax %allocation (identifier-syntax allocation))
306 ;; Minimum and maximum UIDs and GIDs (from find_new_uid.c and find_new_gid.c
308 (define %id-min 1000)
309 (define %id-max 60000)
311 (define %system-id-min 100)
312 (define %system-id-max 999)
314 (define (system-id? id)
315 (and (> id %system-id-min)
316 (<= id %system-id-max)))
318 (define (user-id? id)
322 (define* (allocate-id assignment #:key system?)
323 "Return two values: a newly allocated ID, and an updated <allocation> record
324 based on ASSIGNMENT. If SYSTEM? is true, return a system ID."
326 ;; Return the next available ID, looping if necessary.
329 (let ((next-id (- id 1)))
330 (if (< next-id %system-id-min)
334 (let ((next-id (+ id 1)))
335 (if (>= next-id %id-max)
339 (let loop ((id (if system?
340 (allocation-next-system-id assignment)
341 (allocation-next-id assignment))))
342 (if (vhash-assv id (allocation-ids assignment))
344 (let ((taken (vhash-consv id #t (allocation-ids assignment))))
346 (allocation (inherit assignment)
347 (next-system-id (next id))
349 (allocation (inherit assignment)
354 (define* (reserve-ids allocation ids #:key (skip? #t))
355 "Mark the numbers listed in IDS as reserved in ALLOCATION. When SKIP? is
356 true, start allocation after the highest (or lowest, depending on whether it's
357 a system ID allocation) number among IDS."
362 (- (allocation-next-id allocation) 1)
363 (filter user-id? ids))
365 (allocation-next-id allocation)))
369 (+ 1 (allocation-next-system-id allocation))
370 (filter system-id? ids))
372 (allocation-next-system-id allocation)))
373 (ids (fold (cut vhash-consv <> #t <>)
374 (allocation-ids allocation)
377 (define (allocated? allocation id)
378 "Return true if ID is already allocated as part of ALLOCATION."
379 (->bool (vhash-assv id (allocation-ids allocation))))
381 (define (lookup-procedure lst key)
382 "Return a lookup procedure for the elements of LST, calling KEY to obtain
383 the key of each element."
384 (let ((table (fold (lambda (obj table)
385 (vhash-cons (key obj) obj table))
389 (match (vhash-assoc key table)
391 ((_ . value) value)))))
393 (define* (allocate-groups groups members
394 #:optional (current-groups '()))
395 "Return a list of group entries for GROUPS, a list of <user-group>. Members
396 for each group are taken from MEMBERS, a vhash that maps group names to member
397 names. GIDs and passwords found in CURRENT-GROUPS, a list of group entries,
400 ;; Mark all the currently-used GIDs and the explicitly requested GIDs as
402 (reserve-ids (reserve-ids (allocation)
403 (map group-entry-gid current-groups))
404 (filter-map user-group-id groups)
407 (define previous-entry
408 (lookup-procedure current-groups group-entry-name))
411 (fold2 (lambda (group result allocation)
412 (let ((name (user-group-name group))
413 (password (user-group-password group))
414 (requested-id (user-group-id group))
415 (system? (user-group-system? group)))
416 (let*-values (((previous)
417 (previous-entry name))
420 ((number? requested-id)
421 (values (reserve-ids allocation
426 (group-entry-gid previous)))
428 (allocate-id allocation
429 #:system? system?)))))
430 (values (cons (group-entry
434 (group-entry-password previous)
437 (members (vhash-fold* cons '() name members)))
444 (define* (allocate-passwd users groups #:optional (current-passwd '()))
445 "Return a list of password entries for USERS, a list of <user-account>.
446 Take GIDs from GROUPS, a list of group entries. Reuse UIDs from
447 CURRENT-PASSWD, a list of password entries, when possible; otherwise allocate
450 (reserve-ids (reserve-ids (allocation)
451 (map password-entry-uid current-passwd))
452 (filter-map user-account-uid users)
455 (define previous-entry
456 (lookup-procedure current-passwd password-entry-name))
458 (define (group-id name)
459 (or (any (lambda (entry)
460 (and (string=? (group-entry-name entry) name)
461 (group-entry-gid entry)))
463 (error "group not found" name)))
466 (fold2 (lambda (user result allocation)
467 (let ((name (user-account-name user))
468 (requested-id (user-account-uid user))
469 (group (user-account-group user))
470 (real-name (user-account-comment user))
471 (directory (user-account-home-directory user))
472 (shell (user-account-shell user))
473 (system? (user-account-system? user)))
474 (let*-values (((previous)
475 (previous-entry name))
478 ((number? requested-id)
479 (values (reserve-ids allocation
484 (password-entry-uid previous)))
486 (allocate-id allocation
487 #:system? system?)))))
488 (values (cons (password-entry
491 (directory directory)
492 (gid (if (number? group) group (group-id group)))
493 (real-name (if previous
494 (password-entry-real-name previous)
497 ;; Do not reuse the shell of PREVIOUS since (1)
498 ;; that could lead to confusion, and (2) the
499 ;; shell might have been GC'd. See
500 ;; <https://lists.gnu.org/archive/html/guix-devel/2019-04/msg00478.html>.
508 (define* (days-since-epoch #:optional (current-time current-time))
509 "Return the number of days elapsed since the 1st of January, 1970."
510 (let* ((now (current-time time-utc))
511 (epoch (make-time time-utc 0 0))
512 (diff (time-difference now epoch)))
513 (quotient (time-second diff) (* 24 3600))))
515 (define* (passwd->shadow users passwd #:optional (current-shadow '())
516 #:key (current-time current-time))
517 "Return a list of shadow entries for the password entries listed in PASSWD.
518 Reuse shadow entries from CURRENT-SHADOW when they exist, and take the initial
519 password from USERS."
520 (define previous-entry
521 (lookup-procedure current-shadow shadow-entry-name))
524 (days-since-epoch current-time))
526 (map (lambda (user passwd)
527 (or (previous-entry (password-entry-name passwd))
528 (shadow-entry (name (password-entry-name passwd))
529 (password (user-account-password user))
533 (define (empty-if-not-found thunk)
534 "Call THUNK and return the empty list if that throws to ENOENT."
538 (if (= ENOENT (system-error-errno args))
540 (apply throw args)))))
542 (define* (user+group-databases users groups
545 (empty-if-not-found read-passwd))
547 (empty-if-not-found read-group))
549 (empty-if-not-found read-shadow))
550 (current-time current-time))
551 "Return three values: the list of group entries, the list of password
552 entries, and the list of shadow entries corresponding to USERS and GROUPS.
553 Preserve stateful bits from CURRENT-PASSWD, CURRENT-GROUPS, and
554 CURRENT-SHADOW: UIDs, GIDs, passwords, user shells, etc."
556 ;; Map group name to user names.
557 (fold (lambda (user members)
558 (fold (cute vhash-cons <> (user-account-name user) <>)
560 (user-account-supplementary-groups user)))
564 (define group-entries
565 (allocate-groups groups members current-groups))
567 (define passwd-entries
568 (allocate-passwd users group-entries current-passwd))
570 (define shadow-entries
571 (passwd->shadow users passwd-entries current-shadow
572 #:current-time current-time))
574 (values group-entries passwd-entries shadow-entries))