Commit | Line | Data |
---|---|---|
ec600e45 LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org> | |
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 (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 | |
31 | password-entry? | |
32 | password-entry-name | |
33 | password-entry-uid | |
34 | password-entry-gid | |
35 | password-entry-real-name | |
36 | password-entry-directory | |
37 | password-entry-shell | |
38 | ||
39 | shadow-entry | |
40 | shadow-entry? | |
41 | shadow-entry-name | |
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 | |
47 | ||
48 | group-entry | |
49 | group-entry? | |
50 | group-entry-name | |
51 | group-entry-gid | |
52 | group-entry-members | |
53 | ||
d497b6ab | 54 | %password-lock-file |
ec600e45 LC |
55 | write-group |
56 | write-passwd | |
57 | write-shadow | |
58 | read-group | |
59 | read-passwd | |
60 | read-shadow | |
61 | ||
62 | %id-min | |
63 | %id-max | |
64 | %system-id-min | |
65 | %system-id-max | |
66 | ||
67 | user+group-databases)) | |
68 | ||
69 | ;;; Commentary: | |
70 | ;;; | |
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. | |
76 | ;;; | |
77 | ;;; The benefit is twofold: less code is involved, and the ID allocation | |
78 | ;;; strategy and state preservation is made explicit. | |
79 | ;;; | |
80 | ;;; Code: | |
81 | ||
82 | \f | |
83 | ;;; | |
84 | ;;; Machinery to define user and group databases. | |
85 | ;;; | |
86 | ||
87 | (define-syntax serialize-field | |
88 | (syntax-rules (serialization) | |
89 | ((_ entry (field get (serialization ->string string->) _ ...)) | |
90 | (->string (get entry))) | |
91 | ((_ entry (field get _ ...)) | |
92 | (get entry)))) | |
93 | ||
94 | (define-syntax deserialize-field | |
95 | (syntax-rules (serialization) | |
96 | ((_ str (field get (serialization ->string string->) _ ...)) | |
97 | (string-> str)) | |
98 | ((_ str (field get _ ...)) | |
99 | str))) | |
100 | ||
101 | (define-syntax let/fields | |
102 | (syntax-rules () | |
103 | ((_ (((name get attributes ...) rest ...) lst) body ...) | |
104 | (let ((l lst)) | |
105 | (let ((name (deserialize-field (car l) | |
106 | (name get attributes ...)))) | |
107 | (let/fields ((rest ...) (cdr l)) body ...)))) | |
108 | ((_ (() lst) body ...) | |
109 | (begin body ...)))) | |
110 | ||
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 | |
115 | each field." | |
116 | ((_ <record> record make-record record? | |
117 | (serialization separator entry->string string->entry) | |
118 | fields ...) | |
119 | (let-syntax ((field-name | |
120 | (syntax-rules () | |
121 | ((_ (name _ (... ...))) name)))) | |
122 | (define-record-type* <record> record make-record | |
123 | record? | |
124 | fields ...) | |
125 | ||
126 | (define (entry->string entry) | |
127 | (string-join (list (serialize-field entry fields) ...) | |
128 | (string separator))) | |
129 | ||
130 | (define (string->entry str) | |
131 | (let/fields ((fields ...) (string-split str #\:)) | |
132 | (make-record (field-name fields) ...))))))) | |
133 | ||
134 | ||
135 | (define number->string* | |
136 | (match-lambda | |
137 | ((? number? number) (number->string number)) | |
138 | (_ ""))) | |
139 | ||
140 | (define (false-if-string=? false-string) | |
141 | (lambda (str) | |
142 | (if (string=? str false-string) | |
143 | #f | |
144 | str))) | |
145 | ||
146 | (define (string-if-false str) | |
147 | (lambda (obj) | |
148 | (if (not obj) str obj))) | |
149 | ||
150 | (define (comma-separated->list str) | |
151 | (string-tokenize str (char-set-complement (char-set #\,)))) | |
152 | ||
153 | (define (list->comma-separated lst) | |
154 | (string-join lst ",")) | |
155 | ||
156 | \f | |
157 | ;;; | |
158 | ;;; Database definitions. | |
159 | ;;; | |
160 | ||
161 | (define-database-entry <password-entry> ;<pwd.h> | |
162 | password-entry make-password-entry | |
163 | password-entry? | |
164 | (serialization #\: password-entry->string string->password-entry) | |
165 | ||
166 | (name password-entry-name) | |
167 | (password password-entry-password | |
168 | (serialization (const "x") (const #f)) | |
169 | (default "x")) | |
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 | |
175 | (default "")) | |
176 | (directory password-entry-directory) | |
177 | (shell password-entry-shell | |
178 | (default "/bin/sh"))) | |
179 | ||
180 | (define-database-entry <shadow-entry> ;<shadow.h> | |
181 | shadow-entry make-shadow-entry | |
182 | shadow-entry? | |
183 | (serialization #\: shadow-entry->string string->shadow-entry) | |
184 | ||
185 | (name shadow-entry-name) ;string | |
186 | (password shadow-entry-password ;string | #f | |
187 | (serialization (string-if-false "!") | |
188 | (false-if-string=? "!")) | |
189 | (default #f)) | |
190 | (last-change shadow-entry-last-change ;days since 1970-01-01 | |
191 | (serialization number->string* string->number) | |
192 | (default 0)) | |
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) | |
210 | (default #f))) | |
211 | ||
212 | (define-database-entry <group-entry> ;<grp.h> | |
213 | group-entry make-group-entry | |
214 | group-entry? | |
215 | (serialization #\: group-entry->string string->group-entry) | |
216 | ||
217 | (name group-entry-name) | |
218 | (password group-entry-password | |
219 | (serialization (string-if-false "x") | |
220 | (false-if-string=? "x")) | |
221 | (default #f)) | |
222 | (gid group-entry-gid | |
223 | (serialization number->string string->number)) | |
224 | (members group-entry-members | |
225 | (serialization list->comma-separated comma-separated->list) | |
226 | (default '()))) | |
227 | ||
d497b6ab LC |
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. | |
231 | "/etc/.pwd.lock") | |
232 | ||
ec600e45 LC |
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) | |
240 | (newline port)) | |
dd4e46ed | 241 | (delete-duplicates entries))) |
ec600e45 LC |
242 | |
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))) | |
247 | (dynamic-wind | |
248 | (const #t) | |
249 | (lambda () | |
250 | (chmod port mode) | |
251 | (write-entries port) | |
d088d5c4 | 252 | |
c25b44d6 | 253 | (fsync port) |
ed8570dc | 254 | (close-port port) |
ec600e45 LC |
255 | (rename-file template file-or-port)) |
256 | (lambda () | |
ed8570dc LC |
257 | (unless (port-closed? port) |
258 | (close-port port)) | |
ec600e45 LC |
259 | (when (file-exists? template) |
260 | (delete-file template)))))))) | |
261 | ||
262 | (define write-passwd | |
263 | (database-writer "/etc/passwd" #o644 password-entry->string)) | |
264 | (define write-shadow | |
265 | (database-writer "/etc/shadow" #o600 shadow-entry->string)) | |
266 | (define write-group | |
267 | (database-writer "/etc/group" #o644 group-entry->string)) | |
268 | ||
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) | |
274 | ((? eof-object?) | |
275 | (reverse entries)) | |
276 | (line | |
277 | (loop (cons (string->entry line) entries)))))) | |
278 | ||
279 | (if (port? file-or-port) | |
280 | (read-entries file-or-port) | |
281 | (call-with-input-file file-or-port | |
282 | read-entries)))) | |
283 | ||
284 | (define read-passwd | |
285 | (database-reader "/etc/passwd" string->password-entry)) | |
286 | (define read-shadow | |
287 | (database-reader "/etc/shadow" string->shadow-entry)) | |
288 | (define read-group | |
289 | (database-reader "/etc/group" string->group-entry)) | |
290 | ||
291 | \f | |
292 | ;;; | |
293 | ;;; Building databases. | |
294 | ;;; | |
295 | ||
296 | (define-record-type* <allocation> | |
297 | allocation make-allocation | |
298 | 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))) | |
302 | ||
303 | ;; Trick to avoid name clashes... | |
304 | (define-syntax %allocation (identifier-syntax allocation)) | |
305 | ||
306 | ;; Minimum and maximum UIDs and GIDs (from find_new_uid.c and find_new_gid.c | |
307 | ;; in Shadow.) | |
308 | (define %id-min 1000) | |
309 | (define %id-max 60000) | |
310 | ||
311 | (define %system-id-min 100) | |
312 | (define %system-id-max 999) | |
313 | ||
314 | (define (system-id? id) | |
315 | (and (> id %system-id-min) | |
316 | (<= id %system-id-max))) | |
317 | ||
318 | (define (user-id? id) | |
319 | (and (>= id %id-min) | |
320 | (< id %id-max))) | |
321 | ||
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." | |
325 | (define next | |
326 | ;; Return the next available ID, looping if necessary. | |
327 | (if system? | |
328 | (lambda (id) | |
329 | (let ((next-id (- id 1))) | |
330 | (if (< next-id %system-id-min) | |
331 | %system-id-max | |
332 | next-id))) | |
333 | (lambda (id) | |
334 | (let ((next-id (+ id 1))) | |
335 | (if (>= next-id %id-max) | |
336 | %id-min | |
337 | next-id))))) | |
338 | ||
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)) | |
343 | (loop (next id)) | |
344 | (let ((taken (vhash-consv id #t (allocation-ids assignment)))) | |
345 | (values (if system? | |
346 | (allocation (inherit assignment) | |
347 | (next-system-id (next id)) | |
348 | (ids taken)) | |
349 | (allocation (inherit assignment) | |
350 | (next-id (next id)) | |
351 | (ids taken))) | |
352 | id))))) | |
353 | ||
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." | |
358 | (%allocation | |
359 | (inherit allocation) | |
360 | (next-id (if skip? | |
361 | (+ (reduce max | |
362 | (- (allocation-next-id allocation) 1) | |
363 | (filter user-id? ids)) | |
364 | 1) | |
365 | (allocation-next-id allocation))) | |
366 | (next-system-id | |
367 | (if skip? | |
368 | (- (reduce min | |
369 | (+ 1 (allocation-next-system-id allocation)) | |
370 | (filter system-id? ids)) | |
371 | 1) | |
372 | (allocation-next-system-id allocation))) | |
373 | (ids (fold (cut vhash-consv <> #t <>) | |
374 | (allocation-ids allocation) | |
375 | ids)))) | |
376 | ||
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)))) | |
380 | ||
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)) | |
386 | vlist-null | |
387 | lst))) | |
388 | (lambda (key) | |
389 | (match (vhash-assoc key table) | |
390 | (#f #f) | |
391 | ((_ . value) value))))) | |
392 | ||
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, | |
398 | are reused." | |
399 | (define gids | |
400 | ;; Mark all the currently-used GIDs and the explicitly requested GIDs as | |
401 | ;; reserved. | |
402 | (reserve-ids (reserve-ids (allocation) | |
403 | (map group-entry-gid current-groups)) | |
404 | (filter-map user-group-id groups) | |
405 | #:skip? #f)) | |
406 | ||
407 | (define previous-entry | |
408 | (lookup-procedure current-groups group-entry-name)) | |
409 | ||
410 | (reverse | |
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)) | |
418 | ((allocation id) | |
419 | (cond | |
420 | ((number? requested-id) | |
421 | (values (reserve-ids allocation | |
422 | (list requested-id)) | |
423 | requested-id)) | |
424 | (previous | |
425 | (values allocation | |
426 | (group-entry-gid previous))) | |
427 | (else | |
428 | (allocate-id allocation | |
429 | #:system? system?))))) | |
430 | (values (cons (group-entry | |
431 | (name name) | |
432 | (password | |
433 | (if previous | |
434 | (group-entry-password previous) | |
435 | password)) | |
436 | (gid id) | |
437 | (members (vhash-fold* cons '() name members))) | |
438 | result) | |
439 | allocation)))) | |
440 | '() | |
441 | gids | |
442 | groups))) | |
443 | ||
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 | |
448 | new UIDs." | |
449 | (define uids | |
450 | (reserve-ids (reserve-ids (allocation) | |
451 | (map password-entry-uid current-passwd)) | |
452 | (filter-map user-account-uid users) | |
453 | #:skip? #f)) | |
454 | ||
455 | (define previous-entry | |
456 | (lookup-procedure current-passwd password-entry-name)) | |
457 | ||
458 | (define (group-id name) | |
459 | (or (any (lambda (entry) | |
460 | (and (string=? (group-entry-name entry) name) | |
461 | (group-entry-gid entry))) | |
462 | groups) | |
463 | (error "group not found" name))) | |
464 | ||
465 | (reverse | |
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)) | |
476 | ((allocation id) | |
477 | (cond | |
478 | ((number? requested-id) | |
479 | (values (reserve-ids allocation | |
480 | (list requested-id)) | |
481 | requested-id)) | |
482 | (previous | |
483 | (values allocation | |
484 | (password-entry-uid previous))) | |
485 | (else | |
486 | (allocate-id allocation | |
487 | #:system? system?))))) | |
488 | (values (cons (password-entry | |
489 | (name name) | |
490 | (uid id) | |
491 | (directory directory) | |
492 | (gid (if (number? group) group (group-id group))) | |
493 | (real-name (if previous | |
494 | (password-entry-real-name previous) | |
495 | real-name)) | |
504a0fc6 LC |
496 | |
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>. | |
501 | (shell shell)) | |
ec600e45 LC |
502 | result) |
503 | allocation)))) | |
504 | '() | |
505 | uids | |
506 | users))) | |
507 | ||
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)))) | |
514 | ||
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)) | |
522 | ||
523 | (define now | |
524 | (days-since-epoch current-time)) | |
525 | ||
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)) | |
530 | (last-change now)))) | |
531 | users passwd)) | |
532 | ||
533 | (define (empty-if-not-found thunk) | |
534 | "Call THUNK and return the empty list if that throws to ENOENT." | |
535 | (catch 'system-error | |
536 | thunk | |
537 | (lambda args | |
538 | (if (= ENOENT (system-error-errno args)) | |
539 | '() | |
540 | (apply throw args))))) | |
541 | ||
542 | (define* (user+group-databases users groups | |
543 | #:key | |
544 | (current-passwd | |
545 | (empty-if-not-found read-passwd)) | |
546 | (current-groups | |
547 | (empty-if-not-found read-group)) | |
548 | (current-shadow | |
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." | |
555 | (define members | |
556 | ;; Map group name to user names. | |
557 | (fold (lambda (user members) | |
558 | (fold (cute vhash-cons <> (user-account-name user) <>) | |
559 | members | |
560 | (user-account-supplementary-groups user))) | |
561 | vlist-null | |
562 | users)) | |
563 | ||
564 | (define group-entries | |
565 | (allocate-groups groups members current-groups)) | |
566 | ||
567 | (define passwd-entries | |
568 | (allocate-passwd users group-entries current-passwd)) | |
569 | ||
570 | (define shadow-entries | |
571 | (passwd->shadow users passwd-entries current-shadow | |
572 | #:current-time current-time)) | |
573 | ||
574 | (values group-entries passwd-entries shadow-entries)) |