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 | ||
54 | write-group | |
55 | write-passwd | |
56 | write-shadow | |
57 | read-group | |
58 | read-passwd | |
59 | read-shadow | |
60 | ||
61 | %id-min | |
62 | %id-max | |
63 | %system-id-min | |
64 | %system-id-max | |
65 | ||
66 | user+group-databases)) | |
67 | ||
68 | ;;; Commentary: | |
69 | ;;; | |
70 | ;;; This modules provides functionality equivalent to the C library's | |
71 | ;;; <shadow.h>, <pwd.h>, and <grp.h> routines, as well as a subset of the | |
72 | ;;; functionality of the Shadow command-line tools. It can parse and write | |
73 | ;;; /etc/passwd, /etc/shadow, and /etc/group. It can also take care of UID | |
74 | ;;; and GID allocation in a way similar to what 'useradd' does. | |
75 | ;;; | |
76 | ;;; The benefit is twofold: less code is involved, and the ID allocation | |
77 | ;;; strategy and state preservation is made explicit. | |
78 | ;;; | |
79 | ;;; Code: | |
80 | ||
81 | \f | |
82 | ;;; | |
83 | ;;; Machinery to define user and group databases. | |
84 | ;;; | |
85 | ||
86 | (define-syntax serialize-field | |
87 | (syntax-rules (serialization) | |
88 | ((_ entry (field get (serialization ->string string->) _ ...)) | |
89 | (->string (get entry))) | |
90 | ((_ entry (field get _ ...)) | |
91 | (get entry)))) | |
92 | ||
93 | (define-syntax deserialize-field | |
94 | (syntax-rules (serialization) | |
95 | ((_ str (field get (serialization ->string string->) _ ...)) | |
96 | (string-> str)) | |
97 | ((_ str (field get _ ...)) | |
98 | str))) | |
99 | ||
100 | (define-syntax let/fields | |
101 | (syntax-rules () | |
102 | ((_ (((name get attributes ...) rest ...) lst) body ...) | |
103 | (let ((l lst)) | |
104 | (let ((name (deserialize-field (car l) | |
105 | (name get attributes ...)))) | |
106 | (let/fields ((rest ...) (cdr l)) body ...)))) | |
107 | ((_ (() lst) body ...) | |
108 | (begin body ...)))) | |
109 | ||
110 | (define-syntax define-database-entry | |
111 | (syntax-rules (serialization) | |
112 | "Define a record data type, as per 'define-record-type*', with additional | |
113 | information on how to serialize and deserialize the whole database as well as | |
114 | each field." | |
115 | ((_ <record> record make-record record? | |
116 | (serialization separator entry->string string->entry) | |
117 | fields ...) | |
118 | (let-syntax ((field-name | |
119 | (syntax-rules () | |
120 | ((_ (name _ (... ...))) name)))) | |
121 | (define-record-type* <record> record make-record | |
122 | record? | |
123 | fields ...) | |
124 | ||
125 | (define (entry->string entry) | |
126 | (string-join (list (serialize-field entry fields) ...) | |
127 | (string separator))) | |
128 | ||
129 | (define (string->entry str) | |
130 | (let/fields ((fields ...) (string-split str #\:)) | |
131 | (make-record (field-name fields) ...))))))) | |
132 | ||
133 | ||
134 | (define number->string* | |
135 | (match-lambda | |
136 | ((? number? number) (number->string number)) | |
137 | (_ ""))) | |
138 | ||
139 | (define (false-if-string=? false-string) | |
140 | (lambda (str) | |
141 | (if (string=? str false-string) | |
142 | #f | |
143 | str))) | |
144 | ||
145 | (define (string-if-false str) | |
146 | (lambda (obj) | |
147 | (if (not obj) str obj))) | |
148 | ||
149 | (define (comma-separated->list str) | |
150 | (string-tokenize str (char-set-complement (char-set #\,)))) | |
151 | ||
152 | (define (list->comma-separated lst) | |
153 | (string-join lst ",")) | |
154 | ||
155 | \f | |
156 | ;;; | |
157 | ;;; Database definitions. | |
158 | ;;; | |
159 | ||
160 | (define-database-entry <password-entry> ;<pwd.h> | |
161 | password-entry make-password-entry | |
162 | password-entry? | |
163 | (serialization #\: password-entry->string string->password-entry) | |
164 | ||
165 | (name password-entry-name) | |
166 | (password password-entry-password | |
167 | (serialization (const "x") (const #f)) | |
168 | (default "x")) | |
169 | (uid password-entry-uid | |
170 | (serialization number->string string->number)) | |
171 | (gid password-entry-gid | |
172 | (serialization number->string string->number)) | |
173 | (real-name password-entry-real-name | |
174 | (default "")) | |
175 | (directory password-entry-directory) | |
176 | (shell password-entry-shell | |
177 | (default "/bin/sh"))) | |
178 | ||
179 | (define-database-entry <shadow-entry> ;<shadow.h> | |
180 | shadow-entry make-shadow-entry | |
181 | shadow-entry? | |
182 | (serialization #\: shadow-entry->string string->shadow-entry) | |
183 | ||
184 | (name shadow-entry-name) ;string | |
185 | (password shadow-entry-password ;string | #f | |
186 | (serialization (string-if-false "!") | |
187 | (false-if-string=? "!")) | |
188 | (default #f)) | |
189 | (last-change shadow-entry-last-change ;days since 1970-01-01 | |
190 | (serialization number->string* string->number) | |
191 | (default 0)) | |
192 | (minimum-change-period shadow-entry-minimum-change-period | |
193 | (serialization number->string* string->number) | |
194 | (default #f)) ;days | #f | |
195 | (maximum-change-period shadow-entry-maximum-change-period | |
196 | (serialization number->string* string->number) | |
197 | (default #f)) ;days | #f | |
198 | (change-warning-time shadow-entry-change-warning-time | |
199 | (serialization number->string* string->number) | |
200 | (default #f)) ;days | #f | |
201 | (maximum-inactivity shadow-entry-maximum-inactivity | |
202 | (serialization number->string* string->number) | |
203 | (default #f)) ;days | #f | |
204 | (expiration shadow-entry-expiration | |
205 | (serialization number->string* string->number) | |
206 | (default #f)) ;days since 1970-01-01 | #f | |
207 | (flags shadow-entry-flags ;"reserved" | |
208 | (serialization number->string* string->number) | |
209 | (default #f))) | |
210 | ||
211 | (define-database-entry <group-entry> ;<grp.h> | |
212 | group-entry make-group-entry | |
213 | group-entry? | |
214 | (serialization #\: group-entry->string string->group-entry) | |
215 | ||
216 | (name group-entry-name) | |
217 | (password group-entry-password | |
218 | (serialization (string-if-false "x") | |
219 | (false-if-string=? "x")) | |
220 | (default #f)) | |
221 | (gid group-entry-gid | |
222 | (serialization number->string string->number)) | |
223 | (members group-entry-members | |
224 | (serialization list->comma-separated comma-separated->list) | |
225 | (default '()))) | |
226 | ||
227 | (define (database-writer file mode entry->string) | |
228 | (lambda* (entries #:optional (file-or-port file)) | |
229 | "Write ENTRIES to FILE-OR-PORT. When FILE-OR-PORT is a file name, write | |
230 | to it atomically and set the appropriate permissions." | |
231 | (define (write-entries port) | |
232 | (for-each (lambda (entry) | |
233 | (display (entry->string entry) port) | |
234 | (newline port)) | |
235 | entries)) | |
236 | ||
237 | (if (port? file-or-port) | |
238 | (write-entries file-or-port) | |
239 | (let* ((template (string-append file-or-port ".XXXXXX")) | |
240 | (port (mkstemp! template))) | |
241 | (dynamic-wind | |
242 | (const #t) | |
243 | (lambda () | |
244 | (chmod port mode) | |
245 | (write-entries port) | |
246 | (rename-file template file-or-port)) | |
247 | (lambda () | |
248 | (close-port port) | |
249 | (when (file-exists? template) | |
250 | (delete-file template)))))))) | |
251 | ||
252 | (define write-passwd | |
253 | (database-writer "/etc/passwd" #o644 password-entry->string)) | |
254 | (define write-shadow | |
255 | (database-writer "/etc/shadow" #o600 shadow-entry->string)) | |
256 | (define write-group | |
257 | (database-writer "/etc/group" #o644 group-entry->string)) | |
258 | ||
259 | (define (database-reader file string->entry) | |
260 | (lambda* (#:optional (file-or-port file)) | |
261 | (define (read-entries port) | |
262 | (let loop ((entries '())) | |
263 | (match (read-line port) | |
264 | ((? eof-object?) | |
265 | (reverse entries)) | |
266 | (line | |
267 | (loop (cons (string->entry line) entries)))))) | |
268 | ||
269 | (if (port? file-or-port) | |
270 | (read-entries file-or-port) | |
271 | (call-with-input-file file-or-port | |
272 | read-entries)))) | |
273 | ||
274 | (define read-passwd | |
275 | (database-reader "/etc/passwd" string->password-entry)) | |
276 | (define read-shadow | |
277 | (database-reader "/etc/shadow" string->shadow-entry)) | |
278 | (define read-group | |
279 | (database-reader "/etc/group" string->group-entry)) | |
280 | ||
281 | \f | |
282 | ;;; | |
283 | ;;; Building databases. | |
284 | ;;; | |
285 | ||
286 | (define-record-type* <allocation> | |
287 | allocation make-allocation | |
288 | allocation? | |
289 | (ids allocation-ids (default vlist-null)) | |
290 | (next-id allocation-next-id (default %id-min)) | |
291 | (next-system-id allocation-next-system-id (default %system-id-max))) | |
292 | ||
293 | ;; Trick to avoid name clashes... | |
294 | (define-syntax %allocation (identifier-syntax allocation)) | |
295 | ||
296 | ;; Minimum and maximum UIDs and GIDs (from find_new_uid.c and find_new_gid.c | |
297 | ;; in Shadow.) | |
298 | (define %id-min 1000) | |
299 | (define %id-max 60000) | |
300 | ||
301 | (define %system-id-min 100) | |
302 | (define %system-id-max 999) | |
303 | ||
304 | (define (system-id? id) | |
305 | (and (> id %system-id-min) | |
306 | (<= id %system-id-max))) | |
307 | ||
308 | (define (user-id? id) | |
309 | (and (>= id %id-min) | |
310 | (< id %id-max))) | |
311 | ||
312 | (define* (allocate-id assignment #:key system?) | |
313 | "Return two values: a newly allocated ID, and an updated <allocation> record | |
314 | based on ASSIGNMENT. If SYSTEM? is true, return a system ID." | |
315 | (define next | |
316 | ;; Return the next available ID, looping if necessary. | |
317 | (if system? | |
318 | (lambda (id) | |
319 | (let ((next-id (- id 1))) | |
320 | (if (< next-id %system-id-min) | |
321 | %system-id-max | |
322 | next-id))) | |
323 | (lambda (id) | |
324 | (let ((next-id (+ id 1))) | |
325 | (if (>= next-id %id-max) | |
326 | %id-min | |
327 | next-id))))) | |
328 | ||
329 | (let loop ((id (if system? | |
330 | (allocation-next-system-id assignment) | |
331 | (allocation-next-id assignment)))) | |
332 | (if (vhash-assv id (allocation-ids assignment)) | |
333 | (loop (next id)) | |
334 | (let ((taken (vhash-consv id #t (allocation-ids assignment)))) | |
335 | (values (if system? | |
336 | (allocation (inherit assignment) | |
337 | (next-system-id (next id)) | |
338 | (ids taken)) | |
339 | (allocation (inherit assignment) | |
340 | (next-id (next id)) | |
341 | (ids taken))) | |
342 | id))))) | |
343 | ||
344 | (define* (reserve-ids allocation ids #:key (skip? #t)) | |
345 | "Mark the numbers listed in IDS as reserved in ALLOCATION. When SKIP? is | |
346 | true, start allocation after the highest (or lowest, depending on whether it's | |
347 | a system ID allocation) number among IDS." | |
348 | (%allocation | |
349 | (inherit allocation) | |
350 | (next-id (if skip? | |
351 | (+ (reduce max | |
352 | (- (allocation-next-id allocation) 1) | |
353 | (filter user-id? ids)) | |
354 | 1) | |
355 | (allocation-next-id allocation))) | |
356 | (next-system-id | |
357 | (if skip? | |
358 | (- (reduce min | |
359 | (+ 1 (allocation-next-system-id allocation)) | |
360 | (filter system-id? ids)) | |
361 | 1) | |
362 | (allocation-next-system-id allocation))) | |
363 | (ids (fold (cut vhash-consv <> #t <>) | |
364 | (allocation-ids allocation) | |
365 | ids)))) | |
366 | ||
367 | (define (allocated? allocation id) | |
368 | "Return true if ID is already allocated as part of ALLOCATION." | |
369 | (->bool (vhash-assv id (allocation-ids allocation)))) | |
370 | ||
371 | (define (lookup-procedure lst key) | |
372 | "Return a lookup procedure for the elements of LST, calling KEY to obtain | |
373 | the key of each element." | |
374 | (let ((table (fold (lambda (obj table) | |
375 | (vhash-cons (key obj) obj table)) | |
376 | vlist-null | |
377 | lst))) | |
378 | (lambda (key) | |
379 | (match (vhash-assoc key table) | |
380 | (#f #f) | |
381 | ((_ . value) value))))) | |
382 | ||
383 | (define* (allocate-groups groups members | |
384 | #:optional (current-groups '())) | |
385 | "Return a list of group entries for GROUPS, a list of <user-group>. Members | |
386 | for each group are taken from MEMBERS, a vhash that maps group names to member | |
387 | names. GIDs and passwords found in CURRENT-GROUPS, a list of group entries, | |
388 | are reused." | |
389 | (define gids | |
390 | ;; Mark all the currently-used GIDs and the explicitly requested GIDs as | |
391 | ;; reserved. | |
392 | (reserve-ids (reserve-ids (allocation) | |
393 | (map group-entry-gid current-groups)) | |
394 | (filter-map user-group-id groups) | |
395 | #:skip? #f)) | |
396 | ||
397 | (define previous-entry | |
398 | (lookup-procedure current-groups group-entry-name)) | |
399 | ||
400 | (reverse | |
401 | (fold2 (lambda (group result allocation) | |
402 | (let ((name (user-group-name group)) | |
403 | (password (user-group-password group)) | |
404 | (requested-id (user-group-id group)) | |
405 | (system? (user-group-system? group))) | |
406 | (let*-values (((previous) | |
407 | (previous-entry name)) | |
408 | ((allocation id) | |
409 | (cond | |
410 | ((number? requested-id) | |
411 | (values (reserve-ids allocation | |
412 | (list requested-id)) | |
413 | requested-id)) | |
414 | (previous | |
415 | (values allocation | |
416 | (group-entry-gid previous))) | |
417 | (else | |
418 | (allocate-id allocation | |
419 | #:system? system?))))) | |
420 | (values (cons (group-entry | |
421 | (name name) | |
422 | (password | |
423 | (if previous | |
424 | (group-entry-password previous) | |
425 | password)) | |
426 | (gid id) | |
427 | (members (vhash-fold* cons '() name members))) | |
428 | result) | |
429 | allocation)))) | |
430 | '() | |
431 | gids | |
432 | groups))) | |
433 | ||
434 | (define* (allocate-passwd users groups #:optional (current-passwd '())) | |
435 | "Return a list of password entries for USERS, a list of <user-account>. | |
436 | Take GIDs from GROUPS, a list of group entries. Reuse UIDs from | |
437 | CURRENT-PASSWD, a list of password entries, when possible; otherwise allocate | |
438 | new UIDs." | |
439 | (define uids | |
440 | (reserve-ids (reserve-ids (allocation) | |
441 | (map password-entry-uid current-passwd)) | |
442 | (filter-map user-account-uid users) | |
443 | #:skip? #f)) | |
444 | ||
445 | (define previous-entry | |
446 | (lookup-procedure current-passwd password-entry-name)) | |
447 | ||
448 | (define (group-id name) | |
449 | (or (any (lambda (entry) | |
450 | (and (string=? (group-entry-name entry) name) | |
451 | (group-entry-gid entry))) | |
452 | groups) | |
453 | (error "group not found" name))) | |
454 | ||
455 | (reverse | |
456 | (fold2 (lambda (user result allocation) | |
457 | (let ((name (user-account-name user)) | |
458 | (requested-id (user-account-uid user)) | |
459 | (group (user-account-group user)) | |
460 | (real-name (user-account-comment user)) | |
461 | (directory (user-account-home-directory user)) | |
462 | (shell (user-account-shell user)) | |
463 | (system? (user-account-system? user))) | |
464 | (let*-values (((previous) | |
465 | (previous-entry name)) | |
466 | ((allocation id) | |
467 | (cond | |
468 | ((number? requested-id) | |
469 | (values (reserve-ids allocation | |
470 | (list requested-id)) | |
471 | requested-id)) | |
472 | (previous | |
473 | (values allocation | |
474 | (password-entry-uid previous))) | |
475 | (else | |
476 | (allocate-id allocation | |
477 | #:system? system?))))) | |
478 | (values (cons (password-entry | |
479 | (name name) | |
480 | (uid id) | |
481 | (directory directory) | |
482 | (gid (if (number? group) group (group-id group))) | |
483 | (real-name (if previous | |
484 | (password-entry-real-name previous) | |
485 | real-name)) | |
504a0fc6 LC |
486 | |
487 | ;; Do not reuse the shell of PREVIOUS since (1) | |
488 | ;; that could lead to confusion, and (2) the | |
489 | ;; shell might have been GC'd. See | |
490 | ;; <https://lists.gnu.org/archive/html/guix-devel/2019-04/msg00478.html>. | |
491 | (shell shell)) | |
ec600e45 LC |
492 | result) |
493 | allocation)))) | |
494 | '() | |
495 | uids | |
496 | users))) | |
497 | ||
498 | (define* (days-since-epoch #:optional (current-time current-time)) | |
499 | "Return the number of days elapsed since the 1st of January, 1970." | |
500 | (let* ((now (current-time time-utc)) | |
501 | (epoch (make-time time-utc 0 0)) | |
502 | (diff (time-difference now epoch))) | |
503 | (quotient (time-second diff) (* 24 3600)))) | |
504 | ||
505 | (define* (passwd->shadow users passwd #:optional (current-shadow '()) | |
506 | #:key (current-time current-time)) | |
507 | "Return a list of shadow entries for the password entries listed in PASSWD. | |
508 | Reuse shadow entries from CURRENT-SHADOW when they exist, and take the initial | |
509 | password from USERS." | |
510 | (define previous-entry | |
511 | (lookup-procedure current-shadow shadow-entry-name)) | |
512 | ||
513 | (define now | |
514 | (days-since-epoch current-time)) | |
515 | ||
516 | (map (lambda (user passwd) | |
517 | (or (previous-entry (password-entry-name passwd)) | |
518 | (shadow-entry (name (password-entry-name passwd)) | |
519 | (password (user-account-password user)) | |
520 | (last-change now)))) | |
521 | users passwd)) | |
522 | ||
523 | (define (empty-if-not-found thunk) | |
524 | "Call THUNK and return the empty list if that throws to ENOENT." | |
525 | (catch 'system-error | |
526 | thunk | |
527 | (lambda args | |
528 | (if (= ENOENT (system-error-errno args)) | |
529 | '() | |
530 | (apply throw args))))) | |
531 | ||
532 | (define* (user+group-databases users groups | |
533 | #:key | |
534 | (current-passwd | |
535 | (empty-if-not-found read-passwd)) | |
536 | (current-groups | |
537 | (empty-if-not-found read-group)) | |
538 | (current-shadow | |
539 | (empty-if-not-found read-shadow)) | |
540 | (current-time current-time)) | |
541 | "Return three values: the list of group entries, the list of password | |
542 | entries, and the list of shadow entries corresponding to USERS and GROUPS. | |
543 | Preserve stateful bits from CURRENT-PASSWD, CURRENT-GROUPS, and | |
544 | CURRENT-SHADOW: UIDs, GIDs, passwords, user shells, etc." | |
545 | (define members | |
546 | ;; Map group name to user names. | |
547 | (fold (lambda (user members) | |
548 | (fold (cute vhash-cons <> (user-account-name user) <>) | |
549 | members | |
550 | (user-account-supplementary-groups user))) | |
551 | vlist-null | |
552 | users)) | |
553 | ||
554 | (define group-entries | |
555 | (allocate-groups groups members current-groups)) | |
556 | ||
557 | (define passwd-entries | |
558 | (allocate-passwd users group-entries current-passwd)) | |
559 | ||
560 | (define shadow-entries | |
561 | (passwd->shadow users passwd-entries current-shadow | |
562 | #:current-time current-time)) | |
563 | ||
564 | (values group-entries passwd-entries shadow-entries)) |