aboutsummaryrefslogtree
summaryrefslogtreecommitdiff
path: root/icons
ModeNameSize
-rw-r--r--hachette.svg5642logplainabout
-rw-r--r--hachette128.png6031logplainabout
-rw-r--r--hachette16.png752logplainabout
-rw-r--r--hachette32.png1358logplainabout
-rw-r--r--hachette48.png2154logplainabout
-rw-r--r--hachette64.png2908logplainabout
generated by cgit
ssword-entry-name) (password password-entry-password (serialization (const "x") (const #f)) (default "x")) (uid password-entry-uid (serialization number->string string->number)) (gid password-entry-gid (serialization number->string string->number)) (real-name password-entry-real-name (default "")) (directory password-entry-directory) (shell password-entry-shell (default "/bin/sh"))) (define-database-entry <shadow-entry> ;<shadow.h> shadow-entry make-shadow-entry shadow-entry? (serialization #\: shadow-entry->string string->shadow-entry) (name shadow-entry-name) ;string (password shadow-entry-password ;string | #f (serialization (string-if-false "!") (false-if-string=? "!")) (default #f)) (last-change shadow-entry-last-change ;days since 1970-01-01 (serialization number->string* string->number) (default 0)) (minimum-change-period shadow-entry-minimum-change-period (serialization number->string* string->number) (default #f)) ;days | #f (maximum-change-period shadow-entry-maximum-change-period (serialization number->string* string->number) (default #f)) ;days | #f (change-warning-time shadow-entry-change-warning-time (serialization number->string* string->number) (default #f)) ;days | #f (maximum-inactivity shadow-entry-maximum-inactivity (serialization number->string* string->number) (default #f)) ;days | #f (expiration shadow-entry-expiration (serialization number->string* string->number) (default #f)) ;days since 1970-01-01 | #f (flags shadow-entry-flags ;"reserved" (serialization number->string* string->number) (default #f))) (define-database-entry <group-entry> ;<grp.h> group-entry make-group-entry group-entry? (serialization #\: group-entry->string string->group-entry) (name group-entry-name) (password group-entry-password (serialization (string-if-false "x") (false-if-string=? "x")) (default #f)) (gid group-entry-gid (serialization number->string string->number)) (members group-entry-members (serialization list->comma-separated comma-separated->list) (default '()))) (define %password-lock-file ;; The password database lock file used by libc's 'lckpwdf'. Users should ;; grab this lock with 'with-file-lock' when they access the databases. "/etc/.pwd.lock") (define (database-writer file mode entry->string) (lambda* (entries #:optional (file-or-port file)) "Write ENTRIES to FILE-OR-PORT. When FILE-OR-PORT is a file name, write to it atomically and set the appropriate permissions." (define (write-entries port) (for-each (lambda (entry) (display (entry->string entry) port) (newline port)) (delete-duplicates entries))) (if (port? file-or-port) (write-entries file-or-port) (let* ((template (string-append file-or-port ".XXXXXX")) (port (mkstemp! template))) (dynamic-wind (const #t) (lambda () (chmod port mode) (write-entries port) (fsync port) (close-port port) (rename-file template file-or-port)) (lambda () (unless (port-closed? port) (close-port port)) (when (file-exists? template) (delete-file template)))))))) (define write-passwd (database-writer "/etc/passwd" #o644 password-entry->string)) (define write-shadow (database-writer "/etc/shadow" #o600 shadow-entry->string)) (define write-group (database-writer "/etc/group" #o644 group-entry->string)) (define (database-reader file string->entry) (lambda* (#:optional (file-or-port file)) (define (read-entries port) (let loop ((entries '())) (match (read-line port) ((? eof-object?) (reverse entries)) (line (loop (cons (string->entry line) entries)))))) (if (port? file-or-port) (read-entries file-or-port) (call-with-input-file file-or-port read-entries)))) (define read-passwd (database-reader "/etc/passwd" string->password-entry)) (define read-shadow (database-reader "/etc/shadow" string->shadow-entry)) (define read-group (database-reader "/etc/group" string->group-entry)) ;;; ;;; Building databases. ;;; (define-record-type* <allocation> allocation make-allocation allocation? (ids allocation-ids (default vlist-null)) (next-id allocation-next-id (default %id-min)) (next-system-id allocation-next-system-id (default %system-id-max))) ;; Trick to avoid name clashes... (define-syntax %allocation (identifier-syntax allocation)) ;; Minimum and maximum UIDs and GIDs (from find_new_uid.c and find_new_gid.c ;; in Shadow.) (define %id-min 1000) (define %id-max 60000) (define %system-id-min 100) (define %system-id-max 999) (define (system-id? id) (and (> id %system-id-min) (<= id %system-id-max))) (define (user-id? id) (and (>= id %id-min) (< id %id-max))) (define* (allocate-id assignment #:key system?) "Return two values: a newly allocated ID, and an updated <allocation> record based on ASSIGNMENT. If SYSTEM? is true, return a system ID." (define next ;; Return the next available ID, looping if necessary. (if system? (lambda (id) (let ((next-id (- id 1))) (if (< next-id %system-id-min) %system-id-max next-id))) (lambda (id) (let ((next-id (+ id 1))) (if (>= next-id %id-max) %id-min next-id))))) (let loop ((id (if system? (allocation-next-system-id assignment) (allocation-next-id assignment)))) (if (vhash-assv id (allocation-ids assignment)) (loop (next id)) (let ((taken (vhash-consv id #t (allocation-ids assignment)))) (values (if system? (allocation (inherit assignment) (next-system-id (next id)) (ids taken)) (allocation (inherit assignment) (next-id (next id)) (ids taken))) id))))) (define* (reserve-ids allocation ids #:key (skip? #t)) "Mark the numbers listed in IDS as reserved in ALLOCATION. When SKIP? is true, start allocation after the highest (or lowest, depending on whether it's a system ID allocation) number among IDS." (%allocation (inherit allocation) (next-id (if skip? (+ (reduce max (- (allocation-next-id allocation) 1) (filter user-id? ids)) 1) (allocation-next-id allocation))) (next-system-id (if skip? (- (reduce min (+ 1 (allocation-next-system-id allocation)) (filter system-id? ids)) 1) (allocation-next-system-id allocation))) (ids (fold (cut vhash-consv <> #t <>) (allocation-ids allocation) ids)))) (define (allocated? allocation id) "Return true if ID is already allocated as part of ALLOCATION." (->bool (vhash-assv id (allocation-ids allocation)))) (define (lookup-procedure lst key) "Return a lookup procedure for the elements of LST, calling KEY to obtain the key of each element." (let ((table (fold (lambda (obj table) (vhash-cons (key obj) obj table)) vlist-null lst))) (lambda (key) (match (vhash-assoc key table) (#f #f) ((_ . value) value))))) (define* (allocate-groups groups members #:optional (current-groups '())) "Return a list of group entries for GROUPS, a list of <user-group>. Members for each group are taken from MEMBERS, a vhash that maps group names to member names. GIDs and passwords found in CURRENT-GROUPS, a list of group entries, are reused." (define gids ;; Mark all the currently-used GIDs and the explicitly requested GIDs as ;; reserved. (reserve-ids (reserve-ids (allocation) (map group-entry-gid current-groups)) (filter-map user-group-id groups) #:skip? #f)) (define previous-entry (lookup-procedure current-groups group-entry-name)) (reverse (fold2 (lambda (group result allocation) (let ((name (user-group-name group)) (password (user-group-password group)) (requested-id (user-group-id group)) (system? (user-group-system? group))) (let*-values (((previous) (previous-entry name)) ((allocation id) (cond ((number? requested-id) (values (reserve-ids allocation (list requested-id)) requested-id)) (previous (values allocation (group-entry-gid previous))) (else (allocate-id allocation #:system? system?))))) (values (cons (group-entry (name name) (password (if previous (group-entry-password previous) password)) (gid id) (members (vhash-fold* cons '() name members))) result) allocation)))) '() gids groups))) (define* (allocate-passwd users groups #:optional (current-passwd '())) "Return a list of password entries for USERS, a list of <user-account>. Take GIDs from GROUPS, a list of group entries. Reuse UIDs from CURRENT-PASSWD, a list of password entries, when possible; otherwise allocate new UIDs." (define uids (reserve-ids (reserve-ids (allocation) (map password-entry-uid current-passwd)) (filter-map user-account-uid users) #:skip? #f)) (define previous-entry (lookup-procedure current-passwd password-entry-name)) (define (group-id name) (or (any (lambda (entry) (and (string=? (group-entry-name entry) name) (group-entry-gid entry))) groups) (error "group not found" name))) (reverse (fold2 (lambda (user result allocation) (let ((name (user-account-name user)) (requested-id (user-account-uid user)) (group (user-account-group user)) (real-name (user-account-comment user)) (directory (user-account-home-directory user)) (shell (user-account-shell user)) (system? (user-account-system? user))) (let*-values (((previous) (previous-entry name)) ((allocation id) (cond ((number? requested-id) (values (reserve-ids allocation (list requested-id)) requested-id)) (previous (values allocation (password-entry-uid previous))) (else (allocate-id allocation #:system? system?))))) (values (cons (password-entry (name name) (uid id) (directory directory) (gid (if (number? group) group (group-id group))) ;; Users might change their name to something ;; other than what the sysadmin chose, with ;; 'chfn'. Thus consider it "stateful". (real-name (if (and previous (not system?)) (password-entry-real-name previous) real-name)) ;; Do not reuse the shell of PREVIOUS since (1) ;; that could lead to confusion, and (2) the ;; shell might have been GC'd. See ;; <https://lists.gnu.org/archive/html/guix-devel/2019-04/msg00478.html>. (shell shell)) result) allocation)))) '() uids users))) (define* (days-since-epoch #:optional (current-time current-time)) "Return the number of days elapsed since the 1st of January, 1970." (let* ((now (current-time time-utc)) (epoch (make-time time-utc 0 0)) (diff (time-difference now epoch))) (quotient (time-second diff) (* 24 3600)))) (define* (passwd->shadow users passwd #:optional (current-shadow '()) #:key (current-time current-time)) "Return a list of shadow entries for the password entries listed in PASSWD. Reuse shadow entries from CURRENT-SHADOW when they exist, and take the initial password from USERS." (define previous-entry (lookup-procedure current-shadow shadow-entry-name)) (define now ;; On machines without a real-time clock (typically Arm SBCs), the system ;; clock may be at 1970-01-01 while booting, which would lead us to define ;; NOW as zero. ;; ;; However, the 'isexpired' function in Shadow interprets the combination ;; uninitialized password + last-change = 0 as "The password has expired, ;; it must be changed", which prevents logins altogether. To avoid that, ;; never set 'last-change' to zero. (max (days-since-epoch current-time) 1)) (map (lambda (user passwd) (or (previous-entry (password-entry-name passwd)) (shadow-entry (name (password-entry-name passwd)) (password (user-account-password user)) (last-change now)))) users passwd)) (define (empty-if-not-found thunk) "Call THUNK and return the empty list if that throws to ENOENT." (catch 'system-error thunk (lambda args (if (= ENOENT (system-error-errno args)) '() (apply throw args))))) (define* (user+group-databases users groups #:key (current-passwd (empty-if-not-found read-passwd)) (current-groups (empty-if-not-found read-group)) (current-shadow (empty-if-not-found read-shadow)) (current-time current-time)) "Return three values: the list of group entries, the list of password entries, and the list of shadow entries corresponding to USERS and GROUPS. Preserve stateful bits from CURRENT-PASSWD, CURRENT-GROUPS, and CURRENT-SHADOW: UIDs, GIDs, passwords, user shells, etc." (define members ;; Map group name to user names. (fold (lambda (user members) (fold (cute vhash-cons <> (user-account-name user) <>) members (user-account-supplementary-groups user))) vlist-null users)) (define group-entries (allocate-groups groups members current-groups)) (define passwd-entries (allocate-passwd users group-entries current-passwd)) (define shadow-entries (passwd->shadow users passwd-entries current-shadow #:current-time current-time)) (values group-entries passwd-entries shadow-entries))
generated by cgit