;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; ;;; GNU Guix is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or (at ;;; your option) any later version. ;;; ;;; GNU Guix is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . (define-module (gnu build accounts) #:use-module (guix records) #:use-module (guix combinators) #:use-module (gnu system accounts) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (ice-9 rdelim) #:export (password-entry password-entry? password-entry-name password-entry-uid password-entry-gid password-entry-real-name password-entry-directory password-entry-shell shadow-entry shadow-entry? shadow-entry-name shadow-entry-minimum-change-period shadow-entry-maximum-change-period shadow-entry-change-warning-time shadow-entry-maximum-inactivity shadow-entry-expiration group-entry group-entry? group-entry-name group-entry-gid group-entry-members %password-lock-file write-group write-passwd write-shadow read-group read-passwd read-shadow %id-min %id-max %system-id-min %system-id-max user+group-databases)) ;;; Commentary: ;;; ;;; This modules provides functionality equivalent to the C library's ;;; , , and routines, as well as a subset of the ;;; functionality of the Shadow command-line tools. It can parse and write ;;; /etc/passwd, /etc/shadow, and /etc/group. It can also take care of UID ;;; and GID allocation in a way similar to what 'useradd' does. ;;; ;;; The benefit is twofold: less code is involved, and the ID allocation ;;; strategy and state preservation is made explicit. ;;; ;;; Code: ;;; ;;; Machinery to define user and group databases. ;;; (define-syntax serialize-field (syntax-rules (serialization) ((_ entry (field get (serialization ->string string->) _ ...)) (->string (get entry))) ((_ entry (field get _ ...)) (get entry)))) (define-syntax deserialize-field (syntax-rules (serialization) ((_ str (field get (serialization ->string string->) _ ...)) (string-> str)) ((_ str (field get _ ...)) str))) (define-syntax let/fields (syntax-rules () ((_ (((name get attributes ...) rest ...) lst) body ...) (let ((l lst)) (let ((name (deserialize-field (car l) (name get attributes ...)))) (let/fields ((rest ...) (cdr l)) body ...)))) ((_ (() lst) body ...) (begin body ...)))) (define-syntax define-database-entry (syntax-rules (serialization) "Define a record data type, as per 'define-record-type*', with additional information on how to serialize and deserialize the whole database as well as each field." ((_ record make-record record? (serialization separator entry->string string->entry) fields ...) (let-syntax ((field-name (syntax-rules () ((_ (name _ (... ...))) name)))) (define-record-type* record make-record record? fields ...) (define (entry->string entry) (string-join (list (serialize-field entry fields) ...) (string separator))) (define (string->entry str) (let/fields ((fields ...) (string-split str #\:)) (make-record (field-name fields) ...))))))) (define number->string* (match-lambda ((? number? number) (number->string number)) (_ ""))) (define (false-if-string=? false-string) (lambda (str) (if (string=? str false-string) #f str))) (define (string-if-false str) (lambda (obj) (if (not obj) str obj))) (define (comma-separated->list str) (string-tokenize str (char-set-complement (char-set #\,)))) (define (list->comma-separated lst) (string-join lst ",")) ;;; ;;; Database definitions. ;;; (define-database-entry ; password-entry make-password-entry password-entry? (serialization #\: password-entry->string string->password-entry) (name password-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 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 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-li2019-07-23Makefile: Sort scheme tests alphabetically....Robert Vollmert 2019-07-22swh: Add basic tests....Ludovic Courtès 2019-07-15lint: Move the linting code to a different module....Christopher Baines 2019-07-14gnu: linux-libre: Update to 5.2....Mark H Weaver 2019-07-14Revert "guix: node-build-system: Use guile-json instead of a custom parser."...Julien Lepiller 2019-07-14guix: node-build-system: Use guile-json instead of a custom parser....Julien Lepiller 2019-07-14build: Add node-build-system....Jelle Licht 2019-07-07build: Remove outdated 'release.nix'....Ludovic Courtès 2019-07-07build: Add 'doc/build.scm' to build on-line copies of the manual....Ludovic Courtès 2019-07-06Remove references to non-existent 'tests/machine.scm'....Jakob L. Kreuze 2019-07-06Add 'guix deploy'....Jakob L. Kreuze 2019-07-06gnu: Add machine type for deployment specifications....Jakob L. Kreuze 2019-07-04Add (guix remote)....Ludovic Courtès 2019-07-04Add (guix repl)....Ludovic Courtès 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 ;; . (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 (days-since-epoch current-time)) (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))