guix/gnu/build/accounts.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019, 2021, 2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2024 Giacomo Leidi <goodoldpaul@autistici.org>
;;;
;;; 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 <http://www.gnu.org/licenses/>.

(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 (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (ice-9 match)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 receive)
  #: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

            subid-entry
            subid-entry?
            subid-entry-name
            subid-entry-start
            subid-entry-count

            %password-lock-file
            write-group
            write-passwd
            write-shadow
            write-subgid
            write-subuid
            read-group
            read-passwd
            read-shadow
            read-subgid
            read-subuid

            %id-min
            %id-max
            %system-id-min
            %system-id-max
            %subordinate-id-min
            %subordinate-id-max
            %subordinate-id-count

            &subordinate-id-error
            subordinate-id-error?
            &subordinate-id-overflow-error
            subordinate-id-overflow-error?
            subordinate-id-overflow-error-range
            &invalid-subid-range-error
            invalid-subid-range-error?
            invalid-subid-range-error-range
            &specific-subid-range-expected-error
            specific-subid-range-expected-error?
            specific-subid-range-expected-error-range
            &generic-subid-range-expected-error
            generic-subid-range-expected-error?
            generic-subid-range-expected-error-range

            user+group-databases
            subuid+subgid-databases))

;;; Commentary:
;;;
;;; This module provides functionality equivalent to the C library's
;;; <shadow.h>, <pwd.h>, and <grp.h> routines, as well as a subset of the
;;; functionality of the Shadow command-line tools.  It can parse and write
;;; /etc/passwd, /etc/shadow, /etc/group, /etc/subuid and /etc/subgid.  It can
;;; also take care of UID and GID allocation in a way similar to what 'useradd'
;;; does.  The same goes for sub UID and sub GID allocation.
;;;
;;; 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> record make-record record?
        (serialization separator entry->string string->entry)
        fields ...)
     (let-syntax ((field-name
                   (syntax-rules ()
                     ((_ (name _ (... ...))) name))))
       (define-record-type* <record> 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>           ;<pwd.h>
  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>             ;<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-database-entry <subid-entry>              ;<subid.h>
  subid-entry make-subid-entry
  subid-entry?
  (serialization #\: subid-entry->string string->subid-entry)

  (name            subid-entry-name)
  (start           subid-entry-start
                   (serialization number->string string->number))
  (count           subid-entry-count
                   (serialization number->string string->number)))

(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 write-subuid
  (database-writer "/etc/subuid" #o644 subid-entry->string))
(define write-subgid
  (database-writer "/etc/subgid" #o644 subid-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))
(define read-subuid
  (database-reader "/etc/subuid" string->subid-entry))
(define read-subgid
  (database-reader "/etc/subgid" string->subid-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)))

(define-record-type* <unused-subid-range>
  unused-subid-range make-unused-subid-range
  unused-subid-range?
  (left    unused-subid-range-left   ;previous unused subuid range or #f
           (default #f))
  (min     unused-subid-range-min    ;lower bound of this unused subuid range
           (default %subordinate-id-min))
  (max     unused-subid-range-max    ;upper bound
           (default %subordinate-id-max))
  (right   unused-subid-range-right  ;next unused subuid range or #f
           (default #f)))

;; 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)

;; According to Shadow's libmisc/find_new_sub_uids.c and
;; libmisc/find_new_sub_gids.c.
(define %subordinate-id-min 100000)
(define %subordinate-id-max 600100000)
(define %subordinate-id-count 65536)

(define-condition-type &subordinate-id-error &error
  subordinate-id-error?)
(define-condition-type &subordinate-id-overflow-error &subordinate-id-error
  subordinate-id-overflow-error?
  (range subordinate-id-overflow-error))
(define-condition-type &invalid-subid-range-error &subordinate-id-error
  invalid-subid-range-error?
  (range invalid-subid-range-error-range))
(define-condition-type &specific-subid-range-expected-error &subordinate-id-error
  specific-subid-range-expected-error?
  (range specific-subid-range-expected-error-range))
(define-condition-type &generic-subid-range-expected-error &subordinate-id-error
  generic-subid-range-expected-error?
  (range generic-subid-range-expected-error-range))

(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 (subordinate-id? id)
  (and (>= id %subordinate-id-min)
       (< id %subordinate-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 (within-interval? allocation range)
  "Returns #t when RANGE is included in the ALLOCATION.
Both ends of the ALLOCATION are included in the comparison."
  (define allocation-start
    (unused-subid-range-min allocation))
  (define allocation-end
    (unused-subid-range-max allocation))
  (unless (subid-range-has-start? range)
    (raise
     (condition
      (&specific-subid-range-expected-error
       (range range)))))
  (and (<= allocation-start
           (subid-range-start range))
       (<= (subid-range-end range)
           allocation-end)))

(define (allocate-unused-range allocation actual-range)
  "Allocates RANGE inside ALLOCATION.  RANGE is assumed to be
@code{within-interval?} of ALLOCATION, a new @code{unused-subid-range} record is
returned with all the subids contained in RANGE marked as used."
  (define allocation-start
    (unused-subid-range-min allocation))
  (define allocation-end
    (unused-subid-range-max allocation))
  (define allocation-left
    (unused-subid-range-left allocation))
  (define allocation-right
    (unused-subid-range-left allocation))
  (define range-start
    (subid-range-start actual-range))
  (define range-end
    (subid-range-end actual-range))
  (define new-start
    (+ 1 range-end))
  (define new-end
    (- range-start 1))
  (if (or (= allocation-start range-start)
          (= allocation-end range-end))
      (unused-subid-range
       (inherit allocation)
       (min (if (= allocation-start range-start)
                new-start
                allocation-start))
       (max (if (= allocation-end range-end)
                new-end
                allocation-end)))
      (let* ((left-child?
              (<= (- range-start allocation-start)
                  (- allocation-end range-end)))
             (child
              (unused-subid-range
               (min allocation-start)
               (max new-end)
               (left
                (and left-child?
                     allocation-left))
               (right
                (and (not left-child?)
                     allocation-right)))))
        (unused-subid-range
         (inherit allocation)
         (min new-start)
         (max allocation-end)
         (left
          (if left-child?
              child
              allocation-left))
         (right
          (if left-child?
              allocation-right
              child))))))

(define (allocate-generic-range allocation range)
  "Allocates a range of subids in ALLOCATION, based on RANGE.  RANGE is expected
to be a generic range i.e. to not have an explicit start subordinate id.  All
nodes in ALLOCATION are visited and the first where RANGE is
@code{within-interval?} will be selected, the subordinate ids contained in RANGE
will be marked as used in it."
  (when (subid-range-has-start? range)
    (raise
     (condition
      (&generic-subid-range-expected-error
       (ranges range)))))
  (define left (unused-subid-range-left allocation))
  (define right (unused-subid-range-right allocation))
  (define allocation-start
    (unused-subid-range-min allocation))
  (define actual-range
    (subid-range
     (inherit range)
     (start allocation-start)))

  (if (within-interval? allocation actual-range)
      (values
       (allocate-unused-range allocation actual-range)
       actual-range)
      (if left
          (let-values (((new-left new-range)
                        (allocate-generic-range left range)))
            (values (unused-subid-range
                     (inherit allocation)
                     (left new-left))
                    new-range))
          (if right
              (let-values (((new-right new-range)
                            (allocate-generic-range right range)))
                (values (unused-subid-range
                         (inherit allocation)
                         (left new-right))
                        new-range))
              (raise
               (condition
                (&subordinate-id-overflow-error
                 (range range))))))))

(define (allocate-specific-range allocation range)
  "Allocates a range of subids in ALLOCATION, based on RANGE.  RANGE is expected
to be a specific range i.e. to have an explicit start subordinate id.  ALLOCATION
is visited to find the best unused range that can hold RANGE."
  (unless (subid-range-has-start? range)
    (raise
     (condition
      (&specific-subid-range-expected-error
       (range range)))))
  (define allocation-left
    (unused-subid-range-left allocation))
  (define allocation-right
    (unused-subid-range-right allocation))
  (define allocation-start
    (unused-subid-range-min allocation))
  (define allocation-end
    (unused-subid-range-max allocation))

  (define range-start
    (subid-range-start range))
  (define range-end
    (subid-range-end range))

  (unless (and (subordinate-id? range-start)
               (subordinate-id? range-end))
    (raise
     (condition
      (&invalid-subid-range-error
       (range range)))))

  (define less?
    (< range-end allocation-start))
  (define more?
    (> range-start allocation-end))

  (cond ((within-interval? allocation range)
         (values (allocate-unused-range allocation range)
                 range))
        ((and allocation-left less?)
         (let-values (((new-left _)
                       (allocate-specific-range allocation-left range)))
           (values (unused-subid-range
                    (inherit allocation)
                    (left new-left))
                   range)))
        ((and allocation-right more?)
         (let-values (((new-right _)
                       (allocate-specific-range allocation-right range)))
           (values (unused-subid-range
                    (inherit allocation)
                    (right new-right))
                   range)))
        (else
         (raise
          (condition
           (&subordinate-id-overflow-error
            (range range)))))))

(define* (reserve-subids allocation ranges)
  "Mark the subid ranges listed in RANGES as reserved in ALLOCATION."
  (fold (lambda (range state)
          (define-values (new-allocation actual-range)
            ((if (subid-range-has-start? range)
                 allocate-specific-range
                 allocate-generic-range)
             (first state)
             range))
          (list new-allocation
                (cons actual-range
                      (second state))))
        (list allocation '()) ranges))

(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 (range->entry range)
  (subid-entry
   (name (subid-range-name range))
   (start (subid-range-start range))
   (count (subid-range-count range))))

(define (entry->range entry)
  (subid-range
   (name (subid-entry-name entry))
   (start (subid-entry-start entry))
   (count (subid-entry-count entry))))

(define* (allocate-subids ranges #:optional (current-ranges '()))
  "Return a list of subids entries for RANGES, a list of <subid-range>.  IDs
found in CURRENT-RANGES, a list of subid entries, are reused."
  (let ((generic (any (compose not subid-range-has-start?) current-ranges)))
    (when generic
      (raise
       (condition
        (&specific-subid-range-expected-error
         (range generic))))))
  (define sorted-ranges
    (stable-sort ranges
                 subid-range-less))
  (define current-allocation+subids
    (reserve-subids (unused-subid-range)
                    current-ranges))
  (define subids
    ;; Reserve first specific subid-ranges
    ;; and later generic ones.
    (second
     (reserve-subids (first
                      current-allocation+subids)
                     sorted-ranges)))

  (map range->entry
       ;; Produce deterministic subid collections.
       (stable-sort
        (append (second current-allocation+subids)
                subids)
        subid-range-less)))

(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))

(define* (subuid+subgid-databases subuids subgids
                                  #:key
                                  (current-subuids
                                   (map entry->range
                                        (empty-if-not-found read-subuid)))
                                  (current-subgids
                                   (map entry->range
                                        (empty-if-not-found read-subgid))))
  "Return two values: the list of subgid entries, and the list of subuid entries
corresponding to SUBUIDS and SUBGIDS.
Preserve stateful bits from CURRENT-SUBUIDS and CURRENT-SUBGIDS."

  (define (range-eqv? a b)
    (string=? (subid-range-name a)
              (subid-range-name b)))

  (define subuid-entries
    (allocate-subids
     (lset-difference range-eqv? subuids current-subuids) current-subuids))

  (define subgid-entries
    (allocate-subids
     (lset-difference range-eqv? subgids current-subgids) current-subgids))

  (values subuid-entries subgid-entries))