gnu/build/accounts.scm

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