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