gnu/system/shadow.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2016 Alex Griffin <a@ajgrf.com>
   4 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
   5 ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
   6 ;;;
   7 ;;; This file is part of GNU Guix.
   8 ;;;
   9 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  10 ;;; under the terms of the GNU General Public License as published by
  11 ;;; the Free Software Foundation; either version 3 of the License, or (at
  12 ;;; your option) any later version.
  13 ;;;
  14 ;;; GNU Guix is distributed in the hope that it will be useful, but
  15 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;;; GNU General Public License for more details.
  18 ;;;
  19 ;;; You should have received a copy of the GNU General Public License
  20 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  21
  22 (define-module (gnu system shadow)
  23   #:use-module ((guix diagnostics) #:select (formatted-message))
  24   #:use-module (guix records)
  25   #:use-module (guix gexp)
  26   #:use-module (guix store)
  27   #:use-module (guix modules)
  28   #:use-module (guix sets)
  29   #:use-module (guix ui)
  30   #:use-module (gnu system accounts)
  31   #:use-module (gnu services)
  32   #:use-module (gnu services shepherd)
  33   #:use-module ((gnu system file-systems)
  34                 #:select (%tty-gid))
  35   #:use-module ((gnu packages admin)
  36                 #:select (shadow))
  37   #:use-module (gnu packages bash)
  38   #:use-module (ice-9 match)
  39   #:use-module (srfi srfi-1)
  40   #:use-module (srfi srfi-26)
  41   #:use-module (srfi srfi-34)
  42   #:use-module (srfi srfi-35)
  43
  44   ;; Re-export these bindings for backward compatibility.
  45   #:re-export (user-account
  46                user-account?
  47                user-account-name
  48                user-account-password
  49                user-account-uid
  50                user-account-group
  51                user-account-supplementary-groups
  52                user-account-comment
  53                user-account-home-directory
  54                user-account-create-home-directory?
  55                user-account-shell
  56                user-account-system?
  57
  58                user-group
  59                user-group?
  60                user-group-name
  61                user-group-password
  62                user-group-id
  63                user-group-system?)
  64
  65   #:export (default-skeletons
  66             skeleton-directory
  67             %base-groups
  68             %base-user-accounts
  69
  70             account-service-type
  71             account-service))
  72
  73 ;;; Commentary:
  74 ;;;
  75 ;;; Utilities for configuring the Shadow tool suite ('login', 'passwd', etc.)
  76 ;;;
  77 ;;; Code:
  78
  79 ;; Change the default shell used by new <user-account> records.
  80 (default-shell (file-append bash "/bin/bash"))
  81
  82 (define %base-groups
  83   ;; Default set of groups.
  84   (let-syntax ((system-group (syntax-rules ()
  85                                ((_ args ...)
  86                                 (user-group (system? #t) args ...)))))
  87     (list (system-group (name "root") (id 0))
  88           (system-group (name "wheel"))           ; root-like users
  89           (system-group (name "users"))           ; normal users
  90           (system-group (name "nogroup"))         ; for daemons etc.
  91
  92           ;; The following groups are conventionally used by things like udev to
  93           ;; control access to hardware devices.
  94           (system-group (name "tty") (id %tty-gid))
  95           (system-group (name "dialout"))
  96           (system-group (name "kmem"))
  97           (system-group (name "input"))           ; input devices, from udev
  98           (system-group (name "video"))
  99           (system-group (name "audio"))
 100           (system-group (name "netdev"))          ; used in avahi-dbus.conf
 101           (system-group (name "lp"))
 102           (system-group (name "disk"))
 103           (system-group (name "floppy"))
 104           (system-group (name "cdrom"))
 105           (system-group (name "tape"))
 106           (system-group (name "kvm")))))          ; for /dev/kvm
 107
 108 (define %base-user-accounts
 109   ;; List of standard user accounts.  Note that "root" is a special case, so
 110   ;; it's not listed here.
 111   (list (user-account
 112          (name "nobody")
 113          (uid 65534)
 114          (group "nogroup")
 115          (shell (file-append shadow "/sbin/nologin"))
 116          (home-directory "/nonexistent")
 117          (create-home-directory? #f)
 118          (system? #t))))
 119
 120 (define (default-skeletons)
 121   "Return the default skeleton files for /etc/skel.  These files are copied by
 122 'useradd' in the home directory of newly created user accounts."
 123
 124   (let ((profile (plain-file "bash_profile" "\
 125 # Honor per-interactive-shell startup file
 126 if [ -f ~/.bashrc ]; then . ~/.bashrc; fi\n"))
 127         (bashrc  (plain-file "bashrc" "\
 128 # Bash initialization for interactive non-login shells and
 129 # for remote shells (info \"(bash) Bash Startup Files\").
 130
 131 # Export 'SHELL' to child processes.  Programs such as 'screen'
 132 # honor it and otherwise use /bin/sh.
 133 export SHELL
 134
 135 if [[ $- != *i* ]]
 136 then
 137     # We are being invoked from a non-interactive shell.  If this
 138     # is an SSH session (as in \"ssh host command\"), source
 139     # /etc/profile so we get PATH and other essential variables.
 140     [[ -n \"$SSH_CLIENT\" ]] && source /etc/profile
 141
 142     # Don't do anything else.
 143     return
 144 fi
 145
 146 # Source the system-wide file.
 147 source /etc/bashrc
 148
 149 # Adjust the prompt depending on whether we're in 'guix environment'.
 150 if [ -n \"$GUIX_ENVIRONMENT\" ]
 151 then
 152     PS1='\\u@\\h \\w [env]\\$ '
 153 else
 154     PS1='\\u@\\h \\w\\$ '
 155 fi
 156 alias ls='ls -p --color=auto'
 157 alias ll='ls -l'
 158 alias grep='grep --color=auto'\n"))
 159         (zprofile    (plain-file "zprofile" "\
 160 # Honor system-wide environment variables
 161 source /etc/profile\n"))
 162         (xdefaults (plain-file "Xdefaults" "\
 163 XTerm*utf8: always
 164 XTerm*metaSendsEscape: true\n"))
 165         (gdbinit   (plain-file "gdbinit" "\
 166 # Tell GDB where to look for separate debugging files.
 167 set debug-file-directory ~/.guix-profile/lib/debug
 168
 169 # Authorize extensions found in the store, such as the
 170 # pretty-printers of libstdc++.
 171 set auto-load safe-path /gnu/store/*/lib\n")))
 172     `((".bash_profile" ,profile)
 173       (".bashrc" ,bashrc)
 174       ;; Zsh sources ~/.zprofile before ~/.zshrc, and it sources ~/.zlogin
 175       ;; after ~/.zshrc.  To avoid interfering with any customizations a user
 176       ;; may have made in their ~/.zshrc, put this in .zprofile, not .zlogin.
 177       (".zprofile" ,zprofile)
 178       (".nanorc" ,(plain-file "nanorc" "\
 179 # Include all the syntax highlighting modules.
 180 include /run/current-system/profile/share/nano/*.nanorc\n"))
 181       (".Xdefaults" ,xdefaults)
 182       (".guile" ,(plain-file "dot-guile"
 183                              "(cond ((false-if-exception (resolve-interface '(ice-9 readline)))
 184        =>
 185        (lambda (module)
 186          ;; Enable completion and input history at the REPL.
 187          ((module-ref module 'activate-readline))))
 188       (else
 189        (display \"Consider installing the 'guile-readline' package for
 190 convenient interactive line editing and input history.\\n\\n\")))
 191
 192       (unless (getenv \"INSIDE_EMACS\")
 193         (cond ((false-if-exception (resolve-interface '(ice-9 colorized)))
 194                =>
 195                (lambda (module)
 196                  ;; Enable completion and input history at the REPL.
 197                  ((module-ref module 'activate-colorized))))
 198               (else
 199                (display \"Consider installing the 'guile-colorized' package
 200 for a colorful Guile experience.\\n\\n\"))))\n"))
 201       (".gdbinit" ,gdbinit))))
 202
 203 (define (skeleton-directory skeletons)
 204   "Return a directory containing SKELETONS, a list of name/derivation tuples."
 205   (computed-file "skel"
 206                  (with-imported-modules '((guix build utils))
 207                    #~(begin
 208                        (use-modules (ice-9 match)
 209                                     (guix build utils))
 210
 211                        (mkdir #$output)
 212                        (chdir #$output)
 213
 214                        ;; Note: copy the skeletons instead of symlinking
 215                        ;; them like 'file-union' does, because 'useradd'
 216                        ;; would just copy the symlinks as is.
 217                        (for-each (match-lambda
 218                                    ((target source)
 219                                     (copy-recursively source target)))
 220                                  '#$skeletons)
 221                        ;; Make nanorc respect XDG_CONFIG_HOME.
 222                        (when (file-exists? ".nanorc")
 223                          (mkdir-p ".config/nano")
 224                          (rename-file ".nanorc" ".config/nano/nanorc"))
 225                        #t))))
 226
 227 (define (find-duplicates list)
 228   "Find duplicate entries in @var{list}.
 229 Two entries are considered duplicates, if they are @code{equal?} to each other.
 230 This implementation is made asymptotically faster than @code{delete-duplicates}
 231 through the internal use of hash tables."
 232   (let loop ((list list)
 233              ;; We actually modify table in-place, but still allocate it here
 234              ;; so that we only need one level of indentation.
 235              (table (make-hash-table)))
 236     (match list
 237       (()
 238        (hash-fold (lambda (key value seed)
 239                     (if (> value 1)
 240                         (cons key seed)
 241                         seed))
 242                   '()
 243                   table))
 244       ((first . rest)
 245        (hash-set! table first
 246                   (1+ (hash-ref table first 0)))
 247        (loop rest table)))))
 248
 249 (define (assert-unique-account-names users)
 250   (match (find-duplicates (map user-account-name users))
 251     (() *unspecified*)
 252     (duplicates
 253      (warning
 254       (G_ "the following accounts appear more than once:~{ ~a~}")
 255       duplicates))))
 256
 257 (define (assert-unique-group-names groups)
 258   (match (find-duplicates (map user-group-name groups))
 259     (() *unspecified*)
 260     (duplicates
 261      (warning
 262       (G_ "the following groups appear more than once:~{ ~a~}")
 263       duplicates))))
 264
 265 (define (assert-valid-users/groups users groups)
 266   "Raise an error if USERS refer to groups not listed in GROUPS."
 267   (let ((groups (list->set (map user-group-name groups))))
 268     (define (validate-supplementary-group user group)
 269       (unless (set-contains? groups group)
 270         (raise (condition
 271                 (&message
 272                  (message
 273                   (format #f (G_ "supplementary group '~a' \
 274 of user '~a' is undeclared")
 275                           group
 276                           (user-account-name user))))))))
 277
 278     (for-each (lambda (user)
 279                 (unless (set-contains? groups (user-account-group user))
 280                   (raise (condition
 281                           (&message
 282                            (message
 283                             (format #f (G_ "primary group '~a' \
 284 of user '~a' is undeclared")
 285                                     (user-account-group user)
 286                                     (user-account-name user)))))))
 287
 288                 (for-each (cut validate-supplementary-group user <>)
 289                           (user-account-supplementary-groups user)))
 290               users)))
 291
 292 \f
 293 ;;;
 294 ;;; Service.
 295 ;;;
 296
 297 (define (user-group->gexp group)
 298   "Turn GROUP, a <user-group> object, into a list-valued gexp suitable for
 299 'active-groups'."
 300   #~(list #$(user-group-name group)
 301           #$(user-group-password group)
 302           #$(user-group-id group)
 303           #$(user-group-system? group)))
 304
 305 (define (user-account->gexp account)
 306   "Turn ACCOUNT, a <user-account> object, into a list-valued gexp suitable for
 307 'activate-users'."
 308   #~`(#$(user-account-name account)
 309       #$(user-account-uid account)
 310       #$(user-account-group account)
 311       #$(user-account-supplementary-groups account)
 312       #$(user-account-comment account)
 313       #$(user-account-home-directory account)
 314       #$(user-account-create-home-directory? account)
 315       ,#$(user-account-shell account)             ; this one is a gexp
 316       #$(user-account-password account)
 317       #$(user-account-system? account)))
 318
 319 (define (account-activation accounts+groups)
 320   "Return a gexp that activates ACCOUNTS+GROUPS, a list of <user-account> and
 321 <user-group> objects.  Raise an error if a user account refers to a undefined
 322 group."
 323   (define accounts
 324     (filter user-account? accounts+groups))
 325
 326   (define user-specs
 327     (map user-account->gexp accounts))
 328
 329   (define groups
 330     (filter user-group? accounts+groups))
 331
 332   (define group-specs
 333     (map user-group->gexp groups))
 334
 335   (assert-unique-account-names accounts)
 336   (assert-unique-group-names groups)
 337   (assert-valid-users/groups accounts groups)
 338
 339   ;; Add users and user groups.
 340   (with-imported-modules (source-module-closure '((gnu system accounts)))
 341     #~(begin
 342         (use-modules (gnu system accounts))
 343
 344         (activate-users+groups (map sexp->user-account (list #$@user-specs))
 345                                (map sexp->user-group (list #$@group-specs))))))
 346
 347 (define (account-shepherd-service accounts+groups)
 348   "Return a Shepherd service that creates the home directories for the user
 349 accounts among ACCOUNTS+GROUPS."
 350   (define accounts
 351     (filter user-account? accounts+groups))
 352
 353   ;; Create home directories only once 'file-systems' is up.  This makes sure
 354   ;; they are created in the right place if /home lives on a separate
 355   ;; partition.
 356   ;;
 357   ;; XXX: We arrange for this service to stop right after it's done its job so
 358   ;; that 'guix system reconfigure' knows that it can reload it fearlessly
 359   ;; (and thus create new home directories).
 360   (list (shepherd-service
 361          (requirement '(file-systems))
 362          (provision '(user-homes))
 363          (one-shot? #t)
 364          (modules '((gnu build activation)
 365                     (gnu system accounts)))
 366          (start (with-imported-modules (source-module-closure
 367                                         '((gnu build activation)
 368                                           (gnu system accounts)))
 369                   #~(lambda ()
 370                       (activate-user-home
 371                        (map sexp->user-account
 372                             (list #$@(map user-account->gexp accounts))))
 373                       #t)))                       ;success
 374          (documentation "Create user home directories."))))
 375
 376 (define (shells-file shells)
 377   "Return a file-like object that builds a shell list for use as /etc/shells
 378 based on SHELLS.  /etc/shells is used by xterm, polkit, and other programs."
 379   (computed-file "shells"
 380                  #~(begin
 381                      (use-modules (srfi srfi-1))
 382
 383                      (define shells
 384                        (delete-duplicates (list #$@shells)))
 385
 386                      (call-with-output-file #$output
 387                        (lambda (port)
 388                          (display "\
 389 /bin/sh
 390 /run/current-system/profile/bin/sh
 391 /run/current-system/profile/bin/bash\n" port)
 392                          (for-each (lambda (shell)
 393                                      (display shell port)
 394                                      (newline port))
 395                                    shells))))))
 396 (define (etc-files arguments)
 397   "Filter out among ARGUMENTS things corresponding to skeletons, and return
 398 the /etc/skel directory for those."
 399   (let ((skels (filter pair? arguments))
 400         (users (filter user-account? arguments)))
 401     `(("skel" ,(skeleton-directory skels))
 402       ("shells" ,(shells-file (map user-account-shell users))))))
 403
 404 (define account-service-type
 405   (service-type (name 'account)
 406
 407                 ;; Concatenate <user-account>, <user-group>, and skeleton
 408                 ;; lists.
 409                 (compose concatenate)
 410                 (extend append)
 411
 412                 (extensions
 413                  (list (service-extension activation-service-type
 414                                           account-activation)
 415                        (service-extension shepherd-root-service-type
 416                                           account-shepherd-service)
 417                        ;; Have 'user-processes' depend on 'user-homes' so that
 418                        ;; daemons start after their home directory has been
 419                        ;; created.
 420                        (service-extension user-processes-service-type
 421                                           (const '(user-homes)))
 422                        (service-extension etc-service-type
 423                                           etc-files)))
 424                 (description
 425                  "Ensure the specified user accounts and groups exist, as well
 426 as each account home directory.")))
 427
 428 (define (account-service accounts+groups skeletons)
 429   "Return a <service> that takes care of user accounts and user groups, with
 430 ACCOUNTS+GROUPS as its initial list of accounts and groups."
 431   (service account-service-type
 432            (append skeletons accounts+groups)))
 433
 434 ;;; shadow.scm ends here