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