gnu/system/shadow.scm

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