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