1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2016 Alex Griffin <a@ajgrf.com>
5 ;;; This file is part of GNU Guix.
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.
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.
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/>.
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 services)
28 #:use-module (gnu services shepherd)
29 #:use-module ((gnu system file-systems)
31 #:use-module ((gnu packages admin)
33 #:use-module (gnu packages bash)
34 #:use-module (gnu packages guile-wm)
35 #:use-module (srfi srfi-1)
36 #:use-module (srfi srfi-26)
37 #:use-module (srfi srfi-34)
38 #:use-module (srfi srfi-35)
39 #:export (user-account
45 user-account-supplementary-groups
47 user-account-home-directory
48 user-account-create-home-directory?
69 ;;; Utilities for configuring the Shadow tool suite ('login', 'passwd', etc.)
73 (define-record-type* <user-account>
74 user-account make-user-account
76 (name user-account-name)
77 (password user-account-password (default #f))
78 (uid user-account-uid (default #f))
79 (group user-account-group) ; number | string
80 (supplementary-groups user-account-supplementary-groups
81 (default '())) ; list of strings
82 (comment user-account-comment (default ""))
83 (home-directory user-account-home-directory)
84 (create-home-directory? user-account-create-home-directory? ;Boolean
86 (shell user-account-shell ; gexp
87 (default (file-append bash "/bin/bash")))
88 (system? user-account-system? ; Boolean
91 (define-record-type* <user-group>
92 user-group make-user-group
94 (name user-group-name)
95 (password user-group-password (default #f))
96 (id user-group-id (default #f))
97 (system? user-group-system? ; Boolean
102 ;; Default set of groups.
103 (let-syntax ((system-group (syntax-rules ()
105 (user-group (system? #t) args ...)))))
106 (list (system-group (name "root") (id 0))
107 (system-group (name "wheel")) ; root-like users
108 (system-group (name "users")) ; normal users
109 (system-group (name "nogroup")) ; for daemons etc.
111 ;; The following groups are conventionally used by things like udev to
112 ;; control access to hardware devices.
113 (system-group (name "tty") (id %tty-gid))
114 (system-group (name "dialout"))
115 (system-group (name "kmem"))
116 (system-group (name "input")) ; input devices, from udev
117 (system-group (name "video"))
118 (system-group (name "audio"))
119 (system-group (name "netdev")) ; used in avahi-dbus.conf
120 (system-group (name "lp"))
121 (system-group (name "disk"))
122 (system-group (name "floppy"))
123 (system-group (name "cdrom"))
124 (system-group (name "tape"))
125 (system-group (name "kvm"))))) ; for /dev/kvm
127 (define %base-user-accounts
128 ;; List of standard user accounts. Note that "root" is a special case, so
129 ;; it's not listed here.
134 (shell (file-append shadow "/sbin/nologin"))
135 (home-directory "/nonexistent")
136 (create-home-directory? #f)
139 (define (default-skeletons)
140 "Return the default skeleton files for /etc/skel. These files are copied by
141 'useradd' in the home directory of newly created user accounts."
142 (define copy-guile-wm
143 (with-imported-modules '((guix build utils))
145 (use-modules (guix build utils))
146 (copy-file (car (find-files #+guile-wm "wm-init-sample.scm"))
149 (let ((profile (plain-file "bash_profile" "\
150 # Honor per-interactive-shell startup file
151 if [ -f ~/.bashrc ]; then . ~/.bashrc; fi\n"))
152 (bashrc (plain-file "bashrc" "\
153 # Bash initialization for interactive non-login shells and
154 # for remote shells (info \"(bash) Bash Startup Files\").
156 # Export 'SHELL' to child processes. Programs such as 'screen'
157 # honor it and otherwise use /bin/sh.
162 # We are being invoked from a non-interactive shell. If this
163 # is an SSH session (as in \"ssh host command\"), source
164 # /etc/profile so we get PATH and other essential variables.
165 [[ -n \"$SSH_CLIENT\" ]] && source /etc/profile
167 # Don't do anything else.
171 # Source the system-wide file.
174 # Adjust the prompt depending on whether we're in 'guix environment'.
175 if [ -n \"$GUIX_ENVIRONMENT\" ]
177 PS1='\\u@\\h \\w [env]\\$ '
179 PS1='\\u@\\h \\w\\$ '
181 alias ls='ls -p --color=auto'
183 alias grep='grep --color=auto'\n"))
184 (zlogin (plain-file "zlogin" "\
185 # Honor system-wide environment variables
186 source /etc/profile\n"))
187 (guile-wm (computed-file "guile-wm" copy-guile-wm))
188 (xdefaults (plain-file "Xdefaults" "\
190 XTerm*metaSendsEscape: true\n"))
191 (gdbinit (plain-file "gdbinit" "\
192 # Tell GDB where to look for separate debugging files.
193 set debug-file-directory ~/.guix-profile/lib/debug
195 # Authorize extensions found in the store, such as the
196 # pretty-printers of libstdc++.
197 set auto-load safe-path /gnu/store/*/lib\n")))
198 `((".bash_profile" ,profile)
201 (".nanorc" ,(plain-file "nanorc" "\
202 # Include all the syntax highlighting modules.
203 include /run/current-system/profile/share/nano/*.nanorc\n"))
204 (".Xdefaults" ,xdefaults)
205 (".guile" ,(plain-file "dot-guile"
206 "(cond ((false-if-exception (resolve-interface '(ice-9 readline)))
209 ;; Enable completion and input history at the REPL.
210 ((module-ref module 'activate-readline))))
212 (display \"Consider installing the 'guile-readline' package for
213 convenient interactive line editing and input history.\\n\\n\")))
215 (unless (getenv \"INSIDE_EMACS\")
216 (cond ((false-if-exception (resolve-interface '(ice-9 colorized)))
219 ;; Enable completion and input history at the REPL.
220 ((module-ref module 'activate-colorized))))
222 (display \"Consider installing the 'guile-colorized' package
223 for a colorful Guile experience.\\n\\n\"))))\n"))
224 (".guile-wm" ,guile-wm)
225 (".gdbinit" ,gdbinit))))
227 (define (skeleton-directory skeletons)
228 "Return a directory containing SKELETONS, a list of name/derivation tuples."
229 (computed-file "skel"
230 (with-imported-modules '((guix build utils))
232 (use-modules (ice-9 match)
238 ;; Note: copy the skeletons instead of symlinking
239 ;; them like 'file-union' does, because 'useradd'
240 ;; would just copy the symlinks as is.
241 (for-each (match-lambda
243 (copy-recursively source target)))
247 (define (assert-valid-users/groups users groups)
248 "Raise an error if USERS refer to groups not listed in GROUPS."
249 (let ((groups (list->set (map user-group-name groups))))
250 (define (validate-supplementary-group user group)
251 (unless (set-contains? groups group)
255 (format #f (G_ "supplementary group '~a' \
256 of user '~a' is undeclared")
258 (user-account-name user))))))))
260 (for-each (lambda (user)
261 (unless (set-contains? groups (user-account-group user))
265 (format #f (G_ "primary group '~a' \
266 of user '~a' is undeclared")
267 (user-account-group user)
268 (user-account-name user)))))))
270 (for-each (cut validate-supplementary-group user <>)
271 (user-account-supplementary-groups user)))
279 (define (user-group->gexp group)
280 "Turn GROUP, a <user-group> object, into a list-valued gexp suitable for
282 #~(list #$(user-group-name group)
283 #$(user-group-password group)
284 #$(user-group-id group)
285 #$(user-group-system? group)))
287 (define (user-account->gexp account)
288 "Turn ACCOUNT, a <user-account> object, into a list-valued gexp suitable for
290 #~`(#$(user-account-name account)
291 #$(user-account-uid account)
292 #$(user-account-group account)
293 #$(user-account-supplementary-groups account)
294 #$(user-account-comment account)
295 #$(user-account-home-directory account)
296 #$(user-account-create-home-directory? account)
297 ,#$(user-account-shell account) ; this one is a gexp
298 #$(user-account-password account)
299 #$(user-account-system? account)))
301 (define (account-activation accounts+groups)
302 "Return a gexp that activates ACCOUNTS+GROUPS, a list of <user-account> and
303 <user-group> objects. Raise an error if a user account refers to a undefined
306 (filter user-account? accounts+groups))
309 (map user-account->gexp accounts))
312 (filter user-group? accounts+groups))
315 (map user-group->gexp groups))
317 (assert-valid-users/groups accounts groups)
319 ;; Add users and user groups.
322 (string-append #$(@ (gnu packages admin) shadow) "/sbin"))
323 (activate-users+groups (list #$@user-specs)
324 (list #$@group-specs))))
326 (define (account-shepherd-service accounts+groups)
327 "Return a Shepherd service that creates the home directories for the user
328 accounts among ACCOUNTS+GROUPS."
330 (filter user-account? accounts+groups))
332 ;; Create home directories only once 'file-systems' is up. This makes sure
333 ;; they are created in the right place if /home lives on a separate
336 ;; XXX: We arrange for this service to stop right after it's done its job so
337 ;; that 'guix system reconfigure' knows that it can reload it fearlessly
338 ;; (and thus create new home directories). The cost of this hack is that
339 ;; there's a small window during which first-time logins could happen before
340 ;; the home directory has been created.
341 (list (shepherd-service
342 (requirement '(file-systems))
343 (provision '(user-homes))
344 (modules '((gnu build activation)))
345 (start (with-imported-modules (source-module-closure
346 '((gnu build activation)))
349 (list #$@(map user-account->gexp accounts)))
353 (documentation "Create user home directories."))))
355 (define (shells-file shells)
356 "Return a file-like object that builds a shell list for use as /etc/shells
357 based on SHELLS. /etc/shells is used by xterm, polkit, and other programs."
358 (computed-file "shells"
360 (use-modules (srfi srfi-1))
363 (delete-duplicates (list #$@shells)))
365 (call-with-output-file #$output
369 /run/current-system/profile/bin/sh
370 /run/current-system/profile/bin/bash\n" port)
371 (for-each (lambda (shell)
375 (define (etc-files arguments)
376 "Filter out among ARGUMENTS things corresponding to skeletons, and return
377 the /etc/skel directory for those."
378 (let ((skels (filter pair? arguments))
379 (users (filter user-account? arguments)))
380 `(("skel" ,(skeleton-directory skels))
381 ("shells" ,(shells-file (map user-account-shell users))))))
383 (define account-service-type
384 (service-type (name 'account)
386 ;; Concatenate <user-account>, <user-group>, and skeleton
388 (compose concatenate)
392 (list (service-extension activation-service-type
394 (service-extension shepherd-root-service-type
395 account-shepherd-service)
396 (service-extension etc-service-type
399 (define (account-service accounts+groups skeletons)
400 "Return a <service> that takes care of user accounts and user groups, with
401 ACCOUNTS+GROUPS as its initial list of accounts and groups."
402 (service account-service-type
403 (append skeletons accounts+groups)))
405 ;;; shadow.scm ends here