[jackhill/guix/guix.git] / gnu / system / shadow.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2016 Alex Griffin <a@ajgrf.com>
;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu system shadow)
  #:use-module (guix records)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix modules)
  #:use-module (guix sets)
  #:use-module (guix ui)
  #:use-module (gnu system accounts)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module ((gnu system file-systems)
                #:select (%tty-gid))
  #:use-module ((gnu packages admin)
                #:select (shadow))
  #:use-module (gnu packages bash)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)

  ;; Re-export these bindings for backward compatibility.
  #:re-export (user-account
               user-account?
               user-account-name
               user-account-password
               user-account-uid
               user-account-group
               user-account-supplementary-groups
               user-account-comment
               user-account-home-directory
               user-account-create-home-directory?
               user-account-shell
               user-account-system?

               user-group
               user-group?
               user-group-name
               user-group-password
               user-group-id
               user-group-system?)

  #:export (default-skeletons
            skeleton-directory
            %base-groups
            %base-user-accounts

            account-service-type
            account-service))

;;; Commentary:
;;;
;;; Utilities for configuring the Shadow tool suite ('login', 'passwd', etc.)
;;;
;;; Code:

;; Change the default shell used by new <user-account> records.
(default-shell (file-append bash "/bin/bash"))

(define %base-groups
  ;; Default set of groups.
  (let-syntax ((system-group (syntax-rules ()
                               ((_ args ...)
                                (user-group (system? #t) args ...)))))
    (list (system-group (name "root") (id 0))
          (system-group (name "wheel"))           ; root-like users
          (system-group (name "users"))           ; normal users
          (system-group (name "nogroup"))         ; for daemons etc.

          ;; The following groups are conventionally used by things like udev to
          ;; control access to hardware devices.
          (system-group (name "tty") (id %tty-gid))
          (system-group (name "dialout"))
          (system-group (name "kmem"))
          (system-group (name "input"))           ; input devices, from udev
          (system-group (name "video"))
          (system-group (name "audio"))
          (system-group (name "netdev"))          ; used in avahi-dbus.conf
          (system-group (name "lp"))
          (system-group (name "disk"))
          (system-group (name "floppy"))
          (system-group (name "cdrom"))
          (system-group (name "tape"))
          (system-group (name "kvm")))))          ; for /dev/kvm

(define %base-user-accounts
  ;; List of standard user accounts.  Note that "root" is a special case, so
  ;; it's not listed here.
  (list (user-account
         (name "nobody")
         (uid 65534)
         (group "nogroup")
         (shell (file-append shadow "/sbin/nologin"))
         (home-directory "/nonexistent")
         (create-home-directory? #f)
         (system? #t))))

(define (default-skeletons)
  "Return the default skeleton files for /etc/skel.  These files are copied by
'useradd' in the home directory of newly created user accounts."

  (let ((profile (plain-file "bash_profile" "\
# Honor per-interactive-shell startup file
if [ -f ~/.bashrc ]; then . ~/.bashrc; fi\n"))
        (bashrc  (plain-file "bashrc" "\
# Bash initialization for interactive non-login shells and
# for remote shells (info \"(bash) Bash Startup Files\").

# Export 'SHELL' to child processes.  Programs such as 'screen'
# honor it and otherwise use /bin/sh.
export SHELL

if [[ $- != *i* ]]
then
    # We are being invoked from a non-interactive shell.  If this
    # is an SSH session (as in \"ssh host command\"), source
    # /etc/profile so we get PATH and other essential variables.
    [[ -n \"$SSH_CLIENT\" ]] && source /etc/profile

    # Don't do anything else.
    return
fi

# Source the system-wide file.
source /etc/bashrc

# Adjust the prompt depending on whether we're in 'guix environment'.
if [ -n \"$GUIX_ENVIRONMENT\" ]
then
    PS1='\\u@\\h \\w [env]\\$ '
else
    PS1='\\u@\\h \\w\\$ '
fi
alias ls='ls -p --color=auto'
alias ll='ls -l'
alias grep='grep --color=auto'\n"))
        (zprofile    (plain-file "zprofile" "\
# Honor system-wide environment variables
source /etc/profile\n"))
        (xdefaults (plain-file "Xdefaults" "\
XTerm*utf8: always
XTerm*metaSendsEscape: true\n"))
        (gdbinit   (plain-file "gdbinit" "\
# Tell GDB where to look for separate debugging files.
set debug-file-directory ~/.guix-profile/lib/debug

# Authorize extensions found in the store, such as the
# pretty-printers of libstdc++.
set auto-load safe-path /gnu/store/*/lib\n")))
    `((".bash_profile" ,profile)
      (".bashrc" ,bashrc)
      ;; Zsh sources ~/.zprofile before ~/.zshrc, and it sources ~/.zlogin
      ;; after ~/.zshrc.  To avoid interfering with any customizations a user
      ;; may have made in their ~/.zshrc, put this in .zprofile, not .zlogin.
      (".zprofile" ,zprofile)
      (".nanorc" ,(plain-file "nanorc" "\
# Include all the syntax highlighting modules.
include /run/current-system/profile/share/nano/*.nanorc\n"))
      (".Xdefaults" ,xdefaults)
      (".guile" ,(plain-file "dot-guile"
                             "(cond ((false-if-exception (resolve-interface '(ice-9 readline)))
       =>
       (lambda (module)
         ;; Enable completion and input history at the REPL.
         ((module-ref module 'activate-readline))))
      (else
       (display \"Consider installing the 'guile-readline' package for
convenient interactive line editing and input history.\\n\\n\")))

      (unless (getenv \"INSIDE_EMACS\")
        (cond ((false-if-exception (resolve-interface '(ice-9 colorized)))
               =>
               (lambda (module)
                 ;; Enable completion and input history at the REPL.
                 ((module-ref module 'activate-colorized))))
              (else
               (display \"Consider installing the 'guile-colorized' package
for a colorful Guile experience.\\n\\n\"))))\n"))
      (".gdbinit" ,gdbinit))))

(define (skeleton-directory skeletons)
  "Return a directory containing SKELETONS, a list of name/derivation tuples."
  (computed-file "skel"
                 (with-imported-modules '((guix build utils))
                   #~(begin
                       (use-modules (ice-9 match)
                                    (guix build utils))

                       (mkdir #$output)
                       (chdir #$output)

                       ;; Note: copy the skeletons instead of symlinking
                       ;; them like 'file-union' does, because 'useradd'
                       ;; would just copy the symlinks as is.
                       (for-each (match-lambda
                                   ((target source)
                                    (copy-recursively source target)))
                                 '#$skeletons)
                       ;; Make nanorc respect XDG_CONFIG_HOME.
                       (when (file-exists? ".nanorc")
                         (mkdir-p ".config/nano")
                         (rename-file ".nanorc" ".config/nano/nanorc"))
                       #t))))

(define (assert-valid-users/groups users groups)
  "Raise an error if USERS refer to groups not listed in GROUPS."
  (let ((groups (list->set (map user-group-name groups))))
    (define (validate-supplementary-group user group)
      (unless (set-contains? groups group)
        (raise (condition
                (&message
                 (message
                  (format #f (G_ "supplementary group '~a' \
of user '~a' is undeclared")
                          group
                          (user-account-name user))))))))

    (for-each (lambda (user)
                (unless (set-contains? groups (user-account-group user))
                  (raise (condition
                          (&message
                           (message
                            (format #f (G_ "primary group '~a' \
of user '~a' is undeclared")
                                    (user-account-group user)
                                    (user-account-name user)))))))

                (for-each (cut validate-supplementary-group user <>)
                          (user-account-supplementary-groups user)))
              users)))

\f
;;;
;;; Service.
;;;

(define (user-group->gexp group)
  "Turn GROUP, a <user-group> object, into a list-valued gexp suitable for
'active-groups'."
  #~(list #$(user-group-name group)
          #$(user-group-password group)
          #$(user-group-id group)
          #$(user-group-system? group)))

(define (user-account->gexp account)
  "Turn ACCOUNT, a <user-account> object, into a list-valued gexp suitable for
'activate-users'."
  #~`(#$(user-account-name account)
      #$(user-account-uid account)
      #$(user-account-group account)
      #$(user-account-supplementary-groups account)
      #$(user-account-comment account)
      #$(user-account-home-directory account)
      #$(user-account-create-home-directory? account)
      ,#$(user-account-shell account)             ; this one is a gexp
      #$(user-account-password account)
      #$(user-account-system? account)))

(define (account-activation accounts+groups)
  "Return a gexp that activates ACCOUNTS+GROUPS, a list of <user-account> and
<user-group> objects.  Raise an error if a user account refers to a undefined
group."
  (define accounts
    (filter user-account? accounts+groups))

  (define user-specs
    (map user-account->gexp accounts))

  (define groups
    (filter user-group? accounts+groups))

  (define group-specs
    (map user-group->gexp groups))

  (assert-valid-users/groups accounts groups)

  ;; Add users and user groups.
  (with-imported-modules (source-module-closure '((gnu system accounts)))
    #~(begin
        (use-modules (gnu system accounts))

        (activate-users+groups (map sexp->user-account (list #$@user-specs))
                               (map sexp->user-group (list #$@group-specs))))))

(define (account-shepherd-service accounts+groups)
  "Return a Shepherd service that creates the home directories for the user
accounts among ACCOUNTS+GROUPS."
  (define accounts
    (filter user-account? accounts+groups))

  ;; Create home directories only once 'file-systems' is up.  This makes sure
  ;; they are created in the right place if /home lives on a separate
  ;; partition.
  ;;
  ;; XXX: We arrange for this service to stop right after it's done its job so
  ;; that 'guix system reconfigure' knows that it can reload it fearlessly
  ;; (and thus create new home directories).
  (list (shepherd-service
         (requirement '(file-systems))
         (provision '(user-homes))
         (one-shot? #t)
         (modules '((gnu build activation)
                    (gnu system accounts)))
         (start (with-imported-modules (source-module-closure
                                        '((gnu build activation)
                                          (gnu system accounts)))
                  #~(lambda ()
                      (activate-user-home
                       (map sexp->user-account
                            (list #$@(map user-account->gexp accounts))))
                      #t)))                       ;success
         (documentation "Create user home directories."))))

(define (shells-file shells)
  "Return a file-like object that builds a shell list for use as /etc/shells
based on SHELLS.  /etc/shells is used by xterm, polkit, and other programs."
  (computed-file "shells"
                 #~(begin
                     (use-modules (srfi srfi-1))

                     (define shells
                       (delete-duplicates (list #$@shells)))

                     (call-with-output-file #$output
                       (lambda (port)
                         (display "\
/bin/sh
/run/current-system/profile/bin/sh
/run/current-system/profile/bin/bash\n" port)
                         (for-each (lambda (shell)
                                     (display shell port)
                                     (newline port))
                                   shells))))))
(define (etc-files arguments)
  "Filter out among ARGUMENTS things corresponding to skeletons, and return
the /etc/skel directory for those."
  (let ((skels (filter pair? arguments))
        (users (filter user-account? arguments)))
    `(("skel" ,(skeleton-directory skels))
      ("shells" ,(shells-file (map user-account-shell users))))))

(define account-service-type
  (service-type (name 'account)

                ;; Concatenate <user-account>, <user-group>, and skeleton
                ;; lists.
                (compose concatenate)
                (extend append)

                (extensions
                 (list (service-extension activation-service-type
                                          account-activation)
                       (service-extension shepherd-root-service-type
                                          account-shepherd-service)
                       ;; Have 'user-processes' depend on 'user-homes' so that
                       ;; daemons start after their home directory has been
                       ;; created.
                       (service-extension user-processes-service-type
                                          (const '(user-homes)))
                       (service-extension etc-service-type
                                          etc-files)))
                (description
                 "Ensure the specified user accounts and groups exist, as well
as each account home directory.")))

(define (account-service accounts+groups skeletons)
  "Return a <service> that takes care of user accounts and user groups, with
ACCOUNTS+GROUPS as its initial list of accounts and groups."
  (service account-service-type
           (append skeletons accounts+groups)))

;;; shadow.scm ends here
Commit	Line	Data
0ded70f3	1	;;; GNU Guix --- Functional package management for GNU
1e728110	2	;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
ba2613bb	3	;;; Copyright © 2016 Alex Griffin <a@ajgrf.com>
ac75bd01	4	;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
f12bd0be	5	;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
0ded70f3 LC	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)
bacadb02	23	#:use-module (guix records)
b5f4e686	24	#:use-module (guix gexp)
e87f0591	25	#:use-module (guix store)
ae763b5b	26	#:use-module (guix modules)
0c09a306 LC	27	#:use-module (guix sets)
0c09a306 LC	28	#:use-module (guix ui)
f6f67b87	29	#:use-module (gnu system accounts)
0adfe95a	30	#:use-module (gnu services)
ae763b5b	31	#:use-module (gnu services shepherd)
7f239fd3 LC	32	#:use-module ((gnu system file-systems)
7f239fd3 LC	33	#:select (%tty-gid))
9de46ffb	34	#:use-module ((gnu packages admin)
d0c66871	35	#:select (shadow))
78ed0038	36	#:use-module (gnu packages bash)
0adfe95a	37	#:use-module (srfi srfi-1)
0c09a306 LC	38	#:use-module (srfi srfi-26)
	39	#:use-module (srfi srfi-34)
	40	#:use-module (srfi srfi-35)
bacadb02	41
f6f67b87 LC	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?
838d9a9d	55
f6f67b87 LC	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
773e956d	64	skeleton-directory
0c09a306	65	%base-groups
bf87f38a	66	%base-user-accounts
0adfe95a LC	67
	68	account-service-type
	69	account-service))
0ded70f3 LC	70
	71	;;; Commentary:
	72	;;;
	73	;;; Utilities for configuring the Shadow tool suite ('login', 'passwd', etc.)
	74	;;;
	75	;;; Code:
	76
f6f67b87 LC	77	;; Change the default shell used by new <user-account> records.
f6f67b87 LC	78	(default-shell (file-append bash "/bin/bash"))
0adfe95a	79
773e956d LC	80	(define %base-groups
773e956d LC	81	;; Default set of groups.
c8fa3426 LC	82	(let-syntax ((system-group (syntax-rules ()
	83	((_ args ...)
	84	(user-group (system? #t) args ...)))))
	85	(list (system-group (name "root") (id 0))
0adfe95a LC	86	(system-group (name "wheel")) ; root-like users
	87	(system-group (name "users")) ; normal users
	88	(system-group (name "nogroup")) ; for daemons etc.
773e956d	89
c8fa3426 LC	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"))
0adfe95a	95	(system-group (name "input")) ; input devices, from udev
c8fa3426 LC	96	(system-group (name "video"))
c8fa3426 LC	97	(system-group (name "audio"))
0adfe95a	98	(system-group (name "netdev")) ; used in avahi-dbus.conf
c8fa3426 LC	99	(system-group (name "lp"))
	100	(system-group (name "disk"))
	101	(system-group (name "floppy"))
	102	(system-group (name "cdrom"))
7f28bf9a	103	(system-group (name "tape"))
0adfe95a	104	(system-group (name "kvm"))))) ; for /dev/kvm
773e956d	105
bf87f38a LC	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")
357db1f9	113	(shell (file-append shadow "/sbin/nologin"))
2d94702f	114	(home-directory "/nonexistent")
d03db743	115	(create-home-directory? #f)
bf87f38a LC	116	(system? #t))))
bf87f38a LC	117
838d9a9d LC	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."
838d9a9d	121
e79467f6	122	(let ((profile (plain-file "bash_profile" "\
4e2a21d3 SB	123	# Honor per-interactive-shell startup file
4e2a21d3 SB	124	if [ -f ~/.bashrc ]; then . ~/.bashrc; fi\n"))
e79467f6	125	(bashrc (plain-file "bashrc" "\
9a10acc9 LC	126	# Bash initialization for interactive non-login shells and
	127	# for remote shells (info \"(bash) Bash Startup Files\").
	128
2f094a69 LC	129	# Export 'SHELL' to child processes. Programs such as 'screen'
	130	# honor it and otherwise use /bin/sh.
	131	export SHELL
	132
0ab59dd8	133	if [[ $- != i ]]
9a10acc9	134	then
0ab59dd8 MB	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
2c16be56 MB	139
	140	# Don't do anything else.
	141	return
9a10acc9 LC	142	fi
9a10acc9 LC	143
b19950a1 LC	144	# Source the system-wide file.
	145	source /etc/bashrc
	146
28de8d25 LC	147	# Adjust the prompt depending on whether we're in 'guix environment'.
	148	if [ -n \"$GUIX_ENVIRONMENT\" ]
	149	then
ba2613bb	150	PS1='\\u@\\h \\w [env]\\$ '
28de8d25	151	else
ba2613bb	152	PS1='\\u@\\h \\w\\$ '
28de8d25	153	fi
142869f8	154	alias ls='ls -p --color=auto'
138fe411	155	alias ll='ls -l'
142869f8	156	alias grep='grep --color=auto'\n"))
2f4d4358	157	(zprofile (plain-file "zprofile" "\
02f707c5 SB	158	# Honor system-wide environment variables
02f707c5 SB	159	source /etc/profile\n"))
e79467f6	160	(xdefaults (plain-file "Xdefaults" "\
838d9a9d LC	161	XTerm*utf8: always
838d9a9d LC	162	XTerm*metaSendsEscape: true\n"))
e79467f6	163	(gdbinit (plain-file "gdbinit" "\
838d9a9d	164	# Tell GDB where to look for separate debugging files.
b0de7fdb LC	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")))
e79467f6 LC	170	`((".bash_profile" ,profile)
e79467f6 LC	171	(".bashrc" ,bashrc)
2f4d4358 CM	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)
49d20d51	176	(".nanorc" ,(plain-file "nanorc" "\
76a77cca LC	177	# Include all the syntax highlighting modules.
76a77cca LC	178	include /run/current-system/profile/share/nano/*.nanorc\n"))
e79467f6	179	(".Xdefaults" ,xdefaults)
a84ea219	180	(".guile" ,(plain-file "dot-guile"
2ba2c98d LC	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
10df28d7 LC	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"))
e79467f6	199	(".gdbinit" ,gdbinit))))
838d9a9d LC	200
838d9a9d LC	201	(define (skeleton-directory skeletons)
e79467f6 LC	202	"Return a directory containing SKELETONS, a list of name/derivation tuples."
e79467f6 LC	203	(computed-file "skel"
4ee96a79 LC	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)
f12bd0be EF	219	;; Make nanorc respect XDG_CONFIG_HOME.
	220	(when (file-exists? ".nanorc")
	221	(mkdir-p ".config/nano")
	222	(rename-file ".nanorc" ".config/nano/nanorc"))
4ee96a79	223	#t))))
838d9a9d	224
0c09a306 LC	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
69daee23	233	(format #f (G_ "supplementary group '~a' \
0c09a306 LC	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
69daee23	243	(format #f (G_ "primary group '~a' \
0c09a306 LC	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
0adfe95a LC	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)
eb56ee02	274	#$(user-account-create-home-directory? account)
0adfe95a LC	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.
6061d015 LC	298	(with-imported-modules (source-module-closure '((gnu system accounts)))
	299	#~(begin
	300	(use-modules (gnu system accounts))
	301
6061d015 LC	302	(activate-users+groups (map sexp->user-account (list #$@user-specs))
6061d015 LC	303	(map sexp->user-group (list #$@group-specs))))))
0adfe95a	304
ae763b5b LC	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
1e728110	317	;; (and thus create new home directories).
ae763b5b LC	318	(list (shepherd-service
	319	(requirement '(file-systems))
	320	(provision '(user-homes))
051b279f	321	(one-shot? #t)
6061d015 LC	322	(modules '((gnu build activation)
6061d015 LC	323	(gnu system accounts)))
ae763b5b	324	(start (with-imported-modules (source-module-closure
6061d015 LC	325	'((gnu build activation)
6061d015 LC	326	(gnu system accounts)))
ae763b5b LC	327	#~(lambda ()
ae763b5b LC	328	(activate-user-home
6061d015 LC	329	(map sexp->user-account
6061d015 LC	330	(list #$@(map user-account->gexp accounts))))
051b279f	331	#t))) ;success
ae763b5b LC	332	(documentation "Create user home directories."))))
ae763b5b LC	333
21059b26 LC	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)
0adfe95a LC	355	"Filter out among ARGUMENTS things corresponding to skeletons, and return
0adfe95a LC	356	the /etc/skel directory for those."
21059b26 LC	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))))))
0adfe95a LC	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)
ae763b5b LC	373	(service-extension shepherd-root-service-type
ae763b5b LC	374	account-shepherd-service)
1e728110 LC	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)))
0adfe95a	380	(service-extension etc-service-type
dd0804c6 LC	381	etc-files)))
	382	(description
	383	"Ensure the specified user accounts and groups exist, as well
	384	as each account home directory.")))
0adfe95a LC	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
0ded70f3	392	;;; shadow.scm ends here