1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
|
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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 monads)
#:use-module (guix sets)
#:use-module (guix ui)
#:use-module ((gnu system file-systems)
#:select (%tty-gid))
#:use-module ((gnu packages admin)
#:select (shadow))
#:use-module (gnu packages bash)
#:use-module (gnu packages guile-wm)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#: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-shell
user-account-system?
user-group
user-group?
user-group-name
user-group-password
user-group-id
user-group-system?
default-skeletons
skeleton-directory
%base-groups
assert-valid-users/groups))
;;; Commentary:
;;;
;;; Utilities for configuring the Shadow tool suite ('login', 'passwd', etc.)
;;;
;;; Code:
(define-record-type* <user-account>
user-account make-user-account
user-account?
(name user-account-name)
(password user-account-password (default #f))
(uid user-account-uid (default #f))
(group user-account-group) ; number | string
(supplementary-groups user-account-supplementary-groups
(default '())) ; list of strings
(comment user-account-comment (default ""))
(home-directory user-account-home-directory)
(shell user-account-shell ; gexp
(default #~(string-append #$bash "/bin/bash")))
(system? user-account-system? ; Boolean
(default #f)))
(define-record-type* <user-group>
user-group make-user-group
user-group?
(name user-group-name)
(password user-group-password (default #f))
(id user-group-id (default #f))
(system? user-group-system? ; Boolean
(default #f)))
(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 (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."
(define copy-guile-wm
#~(begin
(use-modules (guix build utils))
(copy-file (car (find-files #$guile-wm "wm-init-sample.scm"))
#$output)))
(mlet %store-monad ((profile (text-file "bash_profile" "\
# Honor per-interactive-shell startup file
if [ -f ~/.bashrc ]; then . ~/.bashrc; fi\n"))
(bashrc (text-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 [ -n \"$SSH_CLIENT\" -a -z \"`type -P cat`\" ]
then
# We are being invoked from a non-interactive SSH session
# (as in \"ssh host command\") but 'cat' cannot be found
# in $PATH. Source /etc/profile so we get $PATH and other
# essential variables.
source /etc/profile
fi
PS1='\\u@\\h \\w\\$ '
alias ls='ls -p --color'
alias ll='ls -l'\n"))
(zlogin (text-file "zlogin" "\
# Honor system-wide environment variables
source /etc/profile\n"))
(guile-wm (gexp->derivation "guile-wm" copy-guile-wm
#:modules
'((guix build utils))))
(xdefaults (text-file "Xdefaults" "\
XTerm*utf8: always
XTerm*metaSendsEscape: true\n"))
(gdbinit (text-file "gdbinit" "\
# Tell GDB where to look for separate debugging files.
set debug-file-directory ~/.guix-profile/lib/debug\n")))
(return `((".bash_profile" ,profile)
(".bashrc" ,bashrc)
(".zlogin" ,zlogin)
(".Xdefaults" ,xdefaults)
(".guile-wm" ,guile-wm)
(".gdbinit" ,gdbinit)))))
(define (skeleton-directory skeletons)
"Return a directory containing SKELETONS, a list of name/derivation pairs."
(gexp->derivation "skel"
#~(begin
(use-modules (ice-9 match))
(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-file source target)))
'#$skeletons)
#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 (_ "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 (_ "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)))
;;; shadow.scm ends here
|
