shadow.scm 14 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382
  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2013, 2014, 2015, 2016, 2017 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. (define-module (gnu system shadow)
  20. #:use-module (guix records)
  21. #:use-module (guix gexp)
  22. #:use-module (guix store)
  23. #:use-module (guix modules)
  24. #:use-module (guix sets)
  25. #:use-module (guix ui)
  26. #:use-module (gnu services)
  27. #:use-module (gnu services shepherd)
  28. #:use-module ((gnu system file-systems)
  29. #:select (%tty-gid))
  30. #:use-module ((gnu packages admin)
  31. #:select (shadow))
  32. #:use-module (gnu packages bash)
  33. #:use-module (gnu packages guile-wm)
  34. #:use-module (srfi srfi-1)
  35. #:use-module (srfi srfi-26)
  36. #:use-module (srfi srfi-34)
  37. #:use-module (srfi srfi-35)
  38. #:export (user-account
  39. user-account?
  40. user-account-name
  41. user-account-password
  42. user-account-uid
  43. user-account-group
  44. user-account-supplementary-groups
  45. user-account-comment
  46. user-account-home-directory
  47. user-account-create-home-directory?
  48. user-account-shell
  49. user-account-system?
  50. user-group
  51. user-group?
  52. user-group-name
  53. user-group-password
  54. user-group-id
  55. user-group-system?
  56. default-skeletons
  57. skeleton-directory
  58. %base-groups
  59. %base-user-accounts
  60. account-service-type
  61. account-service))
  62. ;;; Commentary:
  63. ;;;
  64. ;;; Utilities for configuring the Shadow tool suite ('login', 'passwd', etc.)
  65. ;;;
  66. ;;; Code:
  67. (define-record-type* <user-account>
  68. user-account make-user-account
  69. user-account?
  70. (name user-account-name)
  71. (password user-account-password (default #f))
  72. (uid user-account-uid (default #f))
  73. (group user-account-group) ; number | string
  74. (supplementary-groups user-account-supplementary-groups
  75. (default '())) ; list of strings
  76. (comment user-account-comment (default ""))
  77. (home-directory user-account-home-directory)
  78. (create-home-directory? user-account-create-home-directory? ;Boolean
  79. (default #t))
  80. (shell user-account-shell ; gexp
  81. (default (file-append bash "/bin/bash")))
  82. (system? user-account-system? ; Boolean
  83. (default #f)))
  84. (define-record-type* <user-group>
  85. user-group make-user-group
  86. user-group?
  87. (name user-group-name)
  88. (password user-group-password (default #f))
  89. (id user-group-id (default #f))
  90. (system? user-group-system? ; Boolean
  91. (default #f)))
  92. (define %base-groups
  93. ;; Default set of groups.
  94. (let-syntax ((system-group (syntax-rules ()
  95. ((_ args ...)
  96. (user-group (system? #t) args ...)))))
  97. (list (system-group (name "root") (id 0))
  98. (system-group (name "wheel")) ; root-like users
  99. (system-group (name "users")) ; normal users
  100. (system-group (name "nogroup")) ; for daemons etc.
  101. ;; The following groups are conventionally used by things like udev to
  102. ;; control access to hardware devices.
  103. (system-group (name "tty") (id %tty-gid))
  104. (system-group (name "dialout"))
  105. (system-group (name "kmem"))
  106. (system-group (name "input")) ; input devices, from udev
  107. (system-group (name "video"))
  108. (system-group (name "audio"))
  109. (system-group (name "netdev")) ; used in avahi-dbus.conf
  110. (system-group (name "lp"))
  111. (system-group (name "disk"))
  112. (system-group (name "floppy"))
  113. (system-group (name "cdrom"))
  114. (system-group (name "tape"))
  115. (system-group (name "kvm"))))) ; for /dev/kvm
  116. (define %base-user-accounts
  117. ;; List of standard user accounts. Note that "root" is a special case, so
  118. ;; it's not listed here.
  119. (list (user-account
  120. (name "nobody")
  121. (uid 65534)
  122. (group "nogroup")
  123. (shell (file-append shadow "/sbin/nologin"))
  124. (home-directory "/nonexistent")
  125. (create-home-directory? #f)
  126. (system? #t))))
  127. (define (default-skeletons)
  128. "Return the default skeleton files for /etc/skel. These files are copied by
  129. 'useradd' in the home directory of newly created user accounts."
  130. (define copy-guile-wm
  131. (with-imported-modules '((guix build utils))
  132. #~(begin
  133. (use-modules (guix build utils))
  134. (copy-file (car (find-files #+guile-wm "wm-init-sample.scm"))
  135. #$output))))
  136. (let ((profile (plain-file "bash_profile" "\
  137. # Honor per-interactive-shell startup file
  138. if [ -f ~/.bashrc ]; then . ~/.bashrc; fi\n"))
  139. (bashrc (plain-file "bashrc" "\
  140. # Bash initialization for interactive non-login shells and
  141. # for remote shells (info \"(bash) Bash Startup Files\").
  142. # Export 'SHELL' to child processes. Programs such as 'screen'
  143. # honor it and otherwise use /bin/sh.
  144. export SHELL
  145. if [[ $- != *i* ]]
  146. then
  147. # We are being invoked from a non-interactive shell. If this
  148. # is an SSH session (as in \"ssh host command\"), source
  149. # /etc/profile so we get PATH and other essential variables.
  150. [[ -n \"$SSH_CLIENT\" ]] && source /etc/profile
  151. # Don't do anything else.
  152. return
  153. fi
  154. # Adjust the prompt depending on whether we're in 'guix environment'.
  155. if [ -n \"$GUIX_ENVIRONMENT\" ]
  156. then
  157. PS1='\\u@\\h \\w [env]\\$ '
  158. else
  159. PS1='\\u@\\h \\w\\$ '
  160. fi
  161. alias ls='ls -p --color'
  162. alias ll='ls -l'
  163. alias grep='grep --color'\n"))
  164. (zlogin (plain-file "zlogin" "\
  165. # Honor system-wide environment variables
  166. source /etc/profile\n"))
  167. (guile-wm (computed-file "guile-wm" copy-guile-wm))
  168. (xdefaults (plain-file "Xdefaults" "\
  169. XTerm*utf8: always
  170. XTerm*metaSendsEscape: true\n"))
  171. (gdbinit (plain-file "gdbinit" "\
  172. # Tell GDB where to look for separate debugging files.
  173. set debug-file-directory ~/.guix-profile/lib/debug\n")))
  174. `((".bash_profile" ,profile)
  175. (".bashrc" ,bashrc)
  176. (".zlogin" ,zlogin)
  177. (".Xdefaults" ,xdefaults)
  178. (".guile" ,(plain-file "dot-guile"
  179. (string-append
  180. "(use-modules (ice-9 readline))\n\n"
  181. ";; Enable completion at the REPL.\n"
  182. "(activate-readline)\n")))
  183. (".guile-wm" ,guile-wm)
  184. (".gdbinit" ,gdbinit))))
  185. (define (skeleton-directory skeletons)
  186. "Return a directory containing SKELETONS, a list of name/derivation tuples."
  187. (computed-file "skel"
  188. (with-imported-modules '((guix build utils))
  189. #~(begin
  190. (use-modules (ice-9 match)
  191. (guix build utils))
  192. (mkdir #$output)
  193. (chdir #$output)
  194. ;; Note: copy the skeletons instead of symlinking
  195. ;; them like 'file-union' does, because 'useradd'
  196. ;; would just copy the symlinks as is.
  197. (for-each (match-lambda
  198. ((target source)
  199. (copy-recursively source target)))
  200. '#$skeletons)
  201. #t))))
  202. (define (assert-valid-users/groups users groups)
  203. "Raise an error if USERS refer to groups not listed in GROUPS."
  204. (let ((groups (list->set (map user-group-name groups))))
  205. (define (validate-supplementary-group user group)
  206. (unless (set-contains? groups group)
  207. (raise (condition
  208. (&message
  209. (message
  210. (format #f (G_ "supplementary group '~a' \
  211. of user '~a' is undeclared")
  212. group
  213. (user-account-name user))))))))
  214. (for-each (lambda (user)
  215. (unless (set-contains? groups (user-account-group user))
  216. (raise (condition
  217. (&message
  218. (message
  219. (format #f (G_ "primary group '~a' \
  220. of user '~a' is undeclared")
  221. (user-account-group user)
  222. (user-account-name user)))))))
  223. (for-each (cut validate-supplementary-group user <>)
  224. (user-account-supplementary-groups user)))
  225. users)))
  226. ;;;
  227. ;;; Service.
  228. ;;;
  229. (define (user-group->gexp group)
  230. "Turn GROUP, a <user-group> object, into a list-valued gexp suitable for
  231. 'active-groups'."
  232. #~(list #$(user-group-name group)
  233. #$(user-group-password group)
  234. #$(user-group-id group)
  235. #$(user-group-system? group)))
  236. (define (user-account->gexp account)
  237. "Turn ACCOUNT, a <user-account> object, into a list-valued gexp suitable for
  238. 'activate-users'."
  239. #~`(#$(user-account-name account)
  240. #$(user-account-uid account)
  241. #$(user-account-group account)
  242. #$(user-account-supplementary-groups account)
  243. #$(user-account-comment account)
  244. #$(user-account-home-directory account)
  245. #$(user-account-create-home-directory? account)
  246. ,#$(user-account-shell account) ; this one is a gexp
  247. #$(user-account-password account)
  248. #$(user-account-system? account)))
  249. (define (account-activation accounts+groups)
  250. "Return a gexp that activates ACCOUNTS+GROUPS, a list of <user-account> and
  251. <user-group> objects. Raise an error if a user account refers to a undefined
  252. group."
  253. (define accounts
  254. (filter user-account? accounts+groups))
  255. (define user-specs
  256. (map user-account->gexp accounts))
  257. (define groups
  258. (filter user-group? accounts+groups))
  259. (define group-specs
  260. (map user-group->gexp groups))
  261. (assert-valid-users/groups accounts groups)
  262. ;; Add users and user groups.
  263. #~(begin
  264. (setenv "PATH"
  265. (string-append #$(@ (gnu packages admin) shadow) "/sbin"))
  266. (activate-users+groups (list #$@user-specs)
  267. (list #$@group-specs))))
  268. (define (account-shepherd-service accounts+groups)
  269. "Return a Shepherd service that creates the home directories for the user
  270. accounts among ACCOUNTS+GROUPS."
  271. (define accounts
  272. (filter user-account? accounts+groups))
  273. ;; Create home directories only once 'file-systems' is up. This makes sure
  274. ;; they are created in the right place if /home lives on a separate
  275. ;; partition.
  276. ;;
  277. ;; XXX: We arrange for this service to stop right after it's done its job so
  278. ;; that 'guix system reconfigure' knows that it can reload it fearlessly
  279. ;; (and thus create new home directories). The cost of this hack is that
  280. ;; there's a small window during which first-time logins could happen before
  281. ;; the home directory has been created.
  282. (list (shepherd-service
  283. (requirement '(file-systems))
  284. (provision '(user-homes))
  285. (modules '((gnu build activation)))
  286. (start (with-imported-modules (source-module-closure
  287. '((gnu build activation)))
  288. #~(lambda ()
  289. (activate-user-home
  290. (list #$@(map user-account->gexp accounts)))
  291. #f))) ;stop
  292. (stop #~(const #f))
  293. (respawn? #f)
  294. (documentation "Create user home directories."))))
  295. (define (shells-file shells)
  296. "Return a file-like object that builds a shell list for use as /etc/shells
  297. based on SHELLS. /etc/shells is used by xterm, polkit, and other programs."
  298. (computed-file "shells"
  299. #~(begin
  300. (use-modules (srfi srfi-1))
  301. (define shells
  302. (delete-duplicates (list #$@shells)))
  303. (call-with-output-file #$output
  304. (lambda (port)
  305. (display "\
  306. /bin/sh
  307. /run/current-system/profile/bin/sh
  308. /run/current-system/profile/bin/bash\n" port)
  309. (for-each (lambda (shell)
  310. (display shell port)
  311. (newline port))
  312. shells))))))
  313. (define (etc-files arguments)
  314. "Filter out among ARGUMENTS things corresponding to skeletons, and return
  315. the /etc/skel directory for those."
  316. (let ((skels (filter pair? arguments))
  317. (users (filter user-account? arguments)))
  318. `(("skel" ,(skeleton-directory skels))
  319. ("shells" ,(shells-file (map user-account-shell users))))))
  320. (define account-service-type
  321. (service-type (name 'account)
  322. ;; Concatenate <user-account>, <user-group>, and skeleton
  323. ;; lists.
  324. (compose concatenate)
  325. (extend append)
  326. (extensions
  327. (list (service-extension activation-service-type
  328. account-activation)
  329. (service-extension shepherd-root-service-type
  330. account-shepherd-service)
  331. (service-extension etc-service-type
  332. etc-files)))))
  333. (define (account-service accounts+groups skeletons)
  334. "Return a <service> that takes care of user accounts and user groups, with
  335. ACCOUNTS+GROUPS as its initial list of accounts and groups."
  336. (service account-service-type
  337. (append skeletons accounts+groups)))
  338. ;;; shadow.scm ends here