Commit | Line | Data |
---|---|---|
0ea62e84 MC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2019, 2020 L p R n d n <guix@lprndn.info> | |
3 | ;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net> | |
4 | ;;; Copyright © 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com> | |
5 | ;;; | |
6 | ;;; This file is part of GNU Guix. | |
7 | ;;; | |
8 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
9 | ;;; under the terms of the GNU General Public License as published by | |
10 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
11 | ;;; your option) any later version. | |
12 | ;;; | |
13 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
14 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | ;;; GNU General Public License for more details. | |
17 | ;;; | |
18 | ;;; You should have received a copy of the GNU General Public License | |
19 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
20 | ||
21 | (define-module (gnu services lightdm) | |
22 | #:use-module (gnu artwork) | |
23 | #:use-module (gnu packages admin) | |
24 | #:use-module (gnu packages display-managers) | |
25 | #:use-module (gnu packages freedesktop) | |
26 | #:use-module (gnu packages gnome) | |
27 | #:use-module (gnu packages vnc) | |
28 | #:use-module (gnu packages xorg) | |
29 | #:use-module (gnu services configuration) | |
30 | #:use-module (gnu services dbus) | |
31 | #:use-module (gnu services desktop) | |
32 | #:use-module (gnu services shepherd) | |
33 | #:use-module (gnu services xorg) | |
34 | #:use-module (gnu services) | |
35 | #:use-module (gnu system pam) | |
36 | #:use-module (gnu system shadow) | |
37 | #:use-module (guix diagnostics) | |
38 | #:use-module (guix gexp) | |
39 | #:use-module (guix i18n) | |
40 | #:use-module (guix records) | |
41 | #:use-module (ice-9 format) | |
42 | #:use-module (ice-9 match) | |
43 | #:use-module (oop goops) | |
44 | #:use-module (srfi srfi-1) | |
45 | #:use-module (srfi srfi-26) | |
46 | #:export (lightdm-seat-configuration | |
47 | lightdm-seat-configuration? | |
48 | lightdm-seat-configuration-name | |
49 | lightdm-seat-configuration-type | |
50 | lightdm-seat-configuration-user-session | |
51 | lightdm-seat-configuration-autologin-user | |
52 | lightdm-seat-configuration-greeter-session | |
53 | lightdm-seat-configuration-xserver-command | |
54 | lightdm-seat-configuration-session-wrapper | |
55 | lightdm-seat-configuration-extra-config | |
56 | ||
57 | lightdm-gtk-greeter-configuration | |
58 | lightdm-gtk-greeter-configuration? | |
59 | lightdm-gtk-greeter-configuration-lightdm-gtk-greeter | |
60 | lightdm-gtk-greeter-configuration-assets | |
61 | lightdm-gtk-greeter-configuration-theme-name | |
62 | lightdm-gtk-greeter-configuration-icon-theme-name | |
63 | lightdm-gtk-greeter-configuration-cursor-theme-name | |
64 | lightdm-gtk-greeter-configuration-allow-debug | |
65 | lightdm-gtk-greeter-configuration-background | |
66 | lightdm-gtk-greeter-configuration-a11y-states | |
67 | lightdm-gtk-greeter-configuration-reader | |
68 | lightdm-gtk-greeter-configuration-extra-config | |
69 | ||
70 | lightdm-configuration | |
71 | lightdm-configuration? | |
72 | lightdm-configuration-lightdm | |
73 | lightdm-configuration-allow-empty-passwords? | |
74 | lightdm-configuration-xorg-configuration | |
75 | lightdm-configuration-greeters | |
76 | lightdm-configuration-seats | |
77 | lightdm-configuration-xdmcp? | |
78 | lightdm-configuration-xdmcp-listen-address | |
79 | lightdm-configuration-vnc-server? | |
80 | lightdm-configuration-vnc-server-command | |
81 | lightdm-configuration-vnc-server-listen-address | |
82 | lightdm-configuration-vnc-server-port | |
83 | lightdm-configuration-extra-config | |
84 | ||
85 | lightdm-service-type)) | |
86 | ||
87 | ;;; | |
88 | ;;; Greeters. | |
89 | ;;; | |
90 | ||
91 | (define list-of-file-likes? | |
92 | (list-of file-like?)) | |
93 | ||
94 | (define %a11y-states '(contrast font keyboard reader)) | |
95 | ||
96 | (define (a11y-state? value) | |
97 | (memq value %a11y-states)) | |
98 | ||
99 | (define list-of-a11y-states? | |
100 | (list-of a11y-state?)) | |
101 | ||
102 | (define-maybe boolean) | |
103 | ||
104 | (define (serialize-boolean name value) | |
105 | (define (strip-trailing-? name) | |
106 | ;; field? -> field | |
107 | (let ((str (symbol->string name))) | |
108 | (if (string-suffix? "?" str) | |
109 | (string-drop-right str 1) | |
110 | str))) | |
111 | (format #f "~a=~:[false~;true~]~%" (strip-trailing-? name) value)) | |
112 | ||
113 | (define-maybe file-like) | |
114 | ||
115 | (define (serialize-file-like name value) | |
116 | #~(format #f "~a=~a~%" '#$name #$value)) | |
117 | ||
118 | (define (serialize-list-of-a11y-states name value) | |
119 | (format #f "~a=~a~%" name (string-join (map symbol->string value) ";"))) | |
120 | ||
121 | (define (serialize-string name value) | |
122 | (format #f "~a=~a~%" name value)) | |
123 | ||
124 | (define (serialize-number name value) | |
125 | (format #f "~a=~a~%" name value)) | |
126 | ||
127 | (define (serialize-list-of-strings _ value) | |
128 | (string-join value "\n")) | |
129 | ||
130 | (define-configuration lightdm-gtk-greeter-configuration | |
131 | (lightdm-gtk-greeter | |
132 | (file-like lightdm-gtk-greeter) | |
133 | "The lightdm-gtk-greeter package to use." | |
134 | empty-serializer) | |
135 | (assets | |
136 | (list-of-file-likes (list adwaita-icon-theme | |
137 | gnome-themes-extra | |
138 | ;; FIXME: hicolor-icon-theme should be in the | |
139 | ;; packages of the desktop templates. | |
140 | hicolor-icon-theme)) | |
141 | "The list of packages complementing the greeter, such as package providing | |
142 | icon themes." | |
143 | empty-serializer) | |
144 | (theme-name | |
145 | (string "Adwaita") | |
146 | "The name of the theme to use.") | |
147 | (icon-theme-name | |
148 | (string "Adwaita") | |
149 | "The name of the icon theme to use.") | |
150 | (cursor-theme-name | |
151 | (string "Adwaita") | |
152 | "The name of the cursor theme to use.") | |
153 | (cursor-theme-size | |
154 | (number 16) | |
155 | "The size to use for the the cursor theme.") | |
156 | (allow-debugging? | |
157 | maybe-boolean | |
158 | "Set to #t to enable debug log level.") | |
159 | (background | |
160 | (file-like (file-append %artwork-repository | |
161 | "/backgrounds/guix-checkered-16-9.svg")) | |
162 | "The background image to use.") | |
163 | ;; FIXME: This should be enabled by default, but it currently doesn't work, | |
164 | ;; failing to connect to D-Bus, causing the login to fail. | |
165 | (at-spi-enabled? | |
166 | (boolean #f) | |
167 | "Enable accessibility support through the Assistive Technology Service | |
168 | Provider Interface (AT-SPI).") | |
169 | (a11y-states | |
170 | (list-of-a11y-states %a11y-states) | |
171 | "The accessibility features to enable, given as list of symbols.") | |
172 | (reader | |
173 | maybe-file-like | |
174 | "The command to use to launch a screen reader.") | |
175 | (extra-config | |
176 | (list-of-strings '()) | |
177 | "Extra configuration values to append to the LightDM GTK Greeter | |
178 | configuration file.")) | |
179 | ||
180 | (define (strip-class-name-brackets name) | |
181 | "Remove the '<<' and '>>' brackets from NAME, a symbol." | |
182 | (let ((name* (symbol->string name))) | |
183 | (if (and (string-prefix? "<<" name*) | |
184 | (string-suffix? ">>" name*)) | |
185 | (string->symbol (string-drop (string-drop-right name* 2) 2)) | |
186 | (error "unexpected class name" name*)))) | |
187 | ||
188 | (define (config->name config) | |
189 | "Return the constructor name (a symbol) from CONFIG." | |
190 | (strip-class-name-brackets (class-name (class-of config)))) | |
191 | ||
192 | (define (greeter-configuration->greeter-fields config) | |
193 | "Return the fields of CONFIG, a greeter configuration." | |
194 | (match config | |
195 | ;; Note: register any new greeter configuration here. | |
196 | ((? lightdm-gtk-greeter-configuration?) | |
197 | lightdm-gtk-greeter-configuration-fields))) | |
198 | ||
199 | (define (greeter-configuration->packages config) | |
200 | "Return the list of greeter packages, including assets, used by CONFIG, a | |
201 | greeter configuration." | |
202 | (match config | |
203 | ;; Note: register any new greeter configuration here. | |
204 | ((? lightdm-gtk-greeter-configuration?) | |
205 | (cons (lightdm-gtk-greeter-configuration-lightdm-gtk-greeter config) | |
206 | (lightdm-gtk-greeter-configuration-assets config))))) | |
207 | ||
208 | ;;; TODO: Implement directly in (gnu services configuration), perhaps by | |
209 | ;;; making the FIELDS argument optional. | |
210 | (define (serialize-configuration* config) | |
211 | "Like `serialize-configuration', but not requiring to provide a FIELDS | |
212 | argument." | |
213 | (define fields (greeter-configuration->greeter-fields config)) | |
214 | (serialize-configuration config fields)) | |
215 | ||
216 | (define (greeter-configuration->conf-name config) | |
217 | "Return the file name of CONFIG, a greeter configuration." | |
218 | (format #f "~a.conf" (greeter-configuration->greeter-session config))) | |
219 | ||
220 | (define (greeter-configuration->file config) | |
221 | "Serialize CONFIG into a file under the output directory, so that it can be | |
222 | easily added to XDG_CONF_DIRS." | |
223 | (computed-file | |
224 | (greeter-configuration->conf-name config) | |
225 | #~(begin | |
226 | (call-with-output-file #$output | |
227 | (lambda (port) | |
228 | (format port (string-append | |
229 | "[greeter]\n" | |
230 | #$(serialize-configuration* config)))))))) | |
231 | ||
232 | \f | |
233 | ;;; | |
234 | ;;; Seats. | |
235 | ;;; | |
236 | ||
237 | (define seat-name? string?) | |
238 | ||
239 | (define (serialize-seat-name _ value) | |
240 | (format #f "[Seat:~a]~%" value)) | |
241 | ||
242 | (define (seat-type? type) | |
243 | (memq type '(local xremote))) | |
244 | ||
245 | (define (serialize-seat-type name value) | |
246 | (format #f "~a=~a~%" name value)) | |
247 | ||
248 | (define-maybe seat-type) | |
249 | ||
250 | (define (greeter-session? value) | |
251 | (memq value '(lightdm-gtk-greeter))) | |
252 | ||
253 | (define (serialize-greeter-session name value) | |
254 | (format #f "~a=~a~%" name value)) | |
255 | ||
256 | (define-maybe greeter-session) | |
257 | ||
258 | (define-maybe string) | |
259 | ||
260 | ;;; Note: all the fields except for the seat name should be 'maybe's, since | |
261 | ;;; the real default value is set by the %lightdm-seat-default define later, | |
262 | ;;; and this avoids repeating ourselves in the serialized configuration file. | |
263 | (define-configuration lightdm-seat-configuration | |
264 | (name | |
265 | seat-name | |
266 | "The name of the seat. An asterisk (*) can be used in the name | |
267 | to apply the seat configuration to all the seat names it matches.") | |
268 | (user-session | |
269 | maybe-string | |
270 | "The session to use by default. The session name must be provided as a | |
271 | lowercase string, such as @code{\"gnome\"}, @code{\"ratpoison\"}, etc.") | |
272 | (type | |
273 | (seat-type 'local) | |
274 | "The type of the seat, either the @code{local} or @code{xremote} symbol.") | |
275 | (autologin-user | |
276 | maybe-string | |
277 | "The username to automatically log in with by default.") | |
278 | (greeter-session | |
279 | (greeter-session 'lightdm-gtk-greeter) | |
280 | "The greeter session to use, specified as a symbol. Currently, only | |
281 | @code{lightdm-gtk-greeter} is supported.") | |
282 | ;; Note: xserver-command must be lazily computed, so that it can be | |
283 | ;; overridden via 'lightdm-configuration-xorg-configuration'. | |
284 | (xserver-command | |
285 | maybe-file-like | |
286 | "The Xorg server command to run.") | |
287 | (session-wrapper | |
288 | (file-like (xinitrc)) | |
289 | "The xinitrc session wrapper to use.") | |
290 | (extra-config | |
291 | (list-of-strings '()) | |
292 | "Extra configuration values to append to the seat configuration section.")) | |
293 | ||
294 | (define (greeter-session->greater-configuration-pred identifier) | |
295 | "Return the predicate to check if a configuration is of the type specifying | |
296 | a greeter identified by IDENTIFIER." | |
297 | (match identifier | |
298 | ;; Note: register any new greeter identifier here. | |
299 | ('lightdm-gtk-greeter | |
300 | lightdm-gtk-greeter-configuration?))) | |
301 | ||
302 | (define (greeter-configuration->greeter-session config) | |
303 | "Given CONFIG, a greeter configuration object, return its identifier, | |
304 | a symbol." | |
305 | (let ((suffix "-configuration") | |
306 | (greeter-conf-name (config->name config))) | |
307 | (string->symbol (string-drop-right (symbol->string greeter-conf-name) | |
308 | (string-length suffix))))) | |
309 | ||
310 | (define list-of-seat-configurations? | |
311 | (list-of lightdm-seat-configuration?)) | |
312 | ||
313 | \f | |
314 | ;;; | |
315 | ;;; LightDM. | |
316 | ;;; | |
317 | ||
318 | (define (greeter-configuration? config) | |
319 | (or (lightdm-gtk-greeter-configuration? config) | |
320 | ;; Note: register any new greeter configuration here. | |
321 | )) | |
322 | ||
323 | (define (list-of-greeter-configurations? greeter-configs) | |
324 | (and ((list-of greeter-configuration?) greeter-configs) | |
325 | ;; Greeter configurations must also not be provided more than once. | |
326 | (let* ((types (map (cut (compose class-name class-of) <>) | |
327 | greeter-configs)) | |
328 | (dupes (filter (lambda (type) | |
329 | (< 1 (count (cut eq? type <>) types))) | |
330 | types))) | |
331 | (unless (null? dupes) | |
332 | (leave (G_ "duplicate greeter configurations: ~a~%") dupes))))) | |
333 | ||
334 | (define-configuration/no-serialization lightdm-configuration | |
335 | (lightdm | |
336 | (file-like lightdm) | |
337 | "The lightdm package to use.") | |
338 | (allow-empty-passwords? | |
339 | (boolean #f) | |
340 | "Whether users not having a password set can login.") | |
341 | (debug? | |
342 | (boolean #f) | |
343 | "Enable verbose output.") | |
344 | (xorg-configuration | |
345 | (xorg-configuration (xorg-configuration)) | |
346 | "The default Xorg server configuration to use to generate the Xorg server | |
347 | start script. It can be refined per seat via the @code{xserver-command} of | |
348 | the @code{<lightdm-seat-configuration>} record, if desired.") | |
349 | (greeters | |
350 | (list-of-greeter-configurations (list (lightdm-gtk-greeter-configuration))) | |
351 | "The LightDM greeter configurations specifying the greeters to use.") | |
352 | (seats | |
353 | (list-of-seat-configurations (list (lightdm-seat-configuration | |
354 | (name "*")))) | |
355 | "The seat configurations to use. A LightDM seat is akin to a user.") | |
356 | (xdmcp? | |
357 | (boolean #f) | |
358 | "Whether a XDMCP server should listen on port UDP 177.") | |
359 | (xdmcp-listen-address | |
360 | maybe-string | |
361 | "The host or IP address the XDMCP server listens for incoming connections. | |
362 | When unspecified, listen on for any hosts/IP addresses.") | |
363 | (vnc-server? | |
364 | (boolean #f) | |
365 | "Whether a VNC server is started.") | |
366 | (vnc-server-command | |
367 | (file-like (file-append tigervnc-server "bin/Xvnc")) | |
368 | "The Xvnc command to use for the VNC server, it's possible to provide extra | |
369 | options not otherwise exposed along the command, for example to disable | |
370 | security: | |
371 | @lisp | |
372 | (vnc-server-command | |
373 | (file-append tigervnc-server \"/bin/Xvnc\" | |
374 | \" -SecurityTypes None\" )) | |
375 | @end lisp | |
376 | ||
d3e982dc | 377 | Or to set a PasswordFile for the classic (unsecure) VncAuth mechanism: |
0ea62e84 MC |
378 | @lisp |
379 | (vnc-server-command | |
380 | (file-append tigervnc-server \"/bin/Xvnc\" | |
381 | \" -PasswordFile /var/lib/lightdm/.vnc/passwd\")) | |
382 | @end lisp | |
383 | The password file should be manually created using the @command{vncpasswd} | |
384 | command. | |
385 | ||
386 | Note that LightDM will create new sessions for VNC users, which means they | |
387 | need to authenticate in the same way as local users would. | |
388 | ") | |
389 | (vnc-server-listen-address | |
390 | maybe-string | |
391 | "The host or IP address the VNC server listens for incoming connections. | |
392 | When unspecified, listen for any hosts/IP addresses.") | |
393 | (vnc-server-port | |
394 | (number 5900) | |
395 | "The TCP port the VNC server should listen to.") | |
396 | (extra-config | |
397 | (list-of-strings '()) | |
398 | "Extra configuration values to append to the LightDM configuration file.")) | |
399 | ||
400 | (define (lightdm-configuration->greeters-config-dir config) | |
401 | "Return a directory containing all the serialized greeter configurations | |
402 | from CONFIG, a <lightdm-configuration> object." | |
403 | (file-union "etc-lightdm" | |
404 | (append-map (lambda (g) | |
405 | `((,(greeter-configuration->conf-name g) | |
406 | ,(greeter-configuration->file g)))) | |
407 | (lightdm-configuration-greeters config)))) | |
408 | ||
409 | (define (lightdm-configuration->packages config) | |
410 | "Return all the greeter packages and their assets defined in CONFIG, a | |
411 | <lightdm-configuration> object, as well as the lightdm package itself." | |
412 | (cons (lightdm-configuration-lightdm config) | |
413 | (append-map greeter-configuration->packages | |
414 | (lightdm-configuration-greeters config)))) | |
415 | ||
416 | (define (validate-lightdm-configuration config) | |
417 | "Sanity check CONFIG, a <lightdm-configuration> record instance." | |
418 | ;; This is required to make inter-field validations, such as between the | |
419 | ;; seats and greeters. | |
420 | (let* ((seats (lightdm-configuration-seats config)) | |
421 | (greeter-sessions (delete-duplicates | |
422 | (map lightdm-seat-configuration-greeter-session | |
423 | seats) | |
424 | eq?)) | |
425 | (greeter-configurations (lightdm-configuration-greeters config)) | |
426 | (missing-greeters | |
427 | (filter-map | |
428 | (lambda (id) | |
429 | (define pred (greeter-session->greater-configuration-pred id)) | |
430 | (if (find pred greeter-configurations) | |
431 | #f ;happy path | |
432 | id)) | |
433 | greeter-sessions))) | |
434 | (unless (null? missing-greeters) | |
435 | (leave (G_ "no greeter configured for seat greeter sessions: ~a~%") | |
436 | missing-greeters)))) | |
437 | ||
438 | (define (lightdm-configuration-file config) | |
439 | (match-record config <lightdm-configuration> | |
440 | (xorg-configuration seats | |
441 | xdmcp? xdmcp-listen-address | |
442 | vnc-server? vnc-server-command vnc-server-listen-address vnc-server-port | |
443 | extra-config) | |
444 | (apply | |
445 | mixed-text-file | |
446 | "lightdm.conf" " | |
447 | # | |
448 | # General configuration | |
449 | # | |
450 | [LightDM] | |
451 | greeter-user=lightdm | |
452 | sessions-directory=/run/current-system/profile/share/xsessions\ | |
453 | :/run/current-system/profile/share/wayland-sessions | |
454 | remote-sessions-directory=/run/current-system/profile/share/remote-sessions | |
455 | " | |
456 | #~(string-join '#$extra-config "\n") | |
457 | " | |
458 | # | |
459 | # XDMCP Server configuration | |
460 | # | |
461 | [XDMCPServer] | |
462 | enabled=" (if xdmcp? "true" "false") "\n" | |
463 | (if (maybe-value-set? xdmcp-listen-address) | |
464 | (format #f "xdmcp-listen-address=~a" xdmcp-listen-address) | |
465 | "") " | |
466 | ||
467 | # | |
468 | # VNC Server configuration | |
469 | # | |
470 | [VNCServer] | |
471 | enabled=" (if vnc-server? "true" "false") " | |
472 | command=" vnc-server-command " | |
473 | port=" (number->string vnc-server-port) "\n" | |
474 | (if (maybe-value-set? vnc-server-listen-address) | |
475 | (format #f "vnc-server-listen-address=~a" vnc-server-listen-address) | |
476 | "") " | |
477 | ||
478 | # | |
479 | # Seat configuration. | |
480 | # | |
481 | " | |
482 | (map (lambda (seat) | |
483 | ;; This complication exists to propagate a default value for | |
484 | ;; the 'xserver-command' field of the seats. Having a | |
485 | ;; 'xorg-configuration' field at the root of the | |
486 | ;; lightdm-configuration enables the use of | |
487 | ;; 'set-xorg-configuration' and can be more convenient. | |
488 | (let ((seat* (if (maybe-value-set? | |
489 | (lightdm-seat-configuration-xserver-command seat)) | |
490 | seat | |
491 | (lightdm-seat-configuration | |
492 | (inherit seat) | |
493 | (xserver-command (xorg-start-command | |
494 | xorg-configuration)))))) | |
495 | (serialize-configuration seat* | |
496 | lightdm-seat-configuration-fields))) | |
497 | seats)))) | |
498 | ||
499 | (define %lightdm-accounts | |
500 | (list (user-group (name "lightdm") (system? #t)) | |
501 | (user-account | |
502 | (name "lightdm") | |
503 | (group "lightdm") | |
504 | (system? #t) | |
505 | (comment "LightDM user") | |
506 | (home-directory "/var/lib/lightdm") | |
507 | (shell (file-append shadow "/sbin/nologin"))))) | |
508 | ||
509 | (define %lightdm-activation | |
510 | ;; Ensure /var/lib/lightdm is owned by the "lightdm" user. Adapted from the | |
511 | ;; %gdm-activation. | |
512 | (with-imported-modules '((guix build utils)) | |
513 | #~(begin | |
514 | (use-modules (guix build utils)) | |
515 | ||
516 | (define (ensure-ownership directory) | |
517 | (let* ((lightdm (getpwnam "lightdm")) | |
518 | (uid (passwd:uid lightdm)) | |
519 | (gid (passwd:gid lightdm)) | |
520 | (st (stat directory #f))) | |
521 | ;; Recurse into directory only if it has wrong ownership. | |
522 | (when (and st | |
523 | (or (not (= uid (stat:uid st))) | |
524 | (not (= gid (stat:gid st))))) | |
525 | (for-each (lambda (file) | |
526 | (chown file uid gid)) | |
527 | (find-files "directory" | |
528 | #:directories? #t))))) | |
529 | ||
530 | (when (not (stat "/var/lib/lightdm-data" #f)) | |
531 | (mkdir-p "/var/lib/lightdm-data")) | |
532 | (for-each ensure-ownership | |
533 | '("/var/lib/lightdm" | |
534 | "/var/lib/lightdm-data"))))) | |
535 | ||
536 | (define (lightdm-pam-service config) | |
537 | "Return a PAM service for @command{lightdm}." | |
538 | (unix-pam-service "lightdm" | |
539 | #:login-uid? #t | |
540 | #:allow-empty-passwords? | |
541 | (lightdm-configuration-allow-empty-passwords? config))) | |
542 | ||
543 | (define (lightdm-greeter-pam-service) | |
544 | "Return a PAM service for @command{lightdm-greeter}." | |
545 | (pam-service | |
546 | (name "lightdm-greeter") | |
547 | (auth (list | |
548 | ;; Load environment from /etc/environment and ~/.pam_environment. | |
549 | (pam-entry (control "required") (module "pam_env.so")) | |
550 | ;; Always let the greeter start without authentication. | |
551 | (pam-entry (control "required") (module "pam_permit.so")))) | |
552 | ;; No action required for account management | |
553 | (account (list (pam-entry (control "required") (module "pam_permit.so")))) | |
554 | ;; Prohibit changing password. | |
555 | (password (list (pam-entry (control "required") (module "pam_deny.so")))) | |
556 | ;; Setup session. | |
557 | (session (list (pam-entry (control "required") (module "pam_unix.so")))))) | |
558 | ||
559 | (define (lightdm-autologin-pam-service) | |
560 | "Return a PAM service for @command{lightdm-autologin}}." | |
561 | (pam-service | |
562 | (name "lightdm-autologin") | |
563 | (auth | |
564 | (list | |
565 | ;; Block login if user is globally disabled. | |
566 | (pam-entry (control "required") (module "pam_nologin.so")) | |
567 | (pam-entry (control "required") (module "pam_succeed_if.so") | |
568 | (arguments (list "uid >= 1000"))) | |
569 | ;; Allow access without authentication. | |
570 | (pam-entry (control "required") (module "pam_permit.so")))) | |
571 | ;; Stop autologin if account requires action. | |
572 | (account (list (pam-entry (control "required") (module "pam_unix.so")))) | |
573 | ;; Prohibit changing password. | |
574 | (password (list (pam-entry (control "required") (module "pam_deny.so")))) | |
575 | ;; Setup session. | |
576 | (session (list (pam-entry (control "required") (module "pam_unix.so")))))) | |
577 | ||
578 | (define (lightdm-pam-services config) | |
579 | (list (lightdm-pam-service config) | |
580 | (lightdm-greeter-pam-service) | |
581 | (lightdm-autologin-pam-service))) | |
582 | ||
583 | (define (lightdm-shepherd-service config) | |
584 | "Return a <lightdm-service> for LightDM using CONFIG." | |
585 | ||
586 | (validate-lightdm-configuration config) | |
587 | ||
588 | (define lightdm-command | |
589 | #~(list #$(file-append (lightdm-configuration-lightdm config) | |
590 | "/sbin/lightdm") | |
591 | #$@(if (lightdm-configuration-debug? config) | |
592 | #~("--debug") | |
593 | #~()) | |
594 | "--config" | |
595 | #$(lightdm-configuration-file config))) | |
596 | ||
597 | (define lightdm-paths | |
598 | (let ((lightdm (lightdm-configuration-lightdm config))) | |
599 | #~(string-join | |
600 | '#$(map (lambda (dir) | |
601 | (file-append lightdm dir)) | |
602 | '("/bin" "/sbin" "/libexec")) | |
603 | ":"))) | |
604 | ||
605 | (define greeters-config-dir | |
606 | (lightdm-configuration->greeters-config-dir config)) | |
607 | ||
608 | (define data-dirs | |
609 | ;; LightDM itself needs to be in XDG_DATA_DIRS for the accountsservice | |
610 | ;; interface it provides to be picked up. The greeters must also be in | |
611 | ;; XDG_DATA_DIRS to be found. | |
612 | (let ((packages (lightdm-configuration->packages config))) | |
613 | #~(string-join '#$(map (cut file-append <> "/share") packages) | |
614 | ":"))) | |
615 | ||
616 | (list | |
617 | (shepherd-service | |
618 | (documentation "LightDM display manager") | |
619 | (requirement '(dbus-system user-processes host-name)) | |
620 | (provision '(lightdm display-manager xorg-server)) | |
621 | (respawn? #f) | |
622 | (start | |
623 | #~(lambda () | |
624 | ;; Note: sadly, environment variables defined for 'lightdm' are | |
625 | ;; cleared and/or overridden by /etc/profile by its spawned greeters, | |
626 | ;; so an out-of-band means such as /etc is required. | |
627 | (fork+exec-command #$lightdm-command | |
628 | ;; Lightdm needs itself in its PATH. | |
629 | #:environment-variables | |
630 | (list | |
631 | ;; It knows to look for greeter configurations in | |
632 | ;; XDG_CONFIG_DIRS... | |
633 | (string-append "XDG_CONFIG_DIRS=" | |
634 | #$greeters-config-dir) | |
635 | ;; ... and for greeter .desktop files as well as | |
636 | ;; lightdm accountsservice interface in | |
637 | ;; XDG_DATA_DIRS. | |
638 | (string-append "XDG_DATA_DIRS=" | |
639 | #$data-dirs) | |
640 | (string-append "PATH=" #$lightdm-paths))))) | |
641 | (stop #~(make-kill-destructor))))) | |
642 | ||
643 | (define lightdm-service-type | |
644 | (handle-xorg-configuration | |
645 | lightdm-configuration | |
646 | (service-type | |
647 | (name 'lightdm) | |
648 | (default-value (lightdm-configuration)) | |
649 | (extensions | |
650 | (list (service-extension pam-root-service-type lightdm-pam-services) | |
651 | (service-extension shepherd-root-service-type | |
652 | lightdm-shepherd-service) | |
653 | (service-extension activation-service-type | |
654 | (const %lightdm-activation)) | |
655 | (service-extension dbus-root-service-type | |
656 | (compose list lightdm-configuration-lightdm)) | |
657 | (service-extension polkit-service-type | |
658 | (compose list lightdm-configuration-lightdm)) | |
659 | (service-extension account-service-type | |
660 | (const %lightdm-accounts)) | |
661 | ;; Add 'lightdm' to the system profile, so that its | |
662 | ;; 'share/accountsservice' D-Bus service extension directory can be | |
663 | ;; found via the 'XDG_DATA_DIRS=/run/current-system/profile/share' | |
664 | ;; environment variable set in the wrapper of the | |
665 | ;; libexec/accounts-daemon binary of the accountsservice package. | |
666 | ;; This daemon is spawned by D-Bus, and there's little we can do to | |
667 | ;; affect its environment. For more reading, see: | |
668 | ;; https://github.com/NixOS/nixpkgs/issues/45059. | |
669 | (service-extension profile-service-type | |
670 | lightdm-configuration->packages) | |
671 | ;; This is needed for the greeter itself to find its configuration, | |
672 | ;; because XDG_CONF_DIRS gets overridden by /etc/profile. | |
673 | (service-extension | |
674 | etc-service-type | |
675 | (lambda (config) | |
676 | `(("lightdm" | |
677 | ,(lightdm-configuration->greeters-config-dir config))))))) | |
678 | (description "Run @code{lightdm}, the LightDM graphical login manager.")))) | |
679 | ||
680 | \f | |
681 | ;;; | |
682 | ;;; Generate documentation. | |
683 | ;;; | |
684 | (define (generate-doc) | |
685 | (configuration->documentation 'lightdm-configuration) | |
686 | (configuration->documentation 'lightdm-gtk-greeter-configuration) | |
687 | (configuration->documentation 'lightdm-seat-configuration)) |