projects/guix·blob python-team · refs

2879 lines · 110.6 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2014-2022 Ludovic Courtès <[email protected]>
3;;; Copyright © 2015 Andy Wingo <[email protected]>
4;;; Copyright © 2015 Mark H Weaver <[email protected]>
5;;; Copyright © 2016 Sou Bunnbu <[email protected]>
6;;; Copyright © 2017, 2020, 2022, 2023, 2025-2026 Maxim Cournoyer <[email protected]>
7;;; Copyright © 2017 Nikita <[email protected]>
8;;; Copyright © 2017, 2019 Hartmut Goebel <[email protected]>
9;;; Copyright © 2018, 2020, 2022, 2025 Efraim Flashner <[email protected]>
10;;; Copyright © 2018, 2023 Ricardo Wurmus <[email protected]>
11;;; Copyright © 2017, 2019 Christopher Baines <[email protected]>
12;;; Copyright © 2019 Tim Gesthuizen <[email protected]>
13;;; Copyright © 2019 David Wilson <[email protected]>
14;;; Copyright © 2020, 2024 Tobias Geerinckx-Rice <[email protected]>
15;;; Copyright © 2020 Reza Alizadeh Majd <[email protected]>
16;;; Copyright © 2021 Brice Waegeneire <[email protected]>
17;;; Copyright © 2021, 2022 muradm <[email protected]>
18;;; Copyright © 2023 Bruno Victal <[email protected]>
19;;; Copyright © 2023 Zheng Junjie <[email protected]>
20;;; Copyright © 2024 45mg <[email protected]>
21;;; Copyright © 2024 Raven Hallsby <[email protected]>
22;;; Copyright © 2025 Jonathan Brielmaier <[email protected]>
23;;; Copyright © 2025 Sergio Pastor Pérez <[email protected]>
24;;; Copyright © 2025 dan <[email protected]>
25;;; Copyright © 2026 Noé Lopez <[email protected]>
26;;; Copyright © 2026 Herman Rimm <[email protected]>
27;;;
28;;; This file is part of GNU Guix.
29;;;
30;;; GNU Guix is free software; you can redistribute it and/or modify it
31;;; under the terms of the GNU General Public License as published by
32;;; the Free Software Foundation; either version 3 of the License, or (at
33;;; your option) any later version.
34;;;
35;;; GNU Guix is distributed in the hope that it will be useful, but
36;;; WITHOUT ANY WARRANTY; without even the implied warranty of
37;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
38;;; GNU General Public License for more details.
39;;;
40;;; You should have received a copy of the GNU General Public License
41;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
42
43;;; Commentary:
44;;;
45;;; This module contains service definitions for a "desktop" environment.
46;;;
47;;; Code:
48
49(define-module (gnu services desktop)
50 #:use-module ((gnu home services utils) #:select (object->camel-case-string))
51 #:use-module (gnu services)
52 #:use-module (gnu services shepherd)
53 #:use-module (gnu services base)
54 #:use-module (gnu services configuration)
55 #:use-module (gnu services dbus)
56 #:use-module (gnu services avahi)
57 #:use-module (gnu services xorg)
58 #:use-module (gnu services networking)
59 #:use-module (gnu services sound)
60 #:use-module ((gnu system file-systems)
61 #:select (%control-groups
62 %elogind-file-systems
63 file-system))
64 #:autoload (gnu services sddm) (sddm-service-type)
65 #:use-module (gnu system)
66 #:use-module (gnu system privilege)
67 #:use-module (gnu system shadow)
68 #:use-module (gnu system uuid)
69 #:use-module (gnu system pam)
70 #:use-module (gnu packages glib)
71 #:use-module (gnu packages admin)
72 #:use-module (gnu packages bash)
73 #:use-module (gnu packages cups)
74 #:use-module (gnu packages dns)
75 #:use-module (gnu packages freedesktop)
76 #:use-module (gnu packages gnome)
77 #:use-module (gnu packages kde-plasma)
78 #:use-module (gnu packages pulseaudio)
79 #:use-module (gnu packages xfce)
80 #:use-module (gnu packages xdisorg)
81 #:use-module (gnu packages scanner)
82 #:use-module (gnu packages suckless)
83 #:use-module (gnu packages sugar)
84 #:use-module (gnu packages linux)
85 #:use-module (gnu packages libusb)
86 #:use-module (gnu packages lxqt)
87 #:use-module (gnu packages mate)
88 #:use-module (gnu packages nfs)
89 #:use-module (gnu packages enlightenment)
90 #:use-module (gnu packages haskell-apps)
91 #:use-module (gnu packages rust-apps)
92 #:use-module (gnu packages video)
93 #:use-module (guix deprecation)
94 #:use-module (guix i18n)
95 #:use-module (guix records)
96 #:use-module (guix packages)
97 #:use-module (guix search-paths)
98 #:use-module (guix store)
99 #:use-module (guix ui)
100 #:use-module (guix utils)
101 #:use-module (guix gexp)
102 #:use-module (guix modules)
103 #:use-module (srfi srfi-1)
104 #:use-module (srfi srfi-26)
105 #:use-module (ice-9 format)
106 #:use-module (ice-9 match)
107 #:export (<upower-configuration>
108 upower-configuration
109 upower-configuration?
110 upower-configuration-upower
111 upower-configuration-watts-up-pro?
112 upower-configuration-poll-batteries?
113 upower-configuration-ignore-lid?
114 upower-configuration-use-percentage-for-policy?
115 upower-configuration-percentage-low
116 upower-configuration-percentage-critical
117 upower-configuration-percentage-action
118 upower-configuration-time-low
119 upower-configuration-time-critical
120 upower-configuration-time-action
121 upower-configuration-critical-power-action
122
123 upower-service-type
124
125 udisks-configuration
126 udisks-configuration?
127 udisks-service ; deprecated
128 udisks-service-type
129
130 gvfs-configuration
131 gvfs-configuration?
132 gvfs-service-type
133
134 colord-service-type
135
136 kmonad-configuration
137 kmonad-configuration-keymaps
138 kmonad-configuration-kmonad
139 kmonad-configuration?
140 kmonad-service-type
141
142 kanata-service-type
143 kanata-configuration
144 kanata-configuration?
145 kanata-configuration-kanata
146 kanata-configuration-keymaps
147
148 gpu-screen-recorder-configuration
149 gpu-screen-recorder-configuration?
150 gpu-screen-recorder-service-type
151
152 geoclue-application
153 geoclue-configuration
154 geoclue-configuration?
155 %standard-geoclue-applications
156 geoclue-service ; deprecated
157 geoclue-service-type
158
159 iio-sensor-proxy-configuration
160 iio-sensor-proxy-configuration?
161 iio-sensor-proxy-configuration-io-sensor-proxy
162 iio-sensor-proxy-service-type
163
164 bluetooth-service-type
165 bluetooth-configuration
166 bluetooth-configuration?
167 bluetooth-service ; deprecated
168
169 elogind-configuration
170 elogind-configuration?
171 elogind-service ; deprecated
172 elogind-service-type
173
174 gardenhostd-configuration
175 gardenhostd-service-type
176
177 %gdm-file-system
178 gdm-file-system-service
179
180 %fontconfig-file-system
181 fontconfig-file-system-service
182
183 accountsservice-service-type
184 accountsservice-service ; deprecated
185
186 cups-pk-helper-service-type
187
188 sane-configuration
189 sane-configuration?
190 sane-configuration-backends
191 sane-configuration-sane
192 sane-service-type
193
194 gnome-desktop-configuration
195 gnome-desktop-configuration?
196 gnome-desktop-configuration-core-services
197 gnome-desktop-configuration-shell
198 gnome-desktop-configuration-utilities
199 gnome-desktop-configuration-extra-packages
200 gnome-desktop-configuration-polkit-ignorelist
201 gnome-desktop-configuration-udev-ignorelist
202 gnome-desktop-configuration-keyring
203 gnome-desktop-service
204 gnome-desktop-service-type
205
206 mate-desktop-configuration
207 mate-desktop-configuration?
208 mate-desktop-service-type
209
210 lxqt-desktop-configuration
211 lxqt-desktop-configuration?
212 lxqt-desktop-service-type
213
214 sugar-desktop-configuration
215 sugar-desktop-configuration?
216 sugar-desktop-service-type
217
218 plasma-desktop-configuration
219 plasma-desktop-configuration?
220 plasma-desktop-service-type
221
222 xfce-desktop-configuration
223 xfce-desktop-configuration?
224 xfce-desktop-service-type
225
226 x11-socket-directory-service ;deprecated
227 x11-socket-directory-service-type
228
229 enlightenment-desktop-configuration
230 enlightenment-desktop-configuration?
231 enlightenment-desktop-service-type
232
233 inputattach-configuration
234 inputattach-configuration?
235 inputattach-service-type
236
237 polkit-wheel-service
238
239 gnome-keyring-configuration
240 gnome-keyring-configuration?
241 gnome-keyring-service-type
242
243 kwallet-configuration
244 kwallet-configuration?
245 kwallet-service-type
246
247 seatd-configuration
248 seatd-service-type
249
250 %desktop-services))
251
252
253;;;
254;;; Helpers.
255;;;
256
257(define (bool value)
258 (if value "true\n" "false\n"))
259
260(define list-of-file-likes?
261 (list-of file-like?))
262
263(define (package-direct-input-selector tree)
264 "Return a procedure that selects TREE from the inputs of PACKAGE. If TREE
265is a list, it recursively searches it until it locates the last item of TREE."
266 (lambda (package)
267 (let loop ((tree (if (pair? tree)
268 tree
269 (list tree)))
270 (package package))
271 (if (null? tree)
272 package
273 (loop (cdr tree)
274 (car (assoc-ref (package-direct-inputs package)
275 (car tree))))))))
276(define (pascal-case text)
277 (object->camel-case-string text 'upper))
278
279
280;;;
281;;; Upower D-Bus service.
282;;;
283
284(define-record-type* <upower-configuration>
285 upower-configuration make-upower-configuration
286 upower-configuration?
287 (upower upower-configuration-upower
288 (default upower))
289 (watts-up-pro? upower-configuration-watts-up-pro?
290 (default #f))
291 (poll-batteries? upower-configuration-poll-batteries?
292 (default #t))
293 (ignore-lid? upower-configuration-ignore-lid?
294 (default #f))
295 (use-percentage-for-policy? upower-configuration-use-percentage-for-policy?
296 (default #t))
297 (percentage-low upower-configuration-percentage-low
298 (default 20))
299 (percentage-critical upower-configuration-percentage-critical
300 (default 5))
301 (percentage-action upower-configuration-percentage-action
302 (default 2))
303 (time-low upower-configuration-time-low
304 (default 1200))
305 (time-critical upower-configuration-time-critical
306 (default 300))
307 (time-action upower-configuration-time-action
308 (default 120))
309 (critical-power-action upower-configuration-critical-power-action
310 (default 'hybrid-sleep)))
311
312(define* upower-configuration-file
313 ;; Return an upower-daemon configuration file.
314 (match-lambda
315 (($ <upower-configuration> upower
316 watts-up-pro? poll-batteries? ignore-lid? use-percentage-for-policy?
317 percentage-low percentage-critical percentage-action time-low
318 time-critical time-action critical-power-action)
319 (plain-file "UPower.conf"
320 (string-append
321 "[UPower]\n"
322 "EnableWattsUpPro=" (bool watts-up-pro?)
323 "NoPollBatteries=" (bool (not poll-batteries?))
324 "IgnoreLid=" (bool ignore-lid?)
325 "UsePercentageForPolicy=" (bool use-percentage-for-policy?)
326 "PercentageLow=" (number->string percentage-low) "\n"
327 "PercentageCritical=" (number->string percentage-critical) "\n"
328 "PercentageAction=" (number->string percentage-action) "\n"
329 "TimeLow=" (number->string time-low) "\n"
330 "TimeCritical=" (number->string time-critical) "\n"
331 "TimeAction=" (number->string time-action) "\n"
332 "CriticalPowerAction=" (match critical-power-action
333 ('hybrid-sleep "HybridSleep")
334 ('hibernate "Hibernate")
335 ('power-off "PowerOff"))
336 "\n")))))
337
338(define %upower-activation
339 #~(begin
340 (use-modules (guix build utils))
341 (mkdir-p "/var/lib/upower")))
342
343(define (upower-dbus-service config)
344 (list (wrapped-dbus-service (upower-configuration-upower config)
345 "libexec/upowerd"
346 `(("UPOWER_CONF_FILE_NAME"
347 ,(upower-configuration-file config))))))
348
349(define (upower-shepherd-service config)
350 "Return a shepherd service for UPower with CONFIG."
351 (let ((upower (upower-configuration-upower config))
352 (config (upower-configuration-file config)))
353 (list (shepherd-service
354 (documentation "Run the UPower power and battery monitor.")
355 (provision '(upower-daemon))
356 (requirement '(user-processes dbus-system udev))
357
358 (start #~(make-forkexec-constructor
359 (list (string-append #$upower "/libexec/upowerd"))
360 #:environment-variables
361 (list (string-append "UPOWER_CONF_FILE_NAME="
362 #$config))))
363 (stop #~(make-kill-destructor))
364 (actions (list (shepherd-configuration-action config)))))))
365
366(define upower-service-type
367 (let ((upower-package (compose list upower-configuration-upower)))
368 (service-type (name 'upower)
369 (description
370 "Run @command{upowerd}, a system-wide monitor for power
371consumption and battery levels, with the given configuration settings. It
372implements the @code{org.freedesktop.UPower} D-Bus interface, and is notably
373used by GNOME.")
374 (extensions
375 (list (service-extension dbus-root-service-type
376 upower-dbus-service)
377 (service-extension shepherd-root-service-type
378 upower-shepherd-service)
379 (service-extension activation-service-type
380 (const %upower-activation))
381 (service-extension udev-service-type
382 upower-package)
383
384 ;; Make the 'upower' command visible.
385 (service-extension profile-service-type
386 upower-package)))
387 (default-value (upower-configuration)))))
388
389
390;;;
391;;; GeoClue D-Bus service.
392;;;
393
394(define* (geoclue-application name #:key (allowed? #t) system? (users '()))
395 "Configure default GeoClue access permissions for an application. NAME is
396the Desktop ID of the application, without the .desktop part. If ALLOWED? is
397true, the application will have access to location information by default.
398The boolean SYSTEM? value indicates that an application is a system component
399or not. Finally USERS is a list of UIDs of all users for which this
400application is allowed location info access. An empty users list means all
401users are allowed."
402 (string-append
403 "[" name "]\n"
404 "allowed=" (bool allowed?)
405 "system=" (bool system?)
406 "users=" (string-join users ";") "\n"))
407
408(define %standard-geoclue-applications
409 (list (geoclue-application "gnome-datetime-panel" #:system? #t)
410 (geoclue-application "epiphany" #:system? #f)
411 (geoclue-application "firefox" #:system? #f)
412 (geoclue-application "librewolf" #:system? #f)
413 (geoclue-application "icecat" #:system? #f)
414 (geoclue-application "redshift" #:system? #f)))
415
416;; TODO: Use define-configuration and export accessors.
417(define-record-type* <geoclue-configuration>
418 geoclue-configuration make-geoclue-configuration
419 geoclue-configuration?
420 (geoclue geoclue-configuration-geoclue
421 (default geoclue))
422 (whitelist geoclue-configuration-whitelist
423 (default '()))
424 (wifi-geolocation-url
425 geoclue-configuration-wifi-geolocation-url
426 ;; BeaconDB geolocation service:
427 (default "https://api.beacondb.net/v1/geolocate?key=geoclue_guix.gnu.org"))
428 (submit-data? geoclue-configuration-submit-data?
429 (default #f))
430 (wifi-submission-url
431 geoclue-configuration-wifi-submission-url
432 (default "https://api.beacondb.net/v2/geosubmit"))
433 (submission-nick geoclue-configuration-submission-nick
434 (default "geoclue"))
435 (applications geoclue-configuration-applications
436 (default %standard-geoclue-applications)))
437
438(define* (geoclue-configuration-file config)
439 "Return a geoclue configuration file."
440 (plain-file "geoclue.conf"
441 (string-append
442 "[agent]\n"
443 "whitelist="
444 (string-join (geoclue-configuration-whitelist config)
445 ";") "\n"
446 "[wifi]\n"
447 "url=" (geoclue-configuration-wifi-geolocation-url config) "\n"
448 "submit-data=" (bool (geoclue-configuration-submit-data? config))
449 "submission-url="
450 (geoclue-configuration-wifi-submission-url config) "\n"
451 "submission-nick="
452 (geoclue-configuration-submission-nick config)
453 "\n"
454 (string-join (geoclue-configuration-applications config)
455 "\n"))))
456
457(define (geoclue-dbus-service config)
458 (list (wrapped-dbus-service (geoclue-configuration-geoclue config)
459 "libexec/geoclue"
460 `(("GEOCLUE_CONFIG_FILE"
461 ,(geoclue-configuration-file config))))))
462
463(define %geoclue-accounts
464 (list (user-group (name "geoclue") (system? #t))
465 (user-account
466 (name "geoclue")
467 (group "geoclue")
468 (system? #t)
469 (comment "GeoClue daemon user")
470 (home-directory "/var/empty")
471 (shell "/run/current-system/profile/sbin/nologin"))))
472
473(define geoclue-service-type
474 (service-type (name 'geoclue)
475 (extensions
476 (list (service-extension dbus-root-service-type
477 geoclue-dbus-service)
478 (service-extension account-service-type
479 (const %geoclue-accounts))))
480 (description "Run the @command{geoclue} location service.
481This service provides a D-Bus interface to allow applications to request
482access to a user's physical location, and optionally to add information to
483online location databases.")
484 (default-value (geoclue-configuration))))
485
486(define-deprecated
487 (geoclue-service #:key (geoclue geoclue)
488 (whitelist '())
489 (wifi-geolocation-url
490 ;; Mozilla geolocation service:
491 "https://location.services.mozilla.com/v1/geolocate?key=geoclue")
492 (submit-data? #f)
493 (wifi-submission-url
494 "https://location.services.mozilla.com/v1/submit?key=geoclue")
495 (submission-nick "geoclue")
496 (applications %standard-geoclue-applications))
497 geoclue-service-type
498 "Return a service that runs the @command{geoclue} location service. This
499service provides a D-Bus interface to allow applications to request access to
500a user's physical location, and optionally to add information to online
501location databases. By default, only the GNOME date-time panel and the Icecat
502and Epiphany web browsers are able to ask for the user's location, and in the
503case of Icecat and Epiphany, both will ask the user for permission first. See
504@uref{https://wiki.freedesktop.org/www/Software/GeoClue/, the geoclue web
505site} for more information."
506 (service geoclue-service-type
507 (geoclue-configuration
508 (geoclue geoclue)
509 (whitelist whitelist)
510 (wifi-geolocation-url wifi-geolocation-url)
511 (submit-data? submit-data?)
512 (wifi-submission-url wifi-submission-url)
513 (submission-nick submission-nick)
514 (applications applications))))
515
516
517;;;
518;;; IIO Sensor proxy.
519;;;
520
521(define-record-type* <iio-sensor-proxy-configuration>
522 iio-sensor-proxy-configuration make-iio-sensor-proxy-configuration
523 iio-sensor-proxy-configuration?
524 (iio-sensor-proxy iio-sensor-proxy-configuration-iio-sensor-proxy
525 (default iio-sensor-proxy)))
526
527(define iio-sensor-proxy-shepherd-service
528 (match-record-lambda <iio-sensor-proxy-configuration>
529 (iio-sensor-proxy)
530 (list (shepherd-service
531 (documentation "IIO sensors to D-Bus proxy")
532 (requirement '(user-processes dbus-system udev))
533 (provision '(iio-sensor-proxy))
534 (start #~(make-forkexec-constructor
535 (list #$(file-append iio-sensor-proxy
536 "/libexec/iio-sensor-proxy"))))
537 (stop #~(make-kill-destructor))))))
538
539(define iio-sensor-proxy-service-type
540 (let ((iio-sensor-proxy-package
541 (match-record-lambda <iio-sensor-proxy-configuration>
542 (iio-sensor-proxy)
543 (list iio-sensor-proxy))))
544 (service-type
545 (name 'iio-sensor-proxy)
546 (extensions
547 (list (service-extension polkit-service-type
548 iio-sensor-proxy-package)
549 (service-extension dbus-root-service-type
550 iio-sensor-proxy-package)
551 (service-extension udev-service-type
552 iio-sensor-proxy-package)
553 (service-extension shepherd-root-service-type
554 iio-sensor-proxy-shepherd-service)))
555 (default-value (iio-sensor-proxy-configuration))
556 (description
557 "Run the @command{iio-sensor-proxy} daemon, which provides IIO sensors data
558through a D-Bus interface."))))
559
560
561;;;
562;;; Bluetooth.
563;;;
564
565(define-record-type* <bluetooth-configuration>
566 bluetooth-configuration make-bluetooth-configuration
567 bluetooth-configuration?
568 (bluez bluetooth-configuration-bluez (default bluez))
569
570 ;;; [General]
571 (name bluetooth-configuration-name (default "BlueZ"))
572 (class bluetooth-configuration-class (default #x000000))
573 (discoverable-timeout
574 bluetooth-configuration-discoverable-timeout (default 180))
575 (always-pairable? bluetooth-configuration-always-pairable? (default #f))
576 (pairable-timeout bluetooth-configuration-pairable-timeout (default 0))
577
578 ;;; MAYBE: Exclude into separate <device-id> record-type?
579 (device-id bluetooth-configuration-device-id (default #f))
580 (reverse-service-discovery?
581 bluetooth-configuration-reverse-service-discovery (default #t))
582 (name-resolving? bluetooth-configuration-name-resolving? (default #t))
583 (debug-keys? bluetooth-configuration-debug-keys? (default #f))
584
585 ;;; Possible values:
586 ;;; 'dual, 'bredr, 'le
587 (controller-mode bluetooth-configuration-controller-mode (default 'dual))
588
589 ;;; Possible values:
590 ;;; 'off, 'single, 'multiple
591 (multi-profile bluetooth-configuration-multi-profile (default 'off))
592 (fast-connectable? bluetooth-configuration-fast-connectable? (default #f))
593
594 ;;; Possible values:
595 ;;; for LE mode: 'off, 'network/on, 'device
596 ;;; for Dual mode: 'off, 'network/on', 'device, 'limited-network, 'limited-device
597 ;;; Source: https://git.kernel.org/pub/scm/bluetooth/bluez.git/tree/src/main.conf#n68
598 (privacy bluetooth-configuration-privacy (default 'off))
599
600 ;;; Possible values:
601 ;;; 'never, 'confirm, 'always
602 (just-works-repairing
603 bluetooth-configuration-just-works-repairing (default 'never))
604 (temporary-timeout bluetooth-configuration-temporary-timeout (default 30))
605 (refresh-discovery? bluetooth-configuration-refresh-discovery (default #t))
606
607 ;;; Possible values: #t, #f, (uuid <uuid>)
608 ;;; Possible UUIDs:
609 ;;; d4992530-b9ec-469f-ab01-6c481c47da1c (BlueZ Experimental Debug)
610 ;;; 671b10b5-42c0-4696-9227-eb28d1b049d6 (BlueZ Experimental Simultaneous Central and Peripheral)
611 ;;; 15c0a148-c273-11ea-b3de-0242ac130004 (BlueZ Experimental LL privacy)
612 ;;; 330859bc-7506-492d-9370-9a6f0614037f (BlueZ Experimental Bluetooth Quality Report)
613 ;;; a6695ace-ee7f-4fb9-881a-5fac66c629af (BlueZ Experimental Offload Codecs)
614 ;;; Source: https://git.kernel.org/pub/scm/bluetooth/bluez.git/tree/src/main.conf#n110
615 (experimental bluetooth-configuration-experimental (default #f))
616 (remote-name-request-retry-delay
617 bluetooth-configuration-remote-name-request-retry-delay (default 300))
618
619 ;;; [BR]
620 (page-scan-type bluetooth-configuration-page-scan-type (default #f))
621 (page-scan-interval bluetooth-configuration-page-scan-interval (default #f))
622 (page-scan-window bluetooth-configuration-page-scan-window (default #f))
623 (inquiry-scan-type bluetooth-configuration-inquiry-scan-type (default #f))
624 (inquiry-scan-interval bluetooth-configuration-inquiry-scan-interval (default #f))
625 (inquiry-scan-window bluetooth-configuration-inquiry-scan-window (default #f))
626 (link-supervision-timeout bluetooth-configuration-link-supervision-timeout (default #f))
627 (page-timeout bluetooth-configuration-page-timeout (default #f))
628 (min-sniff-interval bluetooth-configuration-min-sniff-interval (default #f))
629 (max-sniff-interval bluetooth-configuration-max-sniff-interval (default #f))
630
631 ;;; [LE]
632 (min-advertisement-interval
633 bluetooth-configuration-min-advertisement-interval (default #f))
634 (max-advertisement-interval
635 bluetooth-configuration-max-advertisement-interval (default #f))
636 (multi-advertisement-rotation-interval
637 bluetooth-configuration-multi-advertisement-rotation-interval (default #f))
638 (scan-interval-auto-connect
639 bluetooth-configuration-scan-interval-auto-connect (default #f))
640 (scan-window-auto-connect
641 bluetooth-configuration-scan-window-auto-connect (default #f))
642 (scan-interval-suspend
643 bluetooth-configuration-scan-interval-suspend (default #f))
644 (scan-window-suspend
645 bluetooth-configuration-scan-window-suspend (default #f))
646 (scan-interval-discovery
647 bluetooth-configuration-scan-interval-discovery (default #f))
648 (scan-window-discovery
649 bluetooth-configuration-scan-window-discovery (default #f))
650 (scan-interval-adv-monitor
651 bluetooth-configuration-scan-interval-adv-monitor (default #f))
652 (scan-window-adv-monitor
653 bluetooth-configuration-scan-window-adv-monitor (default #f))
654 (scan-interval-connect
655 bluetooth-configuration-scan-interval-connect (default #f))
656 (scan-window-connect
657 bluetooth-configuration-scan-window-connect (default #f))
658 (min-connection-interval
659 bluetooth-configuration-min-connection-interval (default #f))
660 (max-connection-interval
661 bluetooth-configuration-max-connection-interval (default #f))
662 (connection-latency
663 bluetooth-configuration-connection-latency (default #f))
664 (connection-supervision-timeout
665 bluetooth-configuration-connection-supervision-timeout (default #f))
666 (autoconnect-timeout
667 bluetooth-configuration-autoconnect-timeout (default #f))
668 (adv-mon-allowlist-scan-duration
669 bluetooth-configuration-adv-mon-allowlist-scan-duration (default 300))
670 (adv-mon-no-filter-scan-duration
671 bluetooth-configuration-adv-mon-no-filter-scan-duration (default 500))
672 (enable-adv-mon-interleave-scan?
673 bluetooth-configuration-enable-adv-mon-interleave-scan (default #t))
674
675 ;;; [GATT]
676 ;;; Possible values: 'yes, 'no, 'always
677 (cache bluetooth-configuration-cache (default 'always))
678
679 ;;; Possible values: 7 ... 16, 0 (don't care)
680 (key-size bluetooth-configuration-key-size (default 0))
681
682 ;;; Possible values: 23 ... 517
683 (exchange-mtu bluetooth-configuration-exchange-mtu (default 517))
684
685 ;;; Possible values: 1 ... 5
686 (att-channels bluetooth-configuration-att-channels (default 3))
687
688 ;;; [AVDTP]
689 ;;; Possible values: 'basic, 'ertm
690 (session-mode bluetooth-configuration-session-mode (default 'basic))
691
692 ;;; Possible values: 'basic, 'streaming
693 (stream-mode bluetooth-configuration-stream-mode (default 'basic))
694
695 ;;; [Policy]
696 (reconnect-uuids bluetooth-configuration-reconnect-uuids (default '()))
697 (reconnect-attempts bluetooth-configuration-reconnect-attempts (default 7))
698 (reconnect-intervals bluetooth-configuration-reconnect-intervals
699 (default (list 1 2 4 8 16 32 64)))
700 (auto-enable? bluetooth-configuration-auto-enable? (default #f))
701 (resume-delay bluetooth-configuration-resume-delay (default 2))
702
703 ;;; [AdvMon]
704 ;;; Possible values:
705 ;;; "0x00", "0xFF",
706 ;;; "N = 0x00" ... "N = 0xFF"
707 ;;; Source: https://git.kernel.org/pub/scm/bluetooth/bluez.git/tree/src/main.conf#n286
708 (rssi-sampling-period bluetooth-configuration-rssi-sampling-period
709 (default #xFF)))
710
711(define (bluetooth-configuration-file config)
712 "Return a configuration file for the systemd bluetooth service, as a string."
713 (string-append
714 "[General]"
715 "\nName = " (bluetooth-configuration-name config)
716 "\nClass = " (string-append
717 "0x"
718 (format #f "~6,'0x" (bluetooth-configuration-class config)))
719 "\nDiscoverableTimeout = " (number->string
720 (bluetooth-configuration-discoverable-timeout
721 config))
722 "\nAlwaysPairable = " (bool (bluetooth-configuration-always-pairable?
723 config))
724 "\nPairableTimeout = " (number->string
725 (bluetooth-configuration-pairable-timeout
726 config))
727 (if (bluetooth-configuration-device-id config)
728 (string-append "\nDeviceID = " (bluetooth-configuration-device-id config))
729 "")
730 "\nReverseServiceDiscovery = " (bool
731 (bluetooth-configuration-reverse-service-discovery
732 config))
733 "\nNameResolving = " (bool (bluetooth-configuration-name-resolving? config))
734 "\nDebugKeys = " (bool (bluetooth-configuration-debug-keys? config))
735 "\nControllerMode = " (symbol->string
736 (bluetooth-configuration-controller-mode config))
737 "\nMultiProfile = " (symbol->string (bluetooth-configuration-multi-profile
738 config))
739 "\nFastConnectable = " (bool (bluetooth-configuration-fast-connectable? config))
740 "\nPrivacy = " (symbol->string (bluetooth-configuration-privacy config))
741 "\nJustWorksRepairing = " (symbol->string
742 (bluetooth-configuration-just-works-repairing config))
743 "\nTemporaryTimeout = " (number->string
744 (bluetooth-configuration-temporary-timeout config))
745 "\nRefreshDiscovery = " (bool (bluetooth-configuration-refresh-discovery config))
746 "\nExperimental = " (let ((experimental (bluetooth-configuration-experimental config)))
747 (cond ((or (eq? experimental #t)
748 (eq? experimental #f)) (bool experimental))
749 ((list? experimental)
750 (string-join (map uuid->string experimental) ","))))
751 "\nRemoteNameRequestRetryDelay = " (number->string
752 (bluetooth-configuration-remote-name-request-retry-delay
753 config))
754 "\n[BR]"
755 (if (bluetooth-configuration-page-scan-type config)
756 (string-append
757 "\nPageScanType = "
758 (number->string (bluetooth-configuration-page-scan-type config)))
759 "")
760 (if (bluetooth-configuration-page-scan-interval config)
761 (string-append
762 "\nPageScanInterval = "
763 (number->string (bluetooth-configuration-page-scan-interval config)))
764 "")
765 (if (bluetooth-configuration-page-scan-window config)
766 (string-append
767 "\nPageScanWindow = "
768 (number->string (bluetooth-configuration-page-scan-window config)))
769 "")
770 (if (bluetooth-configuration-inquiry-scan-type config)
771 (string-append
772 "\nInquiryScanType = "
773 (number->string (bluetooth-configuration-inquiry-scan-type config)))
774 "")
775 (if (bluetooth-configuration-inquiry-scan-interval config)
776 (string-append
777 "\nInquiryScanInterval = "
778 (number->string (bluetooth-configuration-inquiry-scan-interval config)))
779 "")
780 (if (bluetooth-configuration-inquiry-scan-window config)
781 (string-append
782 "\nInquiryScanWindow = "
783 (number->string (bluetooth-configuration-inquiry-scan-window config)))
784 "")
785 (if (bluetooth-configuration-link-supervision-timeout config)
786 (string-append
787 "\nLinkSupervisionTimeout = "
788 (number->string (bluetooth-configuration-link-supervision-timeout config)))
789 "")
790 (if (bluetooth-configuration-page-timeout config)
791 (string-append
792 "\nPageTimeout = "
793 (number->string (bluetooth-configuration-page-timeout config)))
794 "")
795 (if (bluetooth-configuration-min-sniff-interval config)
796 (string-append
797 "\nMinSniffInterval = "
798 (number->string (bluetooth-configuration-min-sniff-interval config)))
799 "")
800 (if (bluetooth-configuration-max-sniff-interval config)
801 (string-append
802 "\nMaxSniffInterval = "
803 (number->string (bluetooth-configuration-max-sniff-interval config)))
804 "")
805
806 "\n[LE]"
807 (if (bluetooth-configuration-min-advertisement-interval config)
808 (string-append
809 "\nMinAdvertisementInterval = "
810 (number->string (bluetooth-configuration-min-advertisement-interval config)))
811 "")
812 (if (bluetooth-configuration-max-advertisement-interval config)
813 (string-append
814 "\nMaxAdvertisementInterval = "
815 (number->string (bluetooth-configuration-max-advertisement-interval config)))
816 "")
817 (if (bluetooth-configuration-multi-advertisement-rotation-interval config)
818 (string-append
819 "\nMultiAdvertisementRotationInterval = "
820 (number->string
821 (bluetooth-configuration-multi-advertisement-rotation-interval config)))
822 "")
823 (if (bluetooth-configuration-scan-interval-auto-connect config)
824 (string-append
825 "\nScanIntervalAutoConnect = "
826 (number->string (bluetooth-configuration-scan-interval-auto-connect config)))
827 "")
828 (if (bluetooth-configuration-scan-window-auto-connect config)
829 (string-append
830 "\nScanWindowAutoConnect = "
831 (number->string (bluetooth-configuration-scan-window-auto-connect config)))
832 "")
833 (if (bluetooth-configuration-scan-interval-suspend config)
834 (string-append
835 "\nScanIntervalSuspend = "
836 (number->string (bluetooth-configuration-scan-interval-suspend config)))
837 "")
838 (if (bluetooth-configuration-scan-window-suspend config)
839 (string-append
840 "\nScanWindowSuspend = "
841 (number->string (bluetooth-configuration-scan-window-suspend config)))
842 "")
843 (if (bluetooth-configuration-scan-interval-discovery config)
844 (string-append
845 "\nScanIntervalDiscovery = "
846 (number->string (bluetooth-configuration-scan-interval-discovery config)))
847 "")
848 (if (bluetooth-configuration-scan-window-discovery config)
849 (string-append
850 "\nScanWindowDiscovery = "
851 (number->string (bluetooth-configuration-scan-window-discovery config)))
852 "")
853 (if (bluetooth-configuration-scan-interval-adv-monitor config)
854 (string-append
855 "\nScanIntervalAdvMonitor = "
856 (number->string (bluetooth-configuration-scan-interval-adv-monitor config)))
857 "")
858 (if (bluetooth-configuration-scan-window-adv-monitor config)
859 (string-append
860 "\nScanWindowAdvMonitor = "
861 (number->string (bluetooth-configuration-scan-window-adv-monitor config)))
862 "")
863 (if (bluetooth-configuration-scan-interval-connect config)
864 (string-append
865 "\nScanIntervalConnect = "
866 (number->string (bluetooth-configuration-scan-interval-connect config)))
867 "")
868 (if (bluetooth-configuration-scan-window-connect config)
869 (string-append
870 "\nScanWindowConnect = "
871 (number->string (bluetooth-configuration-scan-window-connect config)))
872 "")
873 (if (bluetooth-configuration-min-connection-interval config)
874 (string-append
875 "\nMinConnectionInterval = "
876 (number->string (bluetooth-configuration-min-connection-interval config)))
877 "")
878 (if (bluetooth-configuration-max-connection-interval config)
879 (string-append
880 "\nMaxConnectionInterval = "
881 (number->string (bluetooth-configuration-max-connection-interval config)))
882 "")
883 (if (bluetooth-configuration-connection-latency config)
884 (string-append
885 "\nConnectionLatency = "
886 (number->string (bluetooth-configuration-connection-latency config)))
887 "")
888 (if (bluetooth-configuration-connection-supervision-timeout config)
889 (string-append
890 "\nConnectionSupervisionTimeout = "
891 (number->string (bluetooth-configuration-connection-supervision-timeout config)))
892 "")
893 (if (bluetooth-configuration-autoconnect-timeout config)
894 (string-append
895 "\nAutoconnecttimeout = "
896 (number->string (bluetooth-configuration-autoconnect-timeout config)))
897 "")
898 "\nAdvMonAllowlistScanDuration = " (number->string
899 (bluetooth-configuration-adv-mon-allowlist-scan-duration
900 config))
901 "\nAdvMonNoFilterScanDuration = " (number->string
902 (bluetooth-configuration-adv-mon-no-filter-scan-duration
903 config))
904 "\nEnableAdvMonInterleaveScan = " (number->string
905 (if (eq? #t
906 (bluetooth-configuration-enable-adv-mon-interleave-scan
907 config))
908 1 0))
909
910 "\n[GATT]"
911 "\nCache = " (symbol->string (bluetooth-configuration-cache config))
912 "\nKeySize = " (number->string (bluetooth-configuration-key-size config))
913 "\nExchangeMTU = " (number->string (bluetooth-configuration-exchange-mtu config))
914 "\nChannels = " (number->string (bluetooth-configuration-att-channels config))
915
916 "\n[AVDTP]"
917 "\nSessionMode = " (symbol->string (bluetooth-configuration-session-mode config))
918 "\nStreamMode = " (symbol->string (bluetooth-configuration-stream-mode config))
919
920 "\n[Policy]"
921 (let ((uuids (bluetooth-configuration-reconnect-uuids config)))
922 (if (not (eq? '() uuids))
923 (string-append
924 "\nReconnectUUIDs = "
925 (string-join (map uuid->string uuids) ","))
926 ""))
927 "\nReconnectAttempts = " (number->string
928 (bluetooth-configuration-reconnect-attempts config))
929 "\nReconnectIntervals = " (string-join
930 (map number->string
931 (bluetooth-configuration-reconnect-intervals
932 config))
933 ",")
934 "\nAutoEnable = " (bool (bluetooth-configuration-auto-enable?
935 config))
936 "\nResumeDelay = " (number->string (bluetooth-configuration-resume-delay config))
937
938 "\n[AdvMon]"
939 "\nRSSISamplingPeriod = " (string-append
940 "0x"
941 (format #f "~2,'0x"
942 (bluetooth-configuration-rssi-sampling-period config)))))
943
944(define (bluetooth-directory config)
945 (computed-file "etc-bluetooth"
946 #~(begin
947 (mkdir #$output)
948 (chdir #$output)
949 (call-with-output-file "main.conf"
950 (lambda (port)
951 (display #$(bluetooth-configuration-file config)
952 port))))))
953
954(define (bluetooth-shepherd-service config)
955 "Return a shepherd service for @command{bluetoothd}."
956 (shepherd-service
957 (provision '(bluetooth))
958 (requirement '(user-processes dbus-system udev))
959 (documentation "Run the bluetoothd daemon.")
960 (start #~(make-forkexec-constructor
961 (list #$(file-append (bluetooth-configuration-bluez config)
962 "/libexec/bluetooth/bluetoothd"))))
963 (stop #~(make-kill-destructor))))
964
965(define bluetooth-service-type
966 (service-type
967 (name 'bluetooth)
968 (extensions
969 (list (service-extension dbus-root-service-type
970 (compose list bluetooth-configuration-bluez))
971 (service-extension udev-service-type
972 (compose list bluetooth-configuration-bluez))
973 (service-extension etc-service-type
974 (lambda (config)
975 `(("bluetooth"
976 ,(bluetooth-directory config)))))
977 (service-extension shepherd-root-service-type
978 (compose list bluetooth-shepherd-service))))
979 (default-value (bluetooth-configuration))
980 (description "Run the @command{bluetoothd} daemon, which manages all the
981Bluetooth devices and provides a number of D-Bus interfaces.")))
982
983(define-deprecated (bluetooth-service #:key (bluez bluez) (auto-enable? #f))
984 bluetooth-service-type
985 "Return a service that runs the @command{bluetoothd} daemon, which manages
986all the Bluetooth devices and provides a number of D-Bus interfaces. When
987AUTO-ENABLE? is true, the bluetooth controller is powered automatically at
988boot, which can be useful when using a bluetooth keyboard or mouse.
989"
990 (service bluetooth-service-type
991 (bluetooth-configuration
992 (bluez bluez)
993 (auto-enable? auto-enable?))))
994
995
996;;;
997;;; Colord D-Bus service.
998;;;
999
1000(define %colord-activation
1001 #~(begin
1002 (use-modules (guix build utils))
1003 (mkdir-p "/var/lib/colord")
1004 (let ((user (getpwnam "colord")))
1005 (chown "/var/lib/colord"
1006 (passwd:uid user) (passwd:gid user)))))
1007
1008(define %colord-accounts
1009 (list (user-group (name "colord") (system? #t))
1010 (user-account
1011 (name "colord")
1012 (group "colord")
1013 (system? #t)
1014 (comment "colord daemon user")
1015 (home-directory "/var/empty")
1016 (shell (file-append shadow "/sbin/nologin")))))
1017
1018(define colord-service-type
1019 (service-type (name 'colord)
1020 (extensions
1021 (list (service-extension account-service-type
1022 (const %colord-accounts))
1023 (service-extension activation-service-type
1024 (const %colord-activation))
1025
1026 ;; Colord is a D-Bus service that dbus-daemon can
1027 ;; activate.
1028 (service-extension dbus-root-service-type list)
1029
1030 ;; Colord provides "color device" rules for udev.
1031 (service-extension udev-service-type list)
1032
1033 ;; It provides polkit "actions".
1034 (service-extension polkit-service-type list)))
1035 (default-value colord)
1036 (description
1037 "Run @command{colord}, a system service with a D-Bus
1038interface to manage the color profiles of input and output devices such as
1039screens and scanners.")))
1040
1041
1042;;;
1043;;; KMonad.
1044;;;
1045
1046(define-configuration/no-serialization kmonad-configuration
1047 (kmonad
1048 (package kmonad)
1049 "The KMonad package to use.")
1050 (keymaps
1051 (list-of-file-likes '())
1052 "A list of KMonad configurations (file-like objects). See
1053@uref{https://github.com/kmonad/kmonad/blob/master/keymap/tutorial.kbd, KMonad
1054- Keymap Tutorial}"))
1055
1056;; Isolate write access to /dev/uinput to prevent privilege escalation for
1057;; users/processes that only need read access to the 'input' group.
1058(define %uinput-group
1059 (user-group
1060 (name "uinput")
1061 (system? #t)))
1062
1063(define %kmonad-group
1064 (user-group
1065 (name "kmonad")
1066 (system? #t)))
1067
1068;; OPTIONS+="static_node=uinput" triggers kmod to load the uinput module on
1069;; boot.
1070(define %kmonad-udev-rule
1071 (udev-rule
1072 "99-kmonad.rules"
1073 "KERNEL==\"uinput\", MODE=\"0660\", GROUP=\"uinput\", OPTIONS+=\"static_node=uinput\"\n"))
1074
1075(define %kmonad-user
1076 (user-account
1077 (name "kmonad")
1078 (group "kmonad")
1079 (supplementary-groups '("input" "uinput"))
1080 (system? #t)
1081 (comment "KMonad daemon user")
1082 (home-directory "/var/empty")
1083 (create-home-directory? #f)
1084 (shell (file-append shadow "/sbin/nologin"))))
1085
1086(define %kmonad-accounts
1087 (list %uinput-group %kmonad-group %kmonad-user))
1088
1089(define (kmonad-shepherd-services config)
1090 "Return a shepherd service for each @command{kmonad} configuration."
1091 (let* ((kmonad (file-append (kmonad-configuration-kmonad config)
1092 "/bin/kmonad"))
1093 (keymaps (kmonad-configuration-keymaps config)))
1094 (map (lambda (index keymap)
1095 (let ((name (string-append "kmonad-" (number->string index))))
1096 (shepherd-service
1097 (provision (list (string->symbol name)))
1098 (requirement '(user-processes udev))
1099 (documentation (string-append "Run kmonad process "
1100 (number->string index) "."))
1101 (start #~(make-forkexec-constructor
1102 (list #$kmonad "-l" "info" #$keymap)
1103 #:user "kmonad"
1104 #:group "kmonad"
1105 #:supplementary-groups '("input" "uinput")
1106 #:log-file #$(string-append "/var/log/" name ".log")))
1107 (stop #~(make-kill-destructor)))))
1108 (iota (length keymaps))
1109 keymaps)))
1110
1111(define kmonad-service-type
1112 (service-type
1113 (name 'kmonad)
1114 (extensions
1115 (list (service-extension account-service-type
1116 (const %kmonad-accounts))
1117 (service-extension shepherd-root-service-type
1118 kmonad-shepherd-services)
1119 (service-extension udev-service-type
1120 (const (list %kmonad-udev-rule)))))
1121 (description "Run the @command{kmonad} daemon, which allows customizing
1122and extending the functionalities of different keyboards.")))
1123
1124
1125;;;
1126;;; Kanata.
1127;;;
1128
1129(define-configuration/no-serialization kanata-configuration
1130 (kanata
1131 (package kanata)
1132 "The @code{kanata} package to use.")
1133 (keymaps
1134 (list-of-file-likes '())
1135 "List of @command{kanata} configuration files (file-like objects). See
1136@uref{https://jtroo.github.io/config.html#linux-only-linux-dev, Kanata's
1137device specification documentation}."))
1138
1139(define %kanata-group
1140 (user-group
1141 (name "kanata")
1142 (system? #t)))
1143
1144(define %kanata-user
1145 (user-account
1146 (name "kanata")
1147 (group "kanata")
1148 (supplementary-groups '("input" "uinput"))
1149 (system? #t)
1150 (comment "Kanata daemon user")
1151 (home-directory "/var/empty")
1152 (create-home-directory? #f)
1153 (shell (file-append shadow "/sbin/nologin"))))
1154
1155(define %kanata-accounts
1156 (list %uinput-group %kanata-group %kanata-user))
1157
1158;; OPTIONS+="static_node=uinput" triggers kmod to load the uinput module on
1159;; boot.
1160(define %kanata-udev-rule
1161 (udev-rule
1162 "99-kanata.rules"
1163 "KERNEL==\"uinput\", MODE=\"0660\", GROUP=\"uinput\", OPTIONS+=\"static_node=uinput\"\n"))
1164
1165(define (kanata-shepherd-services config)
1166 "Return a shepherd service for each @command{kanata} configuration."
1167 (let* ((kanata (file-append (kanata-configuration-kanata config)
1168 "/bin/kanata"))
1169 (keymaps (kanata-configuration-keymaps config)))
1170 (map (lambda (index keymap)
1171 (let ((name (string-append "kanata-" (number->string index))))
1172 (shepherd-service
1173 (provision (list (string->symbol name)))
1174 (requirement '(user-processes udev))
1175 (documentation (string-append "Run kanata process "
1176 (number->string index) "."))
1177 (start #~(make-forkexec-constructor
1178 ;; '--no-wait' prevents pausing on exit so
1179 ;; Shepherd can reliably restart the daemon.
1180 (list #$kanata "-c" #$keymap "--no-wait")
1181 #:user "kanata"
1182 #:group "kanata"
1183 #:supplementary-groups '("input" "uinput")
1184 #:log-file #$(string-append "/var/log/" name ".log")))
1185 (stop #~(make-kill-destructor)))))
1186 (iota (length keymaps))
1187 keymaps)))
1188
1189(define kanata-service-type
1190 (service-type
1191 (name 'kanata)
1192 (extensions
1193 (list (service-extension account-service-type
1194 (const %kanata-accounts))
1195 (service-extension shepherd-root-service-type
1196 kanata-shepherd-services)
1197 (service-extension udev-service-type
1198 (const (list %kanata-udev-rule)))))
1199 (description
1200 "Run the @command{kanata} daemon, which allows customizing and extending
1201the functionalities of different keyboards.")))
1202
1203
1204;;;
1205;;; GPU Screen Recorder.
1206;;;
1207
1208(define-record-type* <gpu-screen-recorder-configuration>
1209 gpu-screen-recorder-configuration
1210 make-gpu-screen-recorder-configuration
1211 gpu-screen-recorder-configuration?
1212 (package
1213 gpu-screen-recorder-configuration-package
1214 (default gpu-screen-recorder)))
1215
1216(define (gpu-screen-recorder-privileged-programs config)
1217 (list
1218 (privileged-program
1219 (program
1220 (file-append
1221 (gpu-screen-recorder-configuration-package config)
1222 "/bin/gsr-kms-server"))
1223 (capabilities "cap_sys_admin=ep"))))
1224
1225(define gpu-screen-recorder-service-type
1226 (service-type
1227 (name 'gpu-screen-recorder)
1228 (extensions
1229 (list
1230 (service-extension
1231 profile-service-type
1232 (compose list gpu-screen-recorder-configuration-package))
1233 (service-extension
1234 privileged-program-service-type
1235 gpu-screen-recorder-privileged-programs)))
1236 (default-value (gpu-screen-recorder-configuration))
1237 (description
1238 "Install GPU Screen Recorder and grant its @command{gsr-kms-server}
1239helper the @code{CAP_SYS_ADMIN} capability required for direct KMS
1240capture.")))
1241
1242
1243;;;
1244;;; UDisks.
1245;;;
1246
1247(define-record-type* <udisks-configuration>
1248 udisks-configuration make-udisks-configuration
1249 udisks-configuration?
1250 (udisks udisks-configuration-udisks
1251 (default udisks)))
1252
1253(define %udisks-activation
1254 (with-imported-modules '((guix build utils))
1255 #~(begin
1256 (use-modules (guix build utils))
1257
1258 (let ((run-dir "/var/run/udisks2"))
1259 (mkdir-p run-dir)
1260 (chmod run-dir #o700)))))
1261
1262(define udisks-service-type
1263 (let ((udisks-package (lambda (config)
1264 (list (udisks-configuration-udisks config)))))
1265 (service-type (name 'udisks)
1266 (extensions
1267 (list (service-extension polkit-service-type
1268 udisks-package)
1269 (service-extension dbus-root-service-type
1270 udisks-package)
1271 (service-extension udev-service-type
1272 udisks-package)
1273 (service-extension activation-service-type
1274 (const %udisks-activation))
1275
1276 ;; Profile 'udisksctl' & co. in the system profile.
1277 (service-extension profile-service-type
1278 udisks-package)))
1279 (description "Run UDisks, a @dfn{disk management} daemon
1280that provides user interfaces with notifications and ways to mount/unmount
1281disks. Programs that talk to UDisks include the @command{udisksctl} command,
1282part of UDisks, and GNOME Disks.")
1283 (default-value (udisks-configuration)))))
1284
1285(define-deprecated (udisks-service #:key (udisks udisks))
1286 udisks-service-type
1287 "Return a service for @uref{http://udisks.freedesktop.org/docs/latest/,
1288UDisks}, a @dfn{disk management} daemon that provides user interfaces with
1289notifications and ways to mount/unmount disks. Programs that talk to UDisks
1290include the @command{udisksctl} command, part of UDisks, and GNOME Disks."
1291 (service udisks-service-type
1292 (udisks-configuration (udisks udisks))))
1293
1294
1295
1296;;;
1297;;; GVfs virtual file system.
1298;;;
1299
1300(define-record-type* <gvfs-configuration>
1301 gvfs-configuration make-gvfs-configuration
1302 gvfs-configuration?
1303 (gvfs gvfs-package (default gvfs)))
1304
1305(define gvfs-service-type
1306 (service-type (name 'gvfs)
1307 (extensions
1308 (list
1309 (service-extension profile-service-type
1310 (compose list gvfs-package))
1311 ;; Required for gvfs-udisks2-volume-monitor.
1312 (service-extension udisks-service-type (const #t))))
1313 (description
1314 "Make GVfs virtual file systems (Trash, SFTP, SMB, HTTP,
1315and many other) available for GIO applications.")
1316 (default-value (gvfs-configuration))))
1317
1318
1319;;;
1320;;; Elogind login and seat management service.
1321;;;
1322
1323;;; Elogind configuration types.
1324(define-maybe boolean
1325 (prefix elogind-))
1326
1327(define (non-negative-integer? x)
1328 (and (exact-integer? x)
1329 (not (negative? x))))
1330
1331(define-maybe non-negative-integer
1332 (prefix elogind-))
1333
1334(define (non-negative-integer-and-suffix? x)
1335 (match-lambda
1336 ((x . '%)
1337 (and (non-negative-integer? x)
1338 (<= x 100)))
1339 (((? non-negative-integer?) . suffix)
1340 (member suffix '(K M G T)))
1341 (x (non-negative-integer? x))))
1342
1343(define-maybe non-negative-integer-and-suffix
1344 (prefix elogind-))
1345
1346(define char-set:user-name
1347 (string->char-set "abcdefghijklmnopqrstuvwxyz0123456789_-"))
1348
1349(define (user-name? x)
1350 (string-every char-set:user-name x))
1351
1352(define list-of-user-names?
1353 (list-of user-name?))
1354
1355(define-maybe list-of-user-names
1356 (prefix elogind-))
1357
1358(define %elogind-actions
1359 '( ignore poweroff reboot halt kexec suspend hibernate hybrid-sleep
1360 suspend-then-hibernate lock factory-reset))
1361
1362(define (action? x)
1363 (member x %elogind-actions))
1364
1365(define-maybe action
1366 (prefix elogind-))
1367
1368(define %linux-suspend-states
1369 ;; The possible suspend states supported by the Linux kernel.
1370 ;; See (info "(linux) Basic sysfs Interfaces for System Suspend and Hibernation").
1371 '(disk standby freeze mem))
1372
1373(define (string->symbol/maybe x)
1374 (if (string? x)
1375 (string->symbol x)
1376 x))
1377
1378(define (suspend-state? x)
1379 (member (string->symbol/maybe x) %linux-suspend-states))
1380
1381(define list-of-suspend-states?
1382 (list-of suspend-state?))
1383
1384(define-maybe list-of-suspend-states
1385 (prefix elogind-))
1386
1387(define %linux-suspend-modes
1388 ;; The possible suspend state variants supported by the Linux kernel.
1389 ;; See (info "(linux) Basic sysfs Interfaces for System Suspend and Hibernation").
1390 '(s2idle shallow deep))
1391
1392(define (suspend-mode? x)
1393 (member (string->symbol/maybe x) %linux-suspend-modes))
1394
1395(define list-of-suspend-modes?
1396 (list-of suspend-mode?))
1397
1398(define-maybe list-of-suspend-modes
1399 (prefix elogind-))
1400
1401(define %linux-hibernation-modes
1402 ;; The possible hibernation operating modes supported by the Linux kernel.
1403 ;; See (info "(linux) Basic sysfs Interfaces for System Suspend and Hibernation").
1404 '(platform shutdown reboot suspend test_resume))
1405
1406(define (hibernation-mode? x)
1407 (member (string->symbol/maybe x) %linux-hibernation-modes))
1408
1409(define list-of-hibernation-modes?
1410 (list-of hibernation-mode?))
1411
1412(define-maybe list-of-hibernation-modes
1413 (prefix elogind-))
1414
1415(define-maybe list-of-strings
1416 (prefix elogind-))
1417
1418;;; Elogind serializers.
1419(define elogind-name->string
1420 (compose (lambda (name)
1421 ;; Configuration file is case sensitive, so special case those
1422 ;; few cases where pascal-case gets it wrong.
1423 (cond ((equal? name "RemoveIpc")
1424 "RemoveIPC")
1425 ((equal? name "HibernateOnAcPower")
1426 "HibernateOnACPower")
1427 (else
1428 name)))
1429 pascal-case
1430 (lambda (name)
1431 (cond ((string-suffix? "?" name)
1432 (string-drop-right name 1))
1433 ((string-suffix? "seconds" name)
1434 (string-drop-right name 4))
1435 (else
1436 name)))
1437 symbol->string))
1438
1439(define (elogind-serialize-boolean name value)
1440 (format #f "~a=~:[no~;yes~]~%" (elogind-name->string name) value))
1441
1442(define (elogind-base-serializer name value)
1443 (format #f "~a=~a~%" (elogind-name->string name) value))
1444
1445(define elogind-serialize-action elogind-base-serializer)
1446(define elogind-serialize-non-negative-integer elogind-base-serializer)
1447
1448(define (elogind-serialize-non-negative-integer-and-suffix name value)
1449 (let ((name (elogind-name->string name)))
1450 (match value
1451 ((first . second)
1452 (format #f "~a=~a~a~%" name first second))
1453 (_ (format #f "~a=~a~%" name value)))))
1454
1455(define (elogind-list-serializer name value)
1456 (format #f "~a=~{~a~^ ~}~%" (elogind-name->string name) value))
1457
1458(define elogind-serialize-list-of-strings elogind-list-serializer)
1459(define elogind-serialize-list-of-user-names elogind-list-serializer)
1460(define elogind-serialize-list-of-suspend-states elogind-list-serializer)
1461(define elogind-serialize-list-of-suspend-modes elogind-list-serializer)
1462(define elogind-serialize-list-of-hibernation-modes elogind-list-serializer)
1463
1464;;; XXX: For backward-compatible/historical reasons, the configuration object
1465;;; is flat, containing the fields of both the logind.conf and sleep.conf
1466;;; files. The list below contains the fields that should be serialized to
1467;;; sleep.conf.
1468(define %elogind-configuration-sleep-fields
1469 '( suspend-state suspend-mode suspend-estimation-seconds
1470 hibernate-mode hibernate-delay-seconds hibernate-on-ac-power
1471 allow-power-off-interrupts? allow-suspend-interrupts?
1472 broadcast-power-off-interrupts? broadcast-suspend-interrupts?))
1473
1474(define-configuration elogind-configuration
1475 (elogind
1476 (file-like elogind)
1477 "The elogind package to use."
1478 (serializer empty-serializer))
1479
1480 (system-sleep-hook-files
1481 (list-of-file-likes '())
1482 "A list of executables (file-like objects) that will be installed into the
1483@file{/etc/elogind/system-sleep} hook directory. See `Hook directories' in
1484the @samp{loginctl(1)} man page for more information."
1485 (serializer empty-serializer))
1486
1487 (system-shutdown-hook-files
1488 (list-of-file-likes '())
1489 "A list of executables (file-like objects) that will be installed into the
1490@file{/etc/elogind/system-shutdown/} hook directory."
1491 (serializer empty-serializer))
1492
1493 (allow-power-off-interrupts?
1494 (maybe-boolean #f)
1495 "Whether the executables in elogind's hook directories (see above) can
1496 cause a power-off action to be cancelled (interrupted) by printing an
1497 appropriate error message to stdout.")
1498
1499 (allow-suspend-interrupts?
1500 (maybe-boolean #f)
1501 "Likewise as the @code{allow-power-off-interrupts?} option, but for the
1502 suspend action.")
1503
1504 (broadcast-power-off-interrupts?
1505 (maybe-boolean #t)
1506 "Whether an interrupt of a power-off action is broadcasted.")
1507
1508 (broadcast-suspend-interrupts?
1509 (maybe-boolean #t)
1510 "Whether an interrupt of a suspend action is broadcasted.")
1511
1512 ;; logind.conf options.
1513 (kill-user-processes?
1514 (maybe-boolean #f)
1515 "Whether the processes of a user should be killed when the user logs
1516 out.")
1517
1518 (kill-only-users
1519 maybe-list-of-user-names
1520 "Usernames whose processes should be killed, regardless the value of
1521 @code{kill-user-processes?}.")
1522
1523 (kill-exclude-users
1524 (maybe-list-of-user-names (list "root"))
1525 "Usernames whose processes should @emph{not} be killed, regardless the
1526 value of @code{kill-user-processes?}.")
1527
1528 (inhibit-delay-max-seconds
1529 (maybe-non-negative-integer 5)
1530 "The maximum time a system shutdown or sleep request is delayed due to an
1531 inhibitor lock of type delay being active before the inhibitor is ignored and
1532 the operation executes anyway.")
1533
1534 (handle-power-key
1535 (maybe-action 'poweroff)
1536 "The action done when the power key is pressed.")
1537
1538 (handle-power-key-long-press
1539 (maybe-action 'ignore)
1540 "The action done when the power key is long pressed.")
1541
1542 (handle-suspend-key
1543 (maybe-action 'suspend)
1544 "The action done when the suspend key is pressed.")
1545
1546 (handle-suspend-key-long-press
1547 (maybe-action 'hibernate)
1548 "The action done when the suspend key is long pressed.")
1549
1550 (handle-hibernate-key
1551 (maybe-action 'hibernate)
1552 "The action done when the hibernate key is pressed.")
1553
1554 (handle-hibernate-key-long-press
1555 (maybe-action 'ignore)
1556 "The action done when the hibernate key is long pressed.")
1557
1558 (handle-lid-switch
1559 (maybe-action 'suspend)
1560 "The action done when the lid is closed.")
1561
1562 (handle-lid-switch-docked
1563 (maybe-action 'ignore)
1564 "The action done when the lid is closed and the device docked.")
1565
1566 (handle-lid-switch-external-power
1567 (maybe-action 'suspend)
1568 "The action done when the lid is closed and the device is externally
1569 powered.")
1570
1571 (power-key-ignore-inhibited?
1572 (maybe-boolean #f)
1573 "Whether to ignore high-level inhibitor locks (shutdown, reboot, sleep or
1574 idle) when the power key is pressed.")
1575
1576 (suspend-key-ignore-inhibited?
1577 (maybe-boolean #f)
1578 "Whether to ignore high-level inhibitor locks (shutdown, reboot, sleep or
1579 idle) when the suspend key is pressed.")
1580
1581 (hibernate-key-ignore-inhibited?
1582 (maybe-boolean #f)
1583 "Whether to ignore high-level inhibitor locks (shutdown, reboot, sleep or
1584 idle) when the hibernate key is pressed.")
1585
1586 (lid-switch-ignore-inhibited?
1587 (maybe-boolean #f)
1588 "Whether to ignore high-level inhibitor locks (shutdown, reboot, sleep or
1589 idle) when the lid is closed.")
1590
1591 (holdoff-timeout-seconds
1592 (maybe-non-negative-integer 30)
1593 "Specifies the number of seconds after system startup or system resume
1594during which elogind will hold off on reacting to lid events.")
1595
1596 (idle-action
1597 (maybe-action 'ignore)
1598 "Action to take when the system is idle.")
1599
1600 (idle-action-seconds
1601 maybe-non-negative-integer
1602 "The delay after which the action configured in @code{idle-action} is
1603taken after the system is idle.")
1604
1605 (runtime-directory-size
1606 (maybe-non-negative-integer-and-suffix '(10 . %))
1607 "Set the size limit on the @env{XDG_RUNTIME_DIR} runtime directory
1608for each user who logs in. The size in bytes can be given as an integer
1609and paired with symbols: K, M, G, or T. When paired with @code{'%}, the
1610integer represents the limit as a percentage share of the total amount
1611of physical @acronym{RAM, read access memory}.")
1612
1613 (remove-ipc?
1614 (maybe-boolean #t)
1615 "Whether @acronym{IPC, inter-process communication} objects belonging to
1616the user shall be removed when the user fully logs out.")
1617
1618 ;; sleep.conf options.
1619 ;; CAUTION: all sleep.conf option names must be registered in the above
1620 ;; %ELOGIND-CONFIGURATION-SLEEP-FIELDS variable: otherwise they will be
1621 ;; serialized to logind.conf instead of sleep.conf!
1622 (suspend-state
1623 (maybe-list-of-suspend-states '(mem standby freeze))
1624 "The suspend state values to be write to @file{/sys/power/state} by elogind
1625 when suspending the system. They will be tried in turn, until one is written
1626 without error.")
1627
1628 (suspend-mode
1629 (maybe-list-of-suspend-modes)
1630 "The suspend mode values to write to @file{/sys/power/mem_sleep} by elogind
1631 when suspending the system.")
1632
1633 (suspend-estimation-seconds
1634 (maybe-non-negative-integer (* 60 60)) ;1 hour
1635 "Cause the RTC alarm to wake the system after the specified time span to
1636 measure the system battery capacity level and estimate the battery discharging
1637 rate, which is used for estimating the time span until the system battery
1638 charge level goes down to 5%. This option is only used by elogind when using
1639 the @code{'suspend-then-hibernate} action.")
1640
1641 (hibernate-mode
1642 (maybe-list-of-hibernation-modes '(platform shutdown))
1643 "The hibernation mode values to write to @file{/sys/power/disk} by elogind
1644 when hibernating the system.")
1645
1646 (hibernate-on-ac-power
1647 (maybe-boolean #t)
1648 "Whether to allow hibernation when the system has AC power.
1649This option is only used if @code{hibernate-delay-seconds} is set. If this
1650option is disabled, the coutdown of @code{hibernate-delay-seconds} starts only
1651after AC power is disconnected, keeping the system in the suspend state
1652otherwise.")
1653
1654 (hibernate-delay-seconds
1655 maybe-non-negative-integer
1656 "The amount of time the system spends in suspend mode before the system is
1657 automatically put into hibernate mode.")
1658
1659 (prefix elogind-))
1660
1661(define (logind.conf config)
1662 (let ((logind-fields (remove (lambda (field)
1663 (memq (configuration-field-name field)
1664 %elogind-configuration-sleep-fields))
1665 elogind-configuration-fields)))
1666 (mixed-text-file
1667 "logind.conf"
1668 "[Login]\n"
1669 (serialize-configuration config logind-fields))))
1670
1671(define (sleep.conf config)
1672 (let ((sleep-fields (filter (lambda (field)
1673 (memq (configuration-field-name field)
1674 %elogind-configuration-sleep-fields))
1675 elogind-configuration-fields)))
1676 (mixed-text-file
1677 "sleep.conf"
1678 "[Sleep]\n"
1679 (serialize-configuration config sleep-fields))))
1680
1681(define (elogind-etc-directory config)
1682 "Return the /etc/elogind directory for CONFIG."
1683 (with-imported-modules (source-module-closure '((guix build utils)))
1684 (computed-file
1685 "etc-elogind"
1686
1687 #~(begin
1688 (use-modules (guix build utils))
1689
1690 (define sleep-directory (string-append #$output "/system-sleep/"))
1691 (define shutdown-directory (string-append #$output "/system-shutdown/"))
1692
1693 (define (copy-script file directory)
1694 "Copy FILE into DIRECTORY, giving rx (500) permissions."
1695 (let ((dest (string-append directory "/" (basename file))))
1696 (mkdir-p directory)
1697 (copy-file file dest)
1698 (chmod dest #o500)))
1699
1700 (mkdir-p #$output) ;in case neither directory gets created
1701
1702 ;; Symlink the main configuration files.
1703 (with-directory-excursion #$output
1704 (mkdir-p "logind.conf.d")
1705 (symlink #$(logind.conf config) "logind.conf.d/logind.conf")
1706 (mkdir-p "sleep.conf.d")
1707 (symlink #$(sleep.conf config) "sleep.conf.d/sleep.conf"))
1708
1709 (for-each (lambda (f)
1710 (copy-script f sleep-directory))
1711 '#$(elogind-configuration-system-sleep-hook-files config))
1712 (for-each (lambda (f)
1713 (copy-script f shutdown-directory))
1714 '#$(elogind-configuration-system-shutdown-hook-files
1715 config))))))
1716
1717(define (elogind-dbus-service config)
1718 "Return a @file{org.freedesktop.login1.service} file that tells D-Bus how to
1719\"start\" elogind. In practice though, our elogind is started when booting by
1720shepherd. Thus, the @code{Exec} line of this @file{.service} file does not
1721explain how to start elogind; instead, it spawns a wrapper that waits for the
1722@code{elogind} shepherd service. This avoids a race condition where both
1723@command{shepherd} and @command{dbus-daemon} would attempt to start elogind."
1724 ;; For more info on the elogind startup race, see
1725 ;; <https://issues.guix.gnu.org/55444>.
1726
1727 (define elogind
1728 (elogind-configuration-elogind config))
1729
1730 (define wrapper
1731 (program-file "elogind-dbus-shepherd-sync"
1732 (with-imported-modules '((gnu services herd))
1733 #~(begin
1734 (use-modules (gnu services herd)
1735 (srfi srfi-34))
1736
1737 (guard (c ((service-not-found-error? c)
1738 (format (current-error-port)
1739 "no elogind shepherd service~%")
1740 (exit 1))
1741 ((shepherd-error? c)
1742 (format (current-error-port)
1743 "elogind shepherd service not \
1744started~%")
1745 (exit 2)))
1746 (wait-for-service 'elogind))))))
1747
1748 (define build
1749 (with-imported-modules '((guix build utils))
1750 #~(begin
1751 (use-modules (guix build utils)
1752 (ice-9 match))
1753
1754 (define service-directory
1755 "/share/dbus-1/system-services")
1756
1757 (define elogind-service-directory
1758 (string-append #$elogind service-directory))
1759
1760 (mkdir-p (dirname (string-append #$output service-directory)))
1761
1762 ;; TODO: Remove (when (file-exists? elogind-service-directory)
1763 ;; conditionals after elogind is ungrafted.
1764 (when (file-exists? elogind-service-directory)
1765 (copy-recursively elogind-service-directory
1766 (string-append #$output service-directory)))
1767 (symlink (string-append #$elogind "/etc") ;for etc/dbus-1
1768 (string-append #$output "/etc"))
1769 ;; Also expose the D-Bus policy configurations (.conf) files, now
1770 ;; installed under '/share' instead of the legacy '/etc' prefix.
1771 (symlink (string-append #$elogind "/share/dbus-1/system.d")
1772 (string-append #$output "/share/dbus-1/system.d"))
1773
1774 ;; Replace the "Exec=" line of the 'org.freedesktop.login1.service'
1775 ;; file with one that refers to WRAPPER instead of elogind.
1776 (when (file-exists? elogind-service-directory)
1777 (match (find-files #$output "\\.service$")
1778 ((file)
1779 (substitute* file
1780 (("Exec[[:blank:]]*=.*" _)
1781 (string-append "Exec=" #$wrapper "\n")))))))))
1782
1783 (list (computed-file "elogind-dbus-service-wrapper" build)))
1784
1785(define (pam-extension-procedure config)
1786 "Return an extension for PAM-ROOT-SERVICE-TYPE that ensures that all the PAM
1787services use 'pam_elogind.so', a module that allows elogind to keep track of
1788logged-in users (run 'loginctl' to see elogind's world view of users and
1789seats.)"
1790 (define pam-elogind
1791 (pam-entry
1792 (control "required")
1793 (module (file-append (elogind-configuration-elogind config)
1794 "/lib/security/pam_elogind.so"))))
1795
1796 (list (pam-extension
1797 (transformer
1798 (lambda (pam)
1799 (pam-service
1800 (inherit pam)
1801 (session (cons pam-elogind (pam-service-session pam))))))
1802 (shepherd-requirements '(elogind)))))
1803
1804(define* (shepherd-configuration-action* files)
1805 "Return a 'configuration' action to display FILES, which should be the names
1806of the service's configuration files."
1807 (shepherd-action
1808 (name 'configuration)
1809 (documentation "Display the names of this service's configuration files.")
1810 (procedure #~(lambda (_)
1811 (format #t "~{~a~%~}" '#$files)
1812 '#$files))))
1813
1814(define (elogind-shepherd-service config)
1815 "Return a Shepherd service to start elogind according to @var{config}."
1816 (list (shepherd-service
1817 (requirement '(user-processes dbus-system))
1818 (provision '(elogind))
1819 (start #~(make-forkexec-constructor
1820 (list #$(file-append (elogind-configuration-elogind config)
1821 "/libexec/elogind/elogind"))))
1822 (stop #~(make-kill-destructor))
1823 (actions (list (shepherd-configuration-action*
1824 (list (logind.conf config)
1825 (sleep.conf config))))))))
1826
1827(define elogind-service-type
1828 (service-type
1829 (name 'elogind)
1830 (extensions
1831 (list (service-extension dbus-root-service-type
1832 elogind-dbus-service)
1833 (service-extension udev-service-type
1834 (compose list elogind-configuration-elogind))
1835 (service-extension polkit-service-type
1836 (compose list elogind-configuration-elogind))
1837
1838 ;; Start elogind from the Shepherd rather than waiting
1839 ;; for bus activation. This ensures that it can handle
1840 ;; events like lid close, etc.
1841 (service-extension shepherd-root-service-type
1842 elogind-shepherd-service)
1843
1844 ;; Provide the 'loginctl' command.
1845 (service-extension profile-service-type
1846 (compose list elogind-configuration-elogind))
1847
1848 ;; Extend PAM with pam_elogind.so.
1849 (service-extension pam-root-service-type
1850 pam-extension-procedure)
1851
1852 ;; Install sleep/shutdown hook files.
1853 (service-extension etc-service-type
1854 (lambda (config)
1855 `(("elogind"
1856 ,(elogind-etc-directory config)))))
1857
1858 ;; We need /run/user, /run/systemd, etc.
1859 (service-extension file-system-service-type
1860 (const %elogind-file-systems))))
1861 (default-value (elogind-configuration))
1862 (description "Run the @command{elogind} login and seat
1863management service. The @command{elogind} service integrates with PAM to
1864allow other system components to know the set of logged-in users as well as
1865their session types (graphical, console, remote, etc.). It can also clean up
1866after users when they log out.")))
1867
1868(define-deprecated (elogind-service #:key (config (elogind-configuration)))
1869 elogind-service-type
1870 "Return a service that runs the @command{elogind} login and seat management
1871service. The @command{elogind} service integrates with PAM to allow other
1872system components to know the set of logged-in users as well as their session
1873types (graphical, console, remote, etc.). It can also clean up after users
1874when they log out."
1875 (service elogind-service-type config))
1876
1877
1878;;;
1879;;; Gardenhostd.
1880;;;
1881
1882(define-configuration/no-serialization gardenhostd-configuration
1883 (gardenhostd
1884 (package gardenhostd)
1885 "The gardenhostd package to use."))
1886
1887(define (gardenhostd-profile config)
1888 (list (gardenhostd-configuration-gardenhostd config)))
1889
1890(define gardenhostd-service-type
1891 (service-type
1892 (name 'gardenhostd)
1893 (extensions
1894 (list
1895 (service-extension dbus-root-service-type gardenhostd-profile)
1896 (service-extension polkit-service-type gardenhostd-profile)))
1897 (default-value (gardenhostd-configuration))
1898 (description "This service provides gardenhostd, a partial
1899implementation of the systemd-hostnamed daemon. It provides the
1900org.freedesktop.hostname1 D-Bus interface, which helps applications
1901like gnome-control-center retrieve and modify the system’s hostname,
1902as well as set a pretty hostname for display.")))
1903
1904
1905;;;
1906;;; Fontconfig and other desktop file-systems.
1907;;;
1908
1909(define %fontconfig-file-system
1910 (file-system
1911 (device "none")
1912 (mount-point "/var/cache/fontconfig")
1913 (type "tmpfs")
1914 (flags '(read-only))
1915 (check? #f)))
1916
1917(define %gdm-file-system
1918 (file-system
1919 (device "none")
1920 (mount-point "/var/lib/gdm")
1921 (type "tmpfs")
1922 (check? #f)))
1923
1924;; The global fontconfig cache directory can sometimes contain stale entries,
1925;; possibly referencing fonts that have been GC'd, so mount it read-only.
1926;; As mentioned https://debbugs.gnu.org/cgi/bugreport.cgi?bug=36924#8 and
1927;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=38046#10 and elsewhere.
1928(define fontconfig-file-system-service
1929 (simple-service 'fontconfig-file-system
1930 file-system-service-type
1931 (list %fontconfig-file-system)))
1932
1933;; Avoid stale caches and stale user IDs being reused between system
1934;; reconfigurations, which would crash GDM and render the system unusable.
1935;; GDM doesn't require persisting anything valuable there anyway.
1936(define gdm-file-system-service
1937 (simple-service 'gdm-file-system
1938 file-system-service-type
1939 (list %gdm-file-system)))
1940
1941
1942;;;
1943;;; AccountsService service.
1944;;;
1945
1946(define %accountsservice-activation
1947 #~(begin
1948 (use-modules (guix build utils))
1949 (mkdir-p "/var/lib/AccountsService")))
1950
1951(define accountsservice-service-type
1952 (service-type (name 'accountsservice)
1953 (extensions
1954 (list (service-extension activation-service-type
1955 (const %accountsservice-activation))
1956 (service-extension dbus-root-service-type list)
1957 (service-extension polkit-service-type list)))
1958 (default-value accountsservice)
1959 (description "Run AccountsService, a system service available
1960over D-Bus that can list available accounts, change their passwords, and so
1961on. AccountsService integrates with PolicyKit to enable unprivileged users to
1962acquire the capability to modify their system configuration.")))
1963
1964(define-deprecated
1965 (accountsservice-service #:key (accountsservice accountsservice))
1966 accountsservice-service-type
1967 "Return a service that runs AccountsService, a system service that
1968can list available accounts, change their passwords, and so on.
1969AccountsService integrates with PolicyKit to enable unprivileged users to
1970acquire the capability to modify their system configuration.
1971@uref{https://www.freedesktop.org/wiki/Software/AccountsService/, the
1972accountsservice web site} for more information."
1973 (service accountsservice-service-type accountsservice))
1974
1975
1976;;;
1977;;; cups-pk-helper service.
1978;;;
1979
1980(define cups-pk-helper-service-type
1981 (service-type
1982 (name 'cups-pk-helper)
1983 (description
1984 "PolicyKit helper to configure CUPS with fine-grained privileges.")
1985 (extensions
1986 (list (service-extension dbus-root-service-type list)
1987 (service-extension polkit-service-type list)))
1988 (default-value cups-pk-helper)))
1989
1990
1991;;;
1992;;; Scanner access via SANE.
1993;;;
1994
1995(define %sane-accounts
1996 ;; The '60-libsane.rules' udev rules refers to the "scanner" group.
1997 (list (user-group (name "scanner") (system? #t))))
1998
1999(define (non-empty-list-of-packages? val)
2000 (and (not (null? val)) (list-of-packages? val)))
2001
2002(define-configuration/no-serialization sane-configuration
2003 (sane
2004 (package sane)
2005 "The package that provides the SANE library.")
2006 (backends
2007 (non-empty-list-of-packages (list sane-backends))
2008 "A list of packages containing SANE backends."))
2009
2010(define (sane-search-paths config)
2011 (match-record config <sane-configuration> (sane backends)
2012 (let ((backend-union (directory-union "sane-backends" backends)))
2013 (map (match-lambda
2014 (($ <search-path-specification> variable (files))
2015 (cons variable (file-append backend-union "/" files))))
2016 (package-native-search-paths sane)))))
2017
2018(define* (lift-sane-configuration config #:key warn?)
2019 (if (sane-configuration? config)
2020 config
2021 (begin
2022 (when warn?
2023 (warning (G_ "'sane' service now expects a 'sane-configuration' record~%"))
2024
2025 (when (eq? config sane-backends)
2026 (warning (G_ "'sane-backends' does not include 'hplip' backend anymore. Add it
2027explicitly when needed.~%"))))
2028
2029 (sane-configuration (backends (list config))))))
2030
2031(define sane-service-type
2032 (service-type
2033 (name 'sane)
2034 (description
2035 "This service provides access to scanners @i{via}
2036@uref{http://www.sane-project.org, SANE} by installing the necessary udev
2037rules.")
2038 (default-value (sane-configuration))
2039 (extensions
2040 (list (service-extension udev-service-type
2041 (lambda (c)
2042 (sane-configuration-backends
2043 (lift-sane-configuration c #:warn? #t))))
2044 (service-extension session-environment-service-type
2045 (lambda (c)
2046 (sane-search-paths (lift-sane-configuration c))))
2047 (service-extension account-service-type
2048 (const %sane-accounts))))))
2049
2050
2051;;;
2052;;; gnome-keyring-service-type
2053;;;
2054
2055(define-record-type* <gnome-keyring-configuration> gnome-keyring-configuration
2056 make-gnome-keyring-configuration
2057 gnome-keyring-configuration?
2058 (keyring gnome-keyring-package (default gnome-keyring))
2059 (pam-services gnome-keyring-pam-services (default '(("gdm-password" . login)
2060 ("passwd" . passwd)))))
2061
2062(define (pam-gnome-keyring config)
2063 ;; CONFIG may be either a <gnome-desktop-configuration> or a
2064 ;; <gnome-keyring-configuration>> record, when using the
2065 ;; gnome-keyring-service-type on its own.
2066 (let ((config (if (gnome-desktop-configuration? config)
2067 (gnome-desktop-configuration-keyring
2068 config)
2069 config)))
2070 (match config
2071 (#f '()) ;explicitly disabled by user
2072 (_
2073 (define (%pam-keyring-entry . arguments)
2074 (pam-entry
2075 (control "optional")
2076 (module (file-append (gnome-keyring-package config)
2077 "/lib/security/pam_gnome_keyring.so"))
2078 (arguments arguments)))
2079
2080 (list
2081 (pam-extension
2082 (transformer
2083 (lambda (service)
2084 (case (assoc-ref (gnome-keyring-pam-services config)
2085 (pam-service-name service))
2086 ((login)
2087 (pam-service
2088 (inherit service)
2089 (auth (append (pam-service-auth service)
2090 (list (%pam-keyring-entry))))
2091 (session (append (pam-service-session service)
2092 (list (%pam-keyring-entry "auto_start"))))))
2093 ((passwd)
2094 (pam-service
2095 (inherit service)
2096 (password (append (pam-service-password service)
2097 (list (%pam-keyring-entry))))))
2098 (else service))))))))))
2099
2100(define gnome-keyring-service-type
2101 (service-type
2102 (name 'gnome-keyring)
2103 (extensions (list
2104 (service-extension pam-root-service-type pam-gnome-keyring)))
2105 (default-value (gnome-keyring-configuration))
2106 (description "Return a service, that extends PAM with entries using
2107@code{pam_gnome_keyring.so}, unlocking a user's login keyring when they log in
2108or setting its password with passwd.")))
2109
2110
2111;;;
2112;;; GNOME desktop service.
2113;;;
2114
2115(define-maybe/no-serialization package)
2116
2117(define (gnome-keyring-configuration-or-#f? value)
2118 (or (gnome-keyring-configuration? value)
2119 (not value)))
2120
2121(define (extract-propagated-inputs package)
2122 ;; Drop input labels. Attempt to support outputs.
2123 (map
2124 (match-lambda
2125 ((_ (? package? pkg)) pkg)
2126 ((_ (? package? pkg) output) (list pkg output)))
2127 (package-propagated-inputs package)))
2128
2129(define-configuration/no-serialization gnome-desktop-configuration
2130 (core-services
2131 (list-of-packages (extract-propagated-inputs gnome-meta-core-services))
2132 "A list of packages that the GNOME Shell and applications may rely on.")
2133 (shell
2134 (list-of-packages (extract-propagated-inputs gnome-meta-core-shell))
2135 "A list of packages that constitute the GNOME Shell, without applications.")
2136 (utilities
2137 (list-of-packages (extract-propagated-inputs gnome-meta-core-utilities))
2138 "A list of packages that serve as applications to use on top of the \
2139GNOME Shell.")
2140 (gnome (maybe-package) "Deprecated. Do not use.")
2141 (extra-packages
2142 (list-of-packages (extract-propagated-inputs gnome-essential-extras))
2143 "A list of GNOME-adjacent packages to also include. This field is intended
2144for users to add their own packages to their GNOME experience. Note, that it
2145already includes some packages that are considered essential by some (most?)
2146GNOME users.")
2147 (udev-ignorelist
2148 (list-of-strings '())
2149 "A list of regular expressions denoting udev rules or hardware file names
2150provided by any package that should not be installed. By default, every udev
2151rule and hardware file specified by any package referenced in the other fields
2152are installed.")
2153 (polkit-ignorelist
2154 (list-of-strings '())
2155 "A list of regular expressions denoting polkit rules provided by any package
2156that should not be installed. By default, every polkit rule added by any package
2157referenced in the other fields are installed.")
2158 (keyring
2159 (gnome-keyring-configuration-or-#f (gnome-keyring-configuration))
2160 "A <gnome-keyring-configuration> record used to better integrate the GNOME
2161keyring with the system. Refer to the documentation of the
2162@code{gnome-keyring-service-type} for more information. If you'd rather avoid
2163integrating the GNOME keyring, you can set this to @code{#f}."))
2164
2165(define (gnome-package gnome name)
2166 "Return the package NAME among the GNOME package inputs. NAME can be a
2167single name or a tree-like, e.g. @code{'(\"gnome-boxes\" \"spice-gtk\")} to
2168denote the spice-gtk input of the gnome-boxes input of the GNOME meta-package."
2169 ((package-direct-input-selector name) gnome))
2170
2171(define (gnome-packages gnome names)
2172 "Return the package NAMES among the GNOME package inputs."
2173 (map (cut gnome-package gnome <>) names))
2174
2175(define (gnome-udev-configuration-files config)
2176 "Return the GNOME udev rules and hardware files as computed from its
2177dependencies by filtering out the ignorelist."
2178 (list
2179 (computed-file
2180 "gnome-udev-configurations"
2181 (with-imported-modules
2182 (source-module-closure '((guix build utils)
2183 (guix build union)))
2184 #~(begin
2185 (use-modules (guix build utils)
2186 (guix build union))
2187 ;; If rules.d or hwdb.d is not a proper directory but a symlink,
2188 ;; then it will not be possible to delete individual files in this
2189 ;; directory.
2190 (union-build #$output
2191 (search-path-as-list
2192 (list "lib/udev" "libexec/udev")
2193 (list #$@(gnome-profile config #:transitive? #t)))
2194 #:create-all-directories? #t)
2195 (for-each
2196 (lambda (pattern)
2197 (for-each
2198 delete-file-recursively
2199 (find-files #$output pattern)))
2200 (list #$@(gnome-desktop-configuration-udev-ignorelist config))))))))
2201
2202(define (gnome-polkit-settings config)
2203 "Return the list of GNOME dependencies that provide polkit actions and
2204rules."
2205 (list
2206 (computed-file
2207 "gnome-polkit-settings"
2208 (with-imported-modules
2209 (source-module-closure '((guix build utils)
2210 (guix build union)))
2211 #~(let ((output (string-append #$output "/share/polkit-1")))
2212 (use-modules (guix build utils)
2213 (guix build union))
2214 (mkdir-p (dirname output))
2215 (union-build output
2216 (search-path-as-list
2217 (list "share/polkit-1")
2218 (list #$@(gnome-profile config #:transitive? #t)))
2219 #:create-all-directories? #t)
2220 (for-each
2221 (lambda (pattern)
2222 (for-each
2223 delete-file-recursively
2224 (find-files output pattern)))
2225 (list #$@(gnome-desktop-configuration-polkit-ignorelist config))))))))
2226
2227(define* (gnome-profile config #:key transitive?)
2228 "Return the list of the packages specified in CONFIG. When TRANSITIVE? is
2229#t, also include their transitive propagated inputs. If there are transitive
2230inputs using non-default outputs, they are returned as gexp-input objects."
2231 (define gnome-packages
2232 (append
2233 (gnome-desktop-configuration-core-services config)
2234 (gnome-desktop-configuration-shell config)
2235 (gnome-desktop-configuration-utilities config)
2236 (let ((gnome-meta (gnome-desktop-configuration-gnome config)))
2237 (if (maybe-value-set? gnome-meta)
2238 (begin
2239 (warning
2240 (gnome-desktop-configuration-source-location config)
2241 (G_ "Using a meta-package for gnome-desktop is discouraged.~%"))
2242 (list gnome-meta))
2243 (list)))
2244 (gnome-desktop-configuration-extra-packages config)))
2245 (if transitive?
2246 (append gnome-packages
2247 (append-map (compose (cut map (match-lambda ;discard labels
2248 ((_ pkg) pkg)
2249 ((_ pkg out)
2250 (gexp-input pkg out)))
2251 <>)
2252 package-transitive-propagated-inputs)
2253 gnome-packages))
2254 gnome-packages))
2255
2256(define (gnome-setuid-programs config)
2257 "Return the list of setuid programs found within the packages specified in
2258CONFIG, a <gnome-desktop-configuration> object."
2259 ;; spice-gtk provides polkit actions for USB redirection in GNOME Boxes; set
2260 ;; its usb-acl-helper script setuid automatically when the gnome-boxes or
2261 ;; spice-gtk packages are added to one of the gnome-desktop-configuration
2262 ;; fields.
2263 (let* ((gnome-packages (gnome-profile config #:transitive? #t))
2264 (spice-gtk (find (compose (cut string=? "spice-gtk" <>)
2265 package-name
2266 (match-lambda ;disregard potential output
2267 ((? package? p) p)
2268 ((? gexp-input? p)
2269 (gexp-input-thing p))))
2270 gnome-packages))
2271 (files `(,@(if spice-gtk
2272 (list (file-append
2273 spice-gtk
2274 "/libexec/spice-client-glib-usb-acl-helper"))
2275 '()))))
2276 (map file-like->setuid-program files)))
2277
2278(define gnome-desktop-service-type
2279 (service-type
2280 (name 'gnome-desktop)
2281 (extensions
2282 (list (service-extension udev-service-type
2283 gnome-udev-configuration-files)
2284 (service-extension pam-root-service-type
2285 pam-gnome-keyring)
2286 (service-extension polkit-service-type
2287 gnome-polkit-settings)
2288 (service-extension privileged-program-service-type
2289 gnome-setuid-programs)
2290 (service-extension profile-service-type
2291 gnome-profile)))
2292 (default-value (gnome-desktop-configuration))
2293 (description "Run the GNOME desktop environment.")))
2294
2295
2296;;;
2297;;; MATE Desktop service.
2298;;; TODO: Add mate-screensaver.
2299
2300(define-record-type* <mate-desktop-configuration> mate-desktop-configuration
2301 make-mate-desktop-configuration
2302 mate-desktop-configuration?
2303 (mate-package mate-package (default mate)))
2304
2305(define (mate-polkit-extension config)
2306 "Return the list of packages for CONFIG's MATE package that extend polkit."
2307 (let ((mate (mate-package config)))
2308 (map (lambda (input)
2309 ((package-direct-input-selector input) mate))
2310 '("mate-system-monitor" ;kill, renice processes
2311 "mate-settings-daemon" ;date/time settings
2312 "mate-power-manager" ;modify brightness
2313 "mate-control-center" ;RandR, display properties FIXME
2314 "mate-applets")))) ;CPU frequency scaling
2315
2316(define mate-desktop-service-type
2317 (service-type
2318 (name 'mate-desktop)
2319 (extensions
2320 (list (service-extension polkit-service-type
2321 mate-polkit-extension)
2322 (service-extension profile-service-type
2323 (compose list
2324 mate-package))))
2325 (default-value (mate-desktop-configuration))
2326 (description "Run the MATE desktop environment.")))
2327
2328
2329;;;
2330;;; XFCE desktop service.
2331;;;
2332
2333(define-record-type* <xfce-desktop-configuration> xfce-desktop-configuration
2334 make-xfce-desktop-configuration
2335 xfce-desktop-configuration?
2336 (xfce xfce-package (default xfce))
2337 (allow-empty-passwords? xfce-allow-empty-passwords? (default #t)))
2338
2339(define (xfce-polkit-settings config)
2340 "Return the list of XFCE dependencies that provide polkit actions and
2341rules."
2342 (let ((xfce (xfce-package config)))
2343 (map (lambda (name)
2344 ((package-direct-input-selector name) xfce))
2345 '("thunar"
2346 "xfce4-power-manager"))))
2347
2348(define (xfce-pam-services config)
2349 (list (unix-pam-service "xfce4-screensaver"
2350 #:allow-empty-passwords?
2351 (xfce-allow-empty-passwords? config))))
2352
2353(define xfce-desktop-service-type
2354 (service-type
2355 (name 'xfce-desktop)
2356 (extensions
2357 (list (service-extension polkit-service-type
2358 xfce-polkit-settings)
2359 (service-extension pam-root-service-type
2360 xfce-pam-services)
2361 (service-extension profile-service-type
2362 (compose list xfce-package))))
2363 (default-value (xfce-desktop-configuration))
2364 (description "Run the Xfce desktop environment.")))
2365
2366
2367;;;
2368;;; Lxqt desktop service.
2369;;;
2370
2371(define-record-type* <lxqt-desktop-configuration> lxqt-desktop-configuration
2372 make-lxqt-desktop-configuration
2373 lxqt-desktop-configuration?
2374 (lxqt lxqt-package
2375 (default lxqt)))
2376
2377(define (lxqt-polkit-settings config)
2378 "Return the list of LXQt dependencies that provide polkit actions and
2379rules."
2380 (let ((lxqt (lxqt-package config)))
2381 (map (lambda (name)
2382 ((package-direct-input-selector name) lxqt))
2383 '("lxqt-admin"))))
2384
2385(define lxqt-desktop-service-type
2386 (service-type
2387 (name 'lxqt-desktop)
2388 (extensions
2389 (list (service-extension polkit-service-type
2390 lxqt-polkit-settings)
2391 (service-extension profile-service-type
2392 (compose list lxqt-package))))
2393 (default-value (lxqt-desktop-configuration))
2394 (description "Run LXQt desktop environment.")))
2395
2396
2397;;;
2398;;; Sugar desktop service.
2399;;;
2400
2401(define-record-type* <sugar-desktop-configuration> sugar-desktop-configuration
2402 make-sugar-desktop-configuration
2403 sugar-desktop-configuration?
2404 (sugar sugar-package (default sugar))
2405 (gobject-introspection
2406 sugar-gobject-introspection (default gobject-introspection))
2407 (activities
2408 sugar-activities (default (list sugar-help-activity))))
2409
2410(define (sugar-polkit-settings config)
2411 "Return the list of packages that provide polkit actions and rules."
2412 (list (sugar-package config)))
2413
2414(define sugar-desktop-service-type
2415 (service-type
2416 (name 'sugar-desktop)
2417 (extensions
2418 (list (service-extension polkit-service-type
2419 sugar-polkit-settings)
2420 (service-extension profile-service-type
2421 (lambda (config)
2422 (cons* (sugar-package config)
2423 (sugar-gobject-introspection config)
2424 (sugar-activities config))))))
2425 (default-value (sugar-desktop-configuration))
2426 (description "Run the Sugar desktop environment.")))
2427
2428
2429;;;
2430;;; X11 socket directory service
2431;;;
2432
2433(define x11-socket-directory-service-type
2434 (let ((x11-socket-directory-shepherd-service
2435 (shepherd-service
2436 (documentation "Create @file{/tmp/.X11-unix} for XWayland.")
2437 (requirement '(file-systems))
2438 (provision '(x11-socket-directory))
2439 (one-shot? #t)
2440 (start #~(lambda _
2441 (let ((directory "/tmp/.X11-unix"))
2442 (mkdir-p directory)
2443 (chmod directory #o1777)))))))
2444 (service-type
2445 (name 'x11-socket-directory-service)
2446 (extensions
2447 (list
2448 (service-extension shepherd-root-service-type
2449 (compose
2450 list
2451 (const x11-socket-directory-shepherd-service)))))
2452 (default-value #f) ; no default value required
2453 (description
2454 "Create @file{/tmp/.X11-unix} for XWayland. When using X11, libxcb
2455takes care of creating that directory however, when using XWayland, we
2456need to create it beforehand."))))
2457
2458(define-deprecated x11-socket-directory-service
2459 x11-socket-directory-service-type
2460 ;; Return a service that creates /tmp/.X11-unix. When using X11, libxcb
2461 ;; takes care of creating that directory. However, when using XWayland, we
2462 ;; need to create beforehand. Thus, create it unconditionally here.
2463 (service x11-socket-directory-service-type))
2464
2465
2466;;;
2467;;; Enlightenment desktop service.
2468;;;
2469
2470(define-record-type* <enlightenment-desktop-configuration>
2471 enlightenment-desktop-configuration make-enlightenment-desktop-configuration
2472 enlightenment-desktop-configuration?
2473 ;; <package>
2474 (enlightenment enlightenment-package
2475 (default enlightenment)))
2476
2477(define (enlightenment-privileged-programs enlightenment-desktop-configuration)
2478 (match-record enlightenment-desktop-configuration
2479 <enlightenment-desktop-configuration>
2480 (enlightenment)
2481 (map file-like->setuid-program
2482 (list (file-append enlightenment
2483 "/lib/enlightenment/utils/enlightenment_sys")
2484 (file-append enlightenment
2485 "/lib/enlightenment/utils/enlightenment_system")
2486 (file-append enlightenment
2487 "/lib/enlightenment/utils/enlightenment_ckpasswd")))))
2488
2489(define enlightenment-desktop-service-type
2490 (service-type
2491 (name 'enlightenment-desktop)
2492 (extensions
2493 (list (service-extension dbus-root-service-type
2494 (compose list
2495 (package-direct-input-selector
2496 "efl")
2497 enlightenment-package))
2498 (service-extension udev-service-type
2499 (compose list
2500 (package-direct-input-selector
2501 "ddcutil")
2502 enlightenment-package))
2503 (service-extension privileged-program-service-type
2504 enlightenment-privileged-programs)
2505 (service-extension profile-service-type
2506 (compose list
2507 enlightenment-package))))
2508 (default-value (enlightenment-desktop-configuration))
2509 (description
2510 "Return a service that adds the @code{enlightenment} package to the system
2511profile, and extends dbus with the ability for @code{efl} to generate
2512thumbnails and privileges the programs which enlightenment needs to function
2513as expected.")))
2514
2515
2516;;;
2517;;; kwallet-service-type.
2518;;;
2519
2520(define-record-type* <kwallet-configuration> kwallet-configuration
2521 make-kwallet-configuration
2522 kwallet-configuration?
2523 (wallet kwallet-package (default kwallet-pam))
2524 (pam-services kwallet-pam-services (default '(("sddm" . login)
2525 ("passwd" . passwd)))))
2526
2527(define (pam-kwallet config)
2528 "Return a PAM extension for KWallet."
2529 (match config
2530 (#f '()) ;explicitly disabled by user
2531 (_
2532 (define (%pam-keyring-entry . arguments)
2533 (pam-entry
2534 (control "optional")
2535 (module (file-append (kwallet-package config)
2536 "/lib/security/pam_kwallet5.so"))
2537 (arguments arguments)))
2538
2539 (list
2540 (pam-extension
2541 (transformer
2542 (lambda (service)
2543 (case (assoc-ref (kwallet-pam-services config)
2544 (pam-service-name service))
2545 ((login)
2546 (pam-service
2547 (inherit service)
2548 (auth (append (pam-service-auth service)
2549 (list (%pam-keyring-entry))))
2550 (session (append (pam-service-session service)
2551 (list (%pam-keyring-entry "auto_start"))))))
2552 ((passwd)
2553 (pam-service
2554 (inherit service)
2555 (password (append (pam-service-password service)
2556 (list (%pam-keyring-entry))))))
2557 (else service)))))))))
2558
2559;; TODO: consider integrating service in `<plasma-desktop-configuration>' as
2560;; done in `<gnome-desktop-configuration>'. This requires rewritting the
2561;; `<plasma-desktop-service-type>' as done for `<gnome-desktop-service-type>'.
2562(define kwallet-service-type
2563 (service-type
2564 (name 'kwallet)
2565 (extensions (list
2566 (service-extension pam-root-service-type pam-kwallet)))
2567 (default-value (kwallet-configuration))
2568 (description "Return a service that extends PAM with entries using
2569@code{pam_kwallet5.so}, unlocking the user's login keyring when they log in or
2570setting its password with @command{passwd}.")))
2571
2572
2573;;;
2574;;; KDE Plasma desktop service.
2575;;;
2576
2577(define-record-type* <plasma-desktop-configuration> plasma-desktop-configuration
2578 make-plasma-desktop-configuration
2579 plasma-desktop-configuration?
2580 (plasma-package plasma-package (default plasma)))
2581
2582(define (plasma-polkit-settings config)
2583 "Return the list of KDE Plasma dependencies that provide polkit actions and
2584rules."
2585 (let ((plasma-plasma (plasma-package config)))
2586 (map (lambda (name)
2587 ((package-direct-input-selector name) plasma-plasma))
2588 '("bolt" ;for plasma-thunderbolt
2589 "kde-inotify-survey"
2590 "kdeplasma-addons"
2591 "kinfocenter"
2592 "kpmcore"
2593 "ktexteditor"
2594 "kwalletmanager"
2595 "libksysguard"
2596 "packagekit" ;for discover
2597 "plasma-desktop"
2598 "plasma-disks"
2599 "plasma-firewall"
2600 "plasma-workspace"
2601 "powerdevil"))))
2602
2603(define (plasma-dbus-service config)
2604 "Return the list of KDE Plasma dependencies that provide D-Bus services."
2605 (let ((plasma-plasma (plasma-package config)))
2606 (map (lambda (name)
2607 ((package-direct-input-selector name) plasma-plasma))
2608 '("bolt" ;for plasma-thunderbolt
2609 "kde-inotify-survey"
2610 "kdeplasma-addons"
2611 "kinfocenter"
2612 "kpmcore"
2613 "ktexteditor"
2614 "kwalletmanager"
2615 "libksysguard"
2616 "packagekit" ;for discover
2617 "plasma-desktop"
2618 "plasma-disks"
2619 "plasma-firewall"
2620 "plasma-workspace"
2621 "powerdevil"))))
2622
2623(define (plasma-udev-configurations config)
2624 "Return the list of KDE Plasma dependencies that provide udev rules and
2625hardware files."
2626 (let ((plasma-plasma (plasma-package config)))
2627 (map (lambda (name)
2628 ((package-direct-input-selector name) plasma-plasma))
2629 '("bolt")))) ;for plasma-thunderbolt
2630
2631;; see https://bugs.kde.org/show_bug.cgi?id=456210
2632;; if `kde' no exits, fallback to `other', and then unlock lockscreen not work,
2633;; so add it.
2634(define (plasma-pam-services config)
2635 (list (unix-pam-service "kde")))
2636
2637(define plasma-desktop-service-type
2638 (service-type
2639 (name 'plasma-desktop)
2640 (description "Run the KDE Plasma desktop environment.")
2641 (default-value (plasma-desktop-configuration))
2642 (extensions
2643 (list (service-extension polkit-service-type
2644 plasma-polkit-settings)
2645 (service-extension dbus-root-service-type
2646 plasma-dbus-service)
2647 (service-extension pam-root-service-type
2648 plasma-pam-services)
2649 (service-extension udev-service-type
2650 plasma-udev-configurations)
2651 (service-extension profile-service-type
2652 (compose list
2653 plasma-package))))))
2654
2655
2656;;;
2657;;; inputattach-service-type
2658;;;
2659
2660(define-record-type* <inputattach-configuration>
2661 inputattach-configuration
2662 make-inputattach-configuration
2663 inputattach-configuration?
2664 (device-type inputattach-configuration-device-type
2665 (default "wacom"))
2666 (device inputattach-configuration-device
2667 (default "/dev/ttyS0"))
2668 (baud-rate inputattach-configuration-baud-rate
2669 (default #f))
2670 (log-file inputattach-configuration-log-file
2671 (default #f)))
2672
2673(define inputattach-shepherd-service
2674 (match-lambda
2675 (($ <inputattach-configuration> type device baud-rate log-file)
2676 (let ((args (append (if baud-rate
2677 (list "--baud" (number->string baud-rate))
2678 '())
2679 (list (string-append "--" type)
2680 device))))
2681 (list (shepherd-service
2682 (provision '(inputattach))
2683 (requirement '(user-processes udev))
2684 (documentation "inputattach daemon")
2685 (start #~(make-forkexec-constructor
2686 (cons (string-append #$inputattach
2687 "/bin/inputattach")
2688 (quote #$args))
2689 #:log-file #$log-file))
2690 (stop #~(make-kill-destructor))))))))
2691
2692(define inputattach-service-type
2693 (service-type
2694 (name 'inputattach)
2695 (extensions
2696 (list (service-extension shepherd-root-service-type
2697 inputattach-shepherd-service)))
2698 (default-value (inputattach-configuration))
2699 (description "Return a service that runs inputattach on a device and
2700dispatches events from it.")))
2701
2702
2703;;;
2704;;; polkit-wheel-service -- Allow wheel group to perform admin actions
2705;;;
2706
2707(define polkit-wheel
2708 (file-union
2709 "polkit-wheel"
2710 `(("share/polkit-1/rules.d/wheel.rules"
2711 ,(plain-file
2712 "wheel.rules"
2713 "polkit.addAdminRule(function(action, subject) {
2714 return [\"unix-group:wheel\"];
2715});
2716")))))
2717
2718(define polkit-wheel-service
2719 (simple-service 'polkit-wheel polkit-service-type (list polkit-wheel)))
2720
2721
2722;;;
2723;;; seatd-service-type -- minimal seat management daemon
2724;;;
2725
2726(define (seatd-group-sanitizer group-or-name)
2727 (match group-or-name
2728 ((? user-group? group) group)
2729 ((? string? group-name) (user-group (name group-name) (system? #t)))
2730 (_ (leave (G_ "seatd: '~a' is not a valid group~%") group-or-name))))
2731
2732(define-record-type* <seatd-configuration> seatd-configuration
2733 make-seatd-configuration
2734 seatd-configuration?
2735 (seatd seatd-package (default seatd))
2736 (group seatd-group ; string | <user-group>
2737 (default "seat")
2738 (sanitize seatd-group-sanitizer))
2739 (socket seatd-socket (default "/run/seatd.sock"))
2740 (logfile seatd-logfile (default "/var/log/seatd.log"))
2741 (loglevel seatd-loglevel (default "info")))
2742
2743(define (seatd-shepherd-service config)
2744 (list (shepherd-service
2745 (documentation "Minimal seat management daemon")
2746 (requirement '(user-processes))
2747 ;; TODO: once cgroups is separate dependency
2748 ;; here we should depend on it rather than elogind
2749 (provision '(seatd elogind))
2750 (start #~(make-forkexec-constructor
2751 (list #$(file-append (seatd-package config) "/bin/seatd")
2752 "-g" #$(user-group-name (seatd-group config)))
2753 #:environment-variables
2754 (list (string-append "SEATD_LOGLEVEL="
2755 #$(seatd-loglevel config))
2756 (string-append "SEATD_DEFAULTPATH="
2757 #$(seatd-socket config)))
2758 #:log-file #$(seatd-logfile config)))
2759 (stop #~(make-kill-destructor)))))
2760
2761(define seatd-accounts
2762 (match-lambda (($ <seatd-configuration> _ group) (list group))))
2763
2764(define seatd-environment
2765 (match-lambda
2766 (($ <seatd-configuration> _ _ socket)
2767 `(("SEATD_SOCK" . ,socket)))))
2768
2769(define seatd-service-type
2770 (service-type
2771 (name 'seatd)
2772 (description "Seat management takes care of mediating access
2773to shared devices (graphics, input), without requiring the
2774applications needing access to be root.")
2775 (extensions
2776 (list
2777 (service-extension account-service-type seatd-accounts)
2778 (service-extension session-environment-service-type seatd-environment)
2779 ;; TODO: once cgroups is separate dependency we should not mount it here
2780 ;; for now it is mounted here, because elogind mounts it
2781 (service-extension file-system-service-type (const %control-groups))
2782 (service-extension shepherd-root-service-type seatd-shepherd-service)))
2783 (default-value (seatd-configuration))))
2784
2785
2786;;;
2787;;; The default set of desktop services.
2788;;;
2789
2790(define* (desktop-services-for-system #:optional
2791 (system (or (%current-target-system)
2792 (%current-system))))
2793 ;; List of services typically useful for a "desktop" use case.
2794
2795 ;; FIXME: Since GDM depends on more dependencies that do not build on i686,
2796 ;; keep SDDM on it for the time being.
2797 ;; XXX: When changing login manager, also change set-xorg-configuration
2798 (cons* (if (target-64bit? system)
2799 (service gdm-service-type)
2800 (service sddm-service-type))
2801
2802 ;; Screen lockers are a pretty useful thing and these are small.
2803 (service screen-locker-service-type
2804 (screen-locker-configuration
2805 (name "slock")
2806 (program (file-append slock "/bin/slock"))))
2807 (service screen-locker-service-type
2808 (screen-locker-configuration
2809 (name "xlock")
2810 (program (file-append xlockmore "/bin/xlock"))))
2811
2812 ;; Add udev rules for MTP devices so that non-root users can access
2813 ;; them.
2814 (simple-service 'mtp udev-service-type (list libmtp))
2815 ;; Add udev rules and default backends for scanners.
2816 (service sane-service-type)
2817 ;; Add polkit rules, so that non-root users in the wheel group can
2818 ;; perform administrative tasks (similar to "sudo").
2819 polkit-wheel-service
2820
2821 ;; Allow desktop users to also mount NTFS and NFS file systems
2822 ;; without root.
2823 (simple-service 'mount-setuid-helpers privileged-program-service-type
2824 (map file-like->setuid-program
2825 (list (file-append nfs-utils "/sbin/mount.nfs")
2826 (file-append ntfs-3g "/sbin/mount.ntfs-3g"))))
2827
2828 ;; Add some of the artwork niceties for the desktop.
2829 (simple-service 'guix-artwork
2830 profile-service-type
2831 %base-packages-artwork)
2832
2833 ;; This is a volatile read-write file system mounted at /var/lib/gdm,
2834 ;; to avoid GDM stale cache and permission issues.
2835 gdm-file-system-service
2836
2837 ;; Provides a nicer experience for VTE-using terminal emulators such
2838 ;; as GNOME Console, Xfce Terminal, etc.
2839 (service vte-integration-service-type)
2840
2841 ;; The global fontconfig cache directory can sometimes contain
2842 ;; stale entries, possibly referencing fonts that have been GC'd,
2843 ;; so mount it read-only.
2844 fontconfig-file-system-service
2845
2846 ;; NetworkManager and its applet.
2847 (service network-manager-service-type)
2848 (service wpa-supplicant-service-type) ;needed by NetworkManager
2849 (simple-service 'network-manager-applet
2850 profile-service-type
2851 (list network-manager-applet))
2852 (service modem-manager-service-type)
2853 (service usb-modeswitch-service-type)
2854
2855 ;; The D-Bus clique.
2856 (service avahi-service-type)
2857 (service udisks-service-type)
2858 (service upower-service-type)
2859 (service accountsservice-service-type)
2860 (service cups-pk-helper-service-type)
2861 (service colord-service-type)
2862 (service geoclue-service-type)
2863 (service polkit-service-type)
2864 (service elogind-service-type)
2865 (service dbus-root-service-type)
2866
2867 (service ntp-service-type)
2868
2869 (service x11-socket-directory-service-type)
2870
2871 (service pulseaudio-service-type)
2872 (service alsa-service-type)
2873
2874 %base-services))
2875
2876(define-syntax %desktop-services
2877 (identifier-syntax (desktop-services-for-system)))
2878
2879;;; desktop.scm ends here