gnu/services/desktop.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2015 Andy Wingo <wingo@igalia.com>
   4 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
   5 ;;; Copyright © 2016 Sou Bunnbu <iyzsong@gmail.com>
   6 ;;; Copyright © 2017, 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
   7 ;;; Copyright © 2017 Nikita <nikita@n0.is>
   8 ;;; Copyright © 2018, 2020 Efraim Flashner <efraim@flashner.co.il>
   9 ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
  10 ;;; Copyright © 2017, 2019 Christopher Baines <mail@cbaines.net>
  11 ;;; Copyright © 2019 Tim Gesthuizen <tim.gesthuizen@yahoo.de>
  12 ;;; Copyright © 2019 David Wilson <david@daviwil.com>
  13 ;;; Copyright © 2020 Tobias Geerinckx-Rice <me@tobias.gr>
  14 ;;; Copyright © 2020 Reza Alizadeh Majd <r.majd@pantherx.org>
  15 ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
  16 ;;;
  17 ;;; This file is part of GNU Guix.
  18 ;;;
  19 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  20 ;;; under the terms of the GNU General Public License as published by
  21 ;;; the Free Software Foundation; either version 3 of the License, or (at
  22 ;;; your option) any later version.
  23 ;;;
  24 ;;; GNU Guix is distributed in the hope that it will be useful, but
  25 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  26 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  27 ;;; GNU General Public License for more details.
  28 ;;;
  29 ;;; You should have received a copy of the GNU General Public License
  30 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  31
  32 (define-module (gnu services desktop)
  33   #:use-module (gnu services)
  34   #:use-module (gnu services shepherd)
  35   #:use-module (gnu services base)
  36   #:use-module (gnu services dbus)
  37   #:use-module (gnu services avahi)
  38   #:use-module (gnu services xorg)
  39   #:use-module (gnu services networking)
  40   #:use-module (gnu services sound)
  41   #:use-module ((gnu system file-systems)
  42                 #:select (%elogind-file-systems file-system))
  43   #:autoload   (gnu services sddm) (sddm-service-type)
  44   #:use-module (gnu system)
  45   #:use-module (gnu system setuid)
  46   #:use-module (gnu system shadow)
  47   #:use-module (gnu system uuid)
  48   #:use-module (gnu system pam)
  49   #:use-module (gnu packages glib)
  50   #:use-module (gnu packages admin)
  51   #:use-module (gnu packages cups)
  52   #:use-module (gnu packages freedesktop)
  53   #:use-module (gnu packages gnome)
  54   #:use-module (gnu packages xfce)
  55   #:use-module (gnu packages avahi)
  56   #:use-module (gnu packages xdisorg)
  57   #:use-module (gnu packages scanner)
  58   #:use-module (gnu packages suckless)
  59   #:use-module (gnu packages linux)
  60   #:use-module (gnu packages libusb)
  61   #:use-module (gnu packages lxqt)
  62   #:use-module (gnu packages mate)
  63   #:use-module (gnu packages nfs)
  64   #:use-module (gnu packages enlightenment)
  65   #:use-module (guix deprecation)
  66   #:use-module (guix records)
  67   #:use-module (guix packages)
  68   #:use-module (guix store)
  69   #:use-module (guix utils)
  70   #:use-module (guix gexp)
  71   #:use-module (srfi srfi-1)
  72   #:use-module (ice-9 format)
  73   #:use-module (ice-9 match)
  74   #:export (<upower-configuration>
  75             upower-configuration
  76             upower-configuration?
  77             upower-configuration-upower
  78             upower-configuration-watts-up-pro?
  79             upower-configuration-poll-batteries?
  80             upower-configuration-ignore-lid?
  81             upower-configuration-use-percentage-for-policy?
  82             upower-configuration-percentage-low
  83             upower-configuration-percentage-critical
  84             upower-configuration-percentage-action
  85             upower-configuration-time-low
  86             upower-configuration-time-critical
  87             upower-configuration-time-action
  88             upower-configuration-critical-power-action
  89
  90             upower-service-type
  91
  92             udisks-configuration
  93             udisks-configuration?
  94             udisks-service
  95             udisks-service-type
  96
  97             colord-service-type
  98
  99             geoclue-application
 100             geoclue-configuration
 101             geoclue-configuration?
 102             %standard-geoclue-applications
 103             geoclue-service
 104             geoclue-service-type
 105
 106             bluetooth-service-type
 107             bluetooth-configuration
 108             bluetooth-configuration?
 109             bluetooth-service
 110
 111             elogind-configuration
 112             elogind-configuration?
 113             elogind-service
 114             elogind-service-type
 115
 116             %fontconfig-file-system
 117             fontconfig-file-system-service
 118
 119             accountsservice-service-type
 120             accountsservice-service
 121
 122             cups-pk-helper-service-type
 123             sane-service-type
 124
 125             gnome-desktop-configuration
 126             gnome-desktop-configuration?
 127             gnome-desktop-service
 128             gnome-desktop-service-type
 129
 130             mate-desktop-configuration
 131             mate-desktop-configuration?
 132             mate-desktop-service
 133             mate-desktop-service-type
 134
 135             lxqt-desktop-configuration
 136             lxqt-desktop-configuration?
 137             lxqt-desktop-service-type
 138
 139             xfce-desktop-configuration
 140             xfce-desktop-configuration?
 141             xfce-desktop-service
 142             xfce-desktop-service-type
 143
 144             x11-socket-directory-service
 145
 146             enlightenment-desktop-configuration
 147             enlightenment-desktop-configuration?
 148             enlightenment-desktop-service-type
 149
 150             inputattach-configuration
 151             inputattach-configuration?
 152             inputattach-service-type
 153
 154             polkit-wheel-service
 155
 156             gnome-keyring-configuration
 157             gnome-keyring-configuration?
 158             gnome-keyring-service-type
 159
 160             %desktop-services))
 161
 162 ;;; Commentary:
 163 ;;;
 164 ;;; This module contains service definitions for a "desktop" environment.
 165 ;;;
 166 ;;; Code:
 167
 168 \f
 169 ;;;
 170 ;;; Helpers.
 171 ;;;
 172
 173 (define (bool value)
 174   (if value "true\n" "false\n"))
 175
 176 (define (package-direct-input-selector input)
 177   (lambda (package)
 178     (match (assoc-ref (package-direct-inputs package) input)
 179       ((package . _) package))))
 180
 181
 182 \f
 183 ;;;
 184 ;;; Upower D-Bus service.
 185 ;;;
 186
 187 (define-record-type* <upower-configuration>
 188   upower-configuration make-upower-configuration
 189   upower-configuration?
 190   (upower                     upower-configuration-upower
 191                               (default upower))
 192   (watts-up-pro?              upower-configuration-watts-up-pro?
 193                               (default #f))
 194   (poll-batteries?            upower-configuration-poll-batteries?
 195                               (default #t))
 196   (ignore-lid?                upower-configuration-ignore-lid?
 197                               (default #f))
 198   (use-percentage-for-policy? upower-configuration-use-percentage-for-policy?
 199                               (default #f))
 200   (percentage-low             upower-configuration-percentage-low
 201                               (default 10))
 202   (percentage-critical        upower-configuration-percentage-critical
 203                               (default 3))
 204   (percentage-action          upower-configuration-percentage-action
 205                               (default 2))
 206   (time-low                   upower-configuration-time-low
 207                               (default 1200))
 208   (time-critical              upower-configuration-time-critical
 209                               (default 300))
 210   (time-action                upower-configuration-time-action
 211                               (default 120))
 212   (critical-power-action      upower-configuration-critical-power-action
 213                               (default 'hybrid-sleep)))
 214
 215 (define* upower-configuration-file
 216   ;; Return an upower-daemon configuration file.
 217   (match-lambda
 218     (($ <upower-configuration> upower
 219         watts-up-pro? poll-batteries? ignore-lid? use-percentage-for-policy?
 220         percentage-low percentage-critical percentage-action time-low
 221         time-critical time-action critical-power-action)
 222      (plain-file "UPower.conf"
 223                  (string-append
 224                   "[UPower]\n"
 225                   "EnableWattsUpPro=" (bool watts-up-pro?)
 226                   "NoPollBatteries=" (bool (not poll-batteries?))
 227                   "IgnoreLid=" (bool ignore-lid?)
 228                   "UsePercentageForPolicy=" (bool use-percentage-for-policy?)
 229                   "PercentageLow=" (number->string percentage-low) "\n"
 230                   "PercentageCritical=" (number->string percentage-critical) "\n"
 231                   "PercentageAction=" (number->string percentage-action) "\n"
 232                   "TimeLow=" (number->string time-low) "\n"
 233                   "TimeCritical=" (number->string time-critical) "\n"
 234                   "TimeAction=" (number->string time-action) "\n"
 235                   "CriticalPowerAction=" (match critical-power-action
 236                                            ('hybrid-sleep "HybridSleep")
 237                                            ('hibernate "Hibernate")
 238                                            ('power-off "PowerOff"))
 239                   "\n")))))
 240
 241 (define %upower-activation
 242   #~(begin
 243       (use-modules (guix build utils))
 244       (mkdir-p "/var/lib/upower")))
 245
 246 (define (upower-dbus-service config)
 247   (list (wrapped-dbus-service (upower-configuration-upower config)
 248                               "libexec/upowerd"
 249                               `(("UPOWER_CONF_FILE_NAME"
 250                                  ,(upower-configuration-file config))))))
 251
 252 (define (upower-shepherd-service config)
 253   "Return a shepherd service for UPower with CONFIG."
 254   (let ((upower (upower-configuration-upower config))
 255         (config (upower-configuration-file config)))
 256     (list (shepherd-service
 257            (documentation "Run the UPower power and battery monitor.")
 258            (provision '(upower-daemon))
 259            (requirement '(dbus-system udev))
 260
 261            (start #~(make-forkexec-constructor
 262                      (list (string-append #$upower "/libexec/upowerd"))
 263                      #:environment-variables
 264                      (list (string-append "UPOWER_CONF_FILE_NAME="
 265                                           #$config))))
 266            (stop #~(make-kill-destructor))))))
 267
 268 (define upower-service-type
 269   (let ((upower-package (compose list upower-configuration-upower)))
 270     (service-type (name 'upower)
 271                   (description
 272                    "Run @command{upowerd}}, a system-wide monitor for power
 273 consumption and battery levels, with the given configuration settings.  It
 274 implements the @code{org.freedesktop.UPower} D-Bus interface, and is notably
 275 used by GNOME.")
 276                   (extensions
 277                    (list (service-extension dbus-root-service-type
 278                                             upower-dbus-service)
 279                          (service-extension shepherd-root-service-type
 280                                             upower-shepherd-service)
 281                          (service-extension activation-service-type
 282                                             (const %upower-activation))
 283                          (service-extension udev-service-type
 284                                             upower-package)
 285
 286                          ;; Make the 'upower' command visible.
 287                          (service-extension profile-service-type
 288                                             upower-package)))
 289                   (default-value (upower-configuration)))))
 290
 291 \f
 292 ;;;
 293 ;;; GeoClue D-Bus service.
 294 ;;;
 295
 296 ;; TODO: Export.
 297 (define-record-type* <geoclue-configuration>
 298   geoclue-configuration make-geoclue-configuration
 299   geoclue-configuration?
 300   (geoclue geoclue-configuration-geoclue
 301            (default geoclue))
 302   (whitelist geoclue-configuration-whitelist)
 303   (wifi-geolocation-url geoclue-configuration-wifi-geolocation-url)
 304   (submit-data? geoclue-configuration-submit-data?)
 305   (wifi-submission-url geoclue-configuration-wifi-submission-url)
 306   (submission-nick geoclue-configuration-submission-nick)
 307   (applications geoclue-configuration-applications))
 308
 309 (define* (geoclue-application name #:key (allowed? #t) system? (users '()))
 310   "Configure default GeoClue access permissions for an application.  NAME is
 311 the Desktop ID of the application, without the .desktop part.  If ALLOWED? is
 312 true, the application will have access to location information by default.
 313 The boolean SYSTEM? value indicates that an application is a system component
 314 or not.  Finally USERS is a list of UIDs of all users for which this
 315 application is allowed location info access.  An empty users list means all
 316 users are allowed."
 317   (string-append
 318    "[" name "]\n"
 319    "allowed=" (bool allowed?)
 320    "system=" (bool system?)
 321    "users=" (string-join users ";") "\n"))
 322
 323 (define %standard-geoclue-applications
 324   (list (geoclue-application "gnome-datetime-panel" #:system? #t)
 325         (geoclue-application "epiphany" #:system? #f)
 326         (geoclue-application "firefox" #:system? #f)))
 327
 328 (define* (geoclue-configuration-file config)
 329   "Return a geoclue configuration file."
 330   (plain-file "geoclue.conf"
 331               (string-append
 332                "[agent]\n"
 333                "whitelist="
 334                (string-join (geoclue-configuration-whitelist config)
 335                             ";") "\n"
 336                "[wifi]\n"
 337                "url=" (geoclue-configuration-wifi-geolocation-url config) "\n"
 338                "submit-data=" (bool (geoclue-configuration-submit-data? config))
 339                "submission-url="
 340                (geoclue-configuration-wifi-submission-url config) "\n"
 341                "submission-nick="
 342                (geoclue-configuration-submission-nick config)
 343                "\n"
 344                (string-join (geoclue-configuration-applications config)
 345                             "\n"))))
 346
 347 (define (geoclue-dbus-service config)
 348   (list (wrapped-dbus-service (geoclue-configuration-geoclue config)
 349                               "libexec/geoclue"
 350                               `(("GEOCLUE_CONFIG_FILE"
 351                                  ,(geoclue-configuration-file config))))))
 352
 353 (define %geoclue-accounts
 354   (list (user-group (name "geoclue") (system? #t))
 355         (user-account
 356          (name "geoclue")
 357          (group "geoclue")
 358          (system? #t)
 359          (comment "GeoClue daemon user")
 360          (home-directory "/var/empty")
 361          (shell "/run/current-system/profile/sbin/nologin"))))
 362
 363 (define geoclue-service-type
 364   (service-type (name 'geoclue)
 365                 (extensions
 366                  (list (service-extension dbus-root-service-type
 367                                           geoclue-dbus-service)
 368                        (service-extension account-service-type
 369                                           (const %geoclue-accounts))))
 370                 (description "Run the @command{geoclue} location service.
 371 This service provides a D-Bus interface to allow applications to request
 372 access to a user's physical location, and optionally to add information to
 373 online location databases.")))
 374
 375 (define* (geoclue-service #:key (geoclue geoclue)
 376                           (whitelist '())
 377                           (wifi-geolocation-url
 378                            ;; Mozilla geolocation service:
 379                            "https://location.services.mozilla.com/v1/geolocate?key=geoclue")
 380                           (submit-data? #f)
 381                           (wifi-submission-url
 382                            "https://location.services.mozilla.com/v1/submit?key=geoclue")
 383                           (submission-nick "geoclue")
 384                           (applications %standard-geoclue-applications))
 385   "Return a service that runs the @command{geoclue} location service.  This
 386 service provides a D-Bus interface to allow applications to request access to
 387 a user's physical location, and optionally to add information to online
 388 location databases.  By default, only the GNOME date-time panel and the Icecat
 389 and Epiphany web browsers are able to ask for the user's location, and in the
 390 case of Icecat and Epiphany, both will ask the user for permission first.  See
 391 @uref{https://wiki.freedesktop.org/www/Software/GeoClue/, the geoclue web
 392 site} for more information."
 393   (service geoclue-service-type
 394            (geoclue-configuration
 395             (geoclue geoclue)
 396             (whitelist whitelist)
 397             (wifi-geolocation-url wifi-geolocation-url)
 398             (submit-data? submit-data?)
 399             (wifi-submission-url wifi-submission-url)
 400             (submission-nick submission-nick)
 401             (applications applications))))
 402
 403 \f
 404 ;;;
 405 ;;; Bluetooth.
 406 ;;;
 407
 408 (define-record-type* <bluetooth-configuration>
 409   bluetooth-configuration make-bluetooth-configuration
 410   bluetooth-configuration?
 411   (bluez bluetooth-configuration-bluez (default bluez))
 412
 413   ;;; [General]
 414   (name bluetooth-configuration-name (default "BlueZ"))
 415   (class bluetooth-configuration-class (default #x000000))
 416   (discoverable-timeout
 417    bluetooth-configuration-discoverable-timeout (default 180))
 418   (always-pairable? bluetooth-configuration-always-pairable? (default #f))
 419   (pairable-timeout bluetooth-configuration-pairable-timeout (default 0))
 420
 421   ;;; MAYBE: Exclude into separate <device-id> record-type?
 422   (device-id bluetooth-configuration-device-id (default #f))
 423   (reverse-service-discovery?
 424    bluetooth-configuration-reverse-service-discovery (default #t))
 425   (name-resolving? bluetooth-configuration-name-resolving? (default #t))
 426   (debug-keys? bluetooth-configuration-debug-keys? (default #f))
 427
 428   ;;; Possible values:
 429   ;;; 'dual, 'bredr, 'le
 430   (controller-mode bluetooth-configuration-controller-mode (default 'dual))
 431
 432   ;;; Possible values:
 433   ;;; 'off, 'single, 'multiple
 434   (multi-profile bluetooth-configuration-multi-profile (default 'off))
 435   (fast-connectable? bluetooth-configuration-fast-connectable? (default #f))
 436
 437   ;;; Possible values:
 438   ;;; for LE mode: 'off, 'network/on, 'device
 439   ;;; for Dual mode: 'off, 'network/on', 'device, 'limited-network, 'limited-device
 440   ;;; Source: https://git.kernel.org/pub/scm/bluetooth/bluez.git/tree/src/main.conf#n68
 441   (privacy bluetooth-configuration-privacy (default 'off))
 442
 443   ;;; Possible values:
 444   ;;; 'never, 'confirm, 'always
 445   (just-works-repairing
 446    bluetooth-configuration-just-works-repairing (default 'never))
 447   (temporary-timeout bluetooth-configuration-temporary-timeout (default 30))
 448   (refresh-discovery? bluetooth-configuration-refresh-discovery (default #t))
 449
 450   ;;; Possible values: #t, #f, (uuid <uuid>)
 451   ;;; Possible UUIDs:
 452   ;;; d4992530-b9ec-469f-ab01-6c481c47da1c (BlueZ Experimental Debug)
 453   ;;; 671b10b5-42c0-4696-9227-eb28d1b049d6 (BlueZ Experimental Simultaneous Central and Peripheral)
 454   ;;; 15c0a148-c273-11ea-b3de-0242ac130004 (BlueZ Experimental LL privacy)
 455   ;;; 330859bc-7506-492d-9370-9a6f0614037f (BlueZ Experimental Bluetooth Quality Report)
 456   ;;; a6695ace-ee7f-4fb9-881a-5fac66c629af (BlueZ Experimental Offload Codecs)
 457   ;;; Source: https://git.kernel.org/pub/scm/bluetooth/bluez.git/tree/src/main.conf#n110
 458   (experimental bluetooth-configuration-experimental (default #f))
 459   (remote-name-request-retry-delay
 460    bluetooth-configuration-remote-name-request-retry-delay (default 300))
 461
 462   ;;; [BR]
 463   (page-scan-type bluetooth-configuration-page-scan-type (default #f))
 464   (page-scan-interval bluetooth-configuration-page-scan-interval (default #f))
 465   (page-scan-window bluetooth-configuration-page-scan-window (default #f))
 466   (inquiry-scan-type bluetooth-configuration-inquiry-scan-type (default #f))
 467   (inquiry-scan-interval bluetooth-configuration-inquiry-scan-interval (default #f))
 468   (inquiry-scan-window bluetooth-configuration-inquiry-scan-window (default #f))
 469   (link-supervision-timeout bluetooth-configuration-link-supervision-timeout (default #f))
 470   (page-timeout bluetooth-configuration-page-timeout (default #f))
 471   (min-sniff-interval bluetooth-configuration-min-sniff-interval (default #f))
 472   (max-sniff-interval bluetooth-configuration-max-sniff-interval (default #f))
 473
 474   ;;; [LE]
 475   (min-advertisement-interval
 476    bluetooth-configuration-min-advertisement-interval (default #f))
 477   (max-advertisement-interval
 478    bluetooth-configuration-max-advertisement-interval (default #f))
 479   (multi-advertisement-rotation-interval
 480    bluetooth-configuration-multi-advertisement-rotation-interval (default #f))
 481   (scan-interval-auto-connect
 482    bluetooth-configuration-scan-interval-auto-connect (default #f))
 483   (scan-window-auto-connect
 484    bluetooth-configuration-scan-window-auto-connect (default #f))
 485   (scan-interval-suspend
 486    bluetooth-configuration-scan-interval-suspend (default #f))
 487   (scan-window-suspend
 488    bluetooth-configuration-scan-window-suspend (default #f))
 489   (scan-interval-discovery
 490    bluetooth-configuration-scan-interval-discovery (default #f))
 491   (scan-window-discovery
 492    bluetooth-configuration-scan-window-discovery (default #f))
 493   (scan-interval-adv-monitor
 494    bluetooth-configuration-scan-interval-adv-monitor (default #f))
 495   (scan-window-adv-monitor
 496    bluetooth-configuration-scan-window-adv-monitor (default #f))
 497   (scan-interval-connect
 498    bluetooth-configuration-scan-interval-connect (default #f))
 499   (scan-window-connect
 500    bluetooth-configuration-scan-window-connect (default #f))
 501   (min-connection-interval
 502    bluetooth-configuration-min-connection-interval (default #f))
 503   (max-connection-interval
 504    bluetooth-configuration-max-connection-interval (default #f))
 505   (connection-latency
 506    bluetooth-configuration-connection-latency (default #f))
 507   (connection-supervision-timeout
 508    bluetooth-configuration-connection-supervision-timeout (default #f))
 509   (autoconnect-timeout
 510    bluetooth-configuration-autoconnect-timeout (default #f))
 511   (adv-mon-allowlist-scan-duration
 512    bluetooth-configuration-adv-mon-allowlist-scan-duration (default 300))
 513   (adv-mon-no-filter-scan-duration
 514    bluetooth-configuration-adv-mon-no-filter-scan-duration (default 500))
 515   (enable-adv-mon-interleave-scan?
 516    bluetooth-configuration-enable-adv-mon-interleave-scan (default #t))
 517
 518   ;;; [GATT]
 519   ;;; Possible values: 'yes, 'no, 'always
 520   (cache bluetooth-configuration-cache (default 'always))
 521
 522   ;;; Possible values: 7 ... 16, 0 (don't care)
 523   (key-size bluetooth-configuration-key-size (default 0))
 524
 525   ;;; Possible values: 23 ... 517
 526   (exchange-mtu bluetooth-configuration-exchange-mtu (default 517))
 527
 528   ;;; Possible values: 1 ... 5
 529   (att-channels bluetooth-configuration-att-channels (default 3))
 530
 531   ;;; [AVDTP]
 532   ;;; Possible values: 'basic, 'ertm
 533   (session-mode bluetooth-configuration-session-mode (default 'basic))
 534
 535   ;;; Possible values: 'basic, 'streaming
 536   (stream-mode bluetooth-configuration-stream-mode (default 'basic))
 537
 538   ;;; [Policy]
 539   (reconnect-uuids bluetooth-configuration-reconnect-uuids (default '()))
 540   (reconnect-attempts bluetooth-configuration-reconnect-attempts (default 7))
 541   (reconnect-intervals bluetooth-configuration-reconnect-intervals
 542                        (default (list 1 2 4 8 16 32 64)))
 543   (auto-enable? bluetooth-configuration-auto-enable? (default #f))
 544   (resume-delay bluetooth-configuration-resume-delay (default 2))
 545
 546   ;;; [AdvMon]
 547   ;;; Possible values:
 548   ;;; "0x00", "0xFF",
 549   ;;; "N = 0x00" ... "N = 0xFF"
 550   ;;; Source: https://git.kernel.org/pub/scm/bluetooth/bluez.git/tree/src/main.conf#n286
 551   (rssi-sampling-period bluetooth-configuration-rssi-sampling-period
 552                         (default #xFF)))
 553
 554 (define (bluetooth-configuration-file config)
 555   "Return a configuration file for the systemd bluetooth service, as a string."
 556   (string-append
 557    "[General]"
 558    "\nName = " (bluetooth-configuration-name config)
 559    "\nClass = " (string-append
 560                  "0x"
 561                  (format #f "~6,'0x" (bluetooth-configuration-class config)))
 562    "\nDiscoverableTimeout = " (number->string
 563                                (bluetooth-configuration-discoverable-timeout
 564                                 config))
 565    "\nAlwaysPairable = " (bool (bluetooth-configuration-always-pairable?
 566                                 config))
 567    "\nPairableTimeout = " (number->string
 568                            (bluetooth-configuration-pairable-timeout
 569                             config))
 570    (if (bluetooth-configuration-device-id config)
 571        (string-append "\nDeviceID = " (bluetooth-configuration-device-id config))
 572        "")
 573    "\nReverseServiceDiscovery = " (bool
 574                                    (bluetooth-configuration-reverse-service-discovery
 575                                     config))
 576    "\nNameResolving = " (bool (bluetooth-configuration-name-resolving? config))
 577    "\nDebugKeys = " (bool (bluetooth-configuration-debug-keys? config))
 578    "\nControllerMode = " (symbol->string
 579                           (bluetooth-configuration-controller-mode config))
 580    "\nMultiProfile = " (symbol->string (bluetooth-configuration-multi-profile
 581                                         config))
 582    "\nFastConnectable = " (bool (bluetooth-configuration-fast-connectable? config))
 583    "\nPrivacy = " (symbol->string (bluetooth-configuration-privacy config))
 584    "\nJustWorksRepairing = " (symbol->string
 585                               (bluetooth-configuration-just-works-repairing config))
 586    "\nTemporaryTimeout = " (number->string
 587                             (bluetooth-configuration-temporary-timeout config))
 588    "\nRefreshDiscovery = " (bool (bluetooth-configuration-refresh-discovery config))
 589    "\nExperimental = " (let ((experimental (bluetooth-configuration-experimental config)))
 590                          (cond ((or (eq? experimental #t)
 591                                     (eq? experimental #f)) (bool experimental))
 592                                ((list? experimental)
 593                                 (string-join (map uuid->string experimental) ","))))
 594    "\nRemoteNameRequestRetryDelay = " (number->string
 595                                        (bluetooth-configuration-remote-name-request-retry-delay
 596                                         config))
 597    "\n[BR]"
 598    (if (bluetooth-configuration-page-scan-type config)
 599        (string-append
 600         "\nPageScanType = "
 601         (number->string (bluetooth-configuration-page-scan-type config)))
 602        "")
 603    (if (bluetooth-configuration-page-scan-interval config)
 604        (string-append
 605         "\nPageScanInterval = "
 606         (number->string (bluetooth-configuration-page-scan-interval config)))
 607        "")
 608    (if (bluetooth-configuration-page-scan-window config)
 609        (string-append
 610         "\nPageScanWindow = "
 611         (number->string (bluetooth-configuration-page-scan-window config)))
 612        "")
 613    (if (bluetooth-configuration-inquiry-scan-type config)
 614        (string-append
 615         "\nInquiryScanType = "
 616         (number->string (bluetooth-configuration-inquiry-scan-type config)))
 617        "")
 618    (if (bluetooth-configuration-inquiry-scan-interval config)
 619        (string-append
 620         "\nInquiryScanInterval = "
 621         (number->string (bluetooth-configuration-inquiry-scan-interval config)))
 622        "")
 623    (if (bluetooth-configuration-inquiry-scan-window config)
 624        (string-append
 625         "\nInquiryScanWindow = "
 626         (number->string (bluetooth-configuration-inquiry-scan-window config)))
 627        "")
 628    (if (bluetooth-configuration-link-supervision-timeout config)
 629        (string-append
 630         "\nLinkSupervisionTimeout = "
 631         (number->string (bluetooth-configuration-link-supervision-timeout config)))
 632        "")
 633    (if (bluetooth-configuration-page-timeout config)
 634        (string-append
 635         "\nPageTimeout = "
 636         (number->string (bluetooth-configuration-page-timeout config)))
 637        "")
 638    (if (bluetooth-configuration-min-sniff-interval config)
 639        (string-append
 640         "\nMinSniffInterval = "
 641         (number->string (bluetooth-configuration-min-sniff-interval config)))
 642        "")
 643    (if (bluetooth-configuration-max-sniff-interval config)
 644        (string-append
 645         "\nMaxSniffInterval = "
 646         (number->string (bluetooth-configuration-max-sniff-interval config)))
 647        "")
 648
 649    "\n[LE]"
 650    (if (bluetooth-configuration-min-advertisement-interval config)
 651        (string-append
 652         "\nMinAdvertisementInterval = "
 653         (number->string (bluetooth-configuration-min-advertisement-interval config)))
 654        "")
 655    (if (bluetooth-configuration-max-advertisement-interval config)
 656        (string-append
 657         "\nMaxAdvertisementInterval = "
 658         (number->string (bluetooth-configuration-max-advertisement-interval config)))
 659        "")
 660    (if (bluetooth-configuration-multi-advertisement-rotation-interval config)
 661        (string-append
 662         "\nMultiAdvertisementRotationInterval = "
 663         (number->string
 664          (bluetooth-configuration-multi-advertisement-rotation-interval config)))
 665        "")
 666    (if (bluetooth-configuration-scan-interval-auto-connect config)
 667        (string-append
 668         "\nScanIntervalAutoConnect = "
 669         (number->string (bluetooth-configuration-scan-interval-auto-connect config)))
 670        "")
 671    (if (bluetooth-configuration-scan-window-auto-connect config)
 672        (string-append
 673         "\nScanWindowAutoConnect = "
 674         (number->string (bluetooth-configuration-scan-window-auto-connect config)))
 675        "")
 676    (if (bluetooth-configuration-scan-interval-suspend config)
 677        (string-append
 678         "\nScanIntervalSuspend = "
 679         (number->string (bluetooth-configuration-scan-interval-suspend config)))
 680        "")
 681    (if (bluetooth-configuration-scan-window-suspend config)
 682        (string-append
 683         "\nScanWindowSuspend = "
 684         (number->string (bluetooth-configuration-scan-window-suspend config)))
 685        "")
 686    (if (bluetooth-configuration-scan-interval-discovery config)
 687        (string-append
 688         "\nScanIntervalDiscovery = "
 689         (number->string (bluetooth-configuration-scan-interval-discovery config)))
 690        "")
 691    (if (bluetooth-configuration-scan-window-discovery config)
 692        (string-append
 693         "\nScanWindowDiscovery = "
 694         (number->string (bluetooth-configuration-scan-window-discovery config)))
 695        "")
 696    (if (bluetooth-configuration-scan-interval-adv-monitor config)
 697        (string-append
 698         "\nScanIntervalAdvMonitor = "
 699         (number->string (bluetooth-configuration-scan-interval-adv-monitor config)))
 700        "")
 701    (if (bluetooth-configuration-scan-window-adv-monitor config)
 702        (string-append
 703         "\nScanWindowAdvMonitor = "
 704         (number->string (bluetooth-configuration-scan-window-adv-monitor config)))
 705        "")
 706    (if (bluetooth-configuration-scan-interval-connect config)
 707        (string-append
 708         "\nScanIntervalConnect = "
 709         (number->string (bluetooth-configuration-scan-interval-connect config)))
 710        "")
 711    (if (bluetooth-configuration-scan-window-connect config)
 712        (string-append
 713         "\nScanWindowConnect = "
 714         (number->string (bluetooth-configuration-scan-window-connect config)))
 715        "")
 716    (if (bluetooth-configuration-min-connection-interval config)
 717        (string-append
 718         "\nMinConnectionInterval = "
 719         (number->string (bluetooth-configuration-min-connection-interval config)))
 720        "")
 721    (if (bluetooth-configuration-max-connection-interval config)
 722        (string-append
 723         "\nMaxConnectionInterval = "
 724         (number->string (bluetooth-configuration-max-connection-interval config)))
 725        "")
 726    (if (bluetooth-configuration-connection-latency config)
 727        (string-append
 728         "\nConnectionLatency = "
 729         (number->string (bluetooth-configuration-connection-latency config)))
 730        "")
 731    (if (bluetooth-configuration-connection-supervision-timeout config)
 732        (string-append
 733         "\nConnectionSupervisionTimeout = "
 734         (number->string (bluetooth-configuration-connection-supervision-timeout config)))
 735        "")
 736    (if (bluetooth-configuration-autoconnect-timeout config)
 737        (string-append
 738         "\nAutoconnecttimeout = "
 739         (number->string (bluetooth-configuration-autoconnect-timeout config)))
 740        "")
 741    "\nAdvMonAllowlistScanDuration = " (number->string
 742                                        (bluetooth-configuration-adv-mon-allowlist-scan-duration
 743                                         config))
 744    "\nAdvMonNoFilterScanDuration = " (number->string
 745                                       (bluetooth-configuration-adv-mon-no-filter-scan-duration
 746                                        config))
 747    "\nEnableAdvMonInterleaveScan = " (number->string
 748                                       (if (eq? #t
 749                                                (bluetooth-configuration-enable-adv-mon-interleave-scan
 750                                                 config))
 751                                           1 0))
 752
 753    "\n[GATT]"
 754    "\nCache = " (symbol->string (bluetooth-configuration-cache config))
 755    "\nKeySize = " (number->string (bluetooth-configuration-key-size config))
 756    "\nExchangeMTU = " (number->string (bluetooth-configuration-exchange-mtu config))
 757    "\nChannels = " (number->string (bluetooth-configuration-att-channels config))
 758
 759    "\n[AVDTP]"
 760    "\nSessionMode = " (symbol->string (bluetooth-configuration-session-mode config))
 761    "\nStreamMode = " (symbol->string (bluetooth-configuration-stream-mode config))
 762
 763    "\n[Policy]"
 764    (let ((uuids (bluetooth-configuration-reconnect-uuids config)))
 765      (if (not (eq? '() uuids))
 766          (string-append
 767           "\nReconnectUUIDs = "
 768           (string-join (map uuid->string uuids) ","))
 769          ""))
 770    "\nReconnectAttempts = " (number->string
 771                              (bluetooth-configuration-reconnect-attempts config))
 772    "\nReconnectIntervals = " (string-join
 773                               (map number->string
 774                                    (bluetooth-configuration-reconnect-intervals
 775                                     config))
 776                               ",")
 777    "\nAutoEnable = " (bool (bluetooth-configuration-auto-enable?
 778                             config))
 779    "\nResumeDelay = " (number->string (bluetooth-configuration-resume-delay config))
 780
 781    "\n[AdvMon]"
 782    "\nRSSISamplingPeriod = " (string-append
 783                               "0x"
 784                               (format #f "~2,'0x"
 785                                       (bluetooth-configuration-rssi-sampling-period config)))))
 786
 787 (define (bluetooth-directory config)
 788   (computed-file "etc-bluetooth"
 789                  #~(begin
 790                      (mkdir #$output)
 791                      (chdir #$output)
 792                      (call-with-output-file "main.conf"
 793                        (lambda (port)
 794                          (display #$(bluetooth-configuration-file config)
 795                                   port))))))
 796
 797 (define (bluetooth-shepherd-service config)
 798   "Return a shepherd service for @command{bluetoothd}."
 799   (shepherd-service
 800    (provision '(bluetooth))
 801    (requirement '(dbus-system udev))
 802    (documentation "Run the bluetoothd daemon.")
 803    (start #~(make-forkexec-constructor
 804              (list #$(file-append (bluetooth-configuration-bluez config)
 805                                   "/libexec/bluetooth/bluetoothd"))))
 806    (stop #~(make-kill-destructor))))
 807
 808 (define bluetooth-service-type
 809   (service-type
 810    (name 'bluetooth)
 811    (extensions
 812     (list (service-extension dbus-root-service-type
 813                              (compose list bluetooth-configuration-bluez))
 814           (service-extension udev-service-type
 815                              (compose list bluetooth-configuration-bluez))
 816           (service-extension etc-service-type
 817                              (lambda (config)
 818                                `(("bluetooth"
 819                                   ,(bluetooth-directory config)))))
 820           (service-extension shepherd-root-service-type
 821                              (compose list bluetooth-shepherd-service))))
 822    (default-value (bluetooth-configuration))
 823    (description "Run the @command{bluetoothd} daemon, which manages all the
 824 Bluetooth devices and provides a number of D-Bus interfaces.")))
 825
 826 (define* (bluetooth-service #:key (bluez bluez) (auto-enable? #f))
 827   "Return a service that runs the @command{bluetoothd} daemon, which manages
 828 all the Bluetooth devices and provides a number of D-Bus interfaces.  When
 829 AUTO-ENABLE? is true, the bluetooth controller is powered automatically at
 830 boot.
 831
 832 Users need to be in the @code{lp} group to access the D-Bus service.
 833 "
 834   (service bluetooth-service-type
 835            (bluetooth-configuration
 836             (bluez bluez)
 837             (auto-enable? auto-enable?))))
 838
 839 \f
 840 ;;;
 841 ;;; Colord D-Bus service.
 842 ;;;
 843
 844 (define %colord-activation
 845   #~(begin
 846       (use-modules (guix build utils))
 847       (mkdir-p "/var/lib/colord")
 848       (let ((user (getpwnam "colord")))
 849         (chown "/var/lib/colord"
 850                (passwd:uid user) (passwd:gid user)))))
 851
 852 (define %colord-accounts
 853   (list (user-group (name "colord") (system? #t))
 854         (user-account
 855          (name "colord")
 856          (group "colord")
 857          (system? #t)
 858          (comment "colord daemon user")
 859          (home-directory "/var/empty")
 860          (shell (file-append shadow "/sbin/nologin")))))
 861
 862 (define colord-service-type
 863   (service-type (name 'colord)
 864                 (extensions
 865                  (list (service-extension account-service-type
 866                                           (const %colord-accounts))
 867                        (service-extension activation-service-type
 868                                           (const %colord-activation))
 869
 870                        ;; Colord is a D-Bus service that dbus-daemon can
 871                        ;; activate.
 872                        (service-extension dbus-root-service-type list)
 873
 874                        ;; Colord provides "color device" rules for udev.
 875                        (service-extension udev-service-type list)
 876
 877                        ;; It provides polkit "actions".
 878                        (service-extension polkit-service-type list)))
 879                 (default-value colord)
 880                 (description
 881                  "Run @command{colord}, a system service with a D-Bus
 882 interface to manage the color profiles of input and output devices such as
 883 screens and scanners.")))
 884
 885 \f
 886 ;;;
 887 ;;; UDisks.
 888 ;;;
 889
 890 (define-record-type* <udisks-configuration>
 891   udisks-configuration make-udisks-configuration
 892   udisks-configuration?
 893   (udisks   udisks-configuration-udisks
 894             (default udisks)))
 895
 896 (define %udisks-activation
 897   (with-imported-modules '((guix build utils))
 898     #~(begin
 899         (use-modules (guix build utils))
 900
 901         (let ((run-dir "/var/run/udisks2"))
 902           (mkdir-p run-dir)
 903           (chmod run-dir #o700)))))
 904
 905 (define udisks-service-type
 906   (let ((udisks-package (lambda (config)
 907                           (list (udisks-configuration-udisks config)))))
 908     (service-type (name 'udisks)
 909                   (extensions
 910                    (list (service-extension polkit-service-type
 911                                             udisks-package)
 912                          (service-extension dbus-root-service-type
 913                                             udisks-package)
 914                          (service-extension udev-service-type
 915                                             udisks-package)
 916                          (service-extension activation-service-type
 917                                             (const %udisks-activation))
 918
 919                          ;; Profile 'udisksctl' & co. in the system profile.
 920                          (service-extension profile-service-type
 921                                             udisks-package)))
 922                   (description "Run UDisks, a @dfn{disk management} daemon
 923 that provides user interfaces with notifications and ways to mount/unmount
 924 disks.  Programs that talk to UDisks include the @command{udisksctl} command,
 925 part of UDisks, and GNOME Disks."))))
 926
 927 (define* (udisks-service #:key (udisks udisks))
 928   "Return a service for @uref{http://udisks.freedesktop.org/docs/latest/,
 929 UDisks}, a @dfn{disk management} daemon that provides user interfaces with
 930 notifications and ways to mount/unmount disks.  Programs that talk to UDisks
 931 include the @command{udisksctl} command, part of UDisks, and GNOME Disks."
 932   (service udisks-service-type
 933            (udisks-configuration (udisks udisks))))
 934
 935 \f
 936 ;;;
 937 ;;; Elogind login and seat management service.
 938 ;;;
 939
 940 (define-record-type* <elogind-configuration> elogind-configuration
 941   make-elogind-configuration
 942   elogind-configuration?
 943   (elogind                          elogind-package
 944                                     (default elogind))
 945   (kill-user-processes?             elogind-kill-user-processes?
 946                                     (default #f))
 947   (kill-only-users                  elogind-kill-only-users
 948                                     (default '()))
 949   (kill-exclude-users               elogind-kill-exclude-users
 950                                     (default '("root")))
 951   (inhibit-delay-max-seconds        elogind-inhibit-delay-max-seconds
 952                                     (default 5))
 953   (handle-power-key                 elogind-handle-power-key
 954                                     (default 'poweroff))
 955   (handle-suspend-key               elogind-handle-suspend-key
 956                                     (default 'suspend))
 957   (handle-hibernate-key             elogind-handle-hibernate-key
 958                                     ;; (default 'hibernate)
 959                                     ;; XXX Ignore it for now, since we don't
 960                                     ;; yet handle resume-from-hibernation in
 961                                     ;; our initrd.
 962                                     (default 'ignore))
 963   (handle-lid-switch                elogind-handle-lid-switch
 964                                     (default 'suspend))
 965   (handle-lid-switch-docked         elogind-handle-lid-switch-docked
 966                                     (default 'ignore))
 967   (handle-lid-switch-external-power elogind-handle-lid-switch-external-power
 968                                     (default 'ignore))
 969   (power-key-ignore-inhibited?      elogind-power-key-ignore-inhibited?
 970                                     (default #f))
 971   (suspend-key-ignore-inhibited?    elogind-suspend-key-ignore-inhibited?
 972                                     (default #f))
 973   (hibernate-key-ignore-inhibited?  elogind-hibernate-key-ignore-inhibited?
 974                                     (default #f))
 975   (lid-switch-ignore-inhibited?     elogind-lid-switch-ignore-inhibited?
 976                                     (default #t))
 977   (holdoff-timeout-seconds          elogind-holdoff-timeout-seconds
 978                                     (default 30))
 979   (idle-action                      elogind-idle-action
 980                                     (default 'ignore))
 981   (idle-action-seconds              elogind-idle-action-seconds
 982                                     (default (* 30 60)))
 983   (runtime-directory-size-percent   elogind-runtime-directory-size-percent
 984                                     (default 10))
 985   (runtime-directory-size           elogind-runtime-directory-size
 986                                     (default #f))
 987   (remove-ipc?                      elogind-remove-ipc?
 988                                     (default #t))
 989
 990   (suspend-state                    elogind-suspend-state
 991                                     (default '("mem" "standby" "freeze")))
 992   (suspend-mode                     elogind-suspend-mode
 993                                     (default '()))
 994   (hibernate-state                  elogind-hibernate-state
 995                                     (default '("disk")))
 996   (hibernate-mode                   elogind-hibernate-mode
 997                                     (default '("platform" "shutdown")))
 998   (hybrid-sleep-state               elogind-hybrid-sleep-state
 999                                     (default '("disk")))
1000   (hybrid-sleep-mode                elogind-hybrid-sleep-mode
1001                                     (default
1002                                       '("suspend" "platform" "shutdown"))))
1003
1004 (define (elogind-configuration-file config)
1005   (define (yesno x)
1006     (match x
1007       (#t "yes")
1008       (#f "no")
1009       (_ (error "expected #t or #f, instead got:" x))))
1010   (define char-set:user-name
1011     (string->char-set "abcdefghijklmnopqrstuvwxyz0123456789_-"))
1012   (define (valid-list? l pred)
1013     (and-map (lambda (x) (string-every pred x)) l))
1014   (define (user-name-list users)
1015     (unless (valid-list? users char-set:user-name)
1016       (error "invalid user list" users))
1017     (string-join users " "))
1018   (define (enum val allowed)
1019     (unless (memq val allowed)
1020       (error "invalid value" val allowed))
1021     (symbol->string val))
1022   (define (non-negative-integer x)
1023     (unless (exact-integer? x) (error "not an integer" x))
1024     (when (negative? x) (error "negative number not allowed" x))
1025     (number->string x))
1026   (define handle-actions
1027     '(ignore poweroff reboot halt kexec suspend hibernate hybrid-sleep lock))
1028   (define (handle-action x)
1029     (enum x handle-actions))
1030   (define (sleep-list tokens)
1031     (unless (valid-list? tokens char-set:user-name)
1032       (error "invalid sleep list" tokens))
1033     (string-join tokens " "))
1034   (define-syntax ini-file-clause
1035     (syntax-rules ()
1036       ((_ config (prop (parser getter)))
1037        (string-append prop "=" (parser (getter config)) "\n"))
1038       ((_ config str)
1039        (string-append str "\n"))))
1040   (define-syntax-rule (ini-file config file clause ...)
1041     (plain-file file (string-append (ini-file-clause config clause) ...)))
1042   (ini-file
1043    config "logind.conf"
1044    "[Login]"
1045    ("KillUserProcesses" (yesno elogind-kill-user-processes?))
1046    ("KillOnlyUsers" (user-name-list elogind-kill-only-users))
1047    ("KillExcludeUsers" (user-name-list elogind-kill-exclude-users))
1048    ("InhibitDelayMaxSec" (non-negative-integer elogind-inhibit-delay-max-seconds))
1049    ("HandlePowerKey" (handle-action elogind-handle-power-key))
1050    ("HandleSuspendKey" (handle-action elogind-handle-suspend-key))
1051    ("HandleHibernateKey" (handle-action elogind-handle-hibernate-key))
1052    ("HandleLidSwitch" (handle-action elogind-handle-lid-switch))
1053    ("HandleLidSwitchDocked" (handle-action elogind-handle-lid-switch-docked))
1054    ("HandleLidSwitchExternalPower" (handle-action elogind-handle-lid-switch-external-power))
1055    ("PowerKeyIgnoreInhibited" (yesno elogind-power-key-ignore-inhibited?))
1056    ("SuspendKeyIgnoreInhibited" (yesno elogind-suspend-key-ignore-inhibited?))
1057    ("HibernateKeyIgnoreInhibited" (yesno elogind-hibernate-key-ignore-inhibited?))
1058    ("LidSwitchIgnoreInhibited" (yesno elogind-lid-switch-ignore-inhibited?))
1059    ("HoldoffTimeoutSec" (non-negative-integer elogind-holdoff-timeout-seconds))
1060    ("IdleAction" (handle-action elogind-idle-action))
1061    ("IdleActionSec" (non-negative-integer elogind-idle-action-seconds))
1062    ("RuntimeDirectorySize"
1063     (identity
1064      (lambda (config)
1065        (match (elogind-runtime-directory-size-percent config)
1066          (#f (non-negative-integer (elogind-runtime-directory-size config)))
1067          (percent (string-append (non-negative-integer percent) "%"))))))
1068    ("RemoveIPC" (yesno elogind-remove-ipc?))
1069    "[Sleep]"
1070    ("SuspendState" (sleep-list elogind-suspend-state))
1071    ("SuspendMode" (sleep-list elogind-suspend-mode))
1072    ("HibernateState" (sleep-list elogind-hibernate-state))
1073    ("HibernateMode" (sleep-list elogind-hibernate-mode))
1074    ("HybridSleepState" (sleep-list elogind-hybrid-sleep-state))
1075    ("HybridSleepMode" (sleep-list elogind-hybrid-sleep-mode))))
1076
1077 (define (elogind-dbus-service config)
1078   (list (wrapped-dbus-service (elogind-package config)
1079                               "libexec/elogind/elogind"
1080                               `(("ELOGIND_CONF_FILE"
1081                                  ,(elogind-configuration-file config))))))
1082
1083 (define (pam-extension-procedure config)
1084   "Return an extension for PAM-ROOT-SERVICE-TYPE that ensures that all the PAM
1085 services use 'pam_elogind.so', a module that allows elogind to keep track of
1086 logged-in users (run 'loginctl' to see elogind's world view of users and
1087 seats.)"
1088   (define pam-elogind
1089     (pam-entry
1090      (control "required")
1091      (module (file-append (elogind-package config)
1092                           "/lib/security/pam_elogind.so"))))
1093
1094   (list (lambda (pam)
1095           (pam-service
1096            (inherit pam)
1097            (session (cons pam-elogind (pam-service-session pam)))))))
1098
1099 (define (elogind-shepherd-service config)
1100   "Return a Shepherd service to start elogind according to @var{config}."
1101   (list (shepherd-service
1102          (requirement '(dbus-system))
1103          (provision '(elogind))
1104          (start #~(make-forkexec-constructor
1105                    (list #$(file-append (elogind-package config)
1106                                         "/libexec/elogind/elogind"))
1107                    #:environment-variables
1108                    (list (string-append "ELOGIND_CONF_FILE="
1109                                         #$(elogind-configuration-file
1110                                            config)))))
1111          (stop #~(make-kill-destructor)))))
1112
1113 (define elogind-service-type
1114   (service-type (name 'elogind)
1115                 (extensions
1116                  (list (service-extension dbus-root-service-type
1117                                           elogind-dbus-service)
1118                        (service-extension udev-service-type
1119                                           (compose list elogind-package))
1120                        (service-extension polkit-service-type
1121                                           (compose list elogind-package))
1122
1123                        ;; Start elogind from the Shepherd rather than waiting
1124                        ;; for bus activation.  This ensures that it can handle
1125                        ;; events like lid close, etc.
1126                        (service-extension shepherd-root-service-type
1127                                           elogind-shepherd-service)
1128
1129                        ;; Provide the 'loginctl' command.
1130                        (service-extension profile-service-type
1131                                           (compose list elogind-package))
1132
1133                        ;; Extend PAM with pam_elogind.so.
1134                        (service-extension pam-root-service-type
1135                                           pam-extension-procedure)
1136
1137                        ;; We need /run/user, /run/systemd, etc.
1138                        (service-extension file-system-service-type
1139                                           (const %elogind-file-systems))))
1140                 (default-value (elogind-configuration))
1141                 (description "Run the @command{elogind} login and seat
1142 management service.  The @command{elogind} service integrates with PAM to
1143 allow other system components to know the set of logged-in users as well as
1144 their session types (graphical, console, remote, etc.).  It can also clean up
1145 after users when they log out.")))
1146
1147 (define* (elogind-service #:key (config (elogind-configuration)))
1148   "Return a service that runs the @command{elogind} login and seat management
1149 service.  The @command{elogind} service integrates with PAM to allow other
1150 system components to know the set of logged-in users as well as their session
1151 types (graphical, console, remote, etc.).  It can also clean up after users
1152 when they log out."
1153   (service elogind-service-type config))
1154
1155 \f
1156 ;;;
1157 ;;; Fontconfig and other desktop file-systems.
1158 ;;;
1159
1160 (define %fontconfig-file-system
1161   (file-system
1162     (device "none")
1163     (mount-point "/var/cache/fontconfig")
1164     (type "tmpfs")
1165     (flags '(read-only))
1166     (check? #f)))
1167
1168 ;; The global fontconfig cache directory can sometimes contain stale entries,
1169 ;; possibly referencing fonts that have been GC'd, so mount it read-only.
1170 ;; As mentioned https://debbugs.gnu.org/cgi/bugreport.cgi?bug=36924#8 and
1171 ;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=38046#10 and elsewhere.
1172 (define fontconfig-file-system-service
1173   (simple-service 'fontconfig-file-system
1174                   file-system-service-type
1175                   (list %fontconfig-file-system)))
1176 \f
1177 ;;;
1178 ;;; AccountsService service.
1179 ;;;
1180
1181 (define %accountsservice-activation
1182   #~(begin
1183       (use-modules (guix build utils))
1184       (mkdir-p "/var/lib/AccountsService")))
1185
1186 (define accountsservice-service-type
1187   (service-type (name 'accountsservice)
1188                 (extensions
1189                  (list (service-extension activation-service-type
1190                                           (const %accountsservice-activation))
1191                        (service-extension dbus-root-service-type list)
1192                        (service-extension polkit-service-type list)))
1193                 (default-value accountsservice)
1194                 (description "Run AccountsService, a system service available
1195 over D-Bus that can list available accounts, change their passwords, and so
1196 on.  AccountsService integrates with PolicyKit to enable unprivileged users to
1197 acquire the capability to modify their system configuration.")))
1198
1199 (define* (accountsservice-service #:key (accountsservice accountsservice))
1200   "Return a service that runs AccountsService, a system service that
1201 can list available accounts, change their passwords, and so on.
1202 AccountsService integrates with PolicyKit to enable unprivileged users to
1203 acquire the capability to modify their system configuration.
1204 @uref{https://www.freedesktop.org/wiki/Software/AccountsService/, the
1205 accountsservice web site} for more information."
1206   (service accountsservice-service-type accountsservice))
1207
1208 \f
1209 ;;;
1210 ;;; cups-pk-helper service.
1211 ;;;
1212
1213 (define cups-pk-helper-service-type
1214   (service-type
1215    (name 'cups-pk-helper)
1216    (description
1217     "PolicyKit helper to configure CUPS with fine-grained privileges.")
1218    (extensions
1219     (list (service-extension dbus-root-service-type list)
1220           (service-extension polkit-service-type list)))
1221    (default-value cups-pk-helper)))
1222
1223 \f
1224 ;;;
1225 ;;; Scanner access via SANE.
1226 ;;;
1227
1228 (define %sane-accounts
1229   ;; The '60-libsane.rules' udev rules refers to the "scanner" group.
1230   (list (user-group (name "scanner") (system? #t))))
1231
1232 (define sane-service-type
1233   (service-type
1234    (name 'sane)
1235    (description
1236     "This service provides access to scanners @i{via}
1237 @uref{http://www.sane-project.org, SANE} by installing the necessary udev
1238 rules.")
1239    (default-value sane-backends-minimal)
1240    (extensions
1241     (list (service-extension udev-service-type list)
1242           (service-extension account-service-type
1243                              (const %sane-accounts))))))
1244
1245
1246 \f
1247 ;;;
1248 ;;; GNOME desktop service.
1249 ;;;
1250
1251 (define-record-type* <gnome-desktop-configuration> gnome-desktop-configuration
1252   make-gnome-desktop-configuration
1253   gnome-desktop-configuration?
1254   (gnome gnome-package (default gnome)))
1255
1256 (define (gnome-packages config packages)
1257   "Return the list of GNOME dependencies from CONFIG which names are part of
1258 the given PACKAGES list."
1259   (let ((gnome (gnome-package config)))
1260     (map (lambda (name)
1261            ((package-direct-input-selector name) gnome))
1262          packages)))
1263
1264 (define (gnome-udev-rules config)
1265   "Return the list of GNOME dependencies that provide udev rules."
1266   (gnome-packages config '("gnome-settings-daemon")))
1267
1268 (define (gnome-polkit-settings config)
1269   "Return the list of GNOME dependencies that provide polkit actions and
1270 rules."
1271   (gnome-packages config
1272                   '("gnome-settings-daemon"
1273                     "gnome-control-center"
1274                     "gnome-system-monitor"
1275                     "gvfs")))
1276
1277 (define gnome-desktop-service-type
1278   (service-type
1279    (name 'gnome-desktop)
1280    (extensions
1281     (list (service-extension udev-service-type
1282                              gnome-udev-rules)
1283           (service-extension polkit-service-type
1284                              gnome-polkit-settings)
1285           (service-extension profile-service-type
1286                              (compose list
1287                                       gnome-package))))
1288    (default-value (gnome-desktop-configuration))
1289    (description "Run the GNOME desktop environment.")))
1290
1291 (define-deprecated (gnome-desktop-service #:key (config
1292                                                  (gnome-desktop-configuration)))
1293   gnome-desktop-service-type
1294   "Return a service that adds the @code{gnome} package to the system profile,
1295 and extends polkit with the actions from @code{gnome-settings-daemon}."
1296   (service gnome-desktop-service-type config))
1297
1298 ;; MATE Desktop service.
1299 ;; TODO: Add mate-screensaver.
1300
1301 (define-record-type* <mate-desktop-configuration> mate-desktop-configuration
1302   make-mate-desktop-configuration
1303   mate-desktop-configuration?
1304   (mate-package mate-package (default mate)))
1305
1306 (define (mate-polkit-extension config)
1307   "Return the list of packages for CONFIG's MATE package that extend polkit."
1308   (let ((mate (mate-package config)))
1309     (map (lambda (input)
1310            ((package-direct-input-selector input) mate))
1311          '("mate-system-monitor"                  ;kill, renice processes
1312            "mate-settings-daemon"                 ;date/time settings
1313            "mate-power-manager"                   ;modify brightness
1314            "mate-control-center"                  ;RandR, display properties FIXME
1315            "mate-applets"))))                     ;CPU frequency scaling
1316
1317 (define mate-desktop-service-type
1318   (service-type
1319    (name 'mate-desktop)
1320    (extensions
1321     (list (service-extension polkit-service-type
1322                              mate-polkit-extension)
1323           (service-extension profile-service-type
1324                              (compose list
1325                                       mate-package))))
1326    (default-value (mate-desktop-configuration))
1327    (description "Run the MATE desktop environment.")))
1328
1329 (define-deprecated (mate-desktop-service #:key
1330                                          (config
1331                                           (mate-desktop-configuration)))
1332   mate-desktop-service-type
1333   "Return a service that adds the @code{mate} package to the system profile,
1334 and extends polkit with the actions from @code{mate-settings-daemon}."
1335   (service mate-desktop-service-type config))
1336
1337 \f
1338 ;;;
1339 ;;; XFCE desktop service.
1340 ;;;
1341
1342 (define-record-type* <xfce-desktop-configuration> xfce-desktop-configuration
1343   make-xfce-desktop-configuration
1344   xfce-desktop-configuration?
1345   (xfce xfce-package (default xfce)))
1346
1347 (define (xfce-polkit-settings config)
1348   "Return the list of XFCE dependencies that provide polkit actions and
1349 rules."
1350   (let ((xfce (xfce-package config)))
1351     (map (lambda (name)
1352            ((package-direct-input-selector name) xfce))
1353          '("thunar"
1354            "xfce4-power-manager"))))
1355
1356 (define xfce-desktop-service-type
1357   (service-type
1358    (name 'xfce-desktop)
1359    (extensions
1360     (list (service-extension polkit-service-type
1361                              xfce-polkit-settings)
1362           (service-extension profile-service-type
1363                              (compose list xfce-package))))
1364    (default-value (xfce-desktop-configuration))
1365    (description "Run the Xfce desktop environment.")))
1366
1367 (define-deprecated (xfce-desktop-service #:key (config
1368                                                 (xfce-desktop-configuration)))
1369   xfce-desktop-service-type
1370   "Return a service that adds the @code{xfce} package to the system profile,
1371 and extends polkit with the ability for @code{thunar} to manipulate the file
1372 system as root from within a user session, after the user has authenticated
1373 with the administrator's password."
1374   (service xfce-desktop-service-type config))
1375
1376 +\f
1377 ;;;
1378 ;;; Lxqt desktop service.
1379 ;;;
1380
1381 (define-record-type* <lxqt-desktop-configuration> lxqt-desktop-configuration
1382   make-lxqt-desktop-configuration
1383   lxqt-desktop-configuration?
1384   (lxqt lxqt-package
1385         (default lxqt)))
1386
1387 (define (lxqt-polkit-settings config)
1388   "Return the list of LXQt dependencies that provide polkit actions and
1389 rules."
1390   (let ((lxqt (lxqt-package config)))
1391     (map (lambda (name)
1392            ((package-direct-input-selector name) lxqt))
1393          '("lxqt-admin"))))
1394
1395 (define lxqt-desktop-service-type
1396   (service-type
1397    (name 'lxqt-desktop)
1398    (extensions
1399     (list (service-extension polkit-service-type
1400                              lxqt-polkit-settings)
1401           (service-extension profile-service-type
1402                              (compose list lxqt-package))))
1403    (default-value (lxqt-desktop-configuration))
1404    (description "Run LXQt desktop environment.")))
1405
1406 \f
1407 ;;;
1408 ;;; X11 socket directory service
1409 ;;;
1410
1411 (define x11-socket-directory-service
1412   ;; Return a service that creates /tmp/.X11-unix.  When using X11, libxcb
1413   ;; takes care of creating that directory.  However, when using XWayland, we
1414   ;; need to create beforehand.  Thus, create it unconditionally here.
1415   (simple-service 'x11-socket-directory
1416                   activation-service-type
1417                   (with-imported-modules '((guix build utils))
1418                     #~(begin
1419                         (use-modules (guix build utils))
1420                         (let ((directory "/tmp/.X11-unix"))
1421                           (mkdir-p directory)
1422                           (chmod directory #o1777))))))
1423 \f
1424 ;;;
1425 ;;; Enlightenment desktop service.
1426 ;;;
1427
1428 (define-record-type* <enlightenment-desktop-configuration>
1429   enlightenment-desktop-configuration make-enlightenment-desktop-configuration
1430   enlightenment-desktop-configuration?
1431   ;; <package>
1432   (enlightenment        enlightenment-package
1433                         (default enlightenment)))
1434
1435 (define (enlightenment-setuid-programs enlightenment-desktop-configuration)
1436   (match-record enlightenment-desktop-configuration
1437       <enlightenment-desktop-configuration>
1438     (enlightenment)
1439     (map file-like->setuid-program
1440          (list (file-append enlightenment
1441                             "/lib/enlightenment/utils/enlightenment_sys")
1442                (file-append enlightenment
1443                             "/lib/enlightenment/utils/enlightenment_system")
1444                (file-append enlightenment
1445                             "/lib/enlightenment/utils/enlightenment_ckpasswd")))))
1446
1447 (define enlightenment-desktop-service-type
1448   (service-type
1449    (name 'enlightenment-desktop)
1450    (extensions
1451     (list (service-extension dbus-root-service-type
1452                              (compose list
1453                                       (package-direct-input-selector
1454                                        "efl")
1455                                       enlightenment-package))
1456           (service-extension setuid-program-service-type
1457                              enlightenment-setuid-programs)
1458           (service-extension profile-service-type
1459                              (compose list
1460                                       enlightenment-package))))
1461    (default-value (enlightenment-desktop-configuration))
1462    (description
1463     "Return a service that adds the @code{enlightenment} package to the system
1464 profile, and extends dbus with the ability for @code{efl} to generate
1465 thumbnails and makes setuid the programs which enlightenment needs to function
1466 as expected.")))
1467
1468 \f
1469 ;;;
1470 ;;; inputattach-service-type
1471 ;;;
1472
1473 (define-record-type* <inputattach-configuration>
1474   inputattach-configuration
1475   make-inputattach-configuration
1476   inputattach-configuration?
1477   (device-type inputattach-configuration-device-type
1478                (default "wacom"))
1479   (device inputattach-configuration-device
1480           (default "/dev/ttyS0"))
1481   (baud-rate inputattach-configuration-baud-rate
1482              (default #f))
1483   (log-file inputattach-configuration-log-file
1484             (default #f)))
1485
1486 (define inputattach-shepherd-service
1487   (match-lambda
1488     (($ <inputattach-configuration> type device baud-rate log-file)
1489      (let ((args (append (if baud-rate
1490                              (list "--baud" (number->string baud-rate))
1491                              '())
1492                          (list (string-append "--" type)
1493                                device))))
1494        (list (shepherd-service
1495               (provision '(inputattach))
1496               (requirement '(udev))
1497               (documentation "inputattach daemon")
1498               (start #~(make-forkexec-constructor
1499                         (cons (string-append #$inputattach
1500                                              "/bin/inputattach")
1501                               (quote #$args))
1502                         #:log-file #$log-file))
1503               (stop #~(make-kill-destructor))))))))
1504
1505 (define inputattach-service-type
1506   (service-type
1507    (name 'inputattach)
1508    (extensions
1509     (list (service-extension shepherd-root-service-type
1510                              inputattach-shepherd-service)))
1511    (default-value (inputattach-configuration))
1512    (description "Return a service that runs inputattach on a device and
1513 dispatches events from it.")))
1514
1515 \f
1516 ;;;
1517 ;;; gnome-keyring-service-type
1518 ;;;
1519
1520 (define-record-type* <gnome-keyring-configuration> gnome-keyring-configuration
1521   make-gnome-keyring-configuration
1522   gnome-keyring-configuration?
1523   (keyring gnome-keyring-package (default gnome-keyring))
1524   (pam-services gnome-keyring-pam-services (default '(("gdm-password" . login)
1525                                                       ("passwd" . passwd)))))
1526
1527 (define (pam-gnome-keyring config)
1528   (define (%pam-keyring-entry . arguments)
1529     (pam-entry
1530      (control "optional")
1531      (module (file-append (gnome-keyring-package config)
1532                           "/lib/security/pam_gnome_keyring.so"))
1533      (arguments arguments)))
1534
1535   (list
1536    (lambda (service)
1537      (case (assoc-ref (gnome-keyring-pam-services config)
1538                       (pam-service-name service))
1539        ((login)
1540         (pam-service
1541          (inherit service)
1542          (auth (append (pam-service-auth service)
1543                        (list (%pam-keyring-entry))))
1544          (session (append (pam-service-session service)
1545                           (list (%pam-keyring-entry "auto_start"))))))
1546        ((passwd)
1547         (pam-service
1548          (inherit service)
1549          (password (append (pam-service-password service)
1550                            (list (%pam-keyring-entry))))))
1551        (else service)))))
1552
1553 (define gnome-keyring-service-type
1554   (service-type
1555    (name 'gnome-keyring)
1556    (extensions (list
1557                 (service-extension pam-root-service-type pam-gnome-keyring)))
1558    (default-value (gnome-keyring-configuration))
1559    (description "Return a service, that adds the @code{gnome-keyring} package
1560 to the system profile and extends PAM with entries using
1561 @code{pam_gnome_keyring.so}, unlocking a user's login keyring when they log in
1562 or setting its password with passwd.")))
1563
1564 \f
1565 ;;;
1566 ;;; polkit-wheel-service -- Allow wheel group to perform admin actions
1567 ;;;
1568
1569 (define polkit-wheel
1570   (file-union
1571    "polkit-wheel"
1572    `(("share/polkit-1/rules.d/wheel.rules"
1573       ,(plain-file
1574         "wheel.rules"
1575         "polkit.addAdminRule(function(action, subject) {
1576     return [\"unix-group:wheel\"];
1577 });
1578 ")))))
1579
1580 (define polkit-wheel-service
1581   (simple-service 'polkit-wheel polkit-service-type (list polkit-wheel)))
1582
1583 \f
1584 ;;;
1585 ;;; The default set of desktop services.
1586 ;;;
1587
1588 (define* (desktop-services-for-system #:optional
1589                                       (system (or (%current-target-system)
1590                                                   (%current-system))))
1591   ;; List of services typically useful for a "desktop" use case.
1592
1593   ;; Since GDM depends on Rust (gdm -> gnome-shell -> gjs -> mozjs -> rust)
1594   ;; and Rust is currently unavailable on non-x86_64 platforms, default to
1595   ;; SDDM there (FIXME).
1596   (cons* (if (string-prefix? "x86_64" system)
1597              (service gdm-service-type)
1598              (service sddm-service-type))
1599
1600          ;; Screen lockers are a pretty useful thing and these are small.
1601          (screen-locker-service slock)
1602          (screen-locker-service xlockmore "xlock")
1603
1604          ;; Add udev rules for MTP devices so that non-root users can access
1605          ;; them.
1606          (simple-service 'mtp udev-service-type (list libmtp))
1607          ;; Add udev rules for scanners.
1608          (service sane-service-type)
1609          ;; Add polkit rules, so that non-root users in the wheel group can
1610          ;; perform administrative tasks (similar to "sudo").
1611          polkit-wheel-service
1612
1613          ;; Allow desktop users to also mount NTFS and NFS file systems
1614          ;; without root.
1615          (simple-service 'mount-setuid-helpers setuid-program-service-type
1616                          (map (lambda (program)
1617                                 (setuid-program
1618                                  (program program)))
1619                               (list (file-append nfs-utils "/sbin/mount.nfs")
1620                                (file-append ntfs-3g "/sbin/mount.ntfs-3g"))))
1621
1622          ;; The global fontconfig cache directory can sometimes contain
1623          ;; stale entries, possibly referencing fonts that have been GC'd,
1624          ;; so mount it read-only.
1625          fontconfig-file-system-service
1626
1627          ;; NetworkManager and its applet.
1628          (service network-manager-service-type)
1629          (service wpa-supplicant-service-type)    ;needed by NetworkManager
1630          (simple-service 'network-manager-applet
1631                          profile-service-type
1632                          (list network-manager-applet))
1633          (service modem-manager-service-type)
1634          (service usb-modeswitch-service-type)
1635
1636          ;; The D-Bus clique.
1637          (service avahi-service-type)
1638          (udisks-service)
1639          (service upower-service-type)
1640          (accountsservice-service)
1641          (service cups-pk-helper-service-type)
1642          (service colord-service-type)
1643          (geoclue-service)
1644          (service polkit-service-type)
1645          (elogind-service)
1646          (dbus-service)
1647
1648          (service ntp-service-type)
1649
1650          x11-socket-directory-service
1651
1652          (service pulseaudio-service-type)
1653          (service alsa-service-type)
1654
1655          %base-services))
1656
1657 (define-syntax %desktop-services
1658   (identifier-syntax (desktop-services-for-system)))
1659
1660 ;;; desktop.scm ends here