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   "Return a @file{org.freedesktop.login1.service} file that tells D-Bus how to
1079 \"start\" elogind.  In practice though, our elogind is started when booting by
1080 shepherd.  Thus, the @code{Exec} line of this @file{.service} file does not
1081 explain how to start elogind; instead, it spawns a wrapper that waits for the
1082 @code{elogind} shepherd service.  This avoids a race condition where both
1083 @command{shepherd} and @command{dbus-daemon} would attempt to start elogind."
1084   ;; For more info on the elogind startup race, see
1085   ;; <https://issues.guix.gnu.org/55444>.
1086
1087   (define elogind
1088     (elogind-package config))
1089
1090   (define wrapper
1091     (program-file "elogind-dbus-shepherd-sync"
1092                   (with-imported-modules '((gnu services herd))
1093                     #~(begin
1094                         (use-modules (gnu services herd)
1095                                      (srfi srfi-34))
1096
1097                         (guard (c ((service-not-found-error? c)
1098                                    (format (current-error-port)
1099                                            "no elogind shepherd service~%")
1100                                    (exit 1))
1101                                   ((shepherd-error? c)
1102                                    (format (current-error-port)
1103                                            "elogind shepherd service not \
1104 started~%")
1105                                    (exit 2)))
1106                           (wait-for-service 'elogind))))))
1107
1108   (define build
1109     (with-imported-modules '((guix build utils))
1110       #~(begin
1111           (use-modules (guix build utils)
1112                        (ice-9 match))
1113
1114           (define service-directory
1115             "/share/dbus-1/system-services")
1116
1117           (mkdir-p (dirname (string-append #$output service-directory)))
1118           (copy-recursively (string-append #$elogind service-directory)
1119                             (string-append #$output service-directory))
1120           (symlink (string-append #$elogind "/etc") ;for etc/dbus-1
1121                    (string-append #$output "/etc"))
1122
1123           ;; Replace the "Exec=" line of the 'org.freedesktop.login1.service'
1124           ;; file with one that refers to WRAPPER instead of elogind.
1125           (match (find-files #$output "\\.service$")
1126             ((file)
1127              (substitute* file
1128                (("Exec[[:blank:]]*=.*" _)
1129                 (string-append "Exec=" #$wrapper "\n"))))))))
1130
1131   (list (computed-file "elogind-dbus-service-wrapper" build)))
1132
1133 (define (pam-extension-procedure config)
1134   "Return an extension for PAM-ROOT-SERVICE-TYPE that ensures that all the PAM
1135 services use 'pam_elogind.so', a module that allows elogind to keep track of
1136 logged-in users (run 'loginctl' to see elogind's world view of users and
1137 seats.)"
1138   (define pam-elogind
1139     (pam-entry
1140      (control "required")
1141      (module (file-append (elogind-package config)
1142                           "/lib/security/pam_elogind.so"))))
1143
1144   (list (lambda (pam)
1145           (pam-service
1146            (inherit pam)
1147            (session (cons pam-elogind (pam-service-session pam)))))))
1148
1149 (define (elogind-shepherd-service config)
1150   "Return a Shepherd service to start elogind according to @var{config}."
1151   (list (shepherd-service
1152          (requirement '(dbus-system))
1153          (provision '(elogind))
1154          (start #~(make-forkexec-constructor
1155                    (list #$(file-append (elogind-package config)
1156                                         "/libexec/elogind/elogind"))
1157                    #:environment-variables
1158                    (list (string-append "ELOGIND_CONF_FILE="
1159                                         #$(elogind-configuration-file
1160                                            config)))))
1161          (stop #~(make-kill-destructor)))))
1162
1163 (define elogind-service-type
1164   (service-type (name 'elogind)
1165                 (extensions
1166                  (list (service-extension dbus-root-service-type
1167                                           elogind-dbus-service)
1168                        (service-extension udev-service-type
1169                                           (compose list elogind-package))
1170                        (service-extension polkit-service-type
1171                                           (compose list elogind-package))
1172
1173                        ;; Start elogind from the Shepherd rather than waiting
1174                        ;; for bus activation.  This ensures that it can handle
1175                        ;; events like lid close, etc.
1176                        (service-extension shepherd-root-service-type
1177                                           elogind-shepherd-service)
1178
1179                        ;; Provide the 'loginctl' command.
1180                        (service-extension profile-service-type
1181                                           (compose list elogind-package))
1182
1183                        ;; Extend PAM with pam_elogind.so.
1184                        (service-extension pam-root-service-type
1185                                           pam-extension-procedure)
1186
1187                        ;; We need /run/user, /run/systemd, etc.
1188                        (service-extension file-system-service-type
1189                                           (const %elogind-file-systems))))
1190                 (default-value (elogind-configuration))
1191                 (description "Run the @command{elogind} login and seat
1192 management service.  The @command{elogind} service integrates with PAM to
1193 allow other system components to know the set of logged-in users as well as
1194 their session types (graphical, console, remote, etc.).  It can also clean up
1195 after users when they log out.")))
1196
1197 (define* (elogind-service #:key (config (elogind-configuration)))
1198   "Return a service that runs the @command{elogind} login and seat management
1199 service.  The @command{elogind} service integrates with PAM to allow other
1200 system components to know the set of logged-in users as well as their session
1201 types (graphical, console, remote, etc.).  It can also clean up after users
1202 when they log out."
1203   (service elogind-service-type config))
1204
1205 \f
1206 ;;;
1207 ;;; Fontconfig and other desktop file-systems.
1208 ;;;
1209
1210 (define %fontconfig-file-system
1211   (file-system
1212     (device "none")
1213     (mount-point "/var/cache/fontconfig")
1214     (type "tmpfs")
1215     (flags '(read-only))
1216     (check? #f)))
1217
1218 ;; The global fontconfig cache directory can sometimes contain stale entries,
1219 ;; possibly referencing fonts that have been GC'd, so mount it read-only.
1220 ;; As mentioned https://debbugs.gnu.org/cgi/bugreport.cgi?bug=36924#8 and
1221 ;; https://debbugs.gnu.org/cgi/bugreport.cgi?bug=38046#10 and elsewhere.
1222 (define fontconfig-file-system-service
1223   (simple-service 'fontconfig-file-system
1224                   file-system-service-type
1225                   (list %fontconfig-file-system)))
1226 \f
1227 ;;;
1228 ;;; AccountsService service.
1229 ;;;
1230
1231 (define %accountsservice-activation
1232   #~(begin
1233       (use-modules (guix build utils))
1234       (mkdir-p "/var/lib/AccountsService")))
1235
1236 (define accountsservice-service-type
1237   (service-type (name 'accountsservice)
1238                 (extensions
1239                  (list (service-extension activation-service-type
1240                                           (const %accountsservice-activation))
1241                        (service-extension dbus-root-service-type list)
1242                        (service-extension polkit-service-type list)))
1243                 (default-value accountsservice)
1244                 (description "Run AccountsService, a system service available
1245 over D-Bus that can list available accounts, change their passwords, and so
1246 on.  AccountsService integrates with PolicyKit to enable unprivileged users to
1247 acquire the capability to modify their system configuration.")))
1248
1249 (define* (accountsservice-service #:key (accountsservice accountsservice))
1250   "Return a service that runs AccountsService, a system service that
1251 can list available accounts, change their passwords, and so on.
1252 AccountsService integrates with PolicyKit to enable unprivileged users to
1253 acquire the capability to modify their system configuration.
1254 @uref{https://www.freedesktop.org/wiki/Software/AccountsService/, the
1255 accountsservice web site} for more information."
1256   (service accountsservice-service-type accountsservice))
1257
1258 \f
1259 ;;;
1260 ;;; cups-pk-helper service.
1261 ;;;
1262
1263 (define cups-pk-helper-service-type
1264   (service-type
1265    (name 'cups-pk-helper)
1266    (description
1267     "PolicyKit helper to configure CUPS with fine-grained privileges.")
1268    (extensions
1269     (list (service-extension dbus-root-service-type list)
1270           (service-extension polkit-service-type list)))
1271    (default-value cups-pk-helper)))
1272
1273 \f
1274 ;;;
1275 ;;; Scanner access via SANE.
1276 ;;;
1277
1278 (define %sane-accounts
1279   ;; The '60-libsane.rules' udev rules refers to the "scanner" group.
1280   (list (user-group (name "scanner") (system? #t))))
1281
1282 (define sane-service-type
1283   (service-type
1284    (name 'sane)
1285    (description
1286     "This service provides access to scanners @i{via}
1287 @uref{http://www.sane-project.org, SANE} by installing the necessary udev
1288 rules.")
1289    (default-value sane-backends-minimal)
1290    (extensions
1291     (list (service-extension udev-service-type list)
1292           (service-extension account-service-type
1293                              (const %sane-accounts))))))
1294
1295
1296 \f
1297 ;;;
1298 ;;; GNOME desktop service.
1299 ;;;
1300
1301 (define-record-type* <gnome-desktop-configuration> gnome-desktop-configuration
1302   make-gnome-desktop-configuration
1303   gnome-desktop-configuration?
1304   (gnome gnome-package (default gnome)))
1305
1306 (define (gnome-packages config packages)
1307   "Return the list of GNOME dependencies from CONFIG which names are part of
1308 the given PACKAGES list."
1309   (let ((gnome (gnome-package config)))
1310     (map (lambda (name)
1311            ((package-direct-input-selector name) gnome))
1312          packages)))
1313
1314 (define (gnome-udev-rules config)
1315   "Return the list of GNOME dependencies that provide udev rules."
1316   (gnome-packages config '("gnome-settings-daemon")))
1317
1318 (define (gnome-polkit-settings config)
1319   "Return the list of GNOME dependencies that provide polkit actions and
1320 rules."
1321   (gnome-packages config
1322                   '("gnome-settings-daemon"
1323                     "gnome-control-center"
1324                     "gnome-system-monitor"
1325                     "gvfs")))
1326
1327 (define gnome-desktop-service-type
1328   (service-type
1329    (name 'gnome-desktop)
1330    (extensions
1331     (list (service-extension udev-service-type
1332                              gnome-udev-rules)
1333           (service-extension polkit-service-type
1334                              gnome-polkit-settings)
1335           (service-extension profile-service-type
1336                              (compose list
1337                                       gnome-package))))
1338    (default-value (gnome-desktop-configuration))
1339    (description "Run the GNOME desktop environment.")))
1340
1341 (define-deprecated (gnome-desktop-service #:key (config
1342                                                  (gnome-desktop-configuration)))
1343   gnome-desktop-service-type
1344   "Return a service that adds the @code{gnome} package to the system profile,
1345 and extends polkit with the actions from @code{gnome-settings-daemon}."
1346   (service gnome-desktop-service-type config))
1347
1348 ;; MATE Desktop service.
1349 ;; TODO: Add mate-screensaver.
1350
1351 (define-record-type* <mate-desktop-configuration> mate-desktop-configuration
1352   make-mate-desktop-configuration
1353   mate-desktop-configuration?
1354   (mate-package mate-package (default mate)))
1355
1356 (define (mate-polkit-extension config)
1357   "Return the list of packages for CONFIG's MATE package that extend polkit."
1358   (let ((mate (mate-package config)))
1359     (map (lambda (input)
1360            ((package-direct-input-selector input) mate))
1361          '("mate-system-monitor"                  ;kill, renice processes
1362            "mate-settings-daemon"                 ;date/time settings
1363            "mate-power-manager"                   ;modify brightness
1364            "mate-control-center"                  ;RandR, display properties FIXME
1365            "mate-applets"))))                     ;CPU frequency scaling
1366
1367 (define mate-desktop-service-type
1368   (service-type
1369    (name 'mate-desktop)
1370    (extensions
1371     (list (service-extension polkit-service-type
1372                              mate-polkit-extension)
1373           (service-extension profile-service-type
1374                              (compose list
1375                                       mate-package))))
1376    (default-value (mate-desktop-configuration))
1377    (description "Run the MATE desktop environment.")))
1378
1379 (define-deprecated (mate-desktop-service #:key
1380                                          (config
1381                                           (mate-desktop-configuration)))
1382   mate-desktop-service-type
1383   "Return a service that adds the @code{mate} package to the system profile,
1384 and extends polkit with the actions from @code{mate-settings-daemon}."
1385   (service mate-desktop-service-type config))
1386
1387 \f
1388 ;;;
1389 ;;; XFCE desktop service.
1390 ;;;
1391
1392 (define-record-type* <xfce-desktop-configuration> xfce-desktop-configuration
1393   make-xfce-desktop-configuration
1394   xfce-desktop-configuration?
1395   (xfce xfce-package (default xfce)))
1396
1397 (define (xfce-polkit-settings config)
1398   "Return the list of XFCE dependencies that provide polkit actions and
1399 rules."
1400   (let ((xfce (xfce-package config)))
1401     (map (lambda (name)
1402            ((package-direct-input-selector name) xfce))
1403          '("thunar"
1404            "xfce4-power-manager"))))
1405
1406 (define xfce-desktop-service-type
1407   (service-type
1408    (name 'xfce-desktop)
1409    (extensions
1410     (list (service-extension polkit-service-type
1411                              xfce-polkit-settings)
1412           (service-extension profile-service-type
1413                              (compose list xfce-package))))
1414    (default-value (xfce-desktop-configuration))
1415    (description "Run the Xfce desktop environment.")))
1416
1417 (define-deprecated (xfce-desktop-service #:key (config
1418                                                 (xfce-desktop-configuration)))
1419   xfce-desktop-service-type
1420   "Return a service that adds the @code{xfce} package to the system profile,
1421 and extends polkit with the ability for @code{thunar} to manipulate the file
1422 system as root from within a user session, after the user has authenticated
1423 with the administrator's password."
1424   (service xfce-desktop-service-type config))
1425
1426 +\f
1427 ;;;
1428 ;;; Lxqt desktop service.
1429 ;;;
1430
1431 (define-record-type* <lxqt-desktop-configuration> lxqt-desktop-configuration
1432   make-lxqt-desktop-configuration
1433   lxqt-desktop-configuration?
1434   (lxqt lxqt-package
1435         (default lxqt)))
1436
1437 (define (lxqt-polkit-settings config)
1438   "Return the list of LXQt dependencies that provide polkit actions and
1439 rules."
1440   (let ((lxqt (lxqt-package config)))
1441     (map (lambda (name)
1442            ((package-direct-input-selector name) lxqt))
1443          '("lxqt-admin"))))
1444
1445 (define lxqt-desktop-service-type
1446   (service-type
1447    (name 'lxqt-desktop)
1448    (extensions
1449     (list (service-extension polkit-service-type
1450                              lxqt-polkit-settings)
1451           (service-extension profile-service-type
1452                              (compose list lxqt-package))))
1453    (default-value (lxqt-desktop-configuration))
1454    (description "Run LXQt desktop environment.")))
1455
1456 \f
1457 ;;;
1458 ;;; X11 socket directory service
1459 ;;;
1460
1461 (define x11-socket-directory-service
1462   ;; Return a service that creates /tmp/.X11-unix.  When using X11, libxcb
1463   ;; takes care of creating that directory.  However, when using XWayland, we
1464   ;; need to create beforehand.  Thus, create it unconditionally here.
1465   (simple-service 'x11-socket-directory
1466                   activation-service-type
1467                   (with-imported-modules '((guix build utils))
1468                     #~(begin
1469                         (use-modules (guix build utils))
1470                         (let ((directory "/tmp/.X11-unix"))
1471                           (mkdir-p directory)
1472                           (chmod directory #o1777))))))
1473 \f
1474 ;;;
1475 ;;; Enlightenment desktop service.
1476 ;;;
1477
1478 (define-record-type* <enlightenment-desktop-configuration>
1479   enlightenment-desktop-configuration make-enlightenment-desktop-configuration
1480   enlightenment-desktop-configuration?
1481   ;; <package>
1482   (enlightenment        enlightenment-package
1483                         (default enlightenment)))
1484
1485 (define (enlightenment-setuid-programs enlightenment-desktop-configuration)
1486   (match-record enlightenment-desktop-configuration
1487       <enlightenment-desktop-configuration>
1488     (enlightenment)
1489     (map file-like->setuid-program
1490          (list (file-append enlightenment
1491                             "/lib/enlightenment/utils/enlightenment_sys")
1492                (file-append enlightenment
1493                             "/lib/enlightenment/utils/enlightenment_system")
1494                (file-append enlightenment
1495                             "/lib/enlightenment/utils/enlightenment_ckpasswd")))))
1496
1497 (define enlightenment-desktop-service-type
1498   (service-type
1499    (name 'enlightenment-desktop)
1500    (extensions
1501     (list (service-extension dbus-root-service-type
1502                              (compose list
1503                                       (package-direct-input-selector
1504                                        "efl")
1505                                       enlightenment-package))
1506           (service-extension setuid-program-service-type
1507                              enlightenment-setuid-programs)
1508           (service-extension profile-service-type
1509                              (compose list
1510                                       enlightenment-package))))
1511    (default-value (enlightenment-desktop-configuration))
1512    (description
1513     "Return a service that adds the @code{enlightenment} package to the system
1514 profile, and extends dbus with the ability for @code{efl} to generate
1515 thumbnails and makes setuid the programs which enlightenment needs to function
1516 as expected.")))
1517
1518 \f
1519 ;;;
1520 ;;; inputattach-service-type
1521 ;;;
1522
1523 (define-record-type* <inputattach-configuration>
1524   inputattach-configuration
1525   make-inputattach-configuration
1526   inputattach-configuration?
1527   (device-type inputattach-configuration-device-type
1528                (default "wacom"))
1529   (device inputattach-configuration-device
1530           (default "/dev/ttyS0"))
1531   (baud-rate inputattach-configuration-baud-rate
1532              (default #f))
1533   (log-file inputattach-configuration-log-file
1534             (default #f)))
1535
1536 (define inputattach-shepherd-service
1537   (match-lambda
1538     (($ <inputattach-configuration> type device baud-rate log-file)
1539      (let ((args (append (if baud-rate
1540                              (list "--baud" (number->string baud-rate))
1541                              '())
1542                          (list (string-append "--" type)
1543                                device))))
1544        (list (shepherd-service
1545               (provision '(inputattach))
1546               (requirement '(udev))
1547               (documentation "inputattach daemon")
1548               (start #~(make-forkexec-constructor
1549                         (cons (string-append #$inputattach
1550                                              "/bin/inputattach")
1551                               (quote #$args))
1552                         #:log-file #$log-file))
1553               (stop #~(make-kill-destructor))))))))
1554
1555 (define inputattach-service-type
1556   (service-type
1557    (name 'inputattach)
1558    (extensions
1559     (list (service-extension shepherd-root-service-type
1560                              inputattach-shepherd-service)))
1561    (default-value (inputattach-configuration))
1562    (description "Return a service that runs inputattach on a device and
1563 dispatches events from it.")))
1564
1565 \f
1566 ;;;
1567 ;;; gnome-keyring-service-type
1568 ;;;
1569
1570 (define-record-type* <gnome-keyring-configuration> gnome-keyring-configuration
1571   make-gnome-keyring-configuration
1572   gnome-keyring-configuration?
1573   (keyring gnome-keyring-package (default gnome-keyring))
1574   (pam-services gnome-keyring-pam-services (default '(("gdm-password" . login)
1575                                                       ("passwd" . passwd)))))
1576
1577 (define (pam-gnome-keyring config)
1578   (define (%pam-keyring-entry . arguments)
1579     (pam-entry
1580      (control "optional")
1581      (module (file-append (gnome-keyring-package config)
1582                           "/lib/security/pam_gnome_keyring.so"))
1583      (arguments arguments)))
1584
1585   (list
1586    (lambda (service)
1587      (case (assoc-ref (gnome-keyring-pam-services config)
1588                       (pam-service-name service))
1589        ((login)
1590         (pam-service
1591          (inherit service)
1592          (auth (append (pam-service-auth service)
1593                        (list (%pam-keyring-entry))))
1594          (session (append (pam-service-session service)
1595                           (list (%pam-keyring-entry "auto_start"))))))
1596        ((passwd)
1597         (pam-service
1598          (inherit service)
1599          (password (append (pam-service-password service)
1600                            (list (%pam-keyring-entry))))))
1601        (else service)))))
1602
1603 (define gnome-keyring-service-type
1604   (service-type
1605    (name 'gnome-keyring)
1606    (extensions (list
1607                 (service-extension pam-root-service-type pam-gnome-keyring)))
1608    (default-value (gnome-keyring-configuration))
1609    (description "Return a service, that adds the @code{gnome-keyring} package
1610 to the system profile and extends PAM with entries using
1611 @code{pam_gnome_keyring.so}, unlocking a user's login keyring when they log in
1612 or setting its password with passwd.")))
1613
1614 \f
1615 ;;;
1616 ;;; polkit-wheel-service -- Allow wheel group to perform admin actions
1617 ;;;
1618
1619 (define polkit-wheel
1620   (file-union
1621    "polkit-wheel"
1622    `(("share/polkit-1/rules.d/wheel.rules"
1623       ,(plain-file
1624         "wheel.rules"
1625         "polkit.addAdminRule(function(action, subject) {
1626     return [\"unix-group:wheel\"];
1627 });
1628 ")))))
1629
1630 (define polkit-wheel-service
1631   (simple-service 'polkit-wheel polkit-service-type (list polkit-wheel)))
1632
1633 \f
1634 ;;;
1635 ;;; The default set of desktop services.
1636 ;;;
1637
1638 (define* (desktop-services-for-system #:optional
1639                                       (system (or (%current-target-system)
1640                                                   (%current-system))))
1641   ;; List of services typically useful for a "desktop" use case.
1642
1643   ;; Since GDM depends on Rust (gdm -> gnome-shell -> gjs -> mozjs -> rust)
1644   ;; and Rust is currently unavailable on non-x86_64 platforms, default to
1645   ;; SDDM there (FIXME).
1646   (cons* (if (string-prefix? "x86_64" system)
1647              (service gdm-service-type)
1648              (service sddm-service-type))
1649
1650          ;; Screen lockers are a pretty useful thing and these are small.
1651          (screen-locker-service slock)
1652          (screen-locker-service xlockmore "xlock")
1653
1654          ;; Add udev rules for MTP devices so that non-root users can access
1655          ;; them.
1656          (simple-service 'mtp udev-service-type (list libmtp))
1657          ;; Add udev rules for scanners.
1658          (service sane-service-type)
1659          ;; Add polkit rules, so that non-root users in the wheel group can
1660          ;; perform administrative tasks (similar to "sudo").
1661          polkit-wheel-service
1662
1663          ;; Allow desktop users to also mount NTFS and NFS file systems
1664          ;; without root.
1665          (simple-service 'mount-setuid-helpers setuid-program-service-type
1666                          (map (lambda (program)
1667                                 (setuid-program
1668                                  (program program)))
1669                               (list (file-append nfs-utils "/sbin/mount.nfs")
1670                                (file-append ntfs-3g "/sbin/mount.ntfs-3g"))))
1671
1672          ;; The global fontconfig cache directory can sometimes contain
1673          ;; stale entries, possibly referencing fonts that have been GC'd,
1674          ;; so mount it read-only.
1675          fontconfig-file-system-service
1676
1677          ;; NetworkManager and its applet.
1678          (service network-manager-service-type)
1679          (service wpa-supplicant-service-type)    ;needed by NetworkManager
1680          (simple-service 'network-manager-applet
1681                          profile-service-type
1682                          (list network-manager-applet))
1683          (service modem-manager-service-type)
1684          (service usb-modeswitch-service-type)
1685
1686          ;; The D-Bus clique.
1687          (service avahi-service-type)
1688          (udisks-service)
1689          (service upower-service-type)
1690          (accountsservice-service)
1691          (service cups-pk-helper-service-type)
1692          (service colord-service-type)
1693          (geoclue-service)
1694          (service polkit-service-type)
1695          (elogind-service)
1696          (dbus-service)
1697
1698          (service ntp-service-type)
1699
1700          x11-socket-directory-service
1701
1702          (service pulseaudio-service-type)
1703          (service alsa-service-type)
1704
1705          %base-services))
1706
1707 (define-syntax %desktop-services
1708   (identifier-syntax (desktop-services-for-system)))
1709
1710 ;;; desktop.scm ends here