;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2018 Ludovic Courtès ;;; Copyright © 2016, 2017, 2018, 2019 Ricardo Wurmus ;;; Copyright © 2018, 2020, 2021 Tobias Geerinckx-Rice ;;; Copyright © 2018, 2019 Pierre Neidhardt ;;; Copyright © 2019, 2020 Efraim Flashner ;;; Copyright © 2019 Guillaume Le Vaillant ;;; Copyright © 2019 Andreas Enge ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen ;;; Copyright © 2020, 2021 Marius Bakke ;;; Copyright © 2020 Katherine Cox-Buday ;;; Copyright © 2020 Maxim Cournoyer ;;; Copyright © 2020, 2021 Greg Hogan ;;; ;;; This file is part of GNU Guix. ;;; ;;; GNU Guix is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published
aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Andy Wingo <wingo@igalia.com>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2016 Sou Bunnbu <iyzsong@gmail.com>
;;; Copyright © 2017, 2020, 2022, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;; Copyright © 2017 Nikita <nikita@n0.is>
;;; Copyright © 2017, 2019 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;; Copyright © 2018, 2020, 2022 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2018, 2023 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2017, 2019 Christopher Baines <mail@cbaines.net>
;;; Copyright © 2019 Tim Gesthuizen <tim.gesthuizen@yahoo.de>
;;; Copyright © 2019 David Wilson <david@daviwil.com>
;;; Copyright © 2020, 2024 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020 Reza Alizadeh Majd <r.majd@pantherx.org>
;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
;;; Copyright © 2021, 2022 muradm <mail@muradm.net>
;;; Copyright © 2023 Bruno Victal <mirai@makinata.eu>
;;; Copyright © 2023 Zheng Junjie <873216071@qq.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu services desktop)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services base)
  #:use-module (gnu services configuration)
  #:use-module (gnu services dbus)
  #:use-module (gnu services avahi)
  #:use-module (gnu services xorg)
  #:use-module (gnu services networking)
  #:use-module (gnu services sound)
  #:use-module ((gnu system file-systems)
                #:select (%control-groups
                          %elogind-file-systems
                          file-system))
  #:autoload   (gnu services sddm) (sddm-service-type)
  #:use-module (gnu system)
  #:use-module (gnu system privilege)
  #:use-module (gnu system shadow)
  #:use-module (gnu system uuid)
  #:use-module (gnu system pam)
  #:use-module (gnu packages glib)
  #:use-module (gnu packages admin)
  #:use-module (gnu packages cups)
  #:use-module (gnu packages freedesktop)
  #:use-module (gnu packages gnome)
  #:use-module (gnu packages kde)
  #:use-module (gnu packages kde-frameworks)
  #:use-module (gnu packages kde-plasma)
  #:use-module (gnu packages pulseaudio)
  #:use-module (gnu packages xfce)
  #:use-module (gnu packages avahi)
  #:use-module (gnu packages xdisorg)
  #:use-module (gnu packages scanner)
  #:use-module (gnu packages suckless)
  #:use-module (gnu packages sugar)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages libusb)
  #:use-module (gnu packages lxqt)
  #:use-module (gnu packages mate)
  #:use-module (gnu packages nfs)
  #:use-module (gnu packages enlightenment)
  #:use-module (guix deprecation)
  #:use-module (guix records)
  #:use-module (guix packages)
  #:use-module (guix store)
  #:use-module (guix ui)
  #:use-module (guix utils)
  #:use-module (guix gexp)
  #:use-module (guix modules)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:export (<upower-configuration>
            upower-configuration
            upower-configuration?
            upower-configuration-upower
            upower-configuration-watts-up-pro?
            upower-configuration-poll-batteries?
            upower-configuration-ignore-lid?
            upower-configuration-use-percentage-for-policy?
            upower-configuration-percentage-low
            upower-configuration-percentage-critical
            upower-configuration-percentage-action
            upower-configuration-time-low
            upower-configuration-time-critical
            upower-configuration-time-action
            upower-configuration-critical-power-action

            upower-service-type

            udisks-configuration
            udisks-configuration?
            udisks-service  ; deprecated
            udisks-service-type

            gvfs-configuration
            gvfs-configuration?
            gvfs-service-type

            colord-service-type

            geoclue-application
            geoclue-configuration
            geoclue-configuration?
            %standard-geoclue-applications
            geoclue-service  ; deprecated
            geoclue-service-type

            bluetooth-service-type
            bluetooth-configuration
            bluetooth-configuration?
            bluetooth-service  ; deprecated

            elogind-configuration
            elogind-configuration?
            elogind-service  ; deprecated
            elogind-service-type

            %gdm-file-system
            gdm-file-system-service

            %fontconfig-file-system
            fontconfig-file-system-service

            accountsservice-service-type
            accountsservice-service  ; deprecated

            cups-pk-helper-service-type
            sane-service-type

            gnome-desktop-configuration
            gnome-desktop-configuration?
            gnome-desktop-configuration-core-services
            gnome-desktop-configuration-shell
            gnome-desktop-configuration-utilities
            gnome-desktop-configuration-extra-packages
            gnome-desktop-configuration-udev-ignorelist
            gnome-desktop-service
            gnome-desktop-service-type

            mate-desktop-configuration
            mate-desktop-configuration?
            mate-desktop-service
            mate-desktop-service-type

            lxqt-desktop-configuration
            lxqt-desktop-configuration?
            lxqt-desktop-service-type

            sugar-desktop-configuration
            sugar-desktop-configuration?
            sugar-desktop-service-type

            plasma-desktop-configuration
            plasma-desktop-configuration?
            plasma-desktop-service-type

            xfce-desktop-configuration
            xfce-desktop-configuration?
            xfce-desktop-service
            xfce-desktop-service-type

            x11-socket-directory-service ;deprecated
            x11-socket-directory-service-type

            enlightenment-desktop-configuration
            enlightenment-desktop-configuration?
            enlightenment-desktop-service-type

            inputattach-configuration
            inputattach-configuration?
            inputattach-service-type

            polkit-wheel-service

            gnome-keyring-configuration
            gnome-keyring-configuration?
            gnome-keyring-service-type

            seatd-configuration
            seatd-service-type

            %desktop-services))

;;; Commentary:
;;;
;;; This module contains service definitions for a "desktop" environment.
;;;
;;; Code:


;;;
;;; Helpers.
;;;

(define (bool value)
  (if value "true\n" "false\n"))

(define (package-direct-input-selector tree)
  "Return a procedure that selects TREE from the inputs of PACKAGE.  If TREE
is a list, it recursively searches it until it locates the last item of TREE."
  (lambda (package)
    (let loop ((tree (if (pair? tree)
                         tree
                         (list tree)))
               (package package))
      (if (null? tree)
          package
          (loop (cdr tree)
                (car (assoc-ref (package-direct-inputs package)
                                (car tree))))))))


;;;
;;; Upower D-Bus service.
;;;

(define-record-type* <upower-configuration>
  upower-configuration make-upower-configuration
  upower-configuration?
  (upower                     upower-configuration-upower
                              (default upower))
  (watts-up-pro?              upower-configuration-watts-up-pro?
                              (default #f))
  (poll-batteries?            upower-configuration-poll-batteries?
                              (default #t))
  (ignore-lid?                upower-configuration-ignore-lid?
                              (default #f))
  (use-percentage-for-policy? upower-configuration-use-percentage-for-policy?
                              (default #t))
  (percentage-low             upower-configuration-percentage-low
                              (default 20))
  (percentage-critical        upower-configuration-percentage-critical
                              (default 5))
  (percentage-action          upower-configuration-percentage-action
                              (default 2))
  (time-low                   upower-configuration-time-low
                              (default 1200))
  (time-critical              upower-configuration-time-critical
                              (default 300))
  (time-action                upower-configuration-time-action
                              (default 120))
  (critical-power-action      upower-configuration-critical-power-action
                              (default 'hybrid-sleep)))

(define* upower-configuration-file
  ;; Return an upower-daemon configuration file.
  (match-lambda
    (($ <upower-configuration> upower
        watts-up-pro? poll-batteries? ignore-lid? use-percentage-for-policy?
        percentage-low percentage-critical percentage-action time-low
        time-critical time-action critical-power-action)
     (plain-file "UPower.conf"
                 (string-append
                  "[UPower]\n"
                  "EnableWattsUpPro=" (bool watts-up-pro?)
                  "NoPollBatteries=" (bool (not poll-batteries?))
                  "IgnoreLid=" (bool ignore-lid?)
                  "UsePercentageForPolicy=" (bool use-percentage-for-policy?)
                  "PercentageLow=" (number->string percentage-low) "\n"
                  "PercentageCritical=" (number->string percentage-critical) "\n"
                  "PercentageAction=" (number->string percentage-action) "\n"
                  "TimeLow=" (number->string time-low) "\n"
                  "TimeCritical=" (number->string time-critical) "\n"
                  "TimeAction=" (number->string time-action) "\n"
                  "CriticalPowerAction=" (match critical-power-action
                                           ('hybrid-sleep "HybridSleep")
                                           ('hibernate "Hibernate")
                                           ('power-off "PowerOff"))
                  "\n")))))

(define %upower-activation
  #~(begin
      (use-modules (guix build utils))
      (mkdir-p "/var/lib/upower")))

(define (upower-dbus-service config)
  (list (wrapped-dbus-service (upower-configuration-upower config)
                              "libexec/upowerd"
                              `(("UPOWER_CONF_FILE_NAME"
                                 ,(upower-configuration-file config))))))

(define (upower-shepherd-service config)
  "Return a shepherd service for UPower with CONFIG."
  (let ((upower (upower-configuration-upower config))
        (config (upower-configuration-file config)))
    (list (shepherd-service
           (documentation "Run the UPower power and battery monitor.")
           (provision '(upower-daemon))
           (requirement '(dbus-system udev))

           (start #~(make-forkexec-constructor
                     (list (string-append #$upower "/libexec/upowerd"))
                     #:environment-variables
                     (list (string-append "UPOWER_CONF_FILE_NAME="
                                          #$config))))
           (stop #~(make-kill-destructor))
           (actions (list (shepherd-configuration-action config)))))))

(define upower-service-type
  (let ((upower-package (compose list upower-configuration-upower)))
    (service-type (name 'upower)
                  (description
                   "Run @command{upowerd}}, a system-wide monitor for power
consumption and battery levels, with the given configuration settings.  It
implements the @code{org.freedesktop.UPower} D-Bus interface, and is notably
used by GNOME.")
                  (extensions
                   (list (service-extension dbus-root-service-type
                                            upower-dbus-service)
                         (service-extension shepherd-root-service-type
                                            upower-shepherd-service)
                         (service-extension activation-service-type
                                            (const %upower-activation))
                         (service-extension udev-service-type
                                            upower-package)

                         ;; Make the 'upower' command visible.
                         (service-extension profile-service-type
                                            upower-package)))
                  (default-value (upower-configuration)))))


;;;
;;; GeoClue D-Bus service.
;;;

(define* (geoclue-application name #:key (allowed? #t) system? (users '()))
  "Configure default GeoClue access permissions for an application.  NAME is
the Desktop ID of the application, without the .desktop part.  If ALLOWED? is
true, the application will have access to location information by default.
The boolean SYSTEM? value indicates that an application is a system component
or not.  Finally USERS is a list of UIDs of all users for which this
application is allowed location info access.  An empty users list means all
users are allowed."
  (string-append
   "[" name "]\n"
   "allowed=" (bool allowed?)
   "system=" (bool system?)
   "users=" (string-join users ";") "\n"))

(define %standard-geoclue-applications
  (list (geoclue-application "gnome-datetime-panel" #:system? #t)
        (geoclue-application "epiphany" #:system? #f)
        (geoclue-application "firefox" #:system? #f)))

;; TODO: Use define-configuration and export accessors.
(define-record-type* <geoclue-configuration>
  geoclue-configuration make-geoclue-configuration
  geoclue-configuration?
  (geoclue geoclue-configuration-geoclue
           (default geoclue))
  (whitelist geoclue-configuration-whitelist
             (default '()))
  (wifi-geolocation-url
   geoclue-configuration-wifi-geolocation-url
   ;; Mozilla geolocation service:
   (default "https://location.services.mozilla.com/v1/geolocate?key=geoclue"))
  (submit-data? geoclue-configuration-submit-data?
                (default #f))
  (wifi-submission-url
   geoclue-configuration-wifi-submission-url
   (default "https://location.services.mozilla.com/v1/submit?key=geoclue"))
  (submission-nick geoclue-configuration-submission-nick
                   (default "geoclue"))
  (applications geoclue-configuration-applications
                (default %standard-geoclue-applications)))

(define* (geoclue-configuration-file config)
  "Return a geoclue configuration file."
  (plain-file "geoclue.conf"
              (string-append
               "[agent]\n"
               "whitelist="
               (string-join (geoclue-configuration-whitelist config)
                            ";") "\n"
               "[wifi]\n"
               "url=" (geoclue-configuration-wifi-geolocation-url config) "\n"
               "submit-data=" (bool (geoclue-configuration-submit-data? config))
               "submission-url="
               (geoclue-configuration-wifi-submission-url config) "\n"
               "submission-nick="
               (geoclue-configuration-submission-nick config)
               "\n"
               (string-join (geoclue-configuration-applications config)
                            "\n"))))

(define (geoclue-dbus-service config)
  (list (wrapped-dbus-service (geoclue-configuration-geoclue config)
                              "libexec/geoclue"
                              `(("GEOCLUE_CONFIG_FILE"
                                 ,(geoclue-configuration-file config))))))

(define %geoclue-accounts
  (list (user-group (name "geoclue") (system? #t))
        (user-account
         (name "geoclue")
         (group "geoclue")
         (system? #t)
         (comment "GeoClue daemon user")
         (home-directory "/var/empty")
         (shell "/run/current-system/profile/sbin/nologin"))))

(define geoclue-service-type
  (service-type (name 'geoclue)
                (extensions
                 (list (service-extension dbus-root-service-type
                                          geoclue-dbus-service)
                       (service-extension account-service-type
                                          (const %geoclue-accounts))))
                (description "Run the @command{geoclue} location service.
This service provides a D-Bus interface to allow applications to request
access to a user's physical location, and optionally to add information to
online location databases.")
                (default-value (geoclue-configuration))))

(define-deprecated
  (geoclue-service #:key (geoclue geoclue)
                   (whitelist '())
                   (wifi-geolocation-url
                    ;; Mozilla geolocation service:
                    "https://location.services.mozilla.com/v1/geolocate?key=geoclue")
                   (submit-data? #f)
                   (wifi-submission-url
                    "https://location.services.mozilla.com/v1/submit?key=geoclue")
                   (submission-nick "geoclue")
                   (applications %standard-geoclue-applications))
  geoclue-service-type
  "Return a service that runs the @command{geoclue} location service.  This
service provides a D-Bus interface to allow applications to request access to
a user's physical location, and optionally to add information to online
location databases.  By default, only the GNOME date-time panel and the Icecat
and Epiphany web browsers are able to ask for the user's location, and in the
case of Icecat and Epiphany, both will ask the user for permission first.  See
@uref{https://wiki.freedesktop.org/www/Software/GeoClue/, the geoclue web
site} for more information."
  (service geoclue-service-type
           (geoclue-configuration
            (geoclue geoclue)
            (whitelist whitelist)
            (wifi-geolocation-url wifi-geolocation-url)
            (submit-data? submit-data?)
            (wifi-submission-url wifi-submission-url)
            (submission-nick submission-nick)
            (applications applications))))


;;;
;;; Bluetooth.
;;;

(define-record-type* <bluetooth-configuration>
  bluetooth-configuration make-bluetooth-configuration
  bluetooth-configuration?
  (bluez bluetooth-configuration-bluez (default bluez))

  ;;; [General]
  (name bluetooth-configuration-name (default "BlueZ"))
  (class bluetooth-configuration-class (default #x000000))
  (discoverable-timeout
   bluetooth-configuration-discoverable-timeout (default 180))
  (always-pairable? bluetooth-configuration-always-pairable? (default #f))
  (pairable-timeout bluetooth-configuration-pairable-timeout (default 0))

  ;;; MAYBE: Exclude into separate <device-id> record-type?
  (device-id bluetooth-configuration-device-id (default #f))
  (reverse-service-discovery?
   bluetooth-configuration-reverse-service-discovery (default #t))
  (name-resolving? bluetooth-configuration-name-resolving? (default #t))
  (debug-keys? bluetooth-configuration-debug-keys? (default #f))

  ;;; Possible values:
  ;;; 'dual, 'bredr, 'le
  (controller-mode bluetooth-configuration-controller-mode (default 'dual))

  ;;; Possible values:
  ;;; 'off, 'single, 'multiple
  (multi-profile bluetooth-configuration-multi-profile (default 'off))
  (fast-connectable? bluetooth-configuration-fast-connectable? (default #f))

  ;;; Possible values:
  ;;; for LE mode: 'off, 'network/on, 'device
  ;;; for Dual mode: 'off, 'network/on', 'device, 'limited-network, 'limited-device
  ;;; Source: https://git.kernel.org/pub/scm/bluetooth/bluez.git/tree/src/main.conf#n68
  (privacy bluetooth-configuration-privacy (default 'off))

  ;;; Possible values:
  ;;; 'never, 'confirm, 'always
  (just-works-repairing
   bluetooth-configuration-just-works-repairing (default 'never))
  (temporary-timeout bluetooth-configuration-temporary-timeout (default 30))
  (refresh-discovery? bluetooth-configuration-refresh-discovery (default #t))

  ;;; Possible values: #t, #f, (uuid <uuid>)
  ;;; Possible UUIDs:
  ;;; d4992530-b9ec-469f-ab01-6c481c47da1c (BlueZ Experimental Debug)
  ;;; 671b10b5-42c0-4696-9227-eb28d1b049d6 (BlueZ Experimental Simultaneous Central and Peripheral)
  ;;; 15c0a148-c273-11ea-b3de-0242ac130004 (BlueZ Experimental LL privacy)
  ;;; 330859bc-7506-492d-9370-9a6f0614037f (BlueZ Experimental Bluetooth Quality Report)
  ;;; a6695ace-ee7f-4fb9-881a-5fac66c629af (BlueZ Experimental Offload Codecs)
  ;;; Source: https://git.kernel.org/pub/scm/bluetooth/bluez.git/tree/src/main.conf#n110
  (experimental bluetooth-configuration-experimental (default #f))
  (remote-name-request-retry-delay
   bluetooth-configuration-remote-name-request-retry-delay (default 300))

  ;;; [BR]
  (page-scan-type bluetooth-configuration-page-scan-type (default #f))
  (page-scan-interval bluetooth-configuration-page-scan-interval (default #f))
  (page-scan-window bluetooth-configuration-page-scan-window (default #f))
  (inquiry-scan-type bluetooth-configuration-inquiry-scan-type (default #f))
  (inquiry-scan-interval bluetooth-configuration-inquiry-scan-interval (default #f))
  (inquiry-scan-window bluetooth-configuration-inquiry-scan-window (default #f))
  (link-supervision-timeout bluetooth-configuration-link-supervision-timeout (default #f))
  (page-timeout bluetooth-configuration-page-timeout (default #f))
  (min-sniff-interval bluetooth-configuration-min-sniff-interval (default #f))
  (max-sniff-interval bluetooth-configuration-max-sniff-interval (default #f))

  ;;; [LE]
  (min-advertisement-interval
   bluetooth-configuration-min-advertisement-interval (default #f))
  (max-advertisement-interval
   bluetooth-configuration-max-advertisement-interval (default #f))
  (multi-advertisement-rotation-interval
   bluetooth-configuration-multi-advertisement-rotation-interval (default #f))
  (scan-interval-auto-connect
   bluetooth-configuration-scan-interval-auto-connect (default #f))
  (scan-window-auto-connect
   bluetooth-configuration-scan-window-auto-connect (default #f))
  (scan-interval-suspend
   bluetooth-configuration-scan-interval-suspend (default #f))
  (scan-window-suspend
   bluetooth-configuration-scan-window-suspend (default #f))
  (scan-interval-discovery
   bluetooth-configuration-scan-interval-discovery (default #f))
  (scan-window-discovery
   bluetooth-configuration-scan-window-discovery (default #f))
  (scan-interval-adv-monitor
   bluetooth-configuration-scan-interval-adv-monitor (default #f))
  (scan-window-adv-monitor
   bluetooth-configuration-scan-window-adv-monitor (default #f))
  (scan-interval-connect
   bluetooth-configuration-scan-interval-connect (default #f))
  (scan-window-connect
   bluetooth-configuration-scan-window-connect (default #f))
  (min-connection-interval
   bluetooth-configuration-min-connection-interval (default #f))
  (max-connection-interval
   bluetooth-configuration-max-connection-interval (default #f))
  (connection-latency
   bluetooth-configuration-connection-latency (default #f))
  (connection-supervision-timeout
   bluetooth-configuration-connection-supervision-timeout (default #f))
  (autoconnect-timeout
   bluetooth-configuration-autoconnect-timeout (default #f))
  (adv-mon-allowlist-scan-duration
   bluetooth-configuration-adv-mon-allowlist-scan-duration (default 300))
  (adv-mon-no-filter-scan-duration
   bluetooth-configuration-adv-mon-no-filter-scan-duration (default 500))
  (enable-adv-mon-interleave-scan?
   bluetooth-configuration-enable-adv-mon-interleave-scan (default #t))

  ;;; [GATT]
  ;;; Possible values: 'yes, 'no, 'always
  (cache bluetooth-configuration-cache (default 'always))

  ;;; Possible values: 7 ... 16, 0 (don't care)
  (key-size bluetooth-configuration-key-size (default 0))

  ;;; Possible values: 23 ... 517
  (exchange-mtu bluetooth-configuration-exchange-mtu (default 517))

  ;;; Possible values: 1 ... 5
  (att-channels bluetooth-configuration-att-channels (default 3))

  ;;; [AVDTP]
  ;;; Possible values: 'basic, 'ertm
  (session-mode bluetooth-configuration-session-mode (default 'basic))

  ;;; Possible values: 'basic, 'streaming
  (stream-mode bluetooth-configuration-stream-mode (default 'basic))

  ;;; [Policy]
  (reconnect-uuids bluetooth-configuration-reconnect-uuids (default '()))
  (reconnect-attempts bluetooth-configuration-reconnect-attempts (default 7))
  (reconnect-intervals bluetooth-configuration-reconnect-intervals
                       (default (list 1 2 4 8 16 32 64)))
  (auto-enable? bluetooth-configuration-auto-enable? (default #f))
  (resume-delay bluetooth-configuration-resume-delay (default 2))

  ;;; [AdvMon]
  ;;; Po