gnu/services/desktop.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2014, 2015, 2016, 2017 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 Maxim Cournoyer <maxim.cournoyer@gmail.com>
   7 ;;; Copyright © 2017 ng0 <ng0@infotropique.org>
   8 ;;;
   9 ;;; This file is part of GNU Guix.
  10 ;;;
  11 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  12 ;;; under the terms of the GNU General Public License as published by
  13 ;;; the Free Software Foundation; either version 3 of the License, or (at
  14 ;;; your option) any later version.
  15 ;;;
  16 ;;; GNU Guix is distributed in the hope that it will be useful, but
  17 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;;; GNU General Public License for more details.
  20 ;;;
  21 ;;; You should have received a copy of the GNU General Public License
  22 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 (define-module (gnu services desktop)
  25   #:use-module (gnu services)
  26   #:use-module (gnu services shepherd)
  27   #:use-module (gnu services base)
  28   #:use-module (gnu services dbus)
  29   #:use-module (gnu services avahi)
  30   #:use-module (gnu services xorg)
  31   #:use-module (gnu services networking)
  32   #:use-module ((gnu system file-systems)
  33                 #:select (%elogind-file-systems))
  34   #:use-module (gnu system shadow)
  35   #:use-module (gnu system pam)
  36   #:use-module (gnu packages glib)
  37   #:use-module (gnu packages admin)
  38   #:use-module (gnu packages freedesktop)
  39   #:use-module (gnu packages gnome)
  40   #:use-module (gnu packages xfce)
  41   #:use-module (gnu packages avahi)
  42   #:use-module (gnu packages xdisorg)
  43   #:use-module (gnu packages suckless)
  44   #:use-module (gnu packages linux)
  45   #:use-module (gnu packages libusb)
  46   #:use-module (gnu packages mate)
  47   #:use-module (guix records)
  48   #:use-module (guix packages)
  49   #:use-module (guix store)
  50   #:use-module (guix gexp)
  51   #:use-module (srfi srfi-1)
  52   #:use-module (ice-9 match)
  53   #:export (upower-configuration
  54             upower-configuration?
  55             upower-service
  56             upower-service-type
  57
  58             udisks-configuration
  59             udisks-configuration?
  60             udisks-service
  61             udisks-service-type
  62
  63             colord-service
  64
  65             geoclue-application
  66             geoclue-configuration
  67             geoclue-configuration?
  68             %standard-geoclue-applications
  69             geoclue-service
  70             geoclue-service-type
  71
  72             bluetooth-service
  73
  74             elogind-configuration
  75             elogind-configuration?
  76             elogind-service
  77             elogind-service-type
  78
  79             accountsservice-service-type
  80             accountsservice-service
  81
  82             gnome-desktop-configuration
  83             gnome-desktop-configuration?
  84             gnome-desktop-service
  85             gnome-desktop-service-type
  86
  87             mate-desktop-configuration
  88             mate-desktop-configuration?
  89             mate-desktop-service
  90             mate-desktop-service-type
  91
  92             xfce-desktop-configuration
  93             xfce-desktop-configuration?
  94             xfce-desktop-service
  95             xfce-desktop-service-type
  96
  97             %desktop-services))
  98
  99 ;;; Commentary:
 100 ;;;
 101 ;;; This module contains service definitions for a "desktop" environment.
 102 ;;;
 103 ;;; Code:
 104
 105 \f
 106 ;;;
 107 ;;; Helpers.
 108 ;;;
 109
 110 (define (bool value)
 111   (if value "true\n" "false\n"))
 112
 113 (define (package-direct-input-selector input)
 114   (lambda (package)
 115     (match (assoc-ref (package-direct-inputs package) input)
 116       ((package . _) package))))
 117
 118
 119 (define (wrapped-dbus-service service program variable value)
 120   "Return a wrapper for @var{service}, a package containing a D-Bus service,
 121 where @var{program} is wrapped such that environment variable @var{variable}
 122 is set to @var{value} when the bus daemon launches it."
 123   (define wrapper
 124     (program-file (string-append (package-name service) "-program-wrapper")
 125                   #~(begin
 126                       (setenv #$variable #$value)
 127                       (apply execl (string-append #$service "/" #$program)
 128                              (string-append #$service "/" #$program)
 129                              (cdr (command-line))))))
 130
 131   (define build
 132     (with-imported-modules '((guix build utils))
 133       #~(begin
 134           (use-modules (guix build utils))
 135
 136           (define service-directory
 137             "/share/dbus-1/system-services")
 138
 139           (mkdir-p (dirname (string-append #$output
 140                                            service-directory)))
 141           (copy-recursively (string-append #$service
 142                                            service-directory)
 143                             (string-append #$output
 144                                            service-directory))
 145           (symlink (string-append #$service "/etc") ;for etc/dbus-1
 146                    (string-append #$output "/etc"))
 147
 148           (for-each (lambda (file)
 149                       (substitute* file
 150                         (("Exec[[:blank:]]*=[[:blank:]]*([[:graph:]]+)(.*)$"
 151                           _ original-program arguments)
 152                          (string-append "Exec=" #$wrapper arguments
 153                                         "\n"))))
 154                     (find-files #$output "\\.service$")))))
 155
 156   (computed-file (string-append (package-name service) "-wrapper")
 157                  build))
 158
 159 \f
 160 ;;;
 161 ;;; Upower D-Bus service.
 162 ;;;
 163
 164 ;; TODO: Export.
 165 (define-record-type* <upower-configuration>
 166   upower-configuration make-upower-configuration
 167   upower-configuration?
 168   (upower        upower-configuration-upower
 169                  (default upower))
 170   (watts-up-pro? upower-configuration-watts-up-pro?)
 171   (poll-batteries? upower-configuration-poll-batteries?)
 172   (ignore-lid? upower-configuration-ignore-lid?)
 173   (use-percentage-for-policy? upower-configuration-use-percentage-for-policy?)
 174   (percentage-low upower-configuration-percentage-low)
 175   (percentage-critical upower-configuration-percentage-critical)
 176   (percentage-action upower-configuration-percentage-action)
 177   (time-low upower-configuration-time-low)
 178   (time-critical upower-configuration-time-critical)
 179   (time-action upower-configuration-time-action)
 180   (critical-power-action upower-configuration-critical-power-action))
 181
 182 (define* upower-configuration-file
 183   ;; Return an upower-daemon configuration file.
 184   (match-lambda
 185     (($ <upower-configuration> upower
 186         watts-up-pro? poll-batteries? ignore-lid? use-percentage-for-policy?
 187         percentage-low percentage-critical percentage-action time-low
 188         time-critical time-action critical-power-action)
 189      (plain-file "UPower.conf"
 190                  (string-append
 191                   "[UPower]\n"
 192                   "EnableWattsUpPro=" (bool watts-up-pro?)
 193                   "NoPollBatteries=" (bool (not poll-batteries?))
 194                   "IgnoreLid=" (bool ignore-lid?)
 195                   "UsePercentageForPolicy=" (bool use-percentage-for-policy?)
 196                   "PercentageLow=" (number->string percentage-low) "\n"
 197                   "PercentageCritical=" (number->string percentage-critical) "\n"
 198                   "PercentageAction=" (number->string percentage-action) "\n"
 199                   "TimeLow=" (number->string time-low) "\n"
 200                   "TimeCritical=" (number->string time-critical) "\n"
 201                   "TimeAction=" (number->string time-action) "\n"
 202                   "CriticalPowerAction=" (match critical-power-action
 203                                            ('hybrid-sleep "HybridSleep")
 204                                            ('hibernate "Hibernate")
 205                                            ('power-off "PowerOff"))
 206                   "\n")))))
 207
 208 (define %upower-activation
 209   #~(begin
 210       (use-modules (guix build utils))
 211       (mkdir-p "/var/lib/upower")))
 212
 213 (define (upower-dbus-service config)
 214   (list (wrapped-dbus-service (upower-configuration-upower config)
 215                               "libexec/upowerd"
 216                               "UPOWER_CONF_FILE_NAME"
 217                               (upower-configuration-file config))))
 218
 219 (define (upower-shepherd-service config)
 220   "Return a shepherd service for UPower with CONFIG."
 221   (let ((upower (upower-configuration-upower config))
 222         (config (upower-configuration-file config)))
 223     (list (shepherd-service
 224            (documentation "Run the UPower power and battery monitor.")
 225            (provision '(upower-daemon))
 226            (requirement '(dbus-system udev))
 227
 228            (start #~(make-forkexec-constructor
 229                      (list (string-append #$upower "/libexec/upowerd"))
 230                      #:environment-variables
 231                      (list (string-append "UPOWER_CONF_FILE_NAME="
 232                                           #$config))))
 233            (stop #~(make-kill-destructor))))))
 234
 235 (define upower-service-type
 236   (let ((upower-package (compose list upower-configuration-upower)))
 237     (service-type (name 'upower)
 238                   (extensions
 239                    (list (service-extension dbus-root-service-type
 240                                             upower-dbus-service)
 241                          (service-extension shepherd-root-service-type
 242                                             upower-shepherd-service)
 243                          (service-extension activation-service-type
 244                                             (const %upower-activation))
 245                          (service-extension udev-service-type
 246                                             upower-package)
 247
 248                          ;; Make the 'upower' command visible.
 249                          (service-extension profile-service-type
 250                                             upower-package))))))
 251
 252 (define* (upower-service #:key (upower upower)
 253                          (watts-up-pro? #f)
 254                          (poll-batteries? #t)
 255                          (ignore-lid? #f)
 256                          (use-percentage-for-policy? #f)
 257                          (percentage-low 10)
 258                          (percentage-critical 3)
 259                          (percentage-action 2)
 260                          (time-low 1200)
 261                          (time-critical 300)
 262                          (time-action 120)
 263                          (critical-power-action 'hybrid-sleep))
 264   "Return a service that runs @uref{http://upower.freedesktop.org/,
 265 @command{upowerd}}, a system-wide monitor for power consumption and battery
 266 levels, with the given configuration settings.  It implements the
 267 @code{org.freedesktop.UPower} D-Bus interface, and is notably used by GNOME."
 268   (let ((config (upower-configuration
 269                  (watts-up-pro? watts-up-pro?)
 270                  (poll-batteries? poll-batteries?)
 271                  (ignore-lid? ignore-lid?)
 272                  (use-percentage-for-policy? use-percentage-for-policy?)
 273                  (percentage-low percentage-low)
 274                  (percentage-critical percentage-critical)
 275                  (percentage-action percentage-action)
 276                  (time-low time-low)
 277                  (time-critical time-critical)
 278                  (time-action time-action)
 279                  (critical-power-action critical-power-action))))
 280     (service upower-service-type config)))
 281
 282 \f
 283 ;;;
 284 ;;; GeoClue D-Bus service.
 285 ;;;
 286
 287 ;; TODO: Export.
 288 (define-record-type* <geoclue-configuration>
 289   geoclue-configuration make-geoclue-configuration
 290   geoclue-configuration?
 291   (geoclue geoclue-configuration-geoclue
 292            (default geoclue))
 293   (whitelist geoclue-configuration-whitelist)
 294   (wifi-geolocation-url geoclue-configuration-wifi-geolocation-url)
 295   (submit-data? geoclue-configuration-submit-data?)
 296   (wifi-submission-url geoclue-configuration-wifi-submission-url)
 297   (submission-nick geoclue-configuration-submission-nick)
 298   (applications geoclue-configuration-applications))
 299
 300 (define* (geoclue-application name #:key (allowed? #t) system? (users '()))
 301   "Configure default GeoClue access permissions for an application.  NAME is
 302 the Desktop ID of the application, without the .desktop part.  If ALLOWED? is
 303 true, the application will have access to location information by default.
 304 The boolean SYSTEM? value indicates that an application is a system component
 305 or not.  Finally USERS is a list of UIDs of all users for which this
 306 application is allowed location info access.  An empty users list means all
 307 users are allowed."
 308   (string-append
 309    "[" name "]\n"
 310    "allowed=" (bool allowed?)
 311    "system=" (bool system?)
 312    "users=" (string-join users ";") "\n"))
 313
 314 (define %standard-geoclue-applications
 315   (list (geoclue-application "gnome-datetime-panel" #:system? #t)
 316         (geoclue-application "epiphany" #:system? #f)
 317         (geoclue-application "firefox" #:system? #f)))
 318
 319 (define* (geoclue-configuration-file config)
 320   "Return a geoclue configuration file."
 321   (plain-file "geoclue.conf"
 322               (string-append
 323                "[agent]\n"
 324                "whitelist="
 325                (string-join (geoclue-configuration-whitelist config)
 326                             ";") "\n"
 327                "[wifi]\n"
 328                "url=" (geoclue-configuration-wifi-geolocation-url config) "\n"
 329                "submit-data=" (bool (geoclue-configuration-submit-data? config))
 330                "submission-url="
 331                (geoclue-configuration-wifi-submission-url config) "\n"
 332                "submission-nick="
 333                (geoclue-configuration-submission-nick config)
 334                "\n"
 335                (string-join (geoclue-configuration-applications config)
 336                             "\n"))))
 337
 338 (define (geoclue-dbus-service config)
 339   (list (wrapped-dbus-service (geoclue-configuration-geoclue config)
 340                               "libexec/geoclue"
 341                               "GEOCLUE_CONFIG_FILE"
 342                               (geoclue-configuration-file config))))
 343
 344 (define %geoclue-accounts
 345   (list (user-group (name "geoclue") (system? #t))
 346         (user-account
 347          (name "geoclue")
 348          (group "geoclue")
 349          (system? #t)
 350          (comment "GeoClue daemon user")
 351          (home-directory "/var/empty")
 352          (shell "/run/current-system/profile/sbin/nologin"))))
 353
 354 (define geoclue-service-type
 355   (service-type (name 'geoclue)
 356                 (extensions
 357                  (list (service-extension dbus-root-service-type
 358                                           geoclue-dbus-service)
 359                        (service-extension account-service-type
 360                                           (const %geoclue-accounts))))))
 361
 362 (define* (geoclue-service #:key (geoclue geoclue)
 363                           (whitelist '())
 364                           (wifi-geolocation-url
 365                            ;; Mozilla geolocation service:
 366                            "https://location.services.mozilla.com/v1/geolocate?key=geoclue")
 367                           (submit-data? #f)
 368                           (wifi-submission-url
 369                            "https://location.services.mozilla.com/v1/submit?key=geoclue")
 370                           (submission-nick "geoclue")
 371                           (applications %standard-geoclue-applications))
 372   "Return a service that runs the @command{geoclue} location service.  This
 373 service provides a D-Bus interface to allow applications to request access to
 374 a user's physical location, and optionally to add information to online
 375 location databases.  By default, only the GNOME date-time panel and the Icecat
 376 and Epiphany web browsers are able to ask for the user's location, and in the
 377 case of Icecat and Epiphany, both will ask the user for permission first.  See
 378 @uref{https://wiki.freedesktop.org/www/Software/GeoClue/, the geoclue web
 379 site} for more information."
 380   (service geoclue-service-type
 381            (geoclue-configuration
 382             (geoclue geoclue)
 383             (whitelist whitelist)
 384             (wifi-geolocation-url wifi-geolocation-url)
 385             (submit-data? submit-data?)
 386             (wifi-submission-url wifi-submission-url)
 387             (submission-nick submission-nick)
 388             (applications applications))))
 389
 390 \f
 391 ;;;
 392 ;;; Bluetooth.
 393 ;;;
 394
 395 (define-record-type* <bluetooth-configuration>
 396   bluetooth-configuration make-bluetooth-configuration
 397   bluetooth-configuration?
 398   (bluez bluetooth-configuration-bluez (default bluez))
 399   (auto-enable? bluetooth-configuration-auto-enable? (default #f)))
 400
 401 (define (bluetooth-configuration-file config)
 402   "Return a configuration file for the systemd bluetooth service, as a string."
 403   (string-append
 404    "[Policy]\n"
 405    "AutoEnable=" (bool (bluetooth-configuration-auto-enable?
 406                         config))))
 407
 408 (define (bluetooth-directory config)
 409   (computed-file "etc-bluetooth"
 410                  #~(begin
 411                      (mkdir #$output)
 412                      (chdir #$output)
 413                      (call-with-output-file "main.conf"
 414                        (lambda (port)
 415                          (display #$(bluetooth-configuration-file config)
 416                                   port))))))
 417
 418 (define (bluetooth-shepherd-service config)
 419   "Return a shepherd service for @command{bluetoothd}."
 420   (shepherd-service
 421    (provision '(bluetooth))
 422    (requirement '(dbus-system udev))
 423    (documentation "Run the bluetoothd daemon.")
 424    (start #~(make-forkexec-constructor
 425              (string-append #$(bluetooth-configuration-bluez config)
 426                             "/libexec/bluetooth/bluetoothd")))
 427    (stop #~(make-kill-destructor))))
 428
 429 (define bluetooth-service-type
 430   (service-type
 431    (name 'bluetooth)
 432    (extensions
 433     (list (service-extension dbus-root-service-type
 434                              (compose list bluetooth-configuration-bluez))
 435           (service-extension udev-service-type
 436                              (compose list bluetooth-configuration-bluez))
 437           (service-extension etc-service-type
 438                              (lambda (config)
 439                                `(("bluetooth"
 440                                   ,(bluetooth-directory config)))))
 441           (service-extension shepherd-root-service-type
 442                              (compose list bluetooth-shepherd-service))))))
 443
 444 (define* (bluetooth-service #:key (bluez bluez) (auto-enable? #f))
 445   "Return a service that runs the @command{bluetoothd} daemon, which manages
 446 all the Bluetooth devices and provides a number of D-Bus interfaces.  When
 447 AUTO-ENABLE? is true, the bluetooth controller is powered automatically at
 448 boot.
 449
 450 Users need to be in the @code{lp} group to access the D-Bus service.
 451 "
 452   (service bluetooth-service-type
 453            (bluetooth-configuration
 454             (bluez bluez)
 455             (auto-enable? auto-enable?))))
 456
 457 \f
 458 ;;;
 459 ;;; Colord D-Bus service.
 460 ;;;
 461
 462 (define %colord-activation
 463   #~(begin
 464       (use-modules (guix build utils))
 465       (mkdir-p "/var/lib/colord")
 466       (let ((user (getpwnam "colord")))
 467         (chown "/var/lib/colord"
 468                (passwd:uid user) (passwd:gid user)))))
 469
 470 (define %colord-accounts
 471   (list (user-group (name "colord") (system? #t))
 472         (user-account
 473          (name "colord")
 474          (group "colord")
 475          (system? #t)
 476          (comment "colord daemon user")
 477          (home-directory "/var/empty")
 478          (shell (file-append shadow "/sbin/nologin")))))
 479
 480 (define colord-service-type
 481   (service-type (name 'colord)
 482                 (extensions
 483                  (list (service-extension account-service-type
 484                                           (const %colord-accounts))
 485                        (service-extension activation-service-type
 486                                           (const %colord-activation))
 487
 488                        ;; Colord is a D-Bus service that dbus-daemon can
 489                        ;; activate.
 490                        (service-extension dbus-root-service-type list)
 491
 492                        ;; Colord provides "color device" rules for udev.
 493                        (service-extension udev-service-type list)
 494
 495                        ;; It provides polkit "actions".
 496                        (service-extension polkit-service-type list)))))
 497
 498 (define* (colord-service #:key (colord colord))
 499   "Return a service that runs @command{colord}, a system service with a D-Bus
 500 interface to manage the color profiles of input and output devices such as
 501 screens and scanners.  It is notably used by the GNOME Color Manager graphical
 502 tool.  See @uref{http://www.freedesktop.org/software/colord/, the colord web
 503 site} for more information."
 504   (service colord-service-type colord))
 505
 506 \f
 507 ;;;
 508 ;;; UDisks.
 509 ;;;
 510
 511 (define-record-type* <udisks-configuration>
 512   udisks-configuration make-udisks-configuration
 513   udisks-configuration?
 514   (udisks   udisks-configuration-udisks
 515             (default udisks)))
 516
 517 (define %udisks-activation
 518   (with-imported-modules '((guix build utils))
 519     #~(begin
 520         (use-modules (guix build utils))
 521
 522         (let ((run-dir "/var/run/udisks2"))
 523           (mkdir-p run-dir)
 524           (chmod run-dir #o700)))))
 525
 526 (define udisks-service-type
 527   (let ((udisks-package (lambda (config)
 528                           (list (udisks-configuration-udisks config)))))
 529     (service-type (name 'udisks)
 530                   (extensions
 531                    (list (service-extension polkit-service-type
 532                                             udisks-package)
 533                          (service-extension dbus-root-service-type
 534                                             udisks-package)
 535                          (service-extension udev-service-type
 536                                             udisks-package)
 537                          (service-extension activation-service-type
 538                                             (const %udisks-activation))
 539
 540                          ;; Profile 'udisksctl' & co. in the system profile.
 541                          (service-extension profile-service-type
 542                                             udisks-package))))))
 543
 544 (define* (udisks-service #:key (udisks udisks))
 545   "Return a service for @uref{http://udisks.freedesktop.org/docs/latest/,
 546 UDisks}, a @dfn{disk management} daemon that provides user interfaces with
 547 notifications and ways to mount/unmount disks.  Programs that talk to UDisks
 548 include the @command{udisksctl} command, part of UDisks, and GNOME Disks."
 549   (service udisks-service-type
 550            (udisks-configuration (udisks udisks))))
 551
 552 \f
 553 ;;;
 554 ;;; Elogind login and seat management service.
 555 ;;;
 556
 557 (define-record-type* <elogind-configuration> elogind-configuration
 558   make-elogind-configuration
 559   elogind-configuration
 560   (elogind                         elogind-package
 561                                    (default elogind))
 562   (kill-user-processes?            elogind-kill-user-processes?
 563                                    (default #f))
 564   (kill-only-users                 elogind-kill-only-users
 565                                    (default '()))
 566   (kill-exclude-users              elogind-kill-exclude-users
 567                                    (default '("root")))
 568   (inhibit-delay-max-seconds       elogind-inhibit-delay-max-seconds
 569                                    (default 5))
 570   (handle-power-key                elogind-handle-power-key
 571                                    (default 'poweroff))
 572   (handle-suspend-key              elogind-handle-suspend-key
 573                                    (default 'suspend))
 574   (handle-hibernate-key            elogind-handle-hibernate-key
 575                                    ;; (default 'hibernate)
 576                                    ;; XXX Ignore it for now, since we don't
 577                                    ;; yet handle resume-from-hibernation in
 578                                    ;; our initrd.
 579                                    (default 'ignore))
 580   (handle-lid-switch               elogind-handle-lid-switch
 581                                    (default 'suspend))
 582   (handle-lid-switch-docked        elogind-handle-lid-switch-docked
 583                                    (default 'ignore))
 584   (power-key-ignore-inhibited?     elogind-power-key-ignore-inhibited?
 585                                    (default #f))
 586   (suspend-key-ignore-inhibited?   elogind-suspend-key-ignore-inhibited?
 587                                    (default #f))
 588   (hibernate-key-ignore-inhibited? elogind-hibernate-key-ignore-inhibited?
 589                                    (default #f))
 590   (lid-switch-ignore-inhibited?    elogind-lid-switch-ignore-inhibited?
 591                                    (default #t))
 592   (holdoff-timeout-seconds         elogind-holdoff-timeout-seconds
 593                                    (default 30))
 594   (idle-action                     elogind-idle-action
 595                                    (default 'ignore))
 596   (idle-action-seconds             elogind-idle-action-seconds
 597                                    (default (* 30 60)))
 598   (runtime-directory-size-percent  elogind-runtime-directory-size-percent
 599                                    (default 10))
 600   (runtime-directory-size          elogind-runtime-directory-size
 601                                    (default #f))
 602   (remove-ipc?                     elogind-remove-ipc?
 603                                    (default #t))
 604
 605   (suspend-state                   elogind-suspend-state
 606                                    (default '("mem" "standby" "freeze")))
 607   (suspend-mode                    elogind-suspend-mode
 608                                    (default '()))
 609   (hibernate-state                 elogind-hibernate-state
 610                                    (default '("disk")))
 611   (hibernate-mode                  elogind-hibernate-mode
 612                                    (default '("platform" "shutdown")))
 613   (hybrid-sleep-state              elogind-hybrid-sleep-state
 614                                    (default '("disk")))
 615   (hybrid-sleep-mode               elogind-hybrid-sleep-mode
 616                                    (default
 617                                      '("suspend" "platform" "shutdown"))))
 618
 619 (define (elogind-configuration-file config)
 620   (define (yesno x)
 621     (match x
 622       (#t "yes")
 623       (#f "no")
 624       (_ (error "expected #t or #f, instead got:" x))))
 625   (define char-set:user-name
 626     (string->char-set "abcdefghijklmnopqrstuvwxyz0123456789_-"))
 627   (define (valid-list? l pred)
 628     (and-map (lambda (x) (string-every pred x)) l))
 629   (define (user-name-list users)
 630     (unless (valid-list? users char-set:user-name)
 631       (error "invalid user list" users))
 632     (string-join users " "))
 633   (define (enum val allowed)
 634     (unless (memq val allowed)
 635       (error "invalid value" val allowed))
 636     (symbol->string val))
 637   (define (non-negative-integer x)
 638     (unless (exact-integer? x) (error "not an integer" x))
 639     (when (negative? x) (error "negative number not allowed" x))
 640     (number->string x))
 641   (define handle-actions
 642     '(ignore poweroff reboot halt kexec suspend hibernate hybrid-sleep lock))
 643   (define (handle-action x)
 644     (enum x handle-actions))
 645   (define (sleep-list tokens)
 646     (unless (valid-list? tokens char-set:user-name)
 647       (error "invalid sleep list" tokens))
 648     (string-join tokens " "))
 649   (define-syntax ini-file-clause
 650     (syntax-rules ()
 651       ((_ config (prop (parser getter)))
 652        (string-append prop "=" (parser (getter config)) "\n"))
 653       ((_ config str)
 654        (string-append str "\n"))))
 655   (define-syntax-rule (ini-file config file clause ...)
 656     (plain-file file (string-append (ini-file-clause config clause) ...)))
 657   (ini-file
 658    config "logind.conf"
 659    "[Login]"
 660    ("KillUserProcesses" (yesno elogind-kill-user-processes?))
 661    ("KillOnlyUsers" (user-name-list elogind-kill-only-users))
 662    ("KillExcludeUsers" (user-name-list elogind-kill-exclude-users))
 663    ("InhibitDelayMaxSecs" (non-negative-integer elogind-inhibit-delay-max-seconds))
 664    ("HandlePowerKey" (handle-action elogind-handle-power-key))
 665    ("HandleSuspendKey" (handle-action elogind-handle-suspend-key))
 666    ("HandleHibernateKey" (handle-action elogind-handle-hibernate-key))
 667    ("HandleLidSwitch" (handle-action elogind-handle-lid-switch))
 668    ("HandleLidSwitchDocked" (handle-action elogind-handle-lid-switch-docked))
 669    ("PowerKeyIgnoreInhibited" (yesno elogind-power-key-ignore-inhibited?))
 670    ("SuspendKeyIgnoreInhibited" (yesno elogind-suspend-key-ignore-inhibited?))
 671    ("HibernateKeyIgnoreInhibited" (yesno elogind-hibernate-key-ignore-inhibited?))
 672    ("LidSwitchIgnoreInhibited" (yesno elogind-lid-switch-ignore-inhibited?))
 673    ("HoldoffTimeoutSecs" (non-negative-integer elogind-holdoff-timeout-seconds))
 674    ("IdleAction" (handle-action elogind-idle-action))
 675    ("IdleActionSeconds" (non-negative-integer elogind-idle-action-seconds))
 676    ("RuntimeDirectorySize"
 677     (identity
 678      (lambda (config)
 679        (match (elogind-runtime-directory-size-percent config)
 680          (#f (non-negative-integer (elogind-runtime-directory-size config)))
 681          (percent (string-append (non-negative-integer percent) "%"))))))
 682    ("RemoveIpc" (yesno elogind-remove-ipc?))
 683    "[Sleep]"
 684    ("SuspendState" (sleep-list elogind-suspend-state))
 685    ("SuspendMode" (sleep-list elogind-suspend-mode))
 686    ("HibernateState" (sleep-list elogind-hibernate-state))
 687    ("HibernateMode" (sleep-list elogind-hibernate-mode))
 688    ("HybridSleepState" (sleep-list elogind-hybrid-sleep-state))
 689    ("HybridSleepMode" (sleep-list elogind-hybrid-sleep-mode))))
 690
 691 (define (elogind-dbus-service config)
 692   (list (wrapped-dbus-service (elogind-package config)
 693                               "libexec/elogind/elogind"
 694                               "ELOGIND_CONF_FILE"
 695                               (elogind-configuration-file config))))
 696
 697 (define (pam-extension-procedure config)
 698   "Return an extension for PAM-ROOT-SERVICE-TYPE that ensures that all the PAM
 699 services use 'pam_elogind.so', a module that allows elogind to keep track of
 700 logged-in users (run 'loginctl' to see elogind's world view of users and
 701 seats.)"
 702   (define pam-elogind
 703     (pam-entry
 704      (control "required")
 705      (module (file-append (elogind-package config)
 706                           "/lib/security/pam_elogind.so"))))
 707
 708   (list (lambda (pam)
 709           (pam-service
 710            (inherit pam)
 711            (session (cons pam-elogind (pam-service-session pam)))))))
 712
 713 (define (elogind-shepherd-service config)
 714   "Return a Shepherd service to start elogind according to @var{config}."
 715   (list (shepherd-service
 716          (requirement '(dbus-system))
 717          (provision '(elogind))
 718          (start #~(make-forkexec-constructor
 719                    (list #$(file-append (elogind-package config)
 720                                         "/libexec/elogind/elogind"))
 721                    #:environment-variables
 722                    (list (string-append "ELOGIND_CONF_FILE="
 723                                         #$(elogind-configuration-file
 724                                            config)))))
 725          (stop #~(make-kill-destructor)))))
 726
 727 (define elogind-service-type
 728   (service-type (name 'elogind)
 729                 (extensions
 730                  (list (service-extension dbus-root-service-type
 731                                           elogind-dbus-service)
 732                        (service-extension udev-service-type
 733                                           (compose list elogind-package))
 734                        (service-extension polkit-service-type
 735                                           (compose list elogind-package))
 736
 737                        ;; Start elogind from the Shepherd rather than waiting
 738                        ;; for bus activation.  This ensures that it can handle
 739                        ;; events like lid close, etc.
 740                        (service-extension shepherd-root-service-type
 741                                           elogind-shepherd-service)
 742
 743                        ;; Provide the 'loginctl' command.
 744                        (service-extension profile-service-type
 745                                           (compose list elogind-package))
 746
 747                        ;; Extend PAM with pam_elogind.so.
 748                        (service-extension pam-root-service-type
 749                                           pam-extension-procedure)
 750
 751                        ;; We need /run/user, /run/systemd, etc.
 752                        (service-extension file-system-service-type
 753                                           (const %elogind-file-systems))))
 754                 (default-value (elogind-configuration))))
 755
 756 (define* (elogind-service #:key (config (elogind-configuration)))
 757   "Return a service that runs the @command{elogind} login and seat management
 758 service.  The @command{elogind} service integrates with PAM to allow other
 759 system components to know the set of logged-in users as well as their session
 760 types (graphical, console, remote, etc.).  It can also clean up after users
 761 when they log out."
 762   (service elogind-service-type config))
 763
 764 \f
 765 ;;;
 766 ;;; AccountsService service.
 767 ;;;
 768
 769 (define %accountsservice-activation
 770   #~(begin
 771       (use-modules (guix build utils))
 772       (mkdir-p "/var/lib/AccountsService")))
 773
 774 (define accountsservice-service-type
 775   (service-type (name 'accountsservice)
 776                 (extensions
 777                  (list (service-extension activation-service-type
 778                                           (const %accountsservice-activation))
 779                        (service-extension dbus-root-service-type list)
 780                        (service-extension polkit-service-type list)))))
 781
 782 (define* (accountsservice-service #:key (accountsservice accountsservice))
 783   "Return a service that runs AccountsService, a system service that
 784 can list available accounts, change their passwords, and so on.
 785 AccountsService integrates with PolicyKit to enable unprivileged users to
 786 acquire the capability to modify their system configuration.
 787 @uref{https://www.freedesktop.org/wiki/Software/AccountsService/, the
 788 accountsservice web site} for more information."
 789   (service accountsservice-service-type accountsservice))
 790
 791 \f
 792 ;;;
 793 ;;; GNOME desktop service.
 794 ;;;
 795
 796 (define-record-type* <gnome-desktop-configuration> gnome-desktop-configuration
 797   make-gnome-desktop-configuration
 798   gnome-desktop-configuration
 799   (gnome-package gnome-package (default gnome)))
 800
 801 (define (gnome-polkit-settings config)
 802   "Return the list of GNOME dependencies that provide polkit actions and
 803 rules."
 804   (let ((gnome (gnome-package config)))
 805     (map (lambda (name)
 806            ((package-direct-input-selector name) gnome))
 807          '("gnome-settings-daemon"
 808            "gnome-control-center"
 809            "gnome-system-monitor"
 810            "gvfs"))))
 811
 812 (define gnome-desktop-service-type
 813   (service-type
 814    (name 'gnome-desktop)
 815    (extensions
 816     (list (service-extension polkit-service-type
 817                              gnome-polkit-settings)
 818           (service-extension profile-service-type
 819                              (compose list
 820                                       gnome-package))))))
 821
 822 (define* (gnome-desktop-service #:key (config (gnome-desktop-configuration)))
 823   "Return a service that adds the @code{gnome} package to the system profile,
 824 and extends polkit with the actions from @code{gnome-settings-daemon}."
 825   (service gnome-desktop-service-type config))
 826
 827 ;; MATE Desktop service.
 828 ;; TODO: Add mate-screensaver.
 829
 830 (define-record-type* <mate-desktop-configuration> mate-desktop-configuration
 831   make-mate-desktop-configuration
 832   mate-desktop-configuration
 833   (mate-package mate-package (default mate)))
 834
 835 (define mate-desktop-service-type
 836   (service-type
 837    (name 'mate-desktop)
 838    (extensions
 839     (list (service-extension polkit-service-type
 840                              (compose list
 841                                       (package-direct-input-selector
 842                                        "mate-settings-daemon")
 843                                       mate-package))
 844           (service-extension profile-service-type
 845                              (compose list
 846                                       mate-package))))))
 847
 848 (define* (mate-desktop-service #:key (config (mate-desktop-configuration)))
 849   "Return a service that adds the @code{mate} package to the system profile,
 850 and extends polkit with the actions from @code{mate-settings-daemon}."
 851   (service mate-desktop-service-type config))
 852
 853 \f
 854 ;;;
 855 ;;; XFCE desktop service.
 856 ;;;
 857
 858 (define-record-type* <xfce-desktop-configuration> xfce-desktop-configuration
 859   make-xfce-desktop-configuration
 860   xfce-desktop-configuration
 861   (xfce xfce-package (default xfce)))
 862
 863 (define xfce-desktop-service-type
 864   (service-type
 865    (name 'xfce-desktop)
 866    (extensions
 867     (list (service-extension polkit-service-type
 868                              (compose list
 869                                       (package-direct-input-selector
 870                                        "thunar")
 871                                       xfce-package))
 872           (service-extension profile-service-type
 873                              (compose list
 874                                       xfce-package))))))
 875
 876 (define* (xfce-desktop-service #:key (config (xfce-desktop-configuration)))
 877   "Return a service that adds the @code{xfce} package to the system profile,
 878 and extends polkit with the ability for @code{thunar} to manipulate the file
 879 system as root from within a user session, after the user has authenticated
 880 with the administrator's password."
 881   (service xfce-desktop-service-type config))
 882
 883 \f
 884 ;;;
 885 ;;; The default set of desktop services.
 886 ;;;
 887
 888 (define %desktop-services
 889   ;; List of services typically useful for a "desktop" use case.
 890   (cons* (service slim-service-type)
 891
 892          ;; Screen lockers are a pretty useful thing and these are small.
 893          (screen-locker-service slock)
 894          (screen-locker-service xlockmore "xlock")
 895
 896          ;; Add udev rules for MTP devices so that non-root users can access
 897          ;; them.
 898          (simple-service 'mtp udev-service-type (list libmtp))
 899
 900          ;; The D-Bus clique.
 901          (service network-manager-service-type)
 902          (service wpa-supplicant-service-type)    ;needed by NetworkManager
 903          (avahi-service)
 904          (udisks-service)
 905          (upower-service)
 906          (accountsservice-service)
 907          (colord-service)
 908          (geoclue-service)
 909          (polkit-service)
 910          (elogind-service)
 911          (dbus-service)
 912
 913          (ntp-service)
 914
 915          %base-services))
 916
 917 ;;; desktop.scm ends here