path: root/gnu/home/services/desktop.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2022-2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2022 ( <paren@disroot.org>
;;; Copyright © 2023 conses <contact@conses.eu>
;;; Copyright © 2023 Janneke Nieuwenhuizen <janneke@gnu.org>
;;;
;;; 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 home services desktop)
  #:use-module (gnu home services)
  #:use-module (gnu home services shepherd)
  #:use-module (gnu services configuration)
  #:use-module (gnu services xorg)
  #:autoload   (gnu packages glib)    (dbus)
  #:autoload   (gnu packages xdisorg) (redshift unclutter)
  #:autoload   (gnu packages xorg) (setxkbmap xmodmap)
  #:use-module (guix records)
  #:use-module (guix gexp)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:export (home-x11-service-type

            home-redshift-configuration
            home-redshift-configuration?
            home-redshift-service-type

            home-dbus-configuration
            home-dbus-service-type

            home-unclutter-configuration
            home-unclutter-service-type

            home-xmodmap-configuration
            home-xmodmap-service-type

            home-startx-command-service-type))


;;;
;;; Waiting for X11.
;;;

(define (x11-shepherd-service delay)
  (list (shepherd-service
         (provision '(x11-display))
         (modules '((ice-9 ftw)
                    (ice-9 match)
                    (srfi srfi-1)))
         (start
          #~(lambda* (#:optional (display (getenv "DISPLAY")))
              (define x11-directory
                "/tmp/.X11-unix")

              (define (find-display delay)
                ;; Wait for an accessible socket to show up in X11-DIRECTORY,
                ;; up to DELAY seconds.
                (let loop ((attempts delay))
                  (define socket
                    (find (match-lambda
                            ((or "." "..") #f)
                            (name
                             (let ((name (in-vicinity x11-directory
                                                      name)))
                               (access? name O_RDWR))))
                          (or (scandir x11-directory) '())))

                  (if (and socket (string-prefix? "X" socket))
                      (let ((display (string-append
                                      ":" (string-drop socket 1))))
                        (format #t "X11 display server found at ~s.~%"
                                display)
                        display)
                      (if (zero? attempts)
                          (begin
                            (format (current-error-port)
                                    "X11 display server did not show up; \
giving up.\n")
                            #f)
                          (begin
                            (sleep 1)
                            (loop (- attempts 1)))))))

              (let ((display (or display (find-display #$delay))))
                (when display
                  ;; Note: 'make-forkexec-constructor' calls take their
                  ;; default #:environment-variables value before this service
                  ;; is started and are thus unaffected by the 'setenv' call
                  ;; below.  Users of this service have to explicitly query
                  ;; its value.
                  (setenv "DISPLAY" display))
                display)))
         (stop #~(lambda (_)
                   (unsetenv "DISPLAY")
                   #f))
         (respawn? #f))))

(define home-x11-service-type
  (service-type
   (name 'home-x11-display)
   (extensions (list (service-extension home-shepherd-service-type
                                        x11-shepherd-service)))
   (default-value 10)
   (description
    "Create a @code{x11-display} Shepherd service that waits for the X
Window (or ``X11'') graphical display server to be up and running, up to a
configurable delay, and sets the @code{DISPLAY} environment variable of
@command{shepherd} itself accordingly.  If no accessible X11 server shows up
during that time, the @code{x11-display} service is marked as failing to
start.")))


;;;
;;; Redshift.
;;;

(define (serialize-integer field value)
  (string-append (match field
                   ('daytime-temperature "temp-day")
                   ('nighttime-temperature "temp-night")
                   ('daytime-brightness "brightness-day")
                   ('nighttime-brightness "brightness-night")
                   ('latitude "lat")
                   ('longitude "lon")
                   (_ (symbol->string field)))
                 "=" (number->string value) "\n"))

(define (serialize-symbol field value)
  (string-append (symbol->string field)
                 "=" (symbol->string value) "\n"))

(define (serialize-string field value)
  (string-append (symbol->string field)
                 "=" value "\n"))

(define serialize-inexact-number serialize-integer)

(define (inexact-number? n)
  (and (number? n) (inexact? n)))
(define-maybe inexact-number)
(define-maybe string)

(define (serialize-raw-configuration-string field value)
  value)
(define raw-configuration-string? string?)

(define-configuration home-redshift-configuration
  (redshift
   (file-like redshift)
   "Redshift package to use.")

  (location-provider
   (symbol 'geoclue2)
   "Geolocation provider---@code{'manual} or @code{'geoclue2}.

In the former case, you must also specify the @code{latitude} and
@code{longitude} fields so Redshift can determine daytime at your place.  In
the latter case, the Geoclue system service must be running; it will be
queried for location information.")
  (adjustment-method
   (symbol 'randr)
   "Color adjustment method.")

  ;; Default values from redshift(1).
  (daytime-temperature
   (integer 6500)
   "Daytime color temperature (kelvins).")
  (nighttime-temperature
   (integer 4500)
   "Nighttime color temperature (kelvins).")

  (daytime-brightness
   maybe-inexact-number
   "Daytime screen brightness, between 0.1 and 1.0.")
  (nighttime-brightness
   maybe-inexact-number
   "Nighttime screen brightness, between 0.1 and 1.0.")

  (latitude
   maybe-inexact-number
   "Latitude, when @code{location-provider} is @code{'manual}.")
  (longitude
   maybe-inexact-number
   "Longitude, when @code{location-provider} is @code{'manual}.")

  (dawn-time
   maybe-string
   "Custom time for the transition from night to day in the
morning---@code{\"HH:MM\"} format.  When specified, solar elevation is not
used to determine the daytime/nighttime period.")
  (dusk-time
   maybe-string
   "Likewise, custom time for the transition from day to night in the
evening.")

  (extra-content
   (raw-configuration-string "")
   "Extra content appended as-is to the Redshift configuration file.  Run
@command{man redshift} for more information about the configuration file
format."))

(define (serialize-redshift-configuration config)
  (define location-fields
    '(latitude longitude))

  (define (location-field? field)
    (memq (configuration-field-name field) location-fields))

  (define (secondary-field? field)
    (or (location-field? field)
        (memq (configuration-field-name field)
              '(redshift extra-content))))

  #~(string-append
     "[redshift]\n"
     #$(serialize-configuration config
                                (remove secondary-field?
                                        home-redshift-configuration-fields))

     #$(home-redshift-configuration-extra-content config)

     "\n[manual]\n"
     #$(serialize-configuration config
                                (filter location-field?
                                        home-redshift-configuration-fields))))

(define (redshift-shepherd-service config)
  (define config-file
    (computed-file "redshift.conf"
                   #~(call-with-output-file #$output
                       (lambda (port)
                         (display #$(serialize-redshift-configuration config)
                                  port)))))

  (list (shepherd-service
         (documentation "Redshift program.")
         (provision '(redshift))

         ;; Depend on 'x11-display', which sets 'DISPLAY' if an X11 server is
         ;; available, and fails to start otherwise.
         (requirement '(x11-display))

         (modules '((srfi srfi-1)
                    (srfi srfi-26)))
         (start #~(lambda _
                    (fork+exec-command
                     (list #$(file-append
                              (home-redshift-configuration-redshift config)
                              "/bin/redshift")
                           "-c" #$config-file)

                     ;; Inherit the 'DISPLAY' variable set by 'x11-display'.
                     #:environment-variables
                     (cons (string-append "DISPLAY=" (getenv "DISPLAY"))
                           (remove (cut string-prefix? "DISPLAY=" <>)
                                   (default-environment-variables))))))
         (stop #~(make-kill-destructor))
         (actions (list (shepherd-configuration-action config-file))))))

(define home-redshift-service-type
  (service-type
   (name 'home-redshift)
   (extensions (list (service-extension home-shepherd-service-type
                                        redshift-shepherd-service)
                     ;; Ensure 'home-x11-service-type' is instantiated so we
                     ;; can depend on the Shepherd 'x11-display' service.
                     (service-extension home-x11-service-type
                                        (const #t))))
   (default-value (home-redshift-configuration))
   (description
    "Run Redshift, a program that adjusts the color temperature of display
according to time of day.")))


;;;
;;; D-Bus.
;;;

(define-record-type* <home-dbus-configuration>
  home-dbus-configuration make-home-dbus-configuration
  home-dbus-configuration?
  (dbus home-dbus-dbus                  ;file-like
        (default dbus)))

(define (home-dbus-shepherd-services config)
  (list (shepherd-service
         (documentation "Run the D-Bus daemon in session-specific mode.")
         (provision '(dbus))
         (start #~(make-forkexec-constructor
                   (list #$(file-append (home-dbus-dbus config)
                                        "/bin/dbus-daemon")
                         "--nofork" "--session"
                         (format #f "--address=unix:path=~a/bus"
                                 (or (getenv "XDG_RUNTIME_DIR")
                                     (format #f "/run/user/~a"
                                             (getuid)))))
                   #:environment-variables
                   (cons "DBUS_VERBOSE=1"
                         (default-environment-variables))
                   #:log-file
                   (format #f "~a/log/dbus.log"
                           (or (getenv "XDG_STATE_HOME")
                               (format #f "~a/.local/state"
                                       (getenv "HOME"))))))
         (stop #~(make-kill-destructor)))))

(define (home-dbus-environment-variables config)
  '(("DBUS_SESSION_BUS_ADDRESS"
     . "unix:path=${XDG_RUNTIME_DIR:-/run/user/$UID}/bus")))

(define home-dbus-service-type
  (service-type
   (name 'home-dbus)
   (extensions
    (list (service-extension home-shepherd-service-type
                             home-dbus-shepherd-services)
          (service-extension home-environment-variables-service-type
                             home-dbus-environment-variables)))
   (default-value (home-dbus-configuration))
   (description
    "Run the session-specific D-Bus inter-process message bus.")))


;;;
;;; Unclutter.
;;;

(define-configuration/no-serialization home-unclutter-configuration
  (unclutter
   (file-like unclutter)
   "The @code{unclutter} package to use.")
  (idle-timeout
   (integer 5)
   "Timeout in seconds after which to hide the cursor."))

(define (home-unclutter-shepherd-service config)
  (list
   (shepherd-service
    (provision '(unclutter))
    ;; Depend on 'x11-display', which sets 'DISPLAY' if an X11 server is
    ;; available, and fails to start otherwise.
    (requirement '(x11-display))
    (modules '((srfi srfi-1)
               (srfi srfi-26)))
    (one-shot? #t)
    (start #~(lambda _
               (fork+exec-command
                (list
                 #$(file-append
                    (home-unclutter-configuration-unclutter config)
                    "/bin/unclutter")
                 "-idle"
                 (number->string
                  #$(home-unclutter-configuration-idle-timeout config)))
                ;; Inherit the 'DISPLAY' variable set by 'x11-display'.
                #:environment-variables
                (cons (string-append "DISPLAY=" (getenv "DISPLAY"))
                      (remove (cut string-prefix? "DISPLAY=" <>)
                              (default-environment-variables)))
                #:log-file (string-append
                            (or (getenv "XDG_STATE_HOME")
                                (format #f "~a/.local/state"
                                        (getenv "HOME")))
                            "/log/unclutter.log")))))))

(define home-unclutter-service-type
  (service-type
   (name 'home-unclutter)
   (extensions
    (list
     (service-extension home-shepherd-service-type
                        home-unclutter-shepherd-service)))
   (default-value (home-unclutter-configuration))
   (description "Run the @code{unclutter} daemon, which, on systems using the
Xorg graphical display server, automatically hides the cursor after a
user-defined timeout has expired.")))


;;;
;;; Xmodmap.
;;;

(define-configuration/no-serialization home-xmodmap-configuration
  (xmodmap
   (file-like xmodmap)
   "The @code{xmodmap} package to use.")
  (key-map
   (list '())
   "List of expressions to be read by @code{xmodmap} on service startup."))

(define (serialize-xmodmap-configuration field-name val)
  (define serialize-field
    (match-lambda
      ((key . value)
       (format #f "~a = ~a" key value))
      (e e)))

  #~(string-append
     #$@(interpose (map serialize-field val) "\n" 'suffix)))

(define (xmodmap-shepherd-service config)
  (define config-file
    (mixed-text-file
     "config"
     (serialize-xmodmap-configuration
      #f (home-xmodmap-configuration-key-map config))))

  (list
   (shepherd-service
    (provision '(xmodmap))
    (start #~(make-system-constructor
              (string-join
               (list #$(file-append
                        (home-xmodmap-configuration-xmodmap config)
                        "/bin/xmodmap")
                     #$config-file))))
    (stop #~(make-system-constructor
             #$(file-append setxkbmap "/bin/setxkbmap")))
    (documentation "On startup, run @code{xmodmap} and read the expressions in
the configuration file.  On stop, reset all the mappings back to the
defaults."))))

(define home-xmodmap-service-type
  (service-type
   (name 'home-xmodmap)
   (extensions
    (list
     (service-extension home-shepherd-service-type
                        xmodmap-shepherd-service)))
   (default-value (home-xmodmap-configuration))
   (description "Run the @code{xmodmap} utility to modify keymaps and pointer
buttons under the Xorg display server via user-defined expressions.")))


(define home-startx-command-service-type
  (service-type
   (inherit (system->home-service-type startx-command-service-type))
   (default-value (for-home (xorg-configuration)))))

(define-service-type-mapping
  startx-command-service-type => home-startx-command-service-type)