;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2022 ( <paren@disroot.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)
  #:autoload   (gnu packages glib)    (dbus)
  #:autoload   (gnu packages wm)      (mako)
  #:autoload   (gnu packages xdisorg) (redshift)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:export (home-redshift-configuration
            home-redshift-configuration?
            home-redshift-service-type

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

            home-mako-section
            %home-mako-default-section
            %home-mako-default-grouped-section
            home-mako-configuration
            home-mako-service-type))

\f
;;;
;;; 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))
         ;; FIXME: This fails to start if Home is first activated from a
         ;; non-X11 session.
         (start #~(make-forkexec-constructor
                   (list #$(file-append redshift "/bin/redshift")
                         "-c" #$config-file)))
         (stop #~(make-kill-destructor)))))

(define home-redshift-service-type
  (service-type
   (name 'home-redshift)
   (extensions (list (service-extension home-shepherd-service-type
                                        redshift-shepherd-service)))
   (default-value (home-redshift-configuration))
   (description
    "Run Redshift, a program that adjusts the color temperature of display
according to time of day.")))

\f
;;;
;;; 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
                   '("DBUS_VERBOSE=1")
                   #:log-file
                   (format #f "~a/dbus.log"
                           (or (getenv "XDG_LOG_HOME")
                               (format #f "~a/.local/var/log"
                                       (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.")))

\f
;;;
;;; Mako.
;;;

(define-record-type* <home-mako-section>
  home-mako-section make-home-mako-section
  home-mako-section?

  (if-app-name home-mako-if-app-name            ;string | #f
               (default #f))
  (if-app-icon home-mako-if-app-icon             ;string | #f
               (default #f))
  (if-summary home-mako-if-summary               ;string | #f
              (default #f))
  (if-summary-regex? home-mako-if-summary-regex? ;boolean
                     (default #f))
  (if-body home-mako-if-body                     ;string | #f
           (default #f))
  (if-body-regex? home-mako-if-body-regex?       ;boolean
                  (default #f))
  (if-urgency home-mako-if-urgency               ;'low | 'normal | 'critical | #f
              (default #f))
  (if-category home-mako-if-category             ;string | #f
               (default #f))
  (if-desktop-entry home-mako-if-desktop-entry   ;string | #f
                    (default #f))
  (if-actionable? home-mako-if-actionable?       ;boolean | '()
                  (default '()))
  (if-expiring? home-mako-if-expiring?           ;boolean | '()
                (default '()))
  (if-mode home-mako-if-mode                     ;string | #f
           (default #f))
  (if-grouped? home-mako-if-grouped?             ;boolean | '()
               (default '()))
  (if-group-index home-mako-if-group-index       ;integer | #f
                  (default #f))
  (if-hidden? home-mako-if-hidden?               ;boolean | '()
              (default '()))
  (if-output home-mako-if-output                 ;string | #f
             (default #f))
  (if-anchor home-mako-if-anchor                 ;'top-right | 'top-center | 'top-left | 'bottom-right | 'bottom-center | 'bottom-left | 'center-right | 'center-left | 'center | #f
             (default #f))

  (on-button-left home-mako-on-button-left       ;#f | 'default | 'dismiss | 'dismiss-all | 'dismiss-group | list of (file-like | string)
                  (default 'default))
  (on-button-middle home-mako-on-button-middle   ;#f | 'default | 'dismiss | 'dismiss-all | 'dismiss-group | string | list of (file-like | string)
                    (default #f))
  (on-button-right home-mako-on-button-right     ;#f | 'default | 'dismiss | 'dismiss-all | 'dismiss-group | list of (file-like | string)
                   (default 'dismiss))
  (on-touch home-mako-on-touch                   ;#f | 'default | 'dismiss | 'dismiss-all | 'dismiss-group | list of (file-like | string)
            (default 'dismiss))
  (on-notify home-mako-on-notify                 ;#f | 'default | 'dismiss | 'dismiss-all | 'dismiss-group | list of (file-like | string)
             (default #f))

  (font home-mako-font                           ;string
        (default "monospace"))
  (font-size home-mako-font-size                 ;number
             (default 10))

  (background-color home-mako-background-color   ;string
                    (default "285577FF"))
  (text-color home-mako-text-color               ;string
              (default "FFFFFFFF"))

  (width home-mako-width                         ;integer
         (default 300))
  (height home-mako-height                       ;integer
          (default 100))
  (outer-margin home-mako-outer-margin           ;list of integer
                (default '(0)))
  (margin home-mako-margin                       ;list of integer
          (default '(10)))
  (padding home-mako-padding                     ;list of integer
           (default '(5)))

  (border-size home-mako-border-size             ;integer
               (default 2))
  (border-color home-mako-border-color           ;string
                (default "4C7899FF"))
  (border-radius home-mako-border-radius         ;integer
                 (default 0))

  (progress-color home-mako-progress-color       ;string
                  (default "5588AAFF"))
  (progress-style home-mako-progress-style       ;'over | 'source
                  (default 'over))

  (icons? home-mako-icons?                       ;boolean
          (default #t))
  (max-icon-size home-mako-max-icon-size         ;integer
                 (default 64))
  (icon-path home-mako-icon-path                 ;list of string
             (default '()))
  (icon-location home-mako-icon-location         ;'left | 'right | 'top | 'bottom
                 (default 'left))

  (markup? home-mako-markup?                     ;boolean
           (default #t))
  (actions? home-mako-actions?                   ;boolean
            (default #t))
  (history? home-mako-history?                   ;boolean
            (default #t))
  (invisible? home-mako-invisible?               ;boolean
              (default #f))

  (format home-mako-format
          (default "<b>%s</b>\\n%b"))
  (text-alignment home-mako-text-alignment       ;'left | 'center | 'right
                  (default 'left))

  (default-timeout home-mako-default-timeout     ;integer
                   (default 0))
  (ignore-timeout? home-mako-ignore-timeout?     ;boolean
                   (default #f))

  (group-by home-mako-group-by                   ;list of string
            (default #f))
  (max-visible home-mako-max-visible             ;integer
               (default #f))

  (output home-mako-output                       ;string
          (default #f))
  (layer home-mako-layer                         ;'background | 'bottom | 'top | 'overlay
         (default 'top))
  (anchor home-mako-anchor                       ;'top-right | 'top-center | 'top-left | 'bottom-right | 'bottom-center | 'bottom-left | 'center-right | 'center-left | 'center
          (default #f)))

(define (home-mako-configuration-header-attributes section)
  (define (boolean-clause name field)
    (let ((value (field section)))
      (cond ((null? value) '())
            (value (list "!" name " "))
            (else (list name)))))

  (define (string-clause name field)
    (let ((value (field section)))
      (if value
          (list name "=\"" value "\" ")
          '())))

  (define (symbol-clause name field)
    (if (field section)
        (string-clause name (compose symbol->string field))
        '()))

  (define (number-clause name field)
    (if (field section)
        (string-clause name (compose number->string field))
        '()))

  (append (string-clause "app-name" home-mako-if-app-name)
          (string-clause "app-icon" home-mako-if-app-icon)
          (string-clause (if (home-mako-if-summary-regex? section)
                             "summary~"
                             "summary")
                         home-mako-if-summary)
          (string-clause (if (home-mako-if-body-regex? section)
                             "body~"
                             "body")
                         home-mako-if-body)
          (symbol-clause "urgency" home-mako-if-urgency)
          (string-clause "category" home-mako-if-category)
          (string-clause "desktop-entry" home-mako-if-desktop-entry)
          (boolean-clause "actionable" home-mako-if-actionable?)
          (boolean-clause "expiring" home-mako-if-expiring?)
          (string-clause "mode" home-mako-if-mode)
          (boolean-clause "grouped" home-mako-if-grouped?)
          (number-clause "group-index" home-mako-if-group-index)
          (boolean-clause "hidden" home-mako-if-hidden?)
          (string-clause "output" home-mako-if-output)
          (symbol-clause "anchor" home-mako-if-anchor)))

(define (home-mako-configuration-header section)
  (match (home-mako-configuration-header-attributes section)
    (() '())
    ((attributes ...)
     (append (list "\n[ ") attributes (list "]\n")))))

(define (home-mako-configuration-body section)
  (define (string-clause name field)
    (let ((value (field section)))
      (if value
          (list name "=" (field section) "\n")
          '())))

  (define (boolean-clause name field)
    (list name "=" (if (field section) "1" "0") "\n"))

  (define (number-clause name field)
    (if (field section)
        (string-clause name (compose number->string field))
        '()))

  (define (symbol-clause name field)
    (if (field section)
        (string-clause name (compose symbol->string field))
        '()))

  (define (colour-clause name field)
    (string-clause name (compose (cute string-append "#" <>)
                                 field)))

  (define (directional-clause name field)
    (if (field section)
        (string-clause name (compose (cute string-join <> ",")
                                     (cute map number->string <>)
                                     field))
        '()))

  (define (event-clause name field)
    (append (list name "=")
            (match (field section)
              ('default (list "invoke-default-action"))
              ('dismiss (list "dismiss"))
              ('dismiss-all (list "dismiss-all"))
              ('dismiss-group (list "dismiss-group"))
              ((args ...)
               (append (list "exec")
                       (append-map (cute list " \"" <> "\"")
                                   args)))
              (#f (list "none")))
            (list "\n")))

  (append (event-clause "on-button-left" home-mako-on-button-left)
          (event-clause "on-button-middle" home-mako-on-button-middle)
          (event-clause "on-button-right" home-mako-on-button-right)
          (event-clause "on-touch" home-mako-on-touch)
          (event-clause "on-notify" home-mako-on-notify)
          (list "font=" (home-mako-font section) " "
                (number->string (home-mako-font-size section)) "\n")
          (colour-clause "background-color" home-mako-background-color)
          (colour-clause "text-color" home-mako-text-color)
          (number-clause "width" home-mako-width)
          (number-clause "height" home-mako-height)
          (directional-clause "outer-margin" home-mako-outer-margin)
          (directional-clause "margin" home-mako-margin)
          (directional-clause "padding" home-mako-padding)
          (number-clause "border-size" home-mako-border-size)
          (colour-clause "border-color" home-mako-border-color)
          (number-clause "border-radius" home-mako-border-radius)
          (list "progress-color="
                (symbol->string (home-mako-progress-style section))
                " #" (home-mako-progress-color section) "\n")
          (boolean-clause "icons" home-mako-icons?)
          (number-clause "max-icon-size" home-mako-max-icon-size)
          (string-clause "icon-path"
                         (compose (cute string-join <> ":")
                                  home-mako-icon-path))
          (symbol-clause "icon-location" home-mako-icon-location)
          (boolean-clause "markup" home-mako-markup?)
          (boolean-clause "actions" home-mako-actions?)
          (boolean-clause "history" home-mako-history?)
          (boolean-clause "invisible" home-mako-invisible?)
          (string-clause "format" home-mako-format)
          (symbol-clause "text-alignment" home-mako-text-alignment)
          (number-clause "default-timeout" home-mako-default-timeout)
          (boolean-clause "ignore-timeout" home-mako-ignore-timeout?)
          (boolean-clause "ignore-timeout" home-mako-ignore-timeout?)
          (if (home-mako-group-by section)
              (string-clause "group-by"
                             (compose (cute string-join <> ",")
                                      home-mako-group-by))
              '())
          (number-clause "max-visible" home-mako-max-visible)
          (string-clause "output" home-mako-output)
          (symbol-clause "layer" home-mako-layer)
          (symbol-clause "anchor" home-mako-anchor)))

(define (home-mako-configuration-section section)
  (append (home-mako-configuration-header section)
          (home-mako-configuration-body section)))

(define %home-mako-default-section (home-mako-section))

(define %home-mako-default-grouped-section
  (home-mako-section
   (if-grouped? #t)
   (format "(%g) <b>%s</b>\\n%b")))

(define-record-type* <home-mako-configuration>
  home-mako-configuration make-home-mako-configuration
  home-mako-configuration?

  (mako home-mako-configuration-mako             ;file-like
        (default mako))
  (sections home-mako-configuration-sections     ;list of <home-mako-section>
            (default (list %home-mako-default-section
                           %home-mako-default-grouped-section)))

  (max-history home-mako-configuration-max-history ;integer
               (default 5))
  (sort home-mako-configuration-sort             ;'time | 'priority
        (default 'time))
  (sort-order home-mako-configuration-sort-order ;'ascending | 'descending
              (default 'descending)))

(define (home-mako-configuration-file config)
  (apply mixed-text-file "mako-config"
         (append (list "max-history="
                       (number->string
                        (home-mako-configuration-max-history config))
                       "\n"
                       "sort="
                       (match (home-mako-configuration-sort-order config)
                         ('ascending "+")
                         ('descending "-"))
                       (symbol->string (home-mako-configuration-sort config))
                       "\n")
                 (append-map home-mako-configuration-section
                             (home-mako-configuration-sections config)))))

(define (home-mako-xdg-configuration-files config)
  `(("mako/config" ,(home-mako-configuration-file config))))

(define home-mako-service-type
  (service-type
   (name 'home-mako)
   (extensions
    (list (service-extension home-xdg-configuration-files-service-type
                             home-mako-xdg-configuration-files)))
   (default-value (home-mako-configuration))
   (description
    "Install and configure the @code{mako} notification daemon.")))