;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2022 Ludovic Courtès ;;; Copyright © 2022 ( ;;; ;;; 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 . (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)) ;;; ;;; 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."))) ;;; ;;; D-Bus. ;;; (define-record-type* 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."))) ;;; ;;; Mako. ;;; (define-record-type* 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 "%s\\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) %s\\n%b"))) (define-record-type* 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 (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.")))