gnu/home/services/desktop.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu home services desktop)
  20   #:use-module (gnu home services)
  21   #:use-module (gnu home services shepherd)
  22   #:use-module (gnu services configuration)
  23   #:autoload   (gnu packages xdisorg) (redshift)
  24   #:use-module (guix records)
  25   #:use-module (guix gexp)
  26   #:use-module (srfi srfi-1)
  27   #:use-module (ice-9 match)
  28   #:export (home-redshift-configuration
  29             home-redshift-configuration?
  30
  31             home-redshift-service-type))
  32
  33 \f
  34 ;;;
  35 ;;; Redshift.
  36 ;;;
  37
  38 (define (serialize-integer field value)
  39   (string-append (match field
  40                    ('daytime-temperature "temp-day")
  41                    ('nighttime-temperature "temp-night")
  42                    ('daytime-brightness "brightness-day")
  43                    ('nighttime-brightness "brightness-night")
  44                    ('latitude "lat")
  45                    ('longitude "lon")
  46                    (_ (symbol->string field)))
  47                  "=" (number->string value) "\n"))
  48
  49 (define (serialize-symbol field value)
  50   (string-append (symbol->string field)
  51                  "=" (symbol->string value) "\n"))
  52
  53 (define (serialize-string field value)
  54   (string-append (symbol->string field)
  55                  "=" value "\n"))
  56
  57 (define serialize-inexact-number serialize-integer)
  58
  59 (define (inexact-number? n)
  60   (and (number? n) (inexact? n)))
  61 (define-maybe inexact-number)
  62 (define-maybe string)
  63
  64 (define (serialize-raw-configuration-string field value)
  65   value)
  66 (define raw-configuration-string? string?)
  67
  68 (define-configuration home-redshift-configuration
  69   (redshift
  70    (file-like redshift)
  71    "Redshift package to use.")
  72
  73   (location-provider
  74    (symbol 'geoclue2)
  75    "Geolocation provider---@code{'manual} or @code{'geoclue2}.
  76
  77 In the former case, you must also specify the @code{latitude} and
  78 @code{longitude} fields so Redshift can determine daytime at your place.  In
  79 the latter case, the Geoclue system service must be running; it will be
  80 queried for location information.")
  81   (adjustment-method
  82    (symbol 'randr)
  83    "Color adjustment method.")
  84
  85   ;; Default values from redshift(1).
  86   (daytime-temperature
  87    (integer 6500)
  88    "Daytime color temperature (kelvins).")
  89   (nighttime-temperature
  90    (integer 4500)
  91    "Nighttime color temperature (kelvins).")
  92
  93   (daytime-brightness
  94    maybe-inexact-number
  95    "Daytime screen brightness, between 0.1 and 1.0.")
  96   (nighttime-brightness
  97    maybe-inexact-number
  98    "Nighttime screen brightness, between 0.1 and 1.0.")
  99
 100   (latitude
 101    maybe-inexact-number
 102    "Latitude, when @code{location-provider} is @code{'manual}.")
 103   (longitude
 104    maybe-inexact-number
 105    "Longitude, when @code{location-provider} is @code{'manual}.")
 106
 107   (dawn-time
 108    maybe-string
 109    "Custom time for the transition from night to day in the
 110 morning---@code{\"HH:MM\"} format.  When specified, solar elevation is not
 111 used to determine the daytime/nighttime period.")
 112   (dusk-time
 113    maybe-string
 114    "Likewise, custom time for the transition from day to night in the
 115 evening.")
 116
 117   (extra-content
 118    (raw-configuration-string "")
 119    "Extra content appended as-is to the Redshift configuration file.  Run
 120 @command{man redshift} for more information about the configuration file
 121 format."))
 122
 123 (define (serialize-redshift-configuration config)
 124   (define location-fields
 125     '(latitude longitude))
 126
 127   (define (location-field? field)
 128     (memq (configuration-field-name field) location-fields))
 129
 130   (define (secondary-field? field)
 131     (or (location-field? field)
 132         (memq (configuration-field-name field)
 133               '(redshift extra-content))))
 134
 135   #~(string-append
 136      "[redshift]\n"
 137      #$(serialize-configuration config
 138                                 (remove secondary-field?
 139                                         home-redshift-configuration-fields))
 140
 141      #$(home-redshift-configuration-extra-content config)
 142
 143      "\n[manual]\n"
 144      #$(serialize-configuration config
 145                                 (filter location-field?
 146                                         home-redshift-configuration-fields))))
 147
 148 (define (redshift-shepherd-service config)
 149   (define config-file
 150     (computed-file "redshift.conf"
 151                    #~(call-with-output-file #$output
 152                        (lambda (port)
 153                          (display #$(serialize-redshift-configuration config)
 154                                   port)))))
 155
 156   (list (shepherd-service
 157          (documentation "Redshift program.")
 158          (provision '(redshift))
 159          ;; FIXME: This fails to start if Home is first activated from a
 160          ;; non-X11 session.
 161          (start #~(make-forkexec-constructor
 162                    (list #$(file-append redshift "/bin/redshift")
 163                          "-c" #$config-file)))
 164          (stop #~(make-kill-destructor)))))
 165
 166 (define home-redshift-service-type
 167   (service-type
 168    (name 'home-redshift)
 169    (extensions (list (service-extension home-shepherd-service-type
 170                                         redshift-shepherd-service)))
 171    (default-value (home-redshift-configuration))
 172    (description
 173     "Run Redshift, a program that adjusts the color temperature of display
 174 according to time of day.")))