;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019,2020 L  p R n  d n   <guix@lprndn.info>
;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; 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 services lightdm)
  #:use-module (srfi srfi-1)
  #:use-module (ice-9 match)
  #:use-module (ice-9 receive)

  #:use-module (guix gexp)
  #:use-module (guix records)

  #:use-module (gnu artwork)
  #:use-module (gnu system pam)
  #:use-module (gnu system shadow)

  #:use-module (gnu services)
  #:use-module (gnu services dbus)
  #:use-module (gnu services desktop)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services xorg)

  #:use-module (gnu packages admin)
  #:use-module (gnu packages display-managers)
  #:use-module (gnu packages freedesktop)
  #:use-module (gnu packages gnome)
  #:use-module (gnu packages xorg)

  #:export (lightdm-seat-configuration

            lightdm-configuration
            lightdm-configuration?
            lightdm-service-type

            lightdm-gtk-greeter-configuration
            lightdm-gtk-greeter-configuration?
            lightdm-gtk-greeter-service-type))

;; GREETERS

(define-record-type* <lightdm-gtk-greeter-configuration>
  lightdm-gtk-greeter-configuration make-lightdm-gtk-greeter-configuration
  lightdm-gtk-greeter-configuration?

  (lightdm-gtk-greeter lightdm-gtk-greeter-configuration-lightdm-gtk-greeter
                       (default lightdm-gtk-greeter))
  (assets lightdm-gtk-greeter-configuration-assets
          (default (list adwaita-icon-theme
                         gnome-themes-standard)))
  (theme-name lightdm-gtk-greeter-configuration-theme-name
              (default "Adwaita"))
  (icon-theme-name
   lightdm-gtk-greeter-configuration-icon-theme-name
   (default "Adwaita"))
  (cursor-theme-name
   lightdm-gtk-greeter-configuration-cursor-theme-name
   (default "Adwaita"))
  (cursor-theme-size lightdm-gtk-greeter-configuration-cursor-theme-size
                     (default 16))
  (background lightdm-gtk-greeter-configuration-background
              (default (file-append %artwork-repository
                                    "/grub/GuixSD-fully-black-16-9.svg")))
  (a11y-states lightdm-gtk-greeter-a11y-states
               (default "contrast; font; keyboard; reader"))
  (reader lightdm-gtk-greeter-reader
          (default #f))
  (extra-config lightdm-gtk-greeter-configuration-extra-config
                (default '())))

(define (lightdm-gtk-greeter-configuration-file config)
  (match-record config <lightdm-gtk-greeter-configuration>
                (theme-name icon-theme-name cursor-theme-name
                            cursor-theme-size background a11y-states
                            reader extra-config)
                (mixed-text-file "lightdm-gtk-greeter.conf" "
[greeter]
theme-name = "          theme-name                         "
icon-theme-name = "     icon-theme-name                    "
cursor-theme-name = "   cursor-theme-name                  "
cursor-theme-size = "   (number->string cursor-theme-size) "
background = "          background                         "
a11y-states = "         a11y-states                        "
" (if reader (string-append "reader = " reader) "") "
" (string-join extra-config "\n"))))

;; LIGHTDM

(define-record-type* <lightdm-seat-configuration>
  lightdm-seat-configuration make-lightdm-seat-configuration
  lightdm-seat-configuration?
  (name-glob lightdm-seat-configuration-name-glob
             (default "*"))
  (type lightdm-seat-configuration-type
        (default 'local))
  (xorg-configuration lightdm-seat-configuration-xorg-configuration
                      (default #f))
  (session-wrapper lightdm-seat-configuration-session-wrapper
                   (default (xinitrc)))
  (greeter-session lightdm-seat-configuration-greeter-session
                   (default 'lightdm-gtk-greeter))
  (default-user-session lightdm-seat-configuration-default-user-session
    (default ""))
  (autologin-user lightdm-seat-configuration-autologin-user
                  (default ""))
  (extra-config lightdm-seat-configuration-extra-config
                (default '())))


(define (lightdm-seat-configuration->list seat default-xorg-configuration)
  "Given a seat, outputs a list to be used by mixed-text-file through `apply."
  (match-record seat <lightdm-seat-configuration>
                (name-glob
                 type xorg-configuration session-wrapper
                 greeter-session default-user-session
                 autologin-user extra-config)
                (list "
  [Seat:"               name-glob                              "]
  type = "              (symbol->string type)
  ;; If no xorg-configuration is set by the seat use the one provided
  ;; by the lightdm service
  "
  xserver-command = "   (xorg-start-command
                         (or xorg-configuration
                             default-xorg-configuration))
  "
  session-wrapper = "   session-wrapper                         "
  greeter-session = "   (symbol->string greeter-session)
  (if (string-null? default-user-session) ""
      (string-append "
  user-session = "      default-user-session))                  "
  "
  ;; Turn autologin ON if autologin-user is set
  (if (string-null? autologin-user) ""
      (string-append "
  autologin-user = "    autologin-user                          "
  autologin-session = " default-user-session))                  "
  " (string-join extra-config "\n"))))


(define-record-type* <lightdm-configuration>
  lightdm-configuration make-lightdm-configuration
  lightdm-configuration?
  ;; General configuration
  (lightdm lightdm-configuration-lightdm
           (default lightdm))
  (allow-empty-passwords? lightdm-configuration-allow-empty-passwords?
                          (default #f))
  (sessions-directories
   lightdm-configuration-sessions-directory
   (default '("/run/current-system/profile/share/xsessions"
              "/run/current-system/profile/share/wayland-sessions")))
  (greeters-directories lightdm-configuration-greeters-directories
                        (default '("$XDG_DATA_DIRS/lightdm/greeters"
                                  "$XDG_DATA_DIRS/xgreeters"
                                  "/run/current-system/profile/share/xgreeters")))
  (remote-sessions-directories lightdm-configuration-remote-sessions-directories
                             (default
                               '("/run/current-system/profile/share/remote-sessions")))
  ;; Having a xorg-configuration field here allows us
  ;; to benefit from set-xorg-configuration.
  (xorg-configuration lightdm-configuration-xorg-configuration
                      (default (xorg-configuration)))
  (seats lightdm-configuration-seats
         (default (list (lightdm-seat-configuration))))
  (extra-config lightdm-configuration-extra-config
                (default '())))

(define (lightdm-configuration-file config)
  (match-record config <lightdm-configuration>
                (allow-empty-passwords?
                 sessions-directories greeters-directories
                 remote-sessions-directories xorg-configuration
                 seats extra-config)
                ;; Little trick to allow unquote-splicing of seats
                (apply mixed-text-file "lightdm.conf" "
[LightDM]
greeter-user = lightdm
greeters-directory = " #~(string-join '#$greeters-directories ":") "
sessions-directory = " (string-join sessions-directories ":") "
remote-sessions-directory = " (string-join remote-sessions-directories ":") "

#Seats
 " (append
    (concatenate
     (map (lambda (seat)
            (lightdm-seat-configuration->list seat xorg-configuration))
          seats))
    (list "
#Extra config
" (string-join extra-config "\n"))))))

(define %lightdm-accounts
  (list (user-group (name "lightdm") (system? #t))
        (user-account
         (name "lightdm")
         (group "lightdm")
         (system? #t)
         (comment "LightDM user")
         (home-directory "/var/lib/lightdm")
         (shell (file-append shadow "/sbin/nologin")))))

(define %lightdm-activation
  ;; Ensure /var/lib/lightdm is owned by the "lightdm" user.
  ;; Mimics what is done for gdm
  ;; see a43e9157ef479e94c19951cc9d228cf153bf78ee
  (with-imported-modules '((guix build utils))
    #~(begin
        (use-modules (guix build utils))

        (define (ensure-ownership directory)
          (let* ((lightdm (getpwnam "lightdm"))
                 (uid (passwd:uid lightdm))
                 (gid (passwd:gid lightdm))
                 (st  (stat directory #f)))
            ;; Recurse into directory only if it has wrong ownership.
            (when (and st
                       (or (not (= uid (stat:uid st)))
                           (not (= gid (stat:gid st)))))
              (for-each (lambda (file)
                          (chown file uid gid))
                        (find-files "directory"
                                    #:directories? #t)))))

        (when (not (stat "/var/lib/lightdm-data" #f))
          (mkdir-p "/var/lib/lightdm-data"))
        (for-each ensure-ownership
                  '("/var/lib/lightdm"
                    "/var/lib/lightdm-data")))))

(define (lightdm-pam-service config)
  "Return a PAM service for @command{lightdm}."
  (unix-pam-service
   "lightdm"
   #:login-uid? #t
   #:allow-empty-passwords?
   (lightdm-configuration-allow-empty-passwords? config)))


(define (lightdm-greeter-pam-service)
  "Return a PAM service for @command{lightdm-greeter}}."
  (pam-service
   (name "lightdm-greeter")
   (auth
    (list
     ;; Load environment from /etc/environment and ~/.pam_environment
     (pam-entry (control "required") (module "pam_env.so"))
     ;; Always let the greeter start without authentication
     (pam-entry (control "required") (module "pam_permit.so"))))
   ;; No action required for account management
   (account
    (list
     (pam-entry (control "required") (module "pam_permit.so"))))
   ;; Can't change password
   (password
    (list
     (pam-entry (control "required") (module "pam_deny.so"))))
   ;; Setup session
   (session
    (list
     (pam-entry (control "required") (module "pam_unix.so"))))))


(define (lightdm-autologin-pam-service)
  "Return a PAM service for @command{lightdm-autologin}}."
  (pam-service
   (name "lightdm-autologin")
   (auth
    (list
     ;; Block login if they are globally disabled
     (pam-entry (control "required") (module "pam_nologin.so"))

     (pam-entry (control "required") (module "pam_succeed_if.so")
                (arguments (list "uid >= 1000")))
     ;; Allow access without authentication
     (pam-entry (control "required") (module "pam_permit.so"))))
   ;; Stop autologin if account requires action
   (account
    (list
     (pam-entry (control "required") (module "pam_unix.so"))))
   ;; Can't change password
   (password
    (list
     (pam-entry (control "required") (module "pam_deny.so"))))
   ;; Setup session
   (session
    (list
     (pam-entry (control "required") (module "pam_unix.so"))))))

(define (lightdm-pam-services config)
  (list (lightdm-pam-service config)
        (lightdm-greeter-pam-service)
        (lightdm-autologin-pam-service)))

(define (lightdm-shepherd-service config)
  "Return a <lightdm-service> for LightDM with CONFIG."

  (define lightdm-command
    #~(list #$(file-append (lightdm-configuration-lightdm config)
                           "/sbin/lightdm")
            "-c"
            #$(lightdm-configuration-file config)))

  (define lightdm-paths
    (let ((lightdm (lightdm-configuration-lightdm config)))
      #~(string-join
         '#$(map (lambda (dir)
                   (file-append lightdm dir))
                 '("/bin" "/sbin" "/libexec"))
         ":")))

  (list
   (shepherd-service
    (documentation "LightDM display manager.")
    (requirement '(dbus-system user-processes host-name))
    (provision '(display-manager xorg-server))
    (respawn? #f)
    (start
     #~(lambda ()
         (fork+exec-command
          #$lightdm-command
          ;; Lightdm needs itself in its PATH
          #:environment-variables
          (list
           (string-append "PATH=" #$lightdm-paths)))))
    (stop #~(make-kill-destructor)))))

;; LightDM Aggregate

(define-record-type* <lightdm-aggregate>
  lightdm-aggregate make-lightdm-aggregate
  lightdm-aggregate?
  (lightdm lightdm-aggregate-lightdm
           (default (lightdm-configuration)))
  (greeters lightdm-aggregate-greeters
            (default '())))

;; WHAT TO DO IF THERE IS A NON DEFAULT GREETER SERVICE AND
;; A DEFAULT LIGHTDM SERVICE DEFINED OR THE OPPOSITE

;;
(define (greeter-default-configuration greeter-symbol)
  "Given a greeter's symbol, return its default configuration."
  (cond
   ((eq? 'lightdm-gtk-greeter greeter-symbol)
    (lightdm-gtk-greeter-configuration))
   (else #f)))

(define (greeter-desktop-directory greeter-config)
  "Return the directory providing the greeter's .desktop file given a
configuration object. Return #F for unknown greeters."
  (cond
   ((lightdm-gtk-greeter-configuration? greeter-config)
    (file-append (lightdm-gtk-greeter-configuration-lightdm-gtk-greeter
                  greeter-config)
                 "/share/xgreeters"))
   (else #f)))

(define (lightdm-gtk-greeter-etc-service config)
  `(("xdg/lightdm/lightdm-gtk-greeter.conf"
     ,(lightdm-gtk-greeter-configuration-file config))))

(define (lightdm-gtk-greeter-profile-service config)
  (lightdm-gtk-greeter-configuration-assets config))

(define (lightdm-greeter-etc-service greeter-config)
  (cond
   ((lightdm-gtk-greeter-configuration? greeter-config)
    (lightdm-gtk-greeter-etc-service greeter-config))
   (else #f)))

(define (lightdm-greeter-profile-service greeter-config)
  (cond
   ((lightdm-gtk-greeter-configuration? greeter-config)
    (lightdm-gtk-greeter-profile-service greeter-config))
   (else #f)))

(define (augment-greeters-directories lightdm-config greeters)
  "Returns a new lightdm-configuration record based on @code{lightdm-conf}
but with @code{greeters} available in its @code{greeters-directories} field."
  (lightdm-configuration
   (inherit lightdm-config)
   (greeters-directories
    (append (map greeter-desktop-directory greeters)
            (lightdm-configuration-greeters-directories lightdm-config)))))

(define (aggregate->greeters aggregate)
  "Given a lightdm-aggregate, outputs a list of greeter
configurations."
  (let ( ;; Greeters found in seat-configurations.
        (needed-greeters
         (map (lambda (seat)
                (lightdm-seat-configuration-greeter-session seat))
              (lightdm-configuration-seats
               (lightdm-aggregate-lightdm aggregate))))
        ;; Greeter configurations defined by the user
        (user-defined-greeters (lightdm-aggregate-greeters aggregate)))
    (map
     (lambda (greeter)
       ;; If a greeter is used in a seat but not defined by the user
       ;; get its default configuration object
       (or (assoc-ref greeter user-defined-greeters)
           (greeter-default-configuration greeter)))
     needed-greeters)))

;; Private service merging configuration of lightdm and its greeters
(define lightdm-aggregate-service-type
  (service-type
   (name 'lightdm-aggregate)
   (extensions
    (list (service-extension etc-service-type
                       (lambda (aggregate)
                         (concatenate (map lightdm-greeter-etc-service
                                           (lightdm-aggregate-greeters aggregate)))))
    (service-extension profile-service-type
                       (lambda (aggregate)
                         (concatenate (map lightdm-greeter-profile-service
                                           (lightdm-aggregate-greeters aggregate)))))
    ;; LightDM Specifics (at leats for now)
    (service-extension pam-root-service-type
                       (compose lightdm-pam-services
                                lightdm-aggregate-lightdm))
    (service-extension shepherd-root-service-type
                       (compose lightdm-shepherd-service
                                lightdm-aggregate-lightdm))
    (service-extension activation-service-type
                       (const %lightdm-activation))
    (service-extension dbus-root-service-type
                       (compose list lightdm-configuration-lightdm
                                lightdm-aggregate-lightdm))
    (service-extension polkit-service-type
                       (compose list lightdm-configuration-lightdm
                                lightdm-aggregate-lightdm))
    (service-extension account-service-type
                       (const %lightdm-accounts))))
   ;; Get lightdm-configuration from its service and pairs like
   ;; ('greeter-symbol . greeter-configuration) from greeters
   (compose (lambda (extensions)
              (receive (lightdm-extension greeters-extensions)
                  (partition lightdm-configuration? extensions)
                (make-lightdm-aggregate
                 (if (null? lightdm-extension) (lightdm-configuration) (car lightdm-extension))
                 greeters-extensions))))
   (extend (lambda (config extensions)
             (let ((greeters (aggregate->greeters extensions)))
               (make-lightdm-aggregate
                ;; If there are no lightdm-service defined, use the default one.
                ;; Also, add greeters' desktop directories to greeters-directories.
                (augment-greeters-directories
                 (lightdm-aggregate-lightdm extensions) greeters)
                greeters))))
   (default-value (lightdm-aggregate))
   (description "Private service merging LightDM and LightDM's greeters
services configurations and extending needed services.")))

;; GREETERS

(define lightdm-gtk-greeter-service-type
  (service-type (name 'lightdm-gtk-greeter)
                (extensions
                 (list
                  (service-extension lightdm-aggregate-service-type
                                     (lambda (g) (cons 'lightdm-gtk-greeter g)))))
                (default-value (lightdm-gtk-greeter-configuration))
                (description
                 "Set-up lightdm-gtk-greeter as well
as its configuration file and extends LightDM with its seats.")))

;; LightDM

(define lightdm-service-type
  (handle-xorg-configuration
   lightdm-configuration
   (service-type (name 'lightdm)
                 (extensions
                  (list
                   (service-extension lightdm-aggregate-service-type
                                      const)))
                 (default-value (lightdm-configuration))
                 (description "Return a service that spawns the
 LightDM graphical login manager."))))