[bug#75048] [PATCH v5] Add lightdm-greeter-general-configuration and do not hard code config type name everywhere.

[tumashu@163.com]

From: Feng Shu <tumashu@163.com>

* gnu/services/lightdm.scm (gnu): Use (ice-9 local-eval), export new option variables.
(local-eval-environment?): New variable.
(string): Move.
(lightdm-gtk-greeter-configuration): Add local-eval-environment,
  greeter-session-name, greeter-package, greeter-config-name fields.
(lightdm-greeter-general-configuration): New variable.
(strip-record-type-name-brackets): Return string instead symbol.
(config->type-name): Rename from config->name.
(greeter-configuration-field): New function.
(greeter-configuration->greeter-fields): Do not hard code greeter configuation name.
(greeter-configuration->packages): Do not hard code greeter configuation name.
(greeter-configuration->conf-name): Improve.
(greeter-configuration->session-name): New variable.
(greeter-configuration->file): Call different function based config type.
(greeter-configuration->file/lightdm-gtk-greeter-configuration)
(greeter-configuration->file/lightdm-greeter-general-configuration): New functions.
(greeter-configuration-valid?): New function.
(greeter-session?): Do not hard code greeter configuation name.
(greeter-session->greater-configuration-pred)
(greeter-configuration->greeter-session): Removed.
(greeter-configuration?): Do not hard code greeter configuation name.
(lightdm-configuration): Add lightdm-greeter-general-configuration.
(validate-lightdm-configuration): Do not use greeter-session->greater-configuration-pred.
(generate-doc): Handle lightdm-greeter-general-configuration.

* doc/guix.texi (X Window): Improve lightdm-gtk-greeter-configuration options
  doc, Add lightdm-greeter-general-configuration,

Change-Id: Iae22cd641454c86280e88d6986594ad0c8f4c490
---
 doc/guix.texi            |  94 +++++++++++++++-
 gnu/services/lightdm.scm | 225 +++++++++++++++++++++++++++------------
 2 files changed, 250 insertions(+), 69 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 31deb5b003..e1f1fee68b 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -23802,8 +23802,7 @@ In its most basic form, it can be used simply as:
 (service lightdm-service-type)
 @end lisp
 
-A more elaborate example making use of the VNC capabilities and enabling
-more features and verbose logs could look like:
+Two more elaborate examples look like below:
 
 @lisp
 (service lightdm-service-type
@@ -23819,6 +23818,38 @@ more features and verbose logs could look like:
                   (name "*")
                   (user-session "ratpoison"))))))
 @end lisp
+
+@lisp
+(service lightdm-service-type
+         (lightdm-configuration
+          (greeters
+           (list (lightdm-greeter-general-configuration
+                  (greeter-package lightdm-mini-greeter)
+                  (greeter-session-name "lightdm-mini-greeter")
+                  (greeter-config-name "lightdm-mini-greeter.conf")
+                  (config (list "[greeter]"
+                                "user = guest")))
+                 (lightdm-gtk-greeter-configuration
+                  (extra-config
+                   (list "font-name = San 10"
+                         "xft-dpi = 140"
+                         "clock-format = %Y-%m-%d %H:%M"
+                         ;; We need to use "~~" to generate a tilde, for
+                         ;; extra-config sting will be handle as
+                         ;; control-string of format function.
+                         "indicators = ~~host;~~spacer;~~session;~~a11y;~~clock;~~power")))))
+          (seats
+           (list (lightdm-seat-configuration
+                  (name "*")
+                  (greeter-session 'lightdm-mini-greeter))))
+          (xorg-configuration
+           (xorg-configuration
+            (server-arguments
+             (append %default-xorg-server-arguments
+                     '("-dpi" "140")))))))
+@end lisp
+
+
 @end defvar
 
 @c The LightDM service documentation can be auto-generated via the
@@ -23903,8 +23934,21 @@ Extra configuration values to append to the LightDM configuration file.
 Available @code{lightdm-gtk-greeter-configuration} fields are:
 
 @table @asis
+@item @code{local-eval-environment} (default: @code{(the-environment)}) (type: local-eval-environment)
+Recode the environment where lightdm-gtk-greeter-configuration is defined.
+
 @item @code{lightdm-gtk-greeter} (default: @code{lightdm-gtk-greeter}) (type: file-like)
-The lightdm-gtk-greeter package to use.
+The lightdm-gtk-greeter package to use, this option is keeped for
+compatibility, use greeter-package instead.
+
+@item @code{greeter-package} (default: @code{lightdm-gtk-greeter}) (type: file-like)
+The greeter package to use.
+
+@item @code{greeter-session-name} (default: @code{lightdm-gtk-greeter}) (type: string)
+The session name used in lightdm.conf.
+
+@item @code{greeter-config-name} (default: @code{lightdm-gtk-greeter.conf}) (type: string)
+The greeter config file name in /etc/lightdm directory.
 
 @item @code{assets} (default: @code{(adwaita-icon-theme gnome-themes-extra hicolor-icon-theme)}) (type: list-of-file-likes)
 The list of packages complementing the greeter, such as package
@@ -23948,6 +23992,50 @@ configuration file.
 @c %end of fragment
 @c %start of fragment
 
+@deftp {Data Type} lightdm-greeter-general-configuration
+
+@code{lightdm-greeter-general-configuration} support all text config
+greeters which have no build-in configuration type like
+@code{lightdm-gtk-greeter-configuration}, such as lightdm-mini-greeter,
+for example:
+
+@lisp
+(lightdm-greeter-general-configuration
+ (greeter-package lightdm-mini-greeter)
+ (greeter-session-name "lightdm-mini-greeter")
+ (greeter-config-name "lightdm-mini-greeter.conf")
+ (config (list "[greeter]"
+               "user = guest")))
+@end lisp
+
+Available @code{lightdm-greeter-general-configuration} fields are:
+
+@table @asis
+@item @code{local-eval-environment} (default: @code{(the-environment)}) (type: local-eval-environment)
+Recode the environment where lightdm-greeter-general-configuration is defined.
+
+@item @code{greeter-package} (type: maybe-file-like)
+The greeter package to use.
+
+@item @code{greeter-session-name} (type: maybe-string)
+The session name used in lightdm.conf.
+
+@item @code{greeter-config-name} (type: maybe-string)
+The greeter config file name in /etc/lightdm directory.
+
+@item @code{assets} (default: @code{(adwaita-icon-theme gnome-themes-extra hicolor-icon-theme)}) (type: list-of-file-likes)
+The list of packages complementing the greeter, such as package
+providing icon themes.
+
+@item @code{config} (default: @code{'()}) (type: list-of-strings)
+Configuration values of the LightDM Greeter configuration file.
+
+@end table
+@end deftp
+
+@c %end of fragment
+@c %start of fragment
+
 @deftp {Data Type} lightdm-seat-configuration
 Available @code{lightdm-seat-configuration} fields are:
 
diff --git a/gnu/services/lightdm.scm b/gnu/services/lightdm.scm
index 191cb5635b..e59a4ceb6e 100644
--- a/gnu/services/lightdm.scm
+++ b/gnu/services/lightdm.scm
@@ -39,6 +39,7 @@ (define-module (gnu services lightdm)
   #:use-module (guix i18n)
   #:use-module (guix records)
   #:use-module (ice-9 format)
+  #:use-module (ice-9 local-eval)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
@@ -56,7 +57,10 @@ (define-module (gnu services lightdm)
             lightdm-gtk-greeter-configuration
             lightdm-gtk-greeter-configuration?
             lightdm-gtk-greeter-configuration-lightdm-gtk-greeter
+            lightdm-gtk-greeter-configuration-greeter-package
             lightdm-gtk-greeter-configuration-assets
+            lightdm-gtk-greeter-configuration-greeter-config-name
+            lightdm-gtk-greeter-configuration-greeter-session-name
             lightdm-gtk-greeter-configuration-theme-name
             lightdm-gtk-greeter-configuration-icon-theme-name
             lightdm-gtk-greeter-configuration-cursor-theme-name
@@ -66,6 +70,14 @@ (define-module (gnu services lightdm)
             lightdm-gtk-greeter-configuration-reader
             lightdm-gtk-greeter-configuration-extra-config
 
+            lightdm-greeter-general-configuration
+            lightdm-greeter-general-configuration?
+            lightdm-greeter-general-configuration-greeter-package
+            lightdm-greeter-general-configuration-assets
+            lightdm-greeter-general-configuration-greeter-config-name
+            lightdm-greeter-general-configuration-greeter-session-name
+            lightdm-greeter-general-configuration-config
+
             lightdm-configuration
             lightdm-configuration?
             lightdm-configuration-lightdm
@@ -87,6 +99,9 @@ (define-module (gnu services lightdm)
 ;;; Greeters.
 ;;;
 
+(define (local-eval-environment? value)
+  #t)
+
 (define list-of-file-likes?
   (list-of file-like?))
 
@@ -117,6 +132,8 @@ (define (serialize-file-like name value)
 (define (serialize-list-of-a11y-states name value)
   (format #f "~a=~a~%" name (string-join (map symbol->string value) ";")))
 
+(define-maybe string)
+
 (define (serialize-string name value)
   (format #f "~a=~a~%" name value))
 
@@ -127,9 +144,21 @@ (define (serialize-list-of-strings _ value)
   (string-join value "\n"))
 
 (define-configuration lightdm-gtk-greeter-configuration
+  (local-eval-environment
+   (local-eval-environment (the-environment))
+   "Recode the environment where lightdm-gtk-greeter-configuration is defined."
+   empty-serializer)
+  (greeter-session-name
+   (string "lightdm-gtk-greeter")
+   "Session name used in lightdm.conf"
+   empty-serializer)
   (lightdm-gtk-greeter
+   maybe-file-like
+   "Keep it for compatibility, use greeter-package field instead."
+   empty-serializer)
+  (greeter-package
    (file-like lightdm-gtk-greeter)
-   "The lightdm-gtk-greeter package to use."
+   "The greeter package to use."
    empty-serializer)
   (assets
    (list-of-file-likes (list adwaita-icon-theme
@@ -140,6 +169,10 @@ (define-configuration lightdm-gtk-greeter-configuration
    "The list of packages complementing the greeter, such as package providing
 icon themes."
    empty-serializer)
+  (greeter-config-name
+   (string "lightdm-gtk-greeter.conf")
+   "Greeter config file name in /etc/lightdm directory."
+   empty-serializer)
   (theme-name
    (string "Adwaita")
    "The name of the theme to use.")
@@ -176,34 +209,81 @@ (define-configuration lightdm-gtk-greeter-configuration
    "Extra configuration values to append to the LightDM GTK Greeter
 configuration file."))
 
+(define-configuration lightdm-greeter-general-configuration
+  (local-eval-environment
+   (local-eval-environment (the-environment))
+   "Recode the environment where lightdm-greeter-general-configuration is defined."
+   empty-serializer)
+  (greeter-package
+   maybe-file-like
+   "The greeter package to use."
+   empty-serializer)
+  (assets
+   (list-of-file-likes (list adwaita-icon-theme
+                             gnome-themes-extra
+                             ;; FIXME: hicolor-icon-theme should be in the
+                             ;; packages of the desktop templates.
+                             hicolor-icon-theme))
+   "The list of packages complementing the greeter, such as package providing
+icon themes."
+   empty-serializer)
+  (greeter-config-name
+   maybe-string
+   "Greeter config file name in /etc/lightdm directory."
+   empty-serializer)
+  (greeter-session-name
+   maybe-string
+   "Session name used in lightdm.conf"
+   empty-serializer)
+  (config
+   (list-of-strings '())
+   "Configuration values of the LightDM Greeter configuration file."))
+
 (define (strip-record-type-name-brackets name)
   "Remove the '<' and '>' brackets from NAME, a symbol."
   (let ((name (symbol->string name)))
     (if (and (string-prefix? "<" name)
              (string-suffix? ">" name))
-        (string->symbol (string-drop (string-drop-right name 1) 1))
+        (string-drop (string-drop-right name 1) 1)
         (error "unexpected record type name" name))))
 
-(define (config->name config)
-  "Return the constructor name (a symbol) from CONFIG."
+(define (config->type-name config)
+  "Return the type name of CONFIG."
   (strip-record-type-name-brackets
    (record-type-name (struct-vtable config))))
 
+(define (greeter-configuration-field config field)
+  "Return field value of config."
+  (let ((rtd (struct-vtable config)))
+    ((record-accessor rtd field) config)))
+
+(define (greeter-configuration->session-name config)
+  "Return the session name of CONFIG, a greeter configuration."
+  (greeter-configuration-field config 'greeter-session-name))
+
 (define (greeter-configuration->greeter-fields config)
   "Return the fields of CONFIG, a greeter configuration."
-  (match config
-    ;; Note: register any new greeter configuration here.
-    ((? lightdm-gtk-greeter-configuration?)
-     lightdm-gtk-greeter-configuration-fields)))
+  (let* ((type-name (config->type-name config))
+         (variable (string->symbol (string-append type-name "-fields")))
+         (eval-env (greeter-configuration-field config 'local-eval-environment)))
+    (local-eval variable eval-env)))
 
 (define (greeter-configuration->packages config)
   "Return the list of greeter packages, including assets, used by CONFIG, a
 greeter configuration."
-  (match config
-    ;; Note: register any new greeter configuration here.
-    ((? lightdm-gtk-greeter-configuration?)
-     (cons (lightdm-gtk-greeter-configuration-lightdm-gtk-greeter config)
-           (lightdm-gtk-greeter-configuration-assets config)))))
+  (filter file-like?
+          (cons (greeter-configuration->greeter-package config)
+                (greeter-configuration-field config 'assets))))
+
+(define (greeter-configuration->greeter-package config)
+  "Return greeter package used by CONFIG, a greeter configuration."
+  (let ((type-name (config->type-name config))
+        (pkg1 (greeter-configuration-field config 'greeter-package)))
+    (if (eq? type-name "lightdm-gtk-greeter-configuration")
+        ;; Handle lightdm-gtk-greeter field for keeping it for compatibility.
+        (let ((pkg2 (greeter-configuration-field config 'lightdm-gtk-greeter)))
+          (if (file-like? pkg2) pkg2 pkg1))
+        pkg1)))
 
 ;;; TODO: Implement directly in (gnu services configuration), perhaps by
 ;;; making the FIELDS argument optional.
@@ -215,11 +295,19 @@ (define fields (greeter-configuration->greeter-fields config))
 
 (define (greeter-configuration->conf-name config)
   "Return the file name of CONFIG, a greeter configuration."
-  (format #f "~a.conf" (greeter-configuration->greeter-session config)))
+  (greeter-configuration-field config 'greeter-config-name))
 
 (define (greeter-configuration->file config)
   "Serialize CONFIG into a file under the output directory, so that it can be
 easily added to XDG_CONF_DIRS."
+  (let* ((type-name (config->type-name config))
+         (func-name (string->symbol
+                     (string-append
+                      "greeter-configuration->file/" type-name)))
+         (eval-env (greeter-configuration-field config 'local-eval-environment)))
+    (local-eval `(,func-name ,config) eval-env)))
+
+(define (greeter-configuration->file/lightdm-gtk-greeter-configuration config)
   (computed-file
    (greeter-configuration->conf-name config)
    #~(begin
@@ -229,6 +317,23 @@ (define (greeter-configuration->file config)
                          "[greeter]\n"
                          #$(serialize-configuration* config))))))))
 
+(define (greeter-configuration->file/lightdm-greeter-general-configuration config)
+  (computed-file
+   (greeter-configuration->conf-name config)
+   #~(begin
+       (call-with-output-file #$output
+         (lambda (port)
+           (format port #$(serialize-configuration* config)))))))
+
+(define (greeter-configuration-valid? config)
+  "Check greeter-configuration CONFIG valid or not."
+  (let ((conf-name (greeter-configuration->conf-name config))
+        (session-name (greeter-configuration->session-name config)))
+    (and (string? conf-name)
+         (string? session-name)
+         (> (string-length conf-name) 0)
+         (> (string-length session-name) 0))))
+
 \f
 ;;;
 ;;; Seats.
@@ -248,15 +353,14 @@ (define (serialize-seat-type name value)
 (define-maybe seat-type)
 
 (define (greeter-session? value)
-  (memq value '(lightdm-gtk-greeter)))
+  (and (symbol? value)
+       (string-contains (symbol->string value) "greeter")))
 
 (define (serialize-greeter-session name value)
   (format #f "~a=~a~%" name value))
 
 (define-maybe greeter-session)
 
-(define-maybe string)
-
 ;;; Note: all the fields except for the seat name should be 'maybe's, since
 ;;; the real default value is set by the %lightdm-seat-default define later,
 ;;; and this avoids repeating ourselves in the serialized configuration file.
@@ -291,22 +395,6 @@ (define-configuration lightdm-seat-configuration
    (list-of-strings '())
    "Extra configuration values to append to the seat configuration section."))
 
-(define (greeter-session->greater-configuration-pred identifier)
-  "Return the predicate to check if a configuration is of the type specifying
-a greeter identified by IDENTIFIER."
-  (match identifier
-    ;; Note: register any new greeter identifier here.
-    ('lightdm-gtk-greeter
-     lightdm-gtk-greeter-configuration?)))
-
-(define (greeter-configuration->greeter-session config)
-  "Given CONFIG, a greeter configuration object, return its identifier,
-a symbol."
-  (let ((suffix "-configuration")
-        (greeter-conf-name (config->name config)))
-    (string->symbol (string-drop-right (symbol->string greeter-conf-name)
-                                       (string-length suffix)))))
-
 (define list-of-seat-configurations?
   (list-of lightdm-seat-configuration?))
 
@@ -316,20 +404,17 @@ (define list-of-seat-configurations?
 ;;;
 
 (define (greeter-configuration? config)
-  (or (lightdm-gtk-greeter-configuration? config)
-      ;; Note: register any new greeter configuration here.
-      ))
+  ((record-predicate (struct-vtable config)) config))
 
 (define (list-of-greeter-configurations? greeter-configs)
   (and ((list-of greeter-configuration?) greeter-configs)
        ;; Greeter configurations must also not be provided more than once.
-       (let* ((types (map (compose record-type-name struct-vtable)
-                          greeter-configs))
-              (dupes (filter (lambda (type)
-                               (< 1 (count (cut eq? type <>) types)))
-                             types)))
+       (let* ((conf-names (map greeter-configuration->conf-name greeter-configs))
+              (dupes (filter (lambda (conf-name)
+                               (< 1 (count (cut eq? conf-name <>) conf-names)))
+                             conf-names)))
          (unless (null? dupes)
-           (leave (G_ "duplicate greeter configurations: ~a~%") dupes)))))
+           (leave (G_ "Duplicate greeter configurations: ~a~%") dupes)))))
 
 (define-configuration/no-serialization lightdm-configuration
   (lightdm
@@ -347,7 +432,9 @@ (define-configuration/no-serialization lightdm-configuration
 start script.  It can be refined per seat via the @code{xserver-command} of
 the @code{<lightdm-seat-configuration>} record, if desired.")
   (greeters
-   (list-of-greeter-configurations (list (lightdm-gtk-greeter-configuration)))
+   (list-of-greeter-configurations
+    (list (lightdm-gtk-greeter-configuration)
+          (lightdm-greeter-general-configuration)))
    "The LightDM greeter configurations specifying the greeters to use.")
   (seats
    (list-of-seat-configurations (list (lightdm-seat-configuration
@@ -417,8 +504,11 @@ (define (validate-lightdm-configuration config)
          (missing-greeters
           (filter-map
            (lambda (id)
-             (define pred (greeter-session->greater-configuration-pred id))
-             (if (find pred greeter-configurations)
+             (if (find (lambda (greeter-config)
+                         (let* ((id (symbol->string id))
+                                (name (greeter-configuration->session-name greeter-config)))
+                           (equal? id name)))
+                       greeter-configurations)
                  #f                     ;happy path
                  id))
            greeter-sessions)))
@@ -428,10 +518,11 @@ (define pred (greeter-session->greater-configuration-pred id))
 
 (define (lightdm-configuration-file config)
   (match-record config <lightdm-configuration>
-    (xorg-configuration seats
-     xdmcp? xdmcp-listen-address
-     vnc-server? vnc-server-command vnc-server-listen-address vnc-server-port
-     extra-config)
+                (xorg-configuration
+                 seats xdmcp? xdmcp-listen-address
+                 vnc-server? vnc-server-command
+                 vnc-server-listen-address vnc-server-port
+                 extra-config)
     (apply
      mixed-text-file
      "lightdm.conf" "
@@ -470,22 +561,22 @@ (define (lightdm-configuration-file config)
 # Seat configuration.
 #
 "
-     (map (lambda (seat)
-            ;; This complication exists to propagate a default value for
-            ;; the 'xserver-command' field of the seats.  Having a
-            ;; 'xorg-configuration' field at the root of the
-            ;; lightdm-configuration enables the use of
-            ;; 'set-xorg-configuration' and can be more convenient.
-            (let ((seat* (if (maybe-value-set?
-                              (lightdm-seat-configuration-xserver-command seat))
-                             seat
-                             (lightdm-seat-configuration
-                              (inherit seat)
-                              (xserver-command (xorg-start-command
-                                                xorg-configuration))))))
-              (serialize-configuration seat*
-                                       lightdm-seat-configuration-fields)))
-          seats))))
+    (map (lambda (seat)
+           ;; This complication exists to propagate a default value for
+           ;; the 'xserver-command' field of the seats.  Having a
+           ;; 'xorg-configuration' field at the root of the
+           ;; lightdm-configuration enables the use of
+           ;; 'set-xorg-configuration' and can be more convenient.
+           (let ((seat* (if (maybe-value-set?
+                             (lightdm-seat-configuration-xserver-command seat))
+                            seat
+                            (lightdm-seat-configuration
+                             (inherit seat)
+                             (xserver-command (xorg-start-command
+                                               xorg-configuration))))))
+             (serialize-configuration seat*
+                                      lightdm-seat-configuration-fields)))
+         seats))))
 
 (define (lightdm-configuration-directory config)
   "Return a directory containing the serialized lightdm configuration
@@ -495,7 +586,8 @@ (define (lightdm-configuration-directory config)
                     (map (lambda (g)
                            `(,(greeter-configuration->conf-name g)
                              ,(greeter-configuration->file g)))
-                         (lightdm-configuration-greeters config)))))
+                         (filter greeter-configuration-valid?
+                                 (lightdm-configuration-greeters config))))))
 
 (define %lightdm-accounts
   (list (user-group (name "lightdm") (system? #t))
@@ -676,4 +768,5 @@ (define lightdm-service-type
 (define (generate-doc)
   (configuration->documentation 'lightdm-configuration)
   (configuration->documentation 'lightdm-gtk-greeter-configuration)
+  (configuration->documentation 'lightdm-greeter-general-configuration)
   (configuration->documentation 'lightdm-seat-configuration))
-- 
2.45.2