Package: guix-patches;
Reported by: Feng Shu <tumashu <at> 163.com>
Date: Mon, 23 Dec 2024 13:22:02 UTC
Severity: normal
Tags: patch
Message #11 received at 75048 <at> debbugs.gnu.org (full text, mbox):
From: Feng Shu <tumashu <at> 163.com> To: 75048 <at> debbugs.gnu.org Subject: [PATCH v3] Add lightdm-greeter-general-configuration and do not hard code config type name everywhere. Date: Tue, 24 Dec 2024 15:33:20 +0800
From 7fd615c0b03356414919a6ae2799758491b8f582 Mon Sep 17 00:00:00 2001
From: Feng Shu <tumashu <at> 163.com>
Date: Mon, 23 Dec 2024 19:30:28 +0800
Subject: [PATCH v3] Add lightdm-greeter-general-configuration and do not hard
code config type name everywhere.
* 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..e03549e974 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))))
+
;;;
;;; 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
--
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.