From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp2.migadu.com ([2001:41d0:403:58f0::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms13.migadu.com with LMTPS id gPBdMW6ga2e2MwEAe85BDQ:P1 (envelope-from ) for ; Wed, 25 Dec 2024 06:04:30 +0000 Received: from aspmx1.migadu.com ([2001:41d0:403:58f0::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp2.migadu.com with LMTPS id gPBdMW6ga2e2MwEAe85BDQ (envelope-from ) for ; Wed, 25 Dec 2024 07:04:30 +0100 X-Envelope-To: larch@yhetil.org Authentication-Results: aspmx1.migadu.com; dkim=fail ("body hash did not verify") header.d=debbugs.gnu.org header.s=debbugs-gnu-org header.b="BgF/kead"; dkim=fail ("body hash did not verify") header.d=163.com header.s=s110527 header.b=mA32JUdz; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org"; dmarc=fail reason="SPF not aligned (relaxed)" header.from=163.com (policy=none) ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=yhetil.org; s=key1; t=1735106670; h=from:from:sender:sender:reply-to:subject:subject:date:date: message-id:message-id:to:to:cc:cc:mime-version:mime-version: content-transfer-encoding:content-transfer-encoding:resent-cc: resent-from:resent-sender:resent-message-id:in-reply-to:in-reply-to: references:references:list-id:list-help:list-unsubscribe: list-subscribe:list-post:dkim-signature; bh=diGmmN3C4OwbIfsno/IfvztmE/en6mdwPAxGg5y6Adk=; b=i9DX1ilSXxPYJKeWrnXWScjzBqaEZ6uDHd2gPkcgpB/1LPARFmn//232ZPYBBtG21EqQpv gaF/UaRggYZWpdyGoVtFKpCTPDFZeHVnr+hXDwCrXJNsExWGQg5da5pWSIMaWc3aHkvJoS usGNtfLKi7EUD6L8hPBtSr19FrmbHVxmU2hUcebrcsxcfGM3hzICuRXzSGA74U5O2IXoLh lj/PKq0CAEog6fQPM4oysBAnVhKFZnhzTMfI0P2Q66SzONaYDTmkJplTcIAabx2YvDOg/O YnkyRZGUWtrMxWFEi4MgTDue5uHeHJL2zQqida1ZXX8IqlGIOkDKvomydOfwyw== ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=fail ("body hash did not verify") header.d=debbugs.gnu.org header.s=debbugs-gnu-org header.b="BgF/kead"; dkim=fail ("body hash did not verify") header.d=163.com header.s=s110527 header.b=mA32JUdz; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org"; dmarc=fail reason="SPF not aligned (relaxed)" header.from=163.com (policy=none) ARC-Seal: i=1; s=key1; d=yhetil.org; t=1735106670; a=rsa-sha256; cv=none; b=jhUIzXxX4g5DU/NZCJAk1J8BBz56yHVeUArgHd1YnQwrDXD6s3V0v232o1FKPa7kEkG8Hd 1BLEQEsvdWyOiToWlR+btsNYYIGHQR3zigobGrTv97HfOh/qHWXOPanmC+sMrMnJV7n/J+ itQFp8t+6FzPnMkto/m48lnfB6jr5KHpV0jdq5bSEztQB5194haRhd8La6TCj83BJogaLu G3880/ug5/qPayZ7IYqr1pflYhjouYwQxZD8ptJP0JL/piXK/LF4jVLvDN1ZL1Ec/QFhLj SDaGIkhlkIhL+GFwMG/r9aXIExzBfCDqjhalB2UHz2khtXbeyZzIIZaAg7H3NQ== Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id 003B87F90A for ; Wed, 25 Dec 2024 07:04:29 +0100 (CET) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1tQKV5-0005Y0-AC; Wed, 25 Dec 2024 01:04:07 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1tQKV2-0005Xr-I7 for guix-patches@gnu.org; Wed, 25 Dec 2024 01:04:05 -0500 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1tQKV2-0006dD-95 for guix-patches@gnu.org; Wed, 25 Dec 2024 01:04:04 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=debbugs.gnu.org; s=debbugs-gnu-org; h=MIME-Version:Date:From:To:In-Reply-To:References:Subject; bh=eA/nHm8TE+TdDb7+jt/rzmYItvELZ2erq8d0mkhVqwc=; b=BgF/keadp3fi9oORQsSJ9EOVKRvgJdFotg7B9I1m3/jTf8MO+JUjCZl6QKY/kP3BjvWK88C+6G1ONC7lcVsXUrWmvSqn7lsOsJPxM+X6e1jNg5eORu0HemUZ1Le4KmCmAIxUX2DGvT7XVxubr00wBsh+XT52H+9Tg8njzQP/2QFPvYLxZ4XGkCFji1KnmcN+QOyWZZEfYJTzynrJADGKDiG5sj3+dEBb2M+6U2o+rYMm/0m3lwjSzrIY79IPPwnkd/VG/V5xKFdu2KhZbLPBaRrXjfMAsftQ0CvgIAfaL7B+zRM6V1sMw1AD/Zv6q8xUNQ46kfF3wRSSFP0AhKP6rA==; Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1tQKUz-0007t3-Rp; Wed, 25 Dec 2024 01:04:01 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#75048] [PATCH v5] Add lightdm-greeter-general-configuration and do not hard code config type name everywhere. References: <87pllibkr3.fsf@163.com> In-Reply-To: <87pllibkr3.fsf@163.com> Resent-From: tumashu@163.com Original-Sender: "Debbugs-submit" Resent-CC: tumashu@163.com, tumashu@163.com, guix-patches@gnu.org Resent-Date: Wed, 25 Dec 2024 06:04:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 75048 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 75048@debbugs.gnu.org Cc: Feng Shu , Feng Shu , tumashu@163.com X-Debbugs-Original-Xcc: Feng Shu , tumashu@163.com Received: via spool by 75048-submit@debbugs.gnu.org id=B75048.173510662630289 (code B ref 75048); Wed, 25 Dec 2024 06:04:01 +0000 Received: (at 75048) by debbugs.gnu.org; 25 Dec 2024 06:03:46 +0000 Received: from localhost ([127.0.0.1]:35918 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1tQKUj-0007sR-Dw for submit@debbugs.gnu.org; Wed, 25 Dec 2024 01:03:46 -0500 Received: from m16.mail.163.com ([220.197.31.3]:57354) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1tQKUd-0007s4-Rh for 75048@debbugs.gnu.org; Wed, 25 Dec 2024 01:03:44 -0500 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=163.com; s=s110527; h=From:Subject:Date:Message-ID:MIME-Version; bh=eA/nH m8TE+TdDb7+jt/rzmYItvELZ2erq8d0mkhVqwc=; b=mA32JUdz5xNGRm1VCNzfd V0iLgGPMZQLgkW3F5Xe28/WRc5dXhoQgjJfd5JIzWQMZyZrLIu/GFYL7Bl4Rqi0q nL+7+9UHnQiwwQ3BtEYFoiO+GKvEwc8+3SPDCe1W3XJwCnwK12DA3+pI2f1DzXnL 2owo09tbOt94ewZppv52tA= Received: from localhost.localdomain (unknown []) by gzga-smtp-mtada-g0-4 (Coremail) with SMTP id _____wD3X70xoGtnfx8iBg--.17016S2; Wed, 25 Dec 2024 14:03:30 +0800 (CST) From: tumashu@163.com Date: Wed, 25 Dec 2024 14:03:15 +0800 Message-ID: <20241225060317.42053-1-tumashu@163.com> X-Mailer: git-send-email 2.45.2 MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-CM-TRANSID: _____wD3X70xoGtnfx8iBg--.17016S2 X-Coremail-Antispam: 1Uf129KBjvAXoWfZF4rCFyDWF43GF4ruF1xKrg_yoW8tFW5to Z3ZFW7Gr47Cr17WFnayr1fCr47Jryv9r48Zr18JryUAw1vqF43Ja4YvayUZF42kr4jkrn8 Gr95u39xAFWqyF4rn29KB7ZKAUJUUUU8529EdanIXcx71UUUUU7v73VFW2AGmfu7bjvjm3 AaLaJ3UbIYCTnIWIevJa73UjIFyTuYvjTRXdbbDUUUU X-Originating-IP: [218.92.14.78] X-CM-SenderInfo: 5wxpt2lkx6il2tof0z/1tbiERnA1GdrmGyrLwAAsg X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+larch=yhetil.org@gnu.org Sender: guix-patches-bounces+larch=yhetil.org@gnu.org X-Migadu-Flow: FLOW_IN X-Migadu-Country: US X-Migadu-Scanner: mx11.migadu.com X-Migadu-Spam-Score: 4.29 X-Spam-Score: 4.29 X-Migadu-Queue-Id: 003B87F90A X-TUID: SX7LNytr3Izj From: Feng Shu * 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)))) + ;;; ;;; 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{} 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 - (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