mirror of
https://codeberg.org/guix/guix.git
synced 2026-01-25 03:55:08 -06:00
gnu: Merge xorg configurations when extending.
Configuration for xorg is embedded in the various display-manager configuration records, and extension support is factored out into the `handle-xorg-configuration' macro. However, the extension mechanism replaces the existing xorg-configuration with the supplied one, making it impossible to compose configuration from multiple sources. This patch adds a procedure to merge two xorg-configuration records, and calls it within handle-xorg-configuration, allowing the config to be built piecemeal. * gnu/services/xorg.scm (merge-xorg-configurations): New variable. (handle-xorg-configuration): Merge xorg configs. Change-Id: I20e9db911eef5d4efe98fdf382f3084e4defc1ba Signed-off-by: Liliana Marie Prikler <liliana.prikler@gmail.com>
This commit is contained in:
Ian Eure
Liliana Marie Prikler
parent
5ef86f97e2
commit
a9462997d7
2 changed files with 276 additions and 12 deletions
|
|
@ -16,6 +16,7 @@
|
|||
;;; Copyright © 2023 muradm <mail@muradm.net>
|
||||
;;; Copyright © 2024 Zheng Junjie <873216071@qq.com>
|
||||
;;; Copyright © 2024 Tomas Volf <~@wolfsden.cz>
|
||||
;;; Copyright © 2025 Ian Eure <ian@retrospec.tv>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
|
|
@ -43,6 +44,7 @@
|
|||
#:use-module (gnu system privilege)
|
||||
#:use-module (gnu services base)
|
||||
#:use-module (gnu services dbus)
|
||||
#:use-module (gnu services desktop)
|
||||
#:use-module (gnu packages base)
|
||||
#:use-module (gnu packages guile)
|
||||
#:use-module (gnu packages xorg)
|
||||
|
|
@ -194,6 +196,8 @@ the first one in the list is loaded."
|
|||
;; Default command-line arguments for X.
|
||||
'("-nolisten" "tcp"))
|
||||
|
||||
(define %default-xorg-server xorg-server)
|
||||
|
||||
;; Configuration of an Xorg server.
|
||||
(define-record-type* <xorg-configuration>
|
||||
xorg-configuration make-xorg-configuration
|
||||
|
|
@ -217,10 +221,42 @@ the first one in the list is loaded."
|
|||
(extra-config xorg-configuration-extra-config ;list of strings
|
||||
(default '()))
|
||||
(server xorg-configuration-server ;file-like
|
||||
(default xorg-server))
|
||||
(default %default-xorg-server))
|
||||
(server-arguments xorg-configuration-server-arguments ;list of strings
|
||||
(default %default-xorg-server-arguments)))
|
||||
|
||||
(define (merge-xorg-configurations configs)
|
||||
;; Find whichever config has a non-default Xorg server.
|
||||
(let ((config-with-server
|
||||
(or
|
||||
(find
|
||||
(lambda (config)
|
||||
(or (not (eq? %default-xorg-server
|
||||
(xorg-configuration-server config)))
|
||||
(not (eq? %default-xorg-server-arguments
|
||||
(xorg-configuration-server-arguments config)))))
|
||||
(reverse configs))
|
||||
(xorg-configuration))))
|
||||
|
||||
(xorg-configuration
|
||||
(modules
|
||||
(delete-duplicates (append-map xorg-configuration-modules configs)))
|
||||
(fonts
|
||||
(delete-duplicates (append-map xorg-configuration-fonts configs)))
|
||||
(drivers
|
||||
(delete-duplicates (append-map xorg-configuration-drivers configs)))
|
||||
(resolutions
|
||||
(delete-duplicates (append-map xorg-configuration-resolutions configs)))
|
||||
(extra-config
|
||||
(append-map xorg-configuration-extra-config configs))
|
||||
(keyboard-layout
|
||||
(any xorg-configuration-keyboard-layout (reverse configs)))
|
||||
;; Use the later config with non-default server for both these fields.
|
||||
(server
|
||||
(xorg-configuration-server config-with-server))
|
||||
(server-arguments
|
||||
(xorg-configuration-server-arguments config-with-server)))))
|
||||
|
||||
(define (xorg-configuration->file config)
|
||||
"Compute an Xorg configuration file corresponding to CONFIG, an
|
||||
<xorg-configuration> record."
|
||||
|
|
@ -347,7 +383,7 @@ EndSection\n" port)
|
|||
(newline port)))
|
||||
|
||||
(for-each (lambda (config)
|
||||
(display config port))
|
||||
(display (string-append config "\n\n") port))
|
||||
'#$(xorg-configuration-extra-config config))))))
|
||||
|
||||
(computed-file "xserver.conf" build)))
|
||||
|
|
@ -644,16 +680,12 @@ a `service-extension', as used by `set-xorg-configuration'."
|
|||
((_ configuration-record service-type-definition)
|
||||
(service-type
|
||||
(inherit service-type-definition)
|
||||
(compose (lambda (extensions)
|
||||
(match extensions
|
||||
(() #f)
|
||||
((config . _) config))))
|
||||
(extend (lambda (config xorg-configuration)
|
||||
(if xorg-configuration
|
||||
(configuration-record
|
||||
(inherit config)
|
||||
(xorg-configuration xorg-configuration))
|
||||
config)))))))
|
||||
(compose cons*)
|
||||
(extend (lambda (config xorg-configurations)
|
||||
(configuration-record
|
||||
(inherit config)
|
||||
(xorg-configuration
|
||||
(merge-xorg-configurations xorg-configurations)))))))))
|
||||
|
||||
(define (xorg-server-profile-service config)
|
||||
;; XXX: profile-service-type only accepts <package> objects.
|
||||
|
|
|
|||
232
tests/services/xorg.scm
Normal file
232
tests/services/xorg.scm
Normal file
|
|
@ -0,0 +1,232 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2025 Ian Eure <ian@retrospec.tv>
|
||||
;;;
|
||||
;;; 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 (tests services xorg)
|
||||
#:use-module (guix diagnostics)
|
||||
#:use-module (guix packages)
|
||||
#:use-module (gnu packages xorg)
|
||||
#:use-module (gnu bootloader)
|
||||
#:use-module (gnu bootloader grub)
|
||||
#:use-module (gnu services)
|
||||
#:use-module (gnu services base)
|
||||
#:use-module (gnu services xorg)
|
||||
#:use-module (gnu system)
|
||||
#:use-module (gnu system keyboard)
|
||||
#:use-module (gnu system file-systems)
|
||||
#:use-module ((srfi srfi-1) #:select (find))
|
||||
#:use-module (srfi srfi-64))
|
||||
|
||||
;;; Tests for the (gnu services xorg) module.
|
||||
|
||||
(define %config-empty (xorg-configuration))
|
||||
|
||||
(define %default-server (xorg-configuration-server %config-empty))
|
||||
|
||||
|
||||
|
||||
(test-begin "merge-xorg-configurations")
|
||||
|
||||
(define merge-xorg-configurations
|
||||
(@@ (gnu services xorg) merge-xorg-configurations))
|
||||
|
||||
(define gdm-configuration-xorg
|
||||
(@@ (gnu services xorg) gdm-configuration-xorg))
|
||||
|
||||
;; keyboard-layout tests.
|
||||
|
||||
(define %config-xorg-keyboard-layout-1
|
||||
(xorg-configuration
|
||||
(keyboard-layout (keyboard-layout "us" #:options '("ctrl:nocaps")))))
|
||||
|
||||
(define %config-xorg-keyboard-layout-2
|
||||
(xorg-configuration
|
||||
(keyboard-layout (keyboard-layout "us" #:options '("ctrl:esc")))))
|
||||
|
||||
;; Later keyboard layouts replace earlier defaults
|
||||
(test-equal
|
||||
(keyboard-layout "us" #:options '("ctrl:nocaps"))
|
||||
(xorg-configuration-keyboard-layout
|
||||
(merge-xorg-configurations
|
||||
(list %config-empty %config-xorg-keyboard-layout-1))))
|
||||
|
||||
;; Later keyboard layouts replace earlier customizations.
|
||||
(test-equal
|
||||
(keyboard-layout "us" #:options '("ctrl:esc"))
|
||||
(xorg-configuration-keyboard-layout
|
||||
(merge-xorg-configurations (list %config-empty
|
||||
%config-xorg-keyboard-layout-1
|
||||
%config-xorg-keyboard-layout-2))))
|
||||
|
||||
;; server, server-arguments tests.
|
||||
|
||||
(define %custom-server-1
|
||||
(package
|
||||
(inherit xorg-server)
|
||||
(name "fake-xorg-server")))
|
||||
|
||||
(define %custom-server-2
|
||||
(package
|
||||
(inherit xorg-server)
|
||||
(name "another-fake-xorg-server")))
|
||||
|
||||
(define %custom-server-1-arguments
|
||||
(cons "-nosilk" %default-xorg-server-arguments))
|
||||
|
||||
(define %custom-server-2-arguments
|
||||
(cons* "-logverbose" "9" %default-xorg-server-arguments))
|
||||
|
||||
(define %config-custom-server-1
|
||||
(xorg-configuration
|
||||
(server %custom-server-1)))
|
||||
|
||||
(define %config-custom-server-2
|
||||
(xorg-configuration
|
||||
(server %custom-server-2)))
|
||||
|
||||
(define %config-custom-server-1-and-arguments
|
||||
(xorg-configuration
|
||||
(inherit %config-custom-server-1)
|
||||
(server-arguments %custom-server-1-arguments)))
|
||||
|
||||
(define %config-custom-server-2-and-arguments
|
||||
(xorg-configuration
|
||||
(inherit %config-custom-server-2)
|
||||
(server-arguments %custom-server-2-arguments)))
|
||||
|
||||
;; Custom server is prioritized over earlier default.
|
||||
(test-equal
|
||||
%custom-server-1
|
||||
(xorg-configuration-server
|
||||
(merge-xorg-configurations (list %config-empty
|
||||
%config-custom-server-1))))
|
||||
|
||||
;; Custom server preserves arguments.
|
||||
(test-equal
|
||||
(list %custom-server-1 %custom-server-1-arguments)
|
||||
(let ((cfg (merge-xorg-configurations
|
||||
(list
|
||||
%config-empty
|
||||
%config-custom-server-1-and-arguments))))
|
||||
(list (xorg-configuration-server cfg)
|
||||
(xorg-configuration-server-arguments cfg))))
|
||||
|
||||
;; Later custom arguments replace earlier.
|
||||
(test-equal
|
||||
(list %custom-server-2 %custom-server-2-arguments)
|
||||
(let ((cfg (merge-xorg-configurations
|
||||
(list
|
||||
%config-empty
|
||||
%config-custom-server-1-and-arguments
|
||||
%config-custom-server-2-and-arguments))))
|
||||
(list (xorg-configuration-server cfg)
|
||||
(xorg-configuration-server-arguments cfg))))
|
||||
|
||||
;; Custom server is prioritized over later default.
|
||||
(test-equal
|
||||
%custom-server-1
|
||||
(xorg-configuration-server
|
||||
(merge-xorg-configurations (list %config-custom-server-1
|
||||
%config-empty))))
|
||||
|
||||
;; Custom arguments are prioritized over earlier custom server.
|
||||
(test-equal
|
||||
%custom-server-2-arguments
|
||||
(xorg-configuration-server-arguments
|
||||
(merge-xorg-configurations
|
||||
(list
|
||||
(xorg-configuration (server %custom-server-1))
|
||||
(xorg-configuration (server-arguments %custom-server-2-arguments))))))
|
||||
|
||||
;; Later custom servers are prioritized over earlier.
|
||||
(test-equal
|
||||
%custom-server-2
|
||||
(xorg-configuration-server
|
||||
(merge-xorg-configurations (list %config-custom-server-1
|
||||
%config-empty
|
||||
%config-custom-server-2))))
|
||||
|
||||
(test-equal
|
||||
%custom-server-2
|
||||
(xorg-configuration-server
|
||||
(merge-xorg-configurations (list %config-empty
|
||||
%config-custom-server-1
|
||||
%config-custom-server-2))))
|
||||
|
||||
(test-equal
|
||||
%custom-server-1
|
||||
(xorg-configuration-server
|
||||
(merge-xorg-configurations (list %config-empty
|
||||
%config-custom-server-1))))
|
||||
|
||||
;; Make sure it works in the context of an operating-system.
|
||||
(test-equal
|
||||
%custom-server-2
|
||||
(let ((os (operating-system
|
||||
(host-name "test")
|
||||
(bootloader
|
||||
(bootloader-configuration
|
||||
(bootloader grub-bootloader)
|
||||
(targets '("/dev/sdX"))))
|
||||
(file-systems
|
||||
(cons
|
||||
(file-system
|
||||
(device (file-system-label "my-root"))
|
||||
(mount-point "/")
|
||||
(type "ext4"))
|
||||
%base-file-systems))
|
||||
(services
|
||||
(cons*
|
||||
(simple-service 'server-2 gdm-service-type
|
||||
%config-custom-server-2)
|
||||
(simple-service 'server-1 gdm-service-type
|
||||
%config-custom-server-1)
|
||||
(service gdm-service-type)
|
||||
%base-services)))))
|
||||
(xorg-configuration-server
|
||||
(gdm-configuration-xorg
|
||||
(service-value
|
||||
(fold-services
|
||||
(operating-system-services os)
|
||||
#:target-type gdm-service-type))))))
|
||||
|
||||
;; extra-config tests.
|
||||
|
||||
;; Extra configurations append.
|
||||
(let ((snippet-one "# First")
|
||||
(snippet-two "# Second"))
|
||||
(test-equal
|
||||
(list snippet-one snippet-two)
|
||||
(xorg-configuration-extra-config
|
||||
(merge-xorg-configurations
|
||||
(list (xorg-configuration (extra-config (list snippet-one)))
|
||||
(xorg-configuration (extra-config (list snippet-two))))))))
|
||||
|
||||
;; drivers tests.
|
||||
|
||||
(define %drivers-custom-1 '("done"))
|
||||
(define %drivers-custom-2 '("dtwo"))
|
||||
|
||||
(test-equal
|
||||
(append %drivers-custom-1 %drivers-custom-2)
|
||||
(xorg-configuration-drivers
|
||||
(merge-xorg-configurations
|
||||
(list
|
||||
(xorg-configuration (drivers %drivers-custom-1))
|
||||
(xorg-configuration (drivers %drivers-custom-2))))))
|
||||
|
||||
(test-end "merge-xorg-configurations")
|
||||
Loading…
Add table
Reference in a new issue