diff --git a/gnu/services/xorg.scm b/gnu/services/xorg.scm index 25f44566beb..313023f38a0 100644 --- a/gnu/services/xorg.scm +++ b/gnu/services/xorg.scm @@ -16,6 +16,7 @@ ;;; Copyright © 2023 muradm ;;; Copyright © 2024 Zheng Junjie <873216071@qq.com> ;;; Copyright © 2024 Tomas Volf <~@wolfsden.cz> +;;; Copyright © 2025 Ian Eure ;;; ;;; 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 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 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 objects. diff --git a/tests/services/xorg.scm b/tests/services/xorg.scm new file mode 100644 index 00000000000..0bb4a3e14cf --- /dev/null +++ b/tests/services/xorg.scm @@ -0,0 +1,232 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2025 Ian Eure +;;; +;;; 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 . + +(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")