mirror of
https://codeberg.org/guix/guix.git
synced 2026-01-25 03:55:08 -06:00
68e9cb0d21
* tests/services/xorg.scm: Name tests. Change-Id: I7be7438a69a5d55d5904c3b76a2888393291b6bb Signed-off-by: Efraim Flashner <efraim@flashner.co.il>
257 lines
8.7 KiB
Scheme
257 lines
8.7 KiB
Scheme
;;; 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 desktop)
|
||
#:use-module (gnu services lightdm)
|
||
#: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")))))
|
||
|
||
(test-equal "later keyboard layouts replace earlier defaults"
|
||
(keyboard-layout "us" #:options '("ctrl:nocaps"))
|
||
(xorg-configuration-keyboard-layout
|
||
(merge-xorg-configurations
|
||
(list %config-empty %config-xorg-keyboard-layout-1))))
|
||
|
||
(test-equal "later keyboard layouts replace earlier customizations"
|
||
(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)))
|
||
|
||
(test-equal "custom server is prioritized over earlier default"
|
||
%custom-server-1
|
||
(xorg-configuration-server
|
||
(merge-xorg-configurations (list %config-empty
|
||
%config-custom-server-1))))
|
||
|
||
(test-equal "custom server preserves arguments"
|
||
(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))))
|
||
|
||
(test-equal "later custom arguments replace earlier"
|
||
(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))))
|
||
|
||
(test-equal "custom server is prioritized over later default"
|
||
%custom-server-1
|
||
(xorg-configuration-server
|
||
(merge-xorg-configurations (list %config-custom-server-1
|
||
%config-empty))))
|
||
|
||
(test-equal "custom arguments are prioritized over earlier custom server"
|
||
%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))))))
|
||
|
||
(test-equal "later custom servers are prioritized over earlier 1/3"
|
||
%custom-server-2
|
||
(xorg-configuration-server
|
||
(merge-xorg-configurations (list %config-custom-server-1
|
||
%config-empty
|
||
%config-custom-server-2))))
|
||
|
||
(test-equal "later custom servers are prioritized over earlier 2/3"
|
||
%custom-server-2
|
||
(xorg-configuration-server
|
||
(merge-xorg-configurations (list %config-empty
|
||
%config-custom-server-1
|
||
%config-custom-server-2))))
|
||
|
||
(test-equal "later custom servers are prioritized over earlier 3/3"
|
||
%custom-server-1
|
||
(xorg-configuration-server
|
||
(merge-xorg-configurations (list %config-empty
|
||
%config-custom-server-1))))
|
||
|
||
(test-equal "in the context of an operating-system"
|
||
%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.
|
||
|
||
(let ((snippet-one "# First")
|
||
(snippet-two "# Second"))
|
||
(test-equal "extra configurations append"
|
||
(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 "drivers append"
|
||
(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))))))
|
||
|
||
;; regression tests.
|
||
|
||
;; https://codeberg.org/guix/guix/issues/5267
|
||
(test-equal "https://codeberg.org/guix/guix/issues/5267"
|
||
(xorg-configuration-keyboard-layout %config-xorg-keyboard-layout-1)
|
||
(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*
|
||
(service lightdm-service-type
|
||
(lightdm-configuration
|
||
(xorg-configuration
|
||
%config-xorg-keyboard-layout-1)))
|
||
(modify-services %desktop-services
|
||
(delete gdm-service-type)))))))
|
||
(xorg-configuration-keyboard-layout
|
||
(lightdm-configuration-xorg-configuration
|
||
(service-value
|
||
(fold-services
|
||
(operating-system-services os)
|
||
#:target-type lightdm-service-type))))))
|
||
|
||
(test-end "merge-xorg-configurations")
|