diff options
Diffstat (limited to 'gnu/tests')
| -rw-r--r-- | gnu/tests/install.scm | 108 | ||||
| -rw-r--r-- | gnu/tests/linux-modules.scm | 80 |
2 files changed, 169 insertions, 19 deletions
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm index 4b8963eadd..b5263f5f0d 100644 --- a/gnu/tests/install.scm +++ b/gnu/tests/install.scm @@ -36,8 +36,10 @@ #:use-module (gnu packages bootloaders) #:use-module (gnu packages commencement) ;for 'guile-final' #:use-module (gnu packages cryptsetup) + #:use-module (gnu packages disk) #:use-module (gnu packages emacs) #:use-module (gnu packages emacs-xyz) + #:use-module (gnu packages firmware) #:use-module (gnu packages linux) #:use-module (gnu packages ocr) #:use-module (gnu packages openbox) @@ -73,6 +75,7 @@ %test-lvm-separate-home-os %test-gui-installed-os + %test-gui-uefi-installed-os %test-gui-installed-os-encrypted %test-gui-installed-desktop-os-encrypted)) @@ -206,6 +209,15 @@ guix system init /mnt/etc/config.scm /mnt --no-substitutes sync reboot\n") +(define (uefi-firmware system) + "Return the appropriate QEMU OVMF UEFI firmware for the given SYSTEM." + (cond + ((string-prefix? "x86_64" system) + (file-append ovmf "/share/firmware/ovmf_x64.bin")) + ((string-prefix? "i686" system) + (file-append ovmf "/share/firmware/ovmf_ia32.bin")) + (else #f))) + (define* (run-install target-os target-os-source #:key (script %simple-installation-script) @@ -224,6 +236,7 @@ reboot\n") #:imported-modules '((gnu services herd) (gnu installer tests) (guix combinators)))) + (uefi-support? #f) (installation-image-type 'efi-raw) (install-size 'guess) (target-size (* 2200 MiB))) @@ -235,6 +248,8 @@ packages defined in installation-os." (mlet* %store-monad ((_ (set-grafting #f)) (system (current-system)) + (uefi-firmware -> (and uefi-support? + (uefi-firmware system))) ;; Since the installation system has no network access, ;; we cheat a little bit by adding TARGET to its GC ;; roots. This way, we know 'guix system init' will @@ -273,6 +288,9 @@ packages defined in installation-os." `(,(which #$(qemu-command system)) "-no-reboot" "-m" "1200" + ,@(if #$uefi-firmware + '("-bios" #$uefi-firmware) + '()) #$@(cond ((eq? 'efi-raw installation-image-type) #~("-drive" @@ -322,10 +340,15 @@ packages defined in installation-os." (gexp->derivation "installation" install #:substitutable? #f))) ;too big -(define* (qemu-command/writable-image image #:key (memory-size 256)) +(define* (qemu-command/writable-image image + #:key + (uefi-support? #f) + (memory-size 256)) "Return as a monadic value the command to run QEMU on a writable copy of IMAGE, a disk image. The QEMU VM has access to MEMORY-SIZE MiB of RAM." - (mlet %store-monad ((system (current-system))) + (mlet* %store-monad ((system (current-system)) + (uefi-firmware -> (and uefi-support? + (uefi-firmware system)))) (return #~(let ((image #$image)) ;; First we need a writable copy of the image. (format #t "creating writable image from '~a'...~%" image) @@ -343,6 +366,9 @@ IMAGE, a disk image. The QEMU VM has access to MEMORY-SIZE MiB of RAM." ,@(if (file-exists? "/dev/kvm") '("-enable-kvm") '()) + ,@(if #$uefi-firmware + '("-bios" #$uefi-firmware) + '()) "-no-reboot" "-m" #$(number->string memory-size) "-drive" "file=disk.img,if=virtio"))))) @@ -1400,7 +1426,9 @@ build (current-guix) and then store a couple of full system images.") (define* (gui-test-program marionette #:key (desktop? #f) - (encrypted? #f)) + (encrypted? #f) + (uefi-support? #f) + (system (%current-system))) #~(let () (define (screenshot file) (marionette-control (string-append "screendump " file) @@ -1466,7 +1494,8 @@ build (current-guix) and then store a couple of full system images.") (marionette-eval* '(choose-partitioning installer-socket #:encrypted? #$encrypted? - #:passphrase #$%luks-passphrase) + #:passphrase #$%luks-passphrase + #:uefi-support? #$uefi-support?) #$marionette) (screenshot "installer-run.ppm") @@ -1480,9 +1509,43 @@ build (current-guix) and then store a couple of full system images.") "/dev/vda2") #$marionette)) - (marionette-eval* '(conclude-installation installer-socket) + (marionette-eval* '(start-installation installer-socket) #$marionette) + ;; XXX: The grub-install process uses efibootmgr to add an UEFI Guix + ;; boot entry. The corresponding UEFI variable is stored in RAM, and + ;; possibly saved persistently on QEMU reboot in a NvVars file, see: + ;; https://lists.gnu.org/archive/html/qemu-discuss/2018-04/msg00045.html. + ;; + ;; As we are running QEMU with the no-reboot flag, this variable is + ;; never saved persistently, QEMU fails to boot the installed system and + ;; an UEFI shell is displayed instead. + ;; + ;; To make the installed UEFI system bootable, register Grub as the + ;; default UEFI boot entry, in the same way as if grub-install was + ;; invoked with the --removable option. + (when #$uefi-support? + (marionette-eval* + '(begin + (use-modules (ice-9 match)) + (let ((targets (cond + ((string-prefix? "x86_64" #$system) + '("grubx64.efi" "BOOTX64.EFI")) + ((string-prefix? "i686" #$system) + '("grubia32.efi" "BOOTIA32.EFI")) + (else #f)))) + (match targets + ((src dest) + (rename-file "/mnt/boot/efi/EFI/Guix" + "/mnt/boot/efi/EFI/BOOT") + (rename-file + (string-append "/mnt/boot/efi/EFI/BOOT/" src) + (string-append "/mnt/boot/efi/EFI/BOOT/" dest))) + (_ #f)))) + #$marionette)) + + (marionette-eval* '(complete-installation installer-socket) + #$marionette) (sync) #t)) @@ -1490,7 +1553,7 @@ build (current-guix) and then store a couple of full system images.") ;; Packages needed when installing with an encrypted root. (list isc-dhcp lvm2-static cryptsetup-static e2fsck/static - loadkeys-static)) + loadkeys-static grub-efi fatfsck/static dosfstools)) (define installation-os-for-gui-tests ;; Operating system that contains all of %EXTRA-PACKAGES, needed for the @@ -1509,9 +1572,22 @@ build (current-guix) and then store a couple of full system images.") (guix combinators)))) (define* (installation-target-os-for-gui-tests - #:key (encrypted? #f)) + #:key + (encrypted? #f) + (uefi-support? #f)) (operating-system (inherit %minimal-os-on-vda) + (file-systems `(,(file-system + (device (file-system-label "my-root")) + (mount-point "/") + (type "ext4")) + ,@(if uefi-support? + (list (file-system + (device (uuid "1234-ABCD" 'fat)) + (mount-point "/boot/efi") + (type "vfat"))) + '()) + ,@%base-file-systems)) (users (append (list (user-account (name "alice") (comment "Bob's sister") @@ -1569,6 +1645,7 @@ build (current-guix) and then store a couple of full system images.") #:key (desktop? #f) (encrypted? #f) + (uefi-support? #f) target-os (install-size 'guess) (target-size (* 2200 MiB))) @@ -1581,6 +1658,7 @@ build (current-guix) and then store a couple of full system images.") ((image (run-install target-os '(this is unused) #:script #f #:os installation-os-for-gui-tests + #:uefi-support? uefi-support? #:install-size install-size #:target-size target-size #:installation-image-type @@ -1590,8 +1668,11 @@ build (current-guix) and then store a couple of full system images.") (gui-test-program marionette #:desktop? desktop? - #:encrypted? encrypted?)))) - (command (qemu-command/writable-image image #:memory-size 512))) + #:encrypted? encrypted? + #:uefi-support? uefi-support?)))) + (command (qemu-command/writable-image image + #:uefi-support? uefi-support? + #:memory-size 512))) (run-basic-test target-os command name #:initialization (and encrypted? enter-luks-passphrase) #:root-password %root-password @@ -1602,6 +1683,15 @@ build (current-guix) and then store a couple of full system images.") "gui-installed-os" #:target-os (installation-target-os-for-gui-tests))) +;; Test the UEFI installation of Guix System using the graphical installer. +(define %test-gui-uefi-installed-os + (guided-installation-test + "gui-uefi-installed-os" + #:uefi-support? #t + #:target-os (installation-target-os-for-gui-tests + #:uefi-support? #t) + #:target-size (* 3200 MiB))) + (define %test-gui-installed-os-encrypted (guided-installation-test "gui-installed-os-encrypted" diff --git a/gnu/tests/linux-modules.scm b/gnu/tests/linux-modules.scm index 953b132ef7..30d8eae03b 100644 --- a/gnu/tests/linux-modules.scm +++ b/gnu/tests/linux-modules.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2019 Jakob L. Kreuze <zerodaysfordays@sdf.org> ;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org> ;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re> +;;; Copyright © 2021 raid5atemyhomework <raid5atemyhomework@protonmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -34,7 +35,10 @@ #:use-module (guix utils) #:export (%test-loadable-kernel-modules-0 %test-loadable-kernel-modules-1 - %test-loadable-kernel-modules-2)) + %test-loadable-kernel-modules-2 + %test-loadable-kernel-modules-service-0 + %test-loadable-kernel-modules-service-1 + %test-loadable-kernel-modules-service-2)) ;;; Commentary: ;;; @@ -66,17 +70,11 @@ that MODULES are actually loaded." (member module modules string=?)) '#$modules)))))) -(define* (run-loadable-kernel-modules-test module-packages module-names) - "Run a test of an OS having MODULE-PACKAGES, and verify that MODULE-NAMES -are loaded in memory." +(define* (run-loadable-kernel-modules-test-base base-os module-names) + "Run a test of BASE-OS, verifying that MODULE-NAMES are loaded in memory." (define os (marionette-operating-system - (operating-system - (inherit (simple-operating-system)) - (services (cons (service kernel-module-loader-service-type module-names) - (operating-system-user-services - (simple-operating-system)))) - (kernel-loadable-modules module-packages)) + base-os #:imported-modules '((guix combinators)))) (define vm (virtual-machine os)) (define (test script) @@ -98,6 +96,36 @@ are loaded in memory." (gexp->derivation "loadable-kernel-modules" (test (modules-loaded?-program os module-names)))) +(define* (run-loadable-kernel-modules-test module-packages module-names) + "Run a test of an OS having MODULE-PACKAGES, and verify that MODULE-NAMES +are loaded in memory." + (run-loadable-kernel-modules-test-base + (operating-system + (inherit (simple-operating-system)) + (services (cons (service kernel-module-loader-service-type module-names) + (operating-system-user-services + (simple-operating-system)))) + (kernel-loadable-modules module-packages)) + module-names)) + +(define* (run-loadable-kernel-modules-service-test module-packages module-names) + "Run a test of an OS having MODULE-PACKAGES, which are loaded by creating a +service that extends LINUXL-LOADABLE-MODULE-SERVICE-TYPE. Then verify that +MODULE-NAMES are loaded in memory." + (define module-installing-service-type + (service-type + (name 'module-installing-service) + (extensions (list (service-extension linux-loadable-module-service-type + (const module-packages)))) + (default-value #f))) + (run-loadable-kernel-modules-test-base + (operating-system + (inherit (simple-operating-system)) + (services (cons* (service module-installing-service-type) + (operating-system-user-services + (simple-operating-system))))) + module-names)) + (define %test-loadable-kernel-modules-0 (system-test (name "loadable-kernel-modules-0") @@ -129,3 +157,35 @@ with two extra modules.") (package-arguments ddcci-driver-linux)))))) '("acpi_call" "ddcci"))))) + +(define %test-loadable-kernel-modules-service-0 + (system-test + (name "loadable-kernel-modules-service-0") + (description "Tests loadable kernel modules extensible service with no +extra modules.") + (value (run-loadable-kernel-modules-service-test '() '())))) + +(define %test-loadable-kernel-modules-service-1 + (system-test + (name "loadable-kernel-modules-service-1") + (description "Tests loadable kernel modules extensible service with one +extra module.") + (value (run-loadable-kernel-modules-service-test + (list ddcci-driver-linux) + '("ddcci"))))) + +(define %test-loadable-kernel-modules-service-2 + (system-test + (name "loadable-kernel-modules-service-2") + (description "Tests loadable kernel modules extensible service with two +extra modules.") + (value (run-loadable-kernel-modules-service-test + (list acpi-call-linux-module + (package + (inherit ddcci-driver-linux) + (arguments + `(#:linux #f + ,@(strip-keyword-arguments '(#:linux) + (package-arguments + ddcci-driver-linux)))))) + '("acpi_call" "ddcci"))))) |