diff options
Diffstat (limited to 'gnu/tests')
| -rw-r--r-- | gnu/tests/install.scm | 108 | ||||
| -rw-r--r-- | gnu/tests/ldap.scm | 4 | ||||
| -rw-r--r-- | gnu/tests/web.scm | 61 |
3 files changed, 135 insertions, 38 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/ldap.scm b/gnu/tests/ldap.scm index 2d4f15fb3c..197c1bfb28 100644 --- a/gnu/tests/ldap.scm +++ b/gnu/tests/ldap.scm @@ -84,7 +84,7 @@ config_version = 2 \n[slapd] -root_password = SECRET +root_password = SECRET_PASS user = root group = root @@ -112,7 +112,7 @@ suffix = dc=example,dc=com"))) (marionette-eval '(zero? (system* #$(file-append openldap "/bin/ldapwhoami") "-H" "ldap://localhost" "-D" - "cn=Directory Manager" "-w" "SECRET")) + "cn=Directory Manager" "-w" "SECRET_PASS")) marionette)) ;; Wait for nslcd to be up and running. diff --git a/gnu/tests/web.scm b/gnu/tests/web.scm index 7f4518acd2..61575f497d 100644 --- a/gnu/tests/web.scm +++ b/gnu/tests/web.scm @@ -65,6 +65,26 @@ (lambda (port) (display #$%index.html-contents port))))) +(define retry-on-error + #~(lambda* (f #:key times delay) + (let loop ((attempt 1)) + (match (catch + #t + (lambda () + (cons #t + (f))) + (lambda args + (cons #f + args))) + ((#t . return-value) + return-value) + ((#f . error-args) + (if (>= attempt times) + error-args + (begin + (sleep delay) + (loop (+ 1 attempt))))))))) + (define* (run-webserver-test name test-os #:key (log-file #f) (http-port 8080)) "Run tests in %NGINX-OS, which has nginx running and listening on HTTP-PORT." @@ -472,28 +492,9 @@ HTTP-PORT." (start-service 'tailon)) marionette)) - (define* (retry-on-error f #:key times delay) - (let loop ((attempt 1)) - (match (catch - #t - (lambda () - (cons #t - (f))) - (lambda args - (cons #f - args))) - ((#t . return-value) - return-value) - ((#f . error-args) - (if (>= attempt times) - error-args - (begin - (sleep delay) - (loop (+ 1 attempt)))))))) - (test-equal "http-get" 200 - (retry-on-error + (#$retry-on-error (lambda () (let-values (((response text) (http-get #$(format @@ -607,12 +608,14 @@ HTTP-PORT." (define vm (virtual-machine (operating-system os) - (port-forwardings `((8080 . ,forwarded-port))))) + (port-forwardings `((8080 . ,forwarded-port))) + (memory-size 1024))) (define test (with-imported-modules '((gnu build marionette)) #~(begin (use-modules (srfi srfi-11) (srfi srfi-64) + (ice-9 match) (gnu build marionette) (web uri) (web client) @@ -647,12 +650,16 @@ HTTP-PORT." (test-equal "http-get" 200 - (let-values - (((response text) - (http-get #$(simple-format - #f "http://localhost:~A/" forwarded-port) - #:decode-body? #t))) - (response-code response))) + (#$retry-on-error + (lambda () + (let-values + (((response text) + (http-get #$(simple-format + #f "http://localhost:~A/" forwarded-port) + #:decode-body? #t))) + (response-code response))) + #:times 10 + #:delay 5)) (test-end) (exit (= (test-runner-fail-count (test-runner-current)) 0))))) |