tests: Add gui-uefi-installed-os test.

* gnu/installer/tests.scm (conclude-installation): Rename it into ...
(start-installation): ... this new procedure.
(complete-installation): New procedure.
(choose-partitioning): Add an uefi-support? argument.
* gnu/tests/install.scm (uefi-firmware): New procedure.
(run-install, qemu-command/writable-image, gui-test-program,
installation-target-os-for-gui-tests): Add an uefi-support? argument.
(%extra-packages): Add grub-efi, fatfsck/static and dosfstools.
(%test-gui-installed-os): New variable.

1 files changed, 99 insertions, 9 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"