+\f
+;;;
+;;; Btrfs root file system on a subvolume.
+;;;
+
+(define-os-with-source (%btrfs-root-on-subvolume-os
+ %btrfs-root-on-subvolume-os-source)
+ ;; The OS we want to install.
+ (use-modules (gnu) (gnu tests) (srfi srfi-1))
+
+ (operating-system
+ (host-name "hurd")
+ (timezone "America/Montreal")
+ (locale "en_US.UTF-8")
+ (bootloader (bootloader-configuration
+ (bootloader grub-bootloader)
+ (target "/dev/vdb")))
+ (kernel-arguments '("console=ttyS0"))
+ (file-systems (cons* (file-system
+ (device (file-system-label "btrfs-pool"))
+ (mount-point "/")
+ (options "subvol=rootfs,compress=zstd")
+ (type "btrfs"))
+ (file-system
+ (device (file-system-label "btrfs-pool"))
+ (mount-point "/home")
+ (options "subvol=homefs,compress=lzo")
+ (type "btrfs"))
+ %base-file-systems))
+ (users (cons (user-account
+ (name "charlie")
+ (group "users")
+ (supplementary-groups '("wheel" "audio" "video")))
+ %base-user-accounts))
+ (services (cons (service marionette-service-type
+ (marionette-configuration
+ (imported-modules '((gnu services herd)
+ (guix combinators)))))
+ %base-services))))
+
+(define %btrfs-root-on-subvolume-installation-script
+ ;; Shell script of a simple installation.
+ "\
+. /etc/profile
+set -e -x
+guix --version
+
+export GUIX_BUILD_OPTIONS=--no-grafts
+ls -l /run/current-system/gc-roots
+parted --script /dev/vdb mklabel gpt \\
+ mkpart primary ext2 1M 3M \\
+ mkpart primary ext2 3M 2G \\
+ set 1 boot on \\
+ set 1 bios_grub on
+
+# Setup the top level Btrfs file system with its subvolume.
+mkfs.btrfs -L btrfs-pool /dev/vdb2
+mount /dev/vdb2 /mnt
+btrfs subvolume create /mnt/rootfs
+btrfs subvolume create /mnt/homefs
+umount /dev/vdb2
+
+# Mount the subvolumes, ready for installation.
+mount LABEL=btrfs-pool -o 'subvol=rootfs,compress=zstd' /mnt
+mkdir /mnt/home
+mount LABEL=btrfs-pool -o 'subvol=homefs,compress=zstd' /mnt/home
+
+herd start cow-store /mnt
+mkdir /mnt/etc
+cp /etc/target-config.scm /mnt/etc/config.scm
+guix system build /mnt/etc/config.scm
+guix system init /mnt/etc/config.scm /mnt --no-substitutes
+sync
+reboot\n")
+
+(define %test-btrfs-root-on-subvolume-os
+ (system-test
+ (name "btrfs-root-on-subvolume-os")
+ (description
+ "Test basic functionality of an OS installed like one would do by hand.
+This test is expensive in terms of CPU and storage usage since we need to
+build (current-guix) and then store a couple of full system images.")
+ (value
+ (mlet* %store-monad
+ ((image
+ (run-install %btrfs-root-on-subvolume-os
+ %btrfs-root-on-subvolume-os-source
+ #:script
+ %btrfs-root-on-subvolume-installation-script))
+ (command (qemu-command/writable-image image)))
+ (run-basic-test %btrfs-root-on-subvolume-os command
+ "btrfs-root-on-subvolume-os")))))
+
+\f
+;;;
+;;; JFS root file system.
+;;;
+
+(define-os-with-source (%jfs-root-os %jfs-root-os-source)
+ ;; The OS we want to install.
+ (use-modules (gnu) (gnu tests) (srfi srfi-1))
+
+ (operating-system
+ (host-name "liberigilo")
+ (timezone "Europe/Paris")
+ (locale "en_US.UTF-8")
+
+ (bootloader (bootloader-configuration
+ (bootloader grub-bootloader)
+ (target "/dev/vdb")))
+ (kernel-arguments '("console=ttyS0"))
+ (file-systems (cons (file-system
+ (device (file-system-label "my-root"))
+ (mount-point "/")
+ (type "jfs"))
+ %base-file-systems))
+ (users (cons (user-account
+ (name "charlie")
+ (group "users")
+ (supplementary-groups '("wheel" "audio" "video")))
+ %base-user-accounts))
+ (services (cons (service marionette-service-type
+ (marionette-configuration
+ (imported-modules '((gnu services herd)
+ (guix combinators)))))
+ %base-services))))
+
+(define %jfs-root-installation-script
+ ;; Shell script of a simple installation.
+ "\
+. /etc/profile
+set -e -x
+guix --version
+
+export GUIX_BUILD_OPTIONS=--no-grafts
+ls -l /run/current-system/gc-roots
+parted --script /dev/vdb mklabel gpt \\
+ mkpart primary ext2 1M 3M \\
+ mkpart primary ext2 3M 2G \\
+ set 1 boot on \\
+ set 1 bios_grub on
+jfs_mkfs -L my-root -q /dev/vdb2
+mount /dev/vdb2 /mnt
+herd start cow-store /mnt
+mkdir /mnt/etc
+cp /etc/target-config.scm /mnt/etc/config.scm
+guix system build /mnt/etc/config.scm
+guix system init /mnt/etc/config.scm /mnt --no-substitutes
+sync
+reboot\n")
+
+(define %test-jfs-root-os
+ (system-test
+ (name "jfs-root-os")
+ (description
+ "Test basic functionality of an OS installed like one would do by hand.
+This test is expensive in terms of CPU and storage usage since we need to
+build (current-guix) and then store a couple of full system images.")
+ (value
+ (mlet* %store-monad ((image (run-install %jfs-root-os
+ %jfs-root-os-source
+ #:script
+ %jfs-root-installation-script))
+ (command (qemu-command/writable-image image)))
+ (run-basic-test %jfs-root-os command "jfs-root-os")))))
+
+\f
+;;;
+;;; F2FS root file system.
+;;;
+
+(define-os-with-source (%f2fs-root-os %f2fs-root-os-source)
+ ;; The OS we want to install.
+ (use-modules (gnu) (gnu tests) (srfi srfi-1))
+
+ (operating-system
+ (host-name "liberigilo")
+ (timezone "Europe/Paris")
+ (locale "en_US.UTF-8")
+
+ (bootloader (bootloader-configuration
+ (bootloader grub-bootloader)
+ (target "/dev/vdb")))
+ (kernel-arguments '("console=ttyS0"))
+ (file-systems (cons (file-system
+ (device (file-system-label "my-root"))
+ (mount-point "/")
+ (type "f2fs"))
+ %base-file-systems))
+ (users (cons (user-account
+ (name "charlie")
+ (group "users")
+ (supplementary-groups '("wheel" "audio" "video")))
+ %base-user-accounts))
+ (services (cons (service marionette-service-type
+ (marionette-configuration
+ (imported-modules '((gnu services herd)
+ (guix combinators)))))
+ %base-services))))
+
+(define %f2fs-root-installation-script
+ ;; Shell script of a simple installation.
+ "\
+. /etc/profile
+set -e -x
+guix --version
+
+export GUIX_BUILD_OPTIONS=--no-grafts
+ls -l /run/current-system/gc-roots
+parted --script /dev/vdb mklabel gpt \\
+ mkpart primary ext2 1M 3M \\
+ mkpart primary ext2 3M 2G \\
+ set 1 boot on \\
+ set 1 bios_grub on
+mkfs.f2fs -l my-root -q /dev/vdb2
+mount /dev/vdb2 /mnt
+herd start cow-store /mnt
+mkdir /mnt/etc
+cp /etc/target-config.scm /mnt/etc/config.scm
+guix system build /mnt/etc/config.scm
+guix system init /mnt/etc/config.scm /mnt --no-substitutes
+sync
+reboot\n")
+
+(define %test-f2fs-root-os
+ (system-test
+ (name "f2fs-root-os")
+ (description
+ "Test basic functionality of an OS installed like one would do by hand.
+This test is expensive in terms of CPU and storage usage since we need to
+build (current-guix) and then store a couple of full system images.")
+ (value
+ (mlet* %store-monad ((image (run-install %f2fs-root-os
+ %f2fs-root-os-source
+ #:script
+ %f2fs-root-installation-script))
+ (command (qemu-command/writable-image image)))
+ (run-basic-test %f2fs-root-os command "f2fs-root-os")))))
+
+\f
+;;;
+;;; Installation through the graphical interface.
+;;;
+
+(define %syslog-conf
+ ;; Syslog configuration that dumps to /dev/console, so we can see the
+ ;; installer's messages during the test.
+ (computed-file "syslog.conf"
+ #~(begin
+ (copy-file #$%default-syslog.conf #$output)
+ (chmod #$output #o644)
+ (let ((port (open-file #$output "a")))
+ (display "\n*.info /dev/console\n" port)
+ #t))))
+
+(define (operating-system-with-console-syslog os)
+ "Return OS with a syslog service that writes to /dev/console."
+ (operating-system
+ (inherit os)
+ (services (modify-services (operating-system-user-services os)
+ (syslog-service-type config
+ =>
+ (syslog-configuration
+ (inherit config)
+ (config-file %syslog-conf)))))))
+
+(define %root-password "foo")
+
+(define* (gui-test-program marionette
+ #:key
+ (desktop? #f)
+ (encrypted? #f))
+ #~(let ()
+ (define (screenshot file)
+ (marionette-control (string-append "screendump " file)
+ #$marionette))
+
+ (define-syntax-rule (marionette-eval* exp marionette)
+ (or (marionette-eval exp marionette)
+ (throw 'marionette-eval-failure 'exp)))
+
+ (setvbuf (current-output-port) 'none)
+ (setvbuf (current-error-port) 'none)
+
+ (marionette-eval* '(use-modules (gnu installer tests))
+ #$marionette)
+
+ ;; Arrange so that 'converse' prints debugging output to the console.
+ (marionette-eval* '(let ((console (open-output-file "/dev/console")))
+ (setvbuf console 'none)
+ (conversation-log-port console))
+ #$marionette)
+
+ ;; Tell the installer to not wait for the Connman "online" status.
+ (marionette-eval* '(call-with-output-file "/tmp/installer-assume-online"
+ (const #t))
+ #$marionette)
+
+ ;; Run 'guix system init' with '--no-grafts', to cope with the lack of
+ ;; network access.
+ (marionette-eval* '(call-with-output-file
+ "/tmp/installer-system-init-options"
+ (lambda (port)
+ (write '("--no-grafts" "--no-substitutes")
+ port)))
+ #$marionette)
+
+ (marionette-eval* '(define installer-socket
+ (open-installer-socket))
+ #$marionette)
+ (screenshot "installer-start.ppm")
+
+ (marionette-eval* '(choose-locale+keyboard installer-socket)
+ #$marionette)
+ (screenshot "installer-locale.ppm")
+
+ ;; Choose the host name that the "basic" test expects.
+ (marionette-eval* '(enter-host-name+passwords installer-socket
+ #:host-name "liberigilo"
+ #:root-password
+ #$%root-password
+ #:users
+ '(("alice" "pass1")
+ ("bob" "pass2")))
+ #$marionette)
+ (screenshot "installer-services.ppm")
+
+ (marionette-eval* '(choose-services installer-socket
+ #:choose-desktop-environment?
+ (const #$desktop?)
+ #:choose-network-service?
+ (const #f))
+ #$marionette)
+ (screenshot "installer-partitioning.ppm")
+
+ (marionette-eval* '(choose-partitioning installer-socket
+ #:encrypted? #$encrypted?
+ #:passphrase #$%luks-passphrase)
+ #$marionette)
+ (screenshot "installer-run.ppm")
+
+ (marionette-eval* '(conclude-installation installer-socket)
+ #$marionette)
+
+ (sync)
+ #t))
+
+(define %extra-packages
+ ;; Packages needed when installing with an encrypted root.
+ (list isc-dhcp
+ lvm2-static cryptsetup-static e2fsck/static
+ loadkeys-static))
+
+(define installation-os-for-gui-tests
+ ;; Operating system that contains all of %EXTRA-PACKAGES, needed for the
+ ;; target OS, as well as syslog output redirected to the console so we can
+ ;; see what the installer is up to.
+ (marionette-operating-system
+ (operating-system
+ (inherit (operating-system-with-console-syslog
+ (operating-system-add-packages
+ (operating-system-with-current-guix
+ installation-os)
+ %extra-packages)))
+ (kernel-arguments '("console=ttyS0")))
+ #:imported-modules '((gnu services herd)
+ (gnu installer tests)
+ (guix combinators))))
+
+(define* (installation-target-os-for-gui-tests
+ #:key (encrypted? #f))
+ (operating-system
+ (inherit %minimal-os-on-vda)
+ (users (append (list (user-account
+ (name "alice")
+ (comment "Bob's sister")
+ (group "users")
+ (supplementary-groups
+ '("wheel" "audio" "video")))
+ (user-account
+ (name "bob")
+ (comment "Alice's brother")
+ (group "users")
+ (supplementary-groups
+ '("wheel" "audio" "video"))))
+ %base-user-accounts))
+ ;; The installer does not create a swap device in guided mode with
+ ;; encryption support.
+ (swap-devices (if encrypted? '() '("/dev/vda2")))
+ (services (cons (service dhcp-client-service-type)
+ (operating-system-user-services %minimal-os-on-vda)))))
+
+(define* (installation-target-desktop-os-for-gui-tests
+ #:key (encrypted? #f))
+ (operating-system
+ (inherit (installation-target-os-for-gui-tests
+ #:encrypted? encrypted?))
+ (keyboard-layout (keyboard-layout "us" "altgr-intl"))
+
+ ;; Make sure that all the packages and services that may be used by the
+ ;; graphical installer are available.
+ (packages (append
+ (list openbox awesome i3-wm i3status
+ dmenu st ratpoison xterm)
+ %base-packages))
+ (services
+ (append
+ (list (service gnome-desktop-service-type)
+ (service xfce-desktop-service-type)
+ (service mate-desktop-service-type)
+ (service enlightenment-desktop-service-type)
+ (set-xorg-configuration
+ (xorg-configuration
+ (keyboard-layout keyboard-layout)))
+ (service marionette-service-type
+ (marionette-configuration
+ (imported-modules '((gnu services herd)
+ (guix build utils)
+ (guix combinators))))))
+ %desktop-services))))
+
+(define* (guided-installation-test name
+ #:key
+ (desktop? #f)
+ (encrypted? #f)
+ target-os
+ (install-size 'guess)
+ (target-size (* 2200 MiB)))
+ (system-test
+ (name name)
+ (description
+ "Install an OS using the graphical installer and test it.")
+ (value
+ (mlet* %store-monad
+ ((image (run-install target-os '(this is unused)
+ #:script #f
+ #:os installation-os-for-gui-tests
+ #:install-size install-size
+ #:target-size target-size
+ #:installation-image-type
+ 'uncompressed-iso9660
+ #:gui-test
+ (lambda (marionette)
+ (gui-test-program
+ marionette
+ #:desktop? desktop?
+ #:encrypted? encrypted?))))
+ (command (qemu-command/writable-image image #:memory-size 512)))
+ (run-basic-test target-os command name
+ #:initialization (and encrypted? enter-luks-passphrase)
+ #:root-password %root-password
+ #:desktop? desktop?)))))
+
+(define %test-gui-installed-os
+ (guided-installation-test
+ "gui-installed-os"
+ #:target-os (installation-target-os-for-gui-tests)))
+
+(define %test-gui-installed-os-encrypted
+ (guided-installation-test
+ "gui-installed-os-encrypted"
+ #:encrypted? #t
+ #:target-os (installation-target-os-for-gui-tests
+ #:encrypted? #t)))
+
+;; Building a desktop image is very time and space consuming. Install all
+;; desktop environments in a single test to reduce the overhead.
+(define %test-gui-installed-desktop-os-encrypted
+ (guided-installation-test "gui-installed-desktop-os-encrypted"
+ #:desktop? #t
+ #:encrypted? #t
+ #:target-os
+ (installation-target-desktop-os-for-gui-tests
+ #:encrypted? #t)
+ ;; XXX: The disk-image size guess is too low. Use
+ ;; a constant value until this is fixed.
+ #:install-size (* 8000 MiB)
+ #:target-size (* 9000 MiB)))
+