;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2021 Ludovic Courtès ;;; Copyright © 2014, 2015 Mark H Weaver ;;; Copyright © 2016, 2017, 2018, 2020, 2021, 2022 Efraim Flashner ;;; Copyright © 2016, 2017 Nikita ;;; Copyright © 2017–2021 Tobias Geerinckx-Rice ;;; Copyright © 2017, 2018, 2019, 2021 Eric Bavier ;;; Copyright © 2017 Rutger Helling ;;; Copyright © 2018 Ricardo Wurmus ;;; Copyright © 2020 Vincent Legoll ;;; Copyright © 2020 Brice Waegeneire ;;; Copyright © 2020 André Batista ;;; Copyright © 2021-2022 Danial Behzadi ;;; Copyright © 2022 Maxim Cournoyer ;;; Copyright © 2022 Jim Newsome ;;; ;;; This file is part of GNU Guix. ;;; ;;; GN
aboutsummaryrefslogtreecommitdiff
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016-2023 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2017, 2019, 2021 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2020 Danny Milosavljevic <dannym@scratchpost.org>
;;; Copyright © 2020, 2024 Janneke Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2020, 2021, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
;;;
;;; 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 (gnu tests install)
  #:use-module (gnu)
  #:use-module (gnu bootloader extlinux)
  #:use-module (gnu image)
  #:use-module (gnu tests)
  #:use-module (gnu tests base)
  #:use-module (gnu system)
  #:use-module (gnu system image)
  #:use-module (gnu system install)
  #:use-module (gnu system vm)
  #:use-module ((gnu build marionette) #:select (qemu-command))
  #:use-module (gnu packages admin)
  #:use-module (gnu packages bootloaders)
  #:use-module (gnu packages commencement)       ;for 'guile-final'
  #:use-module (gnu packages cpio)
  #: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)
  #:use-module (gnu packages package-management)
  #:use-module (gnu packages ratpoison)
  #:use-module (gnu packages suckless)
  #:use-module (gnu packages virtualization)
  #:use-module (gnu packages wm)
  #:use-module (gnu packages xorg)
  #:use-module (gnu services desktop)
  #:use-module (gnu services networking)
  #:use-module (gnu services xorg)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix packages)
  #:use-module (guix grafts)
  #:use-module (guix gexp)
  #:use-module (guix utils)
  #:use-module (srfi srfi-1)
  #:export (%test-installed-os
            %test-installed-extlinux-os
            %test-iso-image-installer
            %test-separate-store-os
            %test-separate-home-os
            %test-raid-root-os
            %test-encrypted-root-os
            %test-encrypted-home-os
            %test-encrypted-home-os-key-file
            %test-encrypted-root-not-boot-os
            %test-btrfs-root-os
            %test-btrfs-root-on-subvolume-os
            %test-btrfs-raid-root-os
            %test-btrfs-raid10-root-os
            %test-btrfs-raid10-root-os-degraded
            %test-jfs-root-os
            %test-f2fs-root-os
            %test-xfs-root-os
            %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))

;;; Commentary:
;;;
;;; Test the installation of Guix using the documented approach at the
;;; command line.
;;;
;;; Code:

(define-os-with-source (%minimal-os %minimal-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)
                 (targets (list "/dev/vdb"))))
    (kernel-arguments '("console=ttyS0"))
    (file-systems (cons (file-system
                          (device (file-system-label "my-root"))
                          (mount-point "/")
                          (type "ext4"))
                        %base-file-systems))
    (users (cons (user-account
                  (name "alice")
                  (comment "Bob's sister")
                  (group "users")
                  (supplementary-groups '("wheel" "audio" "video")))
                 %base-user-accounts))
    (services (cons (service marionette-service-type
                             (marionette-configuration
                              (imported-modules '((gnu services herd)
                                                  (guix build utils)
                                                  (guix combinators)))))
                    %base-services))))

(define (operating-system-add-packages os packages)
  "Append PACKAGES to OS packages list."
  (operating-system
    (inherit os)
    (packages (append packages (operating-system-packages os)))))

(define-os-with-source (%minimal-extlinux-os
                        %minimal-extlinux-os-source)
  (use-modules (gnu) (gnu tests) (gnu bootloader extlinux)
               (srfi srfi-1))

  (operating-system
    (host-name "liberigilo")
    (timezone "Europe/Paris")
    (locale "en_US.UTF-8")

    (bootloader (bootloader-configuration
                 (bootloader extlinux-bootloader-gpt)
                 (targets (list "/dev/vdb"))))
    (kernel-arguments '("console=ttyS0"))
    (file-systems (cons (file-system
                          (device (file-system-label "my-root"))
                          (mount-point "/")
                          (type "ext4"))
                        %base-file-systems))
    (services (cons (service marionette-service-type
                             (marionette-configuration
                              (imported-modules '((gnu services herd)
                                                  (guix combinators)))))
                    %base-services))))



(define MiB (expt 2 20))

(define %simple-installation-script
  ;; Shell script of a simple installation.
  "\
. /etc/profile
set -e -x
guix --version

export GUIX_BUILD_OPTIONS=--no-grafts
guix build isc-dhcp
parted --script /dev/vdb mklabel gpt \\
  mkpart primary ext2 1M 3M \\
  mkpart primary ext2 3M 1.6G \\
  set 1 boot on \\
  set 1 bios_grub on
mkfs.ext4 -L my-root /dev/vdb2
mount /dev/vdb2 /mnt
df -h /mnt
herd start cow-store /mnt
mkdir /mnt/etc
cp /etc/target-config.scm /mnt/etc/config.scm
guix system init /mnt/etc/config.scm /mnt --no-substitutes
sync
reboot\n")

(define %extlinux-gpt-installation-script
  ;; Shell script of a simple installation.
  ;; As syslinux 6.0.3 does not handle 64bits ext4 partitions,
  ;; we make sure to pass -O '^64bit' to mkfs.
  "\
. /etc/profile
set -e -x
guix --version

export GUIX_BUILD_OPTIONS=--no-grafts
guix build isc-dhcp
parted --script /dev/vdb mklabel gpt \\
  mkpart ext2 1M 1.6G \\
  set 1 legacy_boot on
mkfs.ext4 -L my-root -O '^64bit' /dev/vdb1
mount /dev/vdb1 /mnt
df -h /mnt
herd start cow-store /mnt
mkdir /mnt/etc
cp /etc/target-config.scm /mnt/etc/config.scm
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-x86-64 "/share/firmware/ovmf_x64.bin"))
   ((string-prefix? "i686" system)
    (file-append ovmf-i686 "/share/firmware/ovmf_ia32.bin"))
   ((string-prefix? "aarch64" system)
    (file-append ovmf-aarch64 "/share/firmware/ovmf_aarch64.bin"))
   (else #f)))

(define* (run-install target-os target-os-source
                      #:key
                      (script %simple-installation-script)
                      (gui-test #f)
                      (packages '())
                      (os (marionette-operating-system
                           (operating-system
                             ;; Since the image has no network access, use the
                             ;; current Guix so the store items we need are in
                             ;; the image and add packages provided.
                             (inherit installation-os)
                             (kernel-arguments '("console=ttyS0")))
                           #:imported-modules '((gnu services herd)
                                                (gnu installer tests)
                                                (guix combinators))))
                      (uefi-support? #f)
                      (installation-image-type 'mbr-raw)
                      (install-size 'guess)
                      (target-size (* 2200 MiB))
                      (number-of-disks 1))
  "Run SCRIPT (a shell script following the system installation procedure) in
OS to install TARGET-OS.  Return the VM disk images of TARGET-SIZE bytes
containing the installed system.  PACKAGES is a list of packages added to OS.
NUMBER-OF-DISKS can be used to specify a number of disks different than one,
such as for RAID systems."
  (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
                       ;; succeed.  Also add guile-final, which is pulled in
                       ;; through provenance.drv and may not always be present.
                       (target (operating-system-derivation target-os))
                       (base-image -> (os->image
                                       (operating-system-with-gc-roots
                                        (operating-system-add-packages
                                         os packages)
                                        (list target guile-final))
                                       #:type (lookup-image-type-by-name
                                               installation-image-type)))
                       (image ->
                              (system-image
                               (image
                                (inherit base-image)
                                (size install-size)

                                ;; Don't provide substitutes; too big.
                                (substitutable? #f)))))
    (define install
      (with-imported-modules '((guix build utils)
                               (gnu build marionette))
        #~(begin
            (use-modules (guix build utils)
                         (gnu build marionette)
                         (srfi srfi-1))

            (set-path-environment-variable "PATH" '("bin")
                                           (list #$qemu-minimal))

            (mkdir-p #$output)
            (for-each (lambda (n)
                        (system* "qemu-img" "create" "-f" "qcow2"
                                 (format #f "~a/disk~a.qcow2" #$output n)
                                 #$(number->string target-size)))
                      (iota #$number-of-disks))

            (define marionette
              (make-marionette
               `(,(which #$(qemu-command system))
                 ;; Neither of these architectures have a default machine.
                 ,@(if (or (string=? "aarch64-linux" #$system)
                           (string=? "armhf-linux" #$system))
                       '("-machine" "virt"
                         "-cpu" "host")
                       '())
                 "-no-reboot"
                 "-m" "1200"
                 ,@(if #$uefi-firmware
                       '("-bios" #$uefi-firmware)
                       '())
                 #$@(cond
                     ((eq? 'mbr-raw installation-image-type)
                      #~("-drive"
                         ,(string-append "file=" #$image
                                         ",if=virtio,readonly")))
                     ((eq? 'uncompressed-iso9660 installation-image-type)
                      #~("-cdrom" #$image))
                     (else
                      (error
                       "unsupported installation-image-type:"
                       installation-image-type)))
                 ,@(append-map
                    (lambda (n)
                      (list "-drive"
                            (format #f "file=~a/disk~a.qcow2,if=virtio"
                                    #$output n)))
                    (iota #$number-of-disks))
                 ,@(if (file-exists? "/dev/kvm")
                       '("-enable-kvm")
                       '()))))

            (pk 'uname (marionette-eval '(uname) marionette))

            ;; Wait for tty1.
            (marionette-eval '(begin
                                (use-modules (gnu services herd))
                                (start-service 'term-tty1))
                             marionette)

            (when #$(->bool script)
              (marionette-eval '(call-with-output-file "/etc/target-config.scm"
                                  (lambda (port)
                                    (write '#$target-os-source port)))
                               marionette)

              ;; Run SCRIPT.  It typically invokes 'reboot' as a last step and
              ;; thus normally gets killed with SIGTERM by PID 1.
              (let ((status (marionette-eval '(system #$script) marionette)))
                (exit (or (eof-object? status)
                          (equal? (status:term-sig status) SIGTERM)
                          (equal? (status:exit-val status) 0)))))

            (when #$(->bool gui-test)
              (wait-for-unix-socket "/var/guix/installer-socket"
                                    marionette)
              (format #t "installer socket ready~%")
              (force-output)
              (exit #$(and gui-test
                           (gui-test #~marionette)))))))

    (mlet %store-monad ((images-dir (gexp->derivation "installation"
                                      install
                                      #:substitutable? #f))) ;too big
      (return (with-imported-modules '((guix build utils))
                #~(begin
                    (use-modules (guix build utils))
                    (find-files #$images-dir)))))))

(define* (qemu-command* images #:key (uefi-support? #f) (memory-size 256))
  "Return as a monadic value the command to run QEMU with a writable overlay
on top of IMAGES, a list of disk images.  The QEMU VM has access to MEMORY-SIZE
MiB of RAM."
  (mlet* %store-monad ((system (current-system))
                       (uefi-firmware -> (and uefi-support?
                                              (uefi-firmware system))))
    (return #~(begin
                (use-modules (srfi srfi-1))
                `(,(string-append #$qemu-minimal "/bin/"
                                  #$(qemu-command system))
                  ;; Neither of these architectures have a default machine.
                  ,@(if (or (string=? "aarch64-linux" #$system)
                            (string=? "armhf-linux" #$system))
                        '("-machine" "virt"
                          "-cpu" "host")
                        '())
                  "-snapshot"           ;for the volatile, writable overlay
                  ,@(if (file-exists? "/dev/kvm")
                        '("-enable-kvm")
                        '())
                  ,@(if #$uefi-firmware
                        '("-bios" #$uefi-firmware)
                        '())
                  "-no-reboot" "-m" #$(number->string memory-size)
                  ,@(append-map (lambda (image)
                                  (list "-drive" (format #f "file=~a,if=virtio"
                                                         image)))
                                #$images))))))

(define %test-installed-os
  (system-test
   (name "installed-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 ((images   (run-install %minimal-os %minimal-os-source))
                         (command (qemu-command* images)))
      (run-basic-test %minimal-os command
                      "installed-os")))))

(define %test-installed-extlinux-os
  (system-test
   (name "installed-extlinux-os")
   (description
    "Test basic functionality of an OS booted with an extlinux bootloader.  As
per %test-installed-os, this test is expensive in terms of CPU a