tests: install: Generalize 'run-install'.
* gnu/tests/install.scm (%simple-installation-script): New variable. Contains installation script formerly in 'run-install'. (run-install): Add 'target-os', 'target-os-source', and #:script parameters. Honor them. (qemu-command/writable-image): New procedure. (%test-installed-os): Use it.master
Ludovic Courtès
parent
2bdd7ac17c
commit
b1bf155ffd
|
|
@ -32,7 +32,8 @@
|
||||||
#:use-module (guix grafts)
|
#:use-module (guix grafts)
|
||||||
#:use-module (guix gexp)
|
#:use-module (guix gexp)
|
||||||
#:use-module (guix utils)
|
#:use-module (guix utils)
|
||||||
#:export (%test-installed-os))
|
#:export (%test-installed-os
|
||||||
|
%test-encrypted-os))
|
||||||
|
|
||||||
;;; Commentary:
|
;;; Commentary:
|
||||||
;;;
|
;;;
|
||||||
|
|
@ -91,7 +92,33 @@
|
||||||
|
|
||||||
(define MiB (expt 2 20))
|
(define MiB (expt 2 20))
|
||||||
|
|
||||||
(define* (run-install #:key
|
(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 1G \\
|
||||||
|
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* (run-install target-os target-os-source
|
||||||
|
#:key
|
||||||
|
(script %simple-installation-script)
|
||||||
(os (marionette-operating-system
|
(os (marionette-operating-system
|
||||||
;; Since the image has no network access, use the
|
;; Since the image has no network access, use the
|
||||||
;; current Guix so the store items we need are in
|
;; current Guix so the store items we need are in
|
||||||
|
|
@ -103,12 +130,13 @@
|
||||||
#:imported-modules '((gnu services herd)
|
#:imported-modules '((gnu services herd)
|
||||||
(guix combinators))))
|
(guix combinators))))
|
||||||
(target-size (* 1200 MiB)))
|
(target-size (* 1200 MiB)))
|
||||||
"Run the GuixSD installation procedure from OS and return a VM image of
|
"Run SCRIPT (a shell script following the GuixSD installation procedure) in
|
||||||
TARGET-SIZE bytes containing the installed system."
|
OS to install TARGET-OS. Return a VM image of TARGET-SIZE bytes containing
|
||||||
|
the installed system."
|
||||||
|
|
||||||
(mlet* %store-monad ((_ (set-grafting #f))
|
(mlet* %store-monad ((_ (set-grafting #f))
|
||||||
(system (current-system))
|
(system (current-system))
|
||||||
(target (operating-system-derivation %minimal-os))
|
(target (operating-system-derivation target-os))
|
||||||
|
|
||||||
;; Since the installation system has no network access,
|
;; Since the installation system has no network access,
|
||||||
;; we cheat a little bit by adding TARGET to its GC
|
;; we cheat a little bit by adding TARGET to its GC
|
||||||
|
|
@ -152,39 +180,34 @@ TARGET-SIZE bytes containing the installed system."
|
||||||
(start 'term-tty1))
|
(start 'term-tty1))
|
||||||
marionette)
|
marionette)
|
||||||
|
|
||||||
(marionette-eval '(call-with-output-file "/etc/litl-config.scm"
|
(marionette-eval '(call-with-output-file "/etc/target-config.scm"
|
||||||
(lambda (port)
|
(lambda (port)
|
||||||
(write '#$%minimal-os-source port)))
|
(write '#$target-os-source port)))
|
||||||
marionette)
|
marionette)
|
||||||
|
|
||||||
(exit (marionette-eval '(zero? (system "
|
(exit (marionette-eval '(zero? (system #$script))
|
||||||
. /etc/profile
|
|
||||||
set -e -x;
|
|
||||||
guix --version
|
|
||||||
guix gc --list-live | grep isc-dhcp
|
|
||||||
|
|
||||||
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 1G \\
|
|
||||||
set 1 boot on \\
|
|
||||||
set 1 bios_grub on
|
|
||||||
mkfs.ext4 -L my-root /dev/vdb2
|
|
||||||
ls -l /dev/vdb
|
|
||||||
mount /dev/vdb2 /mnt
|
|
||||||
df -h /mnt
|
|
||||||
herd start cow-store /mnt
|
|
||||||
mkdir /mnt/etc
|
|
||||||
cp /etc/litl-config.scm /mnt/etc/config.scm
|
|
||||||
guix system init /mnt/etc/config.scm /mnt --no-substitutes
|
|
||||||
sync
|
|
||||||
reboot\n"))
|
|
||||||
marionette)))))
|
marionette)))))
|
||||||
|
|
||||||
(gexp->derivation "installation" install)))
|
(gexp->derivation "installation" install)))
|
||||||
|
|
||||||
|
(define (qemu-command/writable-image image)
|
||||||
|
"Return as a monadic value the command to run QEMU on a writable copy of
|
||||||
|
IMAGE, a disk image."
|
||||||
|
(mlet %store-monad ((system (current-system)))
|
||||||
|
(return #~(let ((image #$image))
|
||||||
|
;; First we need a writable copy of the image.
|
||||||
|
(format #t "copying image '~a'...~%" image)
|
||||||
|
(copy-file image "disk.img")
|
||||||
|
(chmod "disk.img" #o644)
|
||||||
|
`(,(string-append #$qemu-minimal "/bin/"
|
||||||
|
#$(qemu-command system))
|
||||||
|
,@(if (file-exists? "/dev/kvm")
|
||||||
|
'("-enable-kvm")
|
||||||
|
'())
|
||||||
|
"-no-reboot" "-m" "256"
|
||||||
|
"-drive" "file=disk.img,if=virtio")))))
|
||||||
|
|
||||||
|
|
||||||
(define %test-installed-os
|
(define %test-installed-os
|
||||||
(system-test
|
(system-test
|
||||||
(name "installed-os")
|
(name "installed-os")
|
||||||
|
|
@ -193,21 +216,89 @@ reboot\n"))
|
||||||
This test is expensive in terms of CPU and storage usage since we need to
|
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.")
|
build (current-guix) and then store a couple of full system images.")
|
||||||
(value
|
(value
|
||||||
(mlet %store-monad ((image (run-install))
|
(mlet* %store-monad ((image (run-install %minimal-os %minimal-os-source))
|
||||||
(system (current-system)))
|
(command (qemu-command/writable-image image)))
|
||||||
(run-basic-test %minimal-os
|
(run-basic-test %minimal-os command
|
||||||
#~(let ((image #$image))
|
|
||||||
;; First we need a writable copy of the image.
|
|
||||||
(format #t "copying image '~a'...~%" image)
|
|
||||||
(copy-file image "disk.img")
|
|
||||||
(chmod "disk.img" #o644)
|
|
||||||
`(,(string-append #$qemu-minimal "/bin/"
|
|
||||||
#$(qemu-command system))
|
|
||||||
,@(if (file-exists? "/dev/kvm")
|
|
||||||
'("-enable-kvm")
|
|
||||||
'())
|
|
||||||
"-no-reboot" "-m" "256"
|
|
||||||
"-drive" "file=disk.img,if=virtio"))
|
|
||||||
"installed-os")))))
|
"installed-os")))))
|
||||||
|
|
||||||
|
|
||||||
|
(define-os-with-source (%encrypted-root-os %encrypted-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 (grub-configuration (device "/dev/vdb")))
|
||||||
|
(kernel-arguments '("console=ttyS0"))
|
||||||
|
(file-systems (cons (file-system
|
||||||
|
(device "/dev/mapper/the-root-device")
|
||||||
|
(title 'device)
|
||||||
|
(mount-point "/")
|
||||||
|
(type "ext4"))
|
||||||
|
%base-file-systems))
|
||||||
|
(mapped-devices (list (mapped-device
|
||||||
|
(source "REPLACE-WITH-LUKS-UUID")
|
||||||
|
(target "the-root-device")
|
||||||
|
(type luks-device-mapping))))
|
||||||
|
(users (cons (user-account
|
||||||
|
(name "charlie")
|
||||||
|
(group "users")
|
||||||
|
(home-directory "/home/charlie")
|
||||||
|
(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 %encrypted-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 1G \\
|
||||||
|
set 1 boot on \\
|
||||||
|
set 1 bios_grub on
|
||||||
|
echo -n thepassphrase | cryptsetup luksFormat -q /dev/vdb2 -
|
||||||
|
echo -n thepassphrase | \\
|
||||||
|
cryptsetup open --type luks --key-file - /dev/vdb2 the-root-device
|
||||||
|
mkfs.ext4 -L my-root /dev/mapper/the-root-device
|
||||||
|
mount LABEL=my-root /mnt
|
||||||
|
herd start cow-store /mnt
|
||||||
|
mkdir /mnt/etc
|
||||||
|
cp /etc/target-config.scm /mnt/etc/config.scm
|
||||||
|
cat /mnt/etc/config
|
||||||
|
luks_uuid=`cryptsetup luksUUID /dev/vdb2`
|
||||||
|
sed -i /mnt/etc/config.scm \\
|
||||||
|
-e \"s/\\\"REPLACE-WITH-LUKS-UUID\\\"/(uuid \\\"$luks_uuid\\\")/g\"
|
||||||
|
guix system build /mnt/etc/config.scm
|
||||||
|
guix system init /mnt/etc/config.scm /mnt --no-substitutes
|
||||||
|
sync
|
||||||
|
reboot\n")
|
||||||
|
|
||||||
|
(define %test-encrypted-os
|
||||||
|
(system-test
|
||||||
|
(name "encrypted-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 %encrypted-root-os
|
||||||
|
%encrypted-root-os-source
|
||||||
|
#:script
|
||||||
|
%encrypted-root-installation-script))
|
||||||
|
(command (qemu-command/writable-image image)))
|
||||||
|
(run-basic-test %encrypted-root-os command "encrypted-root-os")))))
|
||||||
|
|
||||||
;;; install.scm ends here
|
;;; install.scm ends here
|
||||||
|
|
|
||||||
Reference in New Issue