summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-06-20 21:51:59 +0200
committerLudovic Courtès <ludo@gnu.org>2016-06-20 23:50:46 +0200
commit94b4274d0dc5768bac255980c7e785bd3dff261f (patch)
tree831481b9a1c7189c326cdb6c549d863f673b64c9
parentb1dd6ac55d567ca3a1a063efe2a003a9fee9458c (diff)
downloadpatches-94b4274d0dc5768bac255980c7e785bd3dff261f.tar
patches-94b4274d0dc5768bac255980c7e785bd3dff261f.tar.gz
tests: Add system installation test.
* gnu/tests.scm (define-os-with-source): New macro. * gnu/tests/install.scm: New file. * gnu/local.mk (GNU_SYSTEM_MODULES): Add it. * build-aux/run-system-tests.scm (%system-tests): Likewise.
-rw-r--r--build-aux/run-system-tests.scm4
-rw-r--r--gnu/local.mk3
-rw-r--r--gnu/tests.scm22
-rw-r--r--gnu/tests/install.scm205
4 files changed, 231 insertions, 3 deletions
diff --git a/build-aux/run-system-tests.scm b/build-aux/run-system-tests.scm
index e98de9cb7e..4ce9b83fed 100644
--- a/build-aux/run-system-tests.scm
+++ b/build-aux/run-system-tests.scm
@@ -18,6 +18,7 @@
(define-module (run-system-tests)
#:use-module (gnu tests base)
+ #:use-module (gnu tests install)
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix derivations)
@@ -45,7 +46,8 @@
(lift1 reverse %store-monad))))
(define %system-tests
- (list %test-basic-os))
+ (list %test-basic-os
+ %test-installed-os))
(define (run-system-tests . args)
(with-store store
diff --git a/gnu/local.mk b/gnu/local.mk
index 55fea0e855..150d6af553 100644
--- a/gnu/local.mk
+++ b/gnu/local.mk
@@ -409,7 +409,8 @@ GNU_SYSTEM_MODULES = \
%D%/build/vm.scm \
\
%D%/tests.scm \
- %D%/tests/base.scm
+ %D%/tests/base.scm \
+ %D%/tests/install.scm
patchdir = $(guilemoduledir)/%D%/packages/patches
diff --git a/gnu/tests.scm b/gnu/tests.scm
index 7ca80ebf0e..348b5ad40f 100644
--- a/gnu/tests.scm
+++ b/gnu/tests.scm
@@ -22,7 +22,8 @@
#:use-module (gnu services)
#:use-module (gnu services shepherd)
#:export (marionette-service-type
- marionette-operating-system))
+ marionette-operating-system
+ define-os-with-source))
;;; Commentary:
;;;
@@ -127,4 +128,23 @@ in a virtual machine--i.e., controlled from the host system."
(services (cons (service marionette-service-type imported-modules)
(operating-system-user-services os)))))
+(define-syntax define-os-with-source
+ (syntax-rules (use-modules operating-system)
+ "Define two variables: OS containing the given operating system, and
+SOURCE containing the source to define OS as an sexp.
+
+This is convenient when we need both the <operating-system> object so we can
+instantiate it, and the source to create it so we can store in in a file in
+the system under test."
+ ((_ (os source)
+ (use-modules modules ...)
+ (operating-system fields ...))
+ (begin
+ (define os
+ (operating-system fields ...))
+ (define source
+ '(begin
+ (use-modules modules ...)
+ (operating-system fields ...)))))))
+
;;; tests.scm ends here
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
new file mode 100644
index 0000000000..0b3950a212
--- /dev/null
+++ b/gnu/tests/install.scm
@@ -0,0 +1,205 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; 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 tests)
+ #:use-module (gnu tests base)
+ #:use-module (gnu system)
+ #:use-module (gnu system install)
+ #:use-module (gnu system vm)
+ #:use-module ((gnu build vm) #:select (qemu-command))
+ #:use-module (gnu packages qemu)
+ #:use-module (gnu packages package-management)
+ #:use-module (guix store)
+ #:use-module (guix monads)
+ #:use-module (guix packages)
+ #:use-module (guix grafts)
+ #:use-module (guix gexp)
+ #:use-module (guix utils)
+ #:export (%test-installed-os))
+
+;;; Commentary:
+;;;
+;;; Test the installation of GuixSD 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 (grub-configuration (device "/dev/vdb")))
+ (kernel-arguments '("console=ttyS0"))
+ (file-systems (cons (file-system
+ (device "my-root")
+ (title 'label)
+ (mount-point "/")
+ (type "ext4"))
+ %base-file-systems))
+ (users (cons (user-account
+ (name "alice")
+ (comment "Bob's sister")
+ (group "users")
+ (supplementary-groups '("wheel" "audio" "video"))
+ (home-directory "/home/alice"))
+ %base-user-accounts))
+ (services (cons (service marionette-service-type
+ '((gnu services herd)
+ (guix combinators)))
+ %base-services))))
+
+(define (operating-system-with-current-guix os)
+ "Return a variant of OS that uses the current Guix."
+ (operating-system
+ (inherit os)
+ (services (modify-services (operating-system-user-services os)
+ (guix-service-type config =>
+ (guix-configuration
+ (inherit config)
+ (guix (current-guix))))))))
+
+(define (operating-system-with-gc-roots os roots)
+ "Return a variant of OS where ROOTS are registered as GC roots."
+ (operating-system
+ (inherit os)
+ (services (cons (service gc-root-service-type roots)
+ (operating-system-user-services os)))))
+
+
+(define MiB (expt 2 20))
+
+(define* (run-install #:key
+ (os (marionette-operating-system
+ ;; Since the image has no network access, use the
+ ;; current Guix so the store items we need are in
+ ;; the image.
+ (operating-system
+ (inherit (operating-system-with-current-guix
+ installation-os))
+ (kernel-arguments '("console=ttyS0")))
+ #:imported-modules '((gnu services herd)
+ (guix combinators))))
+ (target-size (* 1200 MiB)))
+ "Run the GuixSD installation procedure from OS and return a VM image of
+TARGET-SIZE bytes containing the installed system."
+
+ (mlet* %store-monad ((_ (set-grafting #f))
+ (system (current-system))
+ (target (operating-system-derivation %minimal-os))
+
+ ;; 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.
+ (image (system-disk-image
+ (operating-system-with-gc-roots
+ os (list target))
+ #:disk-image-size (* 1500 MiB))))
+ (define install
+ #~(begin
+ (use-modules (guix build utils)
+ (gnu build marionette))
+
+ (set-path-environment-variable "PATH" '("bin")
+ (list #$qemu-minimal))
+
+ (system* "qemu-img" "create" "-f" "qcow2"
+ #$output #$(number->string target-size))
+
+ (define marionette
+ (make-marionette
+ (cons (which #$(qemu-command system))
+ (cons* "-no-reboot" "-m" "800"
+ "-drive"
+ (string-append "file=" #$image
+ ",if=virtio,readonly")
+ "-drive"
+ (string-append "file=" #$output ",if=virtio")
+ (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 'term-tty1))
+ marionette)
+
+ (marionette-eval '(call-with-output-file "/etc/litl-config.scm"
+ (lambda (port)
+ (write '#$%minimal-os-source port)))
+ marionette)
+
+ (exit (marionette-eval '(zero? (system "
+. /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))))
+
+ (gexp->derivation "installation" install
+ #:modules '((guix build utils)
+ (gnu build marionette)))))
+
+
+(define %test-installed-os
+ ;; 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.
+ (mlet %store-monad ((image (run-install))
+ (system (current-system)))
+ (run-basic-test %minimal-os
+ #~(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)
+ (list (string-append #$qemu-minimal "/bin/"
+ #$(qemu-command system))
+ "-enable-kvm" "-no-reboot" "-m" "256"
+ "-drive" "file=disk.img,if=virtio"))
+ "installed-os")))
+
+;;; install.scm ends here