civodul pushed a commit to branch master
in repository guix.
commit 98b65b5ff6b1dea0ad58b0f47dd163c32d0cbf6e
Author: Ludovic Courtès <l...@gnu.org>
Date: Mon Jun 20 22:34:13 2016 +0200
tests: Add a mechanism to describe and discover system tests.
* gnu/tests.scm (<system-test>): New record type.
(write-system-test, test-modules, fold-system-tests)
(all-system-tests): New procedures.
* gnu/tests/base.scm (%test-basic-os): Turn into a <system-test>.
* gnu/tests/install.scm (%test-installed-os): Likewise.
* build-aux/run-system-tests.scm (%system-tests): Remove.
(run-system-tests): Use 'all-system-tests'.
---
Makefile.am | 1 -
build-aux/run-system-tests.scm | 15 ++++-----
gnu/tests.scm | 68 +++++++++++++++++++++++++++++++++++++++-
gnu/tests/base.scm | 30 ++++++++++--------
gnu/tests/install.scm | 36 +++++++++++----------
5 files changed, 112 insertions(+), 38 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 8fd1c1b..37a0aef 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -334,7 +334,6 @@ check-local:
endif !CAN_RUN_TESTS
check-system: $(GOBJECTS)
- $(AM_V_at)echo "Running system tests..."
$(AM_V_at)$(top_builddir)/pre-inst-env \
$(GUILE) --no-auto-compile \
-e '(@@ (run-system-tests) run-system-tests)' \
diff --git a/build-aux/run-system-tests.scm b/build-aux/run-system-tests.scm
index 4ce9b83..f7c99de 100644
--- a/build-aux/run-system-tests.scm
+++ b/build-aux/run-system-tests.scm
@@ -17,8 +17,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (run-system-tests)
- #:use-module (gnu tests base)
- #:use-module (gnu tests install)
+ #:use-module (gnu tests)
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix derivations)
@@ -45,14 +44,16 @@
lst)
(lift1 reverse %store-monad))))
-(define %system-tests
- (list %test-basic-os
- %test-installed-os))
-
(define (run-system-tests . args)
+ (define tests
+ (all-system-tests))
+
+ (format (current-error-port) "Running ~a system tests...~%"
+ (length tests))
+
(with-store store
(run-with-store store
- (mlet* %store-monad ((drv (sequence %store-monad %system-tests))
+ (mlet* %store-monad ((drv (mapm %store-monad system-test-value tests))
(out -> (map derivation->output-path drv)))
(mbegin %store-monad
(show-what-to-build* drv)
diff --git a/gnu/tests.scm b/gnu/tests.scm
index 348b5ad..ea779ed 100644
--- a/gnu/tests.scm
+++ b/gnu/tests.scm
@@ -18,12 +18,28 @@
(define-module (gnu tests)
#:use-module (guix gexp)
+ #:use-module (guix utils)
+ #:use-module (guix records)
#:use-module (gnu system)
#:use-module (gnu services)
#:use-module (gnu services shepherd)
+ #:use-module ((gnu packages) #:select (scheme-modules))
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module (ice-9 match)
#:export (marionette-service-type
marionette-operating-system
- define-os-with-source))
+ define-os-with-source
+
+ system-test
+ system-test?
+ system-test-name
+ system-test-value
+ system-test-description
+ system-test-location
+
+ fold-system-tests
+ all-system-tests))
;;; Commentary:
;;;
@@ -147,4 +163,54 @@ the system under test."
(use-modules modules ...)
(operating-system fields ...)))))))
+
+;;;
+;;; Tests.
+;;;
+
+(define-record-type* <system-test> system-test make-system-test
+ system-test?
+ (name system-test-name) ;string
+ (value system-test-value) ;%STORE-MONAD value
+ (description system-test-description) ;string
+ (location system-test-location (innate) ;<location>
+ (default (and=> (current-source-location)
+ source-properties->location))))
+
+(define (write-system-test test port)
+ (match test
+ (($ <system-test> name _ _ ($ <location> file line))
+ (format port "#<system-test ~a ~a:~a ~a>"
+ name file line
+ (number->string (object-address test) 16)))
+ (($ <system-test> name)
+ (format port "#<system-test ~a ~a>" name
+ (number->string (object-address test) 16)))))
+
+(set-record-type-printer! <system-test> write-system-test)
+
+(define (test-modules)
+ "Return the list of modules that define system tests."
+ (scheme-modules (dirname (search-path %load-path "guix.scm"))
+ "gnu/tests"))
+
+(define (fold-system-tests proc seed)
+ "Invoke PROC on each system test, passing it the test and the previous
+result."
+ (fold (lambda (module result)
+ (fold (lambda (thing result)
+ (if (system-test? thing)
+ (proc thing result)
+ result))
+ result
+ (module-map (lambda (sym var)
+ (false-if-exception (variable-ref var)))
+ module)))
+ '()
+ (test-modules)))
+
+(define (all-system-tests)
+ "Return the list of system tests."
+ (reverse (fold-system-tests cons '())))
+
;;; tests.scm ends here
diff --git a/gnu/tests/base.scm b/gnu/tests/base.scm
index b417bc4..3dfa28f 100644
--- a/gnu/tests/base.scm
+++ b/gnu/tests/base.scm
@@ -161,16 +161,20 @@ info --version")
#:modules '((gnu build marionette))))
(define %test-basic-os
- ;; Monadic derivation that instruments %SIMPLE-OS, runs it in a VM, and runs
- ;; a series of basic functionality tests.
- (mlet* %store-monad ((os -> (marionette-operating-system
- %simple-os
- #:imported-modules '((gnu services herd)
- (guix combinators))))
- (run (system-qemu-image/shared-store-script
- os #:graphic? #f)))
- ;; XXX: Add call to 'virtualized-operating-system' to get the exact same
- ;; set of services as the OS produced by
- ;; 'system-qemu-image/shared-store-script'.
- (run-basic-test (virtualized-operating-system os '())
- #~(list #$run))))
+ (system-test
+ (name "basic")
+ (description
+ "Instrument %SIMPLE-OS, run it in a VM, and runs a series of basic
+functionality tests.")
+ (value
+ (mlet* %store-monad ((os -> (marionette-operating-system
+ %simple-os
+ #:imported-modules '((gnu services herd)
+ (guix combinators))))
+ (run (system-qemu-image/shared-store-script
+ os #:graphic? #f)))
+ ;; XXX: Add call to 'virtualized-operating-system' to get the exact same
+ ;; set of services as the OS produced by
+ ;; 'system-qemu-image/shared-store-script'.
+ (run-basic-test (virtualized-operating-system os '())
+ #~(list #$run))))))
diff --git a/gnu/tests/install.scm b/gnu/tests/install.scm
index 0b3950a..c33919b 100644
--- a/gnu/tests/install.scm
+++ b/gnu/tests/install.scm
@@ -185,21 +185,25 @@ reboot\n"))
(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")))
+ (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 ((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
