diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | build-aux/run-system-tests.scm | 15 | ||||
| -rw-r--r-- | gnu/tests.scm | 68 | ||||
| -rw-r--r-- | gnu/tests/base.scm | 30 | ||||
| -rw-r--r-- | gnu/tests/install.scm | 36 |
5 files changed, 112 insertions, 38 deletions
diff --git a/Makefile.am b/Makefile.am index 8fd1c1b0b6..37a0aef7dc 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 4ce9b83fed..f7c99def23 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 348b5ad40f..ea779ed6f0 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 b417bc4bda..3dfa28f7f5 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 0b3950a212..c33919ba2f 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 |