05/08: tests: Add a mechanism to describe and discover system tests.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 98b65b5ff6b1dea0ad58b0f47dd163c32d0cbf6e
Author: Ludovic Courtès <address@hidden>
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