Browse Source

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'.
gn-latest-20200428
Ludovic Courtès 5 years ago
parent
commit
98b65b5ff6
No known key found for this signature in database GPG Key ID: 90B11993D9AEBB5
  1. 1
      Makefile.am
  2. 15
      build-aux/run-system-tests.scm
  3. 68
      gnu/tests.scm
  4. 30
      gnu/tests/base.scm
  5. 36
      gnu/tests/install.scm

1
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)' \

15
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)

68
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

30
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))))))

36
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
Loading…
Cancel
Save