me
/
guix
Archived
1
0
Fork 0
Code

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'.
master
Ludovic Courtès 2016-06-20 22:34:13 +02:00
parent 2a6ba87086
commit 98b65b5ff6
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
5 changed files with 112 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Makefile.am
View File

@ -334,7 +334,6 @@ check-local:
endif !CAN_RUN_TESTS endif !CAN_RUN_TESTS
check-system: $(GOBJECTS) check-system: $(GOBJECTS)
$(AM_V_at)echo "Running system tests..."
$(AM_V_at)$(top_builddir)/pre-inst-env \ $(AM_V_at)$(top_builddir)/pre-inst-env \
$(GUILE) --no-auto-compile \ $(GUILE) --no-auto-compile \
-e '(@@ (run-system-tests) run-system-tests)' \ -e '(@@ (run-system-tests) run-system-tests)' \

15
build-aux/run-system-tests.scm
View File

@ -17,8 +17,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (run-system-tests) (define-module (run-system-tests)
#:use-module (gnu tests base) #:use-module (gnu tests)
#:use-module (gnu tests install)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix monads) #:use-module (guix monads)
#:use-module (guix derivations) #:use-module (guix derivations)
@ -45,14 +44,16 @@
lst) lst)
(lift1 reverse %store-monad)))) (lift1 reverse %store-monad))))
(define %system-tests
(list %test-basic-os
%test-installed-os))
(define (run-system-tests . args) (define (run-system-tests . args)
(define tests
(all-system-tests))
(format (current-error-port) "Running ~a system tests...~%"
(length tests))
(with-store store (with-store store
(run-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))) (out -> (map derivation->output-path drv)))
(mbegin %store-monad (mbegin %store-monad
(show-what-to-build* drv) (show-what-to-build* drv)

68
gnu/tests.scm
View File

@ -18,12 +18,28 @@
(define-module (gnu tests) (define-module (gnu tests)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module (guix utils)
#:use-module (guix records)
#:use-module (gnu system) #:use-module (gnu system)
#:use-module (gnu services) #:use-module (gnu services)
#:use-module (gnu services shepherd) #: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 #:export (marionette-service-type
marionette-operating-system 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: ;;; Commentary:
;;; ;;;
@ -147,4 +163,54 @@ the system under test."
(use-modules modules ...) (use-modules modules ...)
(operating-system fields ...))))))) (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 ;;; tests.scm ends here

30
gnu/tests/base.scm
View File

@ -161,16 +161,20 @@ info --version")
#:modules '((gnu build marionette)))) #:modules '((gnu build marionette))))
(define %test-basic-os (define %test-basic-os
;; Monadic derivation that instruments %SIMPLE-OS, runs it in a VM, and runs (system-test
;; a series of basic functionality tests. (name "basic")
(mlet* %store-monad ((os -> (marionette-operating-system (description
%simple-os "Instrument %SIMPLE-OS, run it in a VM, and runs a series of basic
#:imported-modules '((gnu services herd) functionality tests.")
(guix combinators)))) (value
(run (system-qemu-image/shared-store-script (mlet* %store-monad ((os -> (marionette-operating-system
os #:graphic? #f))) %simple-os
;; XXX: Add call to 'virtualized-operating-system' to get the exact same #:imported-modules '((gnu services herd)
;; set of services as the OS produced by (guix combinators))))
;; 'system-qemu-image/shared-store-script'. (run (system-qemu-image/shared-store-script
(run-basic-test (virtualized-operating-system os '()) os #:graphic? #f)))
#~(list #$run)))) ;; 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
View File

@ -185,21 +185,25 @@ reboot\n"))
(define %test-installed-os (define %test-installed-os
;; Test basic functionality of an OS installed like one would do by hand. (system-test
;; This test is expensive in terms of CPU and storage usage since we need to (name "installed-os")
;; build (current-guix) and then store a couple of full system images. (description
(mlet %store-monad ((image (run-install)) "Test basic functionality of an OS installed like one would do by hand.
(system (current-system))) This test is expensive in terms of CPU and storage usage since we need to
(run-basic-test %minimal-os build (current-guix) and then store a couple of full system images.")
#~(let ((image #$image)) (value
;; First we need a writable copy of the image. (mlet %store-monad ((image (run-install))
(format #t "copying image '~a'...~%" image) (system (current-system)))
(copy-file image "disk.img") (run-basic-test %minimal-os
(chmod "disk.img" #o644) #~(let ((image #$image))
(list (string-append #$qemu-minimal "/bin/" ;; First we need a writable copy of the image.
#$(qemu-command system)) (format #t "copying image '~a'...~%" image)
"-enable-kvm" "-no-reboot" "-m" "256" (copy-file image "disk.img")
"-drive" "file=disk.img,if=virtio")) (chmod "disk.img" #o644)
"installed-os"))) (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 ;;; install.scm ends here