mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
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'.
This commit is contained in:
Ludovic Courtès
parent
2a6ba87086
commit
98b65b5ff6
5 changed files with 112 additions and 38 deletions
|
|
@ -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)' \
|
||||
|
|
|
|||
|
|
@ -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 @@ (define (filterm mproc lst) ;XXX: move to (guix monads)
|
|||
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)
|
||||
|
|
|
|||
|
|
@ -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 @@ (define source
|
|||
(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
|
||||
|
|
|
|||
|
|
@ -161,16 +161,20 @@ (define marionette
|
|||
#: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))))))
|
||||
|
|
|
|||
|
|
@ -185,21 +185,25 @@ (define marionette
|
|||
|
||||
|
||||
(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…
Reference in a new issue