summaryrefslogtreecommitdiff
path: root/gnu/tests.scm
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/tests.scm')
-rw-r--r--gnu/tests.scm92
1 files changed, 89 insertions, 3 deletions
diff --git a/gnu/tests.scm b/gnu/tests.scm
index 08d8315ea0..ea779ed6f0 100644
--- a/gnu/tests.scm
+++ b/gnu/tests.scm
@@ -18,11 +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)
- #:export (backdoor-service-type
- marionette-operating-system))
+ #: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
+
+ system-test
+ system-test?
+ system-test-name
+ system-test-value
+ system-test-description
+ system-test-location
+
+ fold-system-tests
+ all-system-tests))
;;; Commentary:
;;;
@@ -112,7 +129,7 @@
(define marionette-service-type
;; This is the type of the "marionette" service, allowing a guest system to
;; be manipulated from the host. This marionette REPL is essentially a
- ;; universal marionette.
+ ;; universal backdoor.
(service-type (name 'marionette-repl)
(extensions
(list (service-extension shepherd-root-service-type
@@ -127,4 +144,73 @@ in a virtual machine--i.e., controlled from the host system."
(services (cons (service marionette-service-type imported-modules)
(operating-system-user-services os)))))
+(define-syntax define-os-with-source
+ (syntax-rules (use-modules operating-system)
+ "Define two variables: OS containing the given operating system, and
+SOURCE containing the source to define OS as an sexp.
+
+This is convenient when we need both the <operating-system> object so we can
+instantiate it, and the source to create it so we can store in in a file in
+the system under test."
+ ((_ (os source)
+ (use-modules modules ...)
+ (operating-system fields ...))
+ (begin
+ (define os
+ (operating-system fields ...))
+ (define source
+ '(begin
+ (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