diff options
Diffstat (limited to 'gnu/tests.scm')
| -rw-r--r-- | gnu/tests.scm | 92 |
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 |