thin-provisioning-tools/functional-tests/functional-tests.scm

295 lines
8.2 KiB
Scheme
Raw Normal View History

2017-08-15 20:37:45 +05:30
(library
(functional-tests)
(export
slurp-file
scenario
scenarios
add-scenario
list-scenarios
describe-scenarios
define-scenario
fail
run-scenario
run-scenarios
tools-version
define-tool
assert-equal
assert-eof
2017-09-15 19:52:04 +05:30
assert-starts-with
assert-matches
assert-superblock-untouched
assert-member?
assert-raises-thunk
assert-raises
assert-every)
2017-08-15 20:37:45 +05:30
(import
(chezscheme)
(bcache block-manager)
2017-08-15 20:37:45 +05:30
(fmt fmt)
(list-utils)
(logging)
(process)
2017-09-15 19:52:04 +05:30
(regex)
(temp-file)
(utils)
(only (srfi s1 lists) every)
(srfi s8 receive))
2017-08-15 20:37:45 +05:30
;;;--------------------------------------------------------------------
(define (vector-sort-by cmp key-fn v)
(define (compare x y)
(cmp (key-fn x) (key-fn y)))
(vector-sort compare v))
;;;--------------------------------------------------------------------
(define-record-type scenario (fields desc thunk))
(define scenarios
(make-hashtable equal-hash equal?))
(define (add-scenario syms s)
(hashtable-set! scenarios syms s))
(define (fmt-keys prev-keys keys)
(define (fmt-keys% n keys)
(if (null? keys)
fmt-null
(cat (space-to n) (dsp (car keys)) (if (null? (cdr keys)) fmt-null nl)
(fmt-keys% (+ n 2) (cdr keys)))))
(let loop ((n 0)
(keys keys)
(prev-keys prev-keys))
(if (and (not (null? keys))
(not (null? prev-keys))
(eq? (car keys) (car prev-keys)))
(loop (+ n 2) (cdr keys) (cdr prev-keys))
(begin
(if (zero? n)
(cat nl (fmt-keys% n keys))
(fmt-keys% n keys))))))
2017-08-15 20:37:45 +05:30
(define (list-scenarios)
(define (fmt-keys ks)
(fmt #f (dsp ks)))
2017-08-15 20:37:45 +05:30
(vector->list
(vector-sort-by string<? fmt-keys (hashtable-keys scenarios))))
2017-08-15 20:37:45 +05:30
(define (fmt-scenarios keys fn)
(define (flush)
(flush-output-port (current-output-port)))
(define (describe prev-keys keys)
2017-08-15 20:37:45 +05:30
(fmt #t
(cat (fmt-keys prev-keys keys)
(dsp #\space)
(pad-char #\. (space-to 38))
(dsp #\space)))
(flush)
(fmt #t (cat (fn keys) nl))
(flush))
(unless (null? keys)
(for-each describe (cons '() (reverse (cdr (reverse keys)))) keys)))
2017-08-15 20:37:45 +05:30
(define (describe-scenarios keys)
(fmt-scenarios keys
(lambda (keys)
(scenario-desc
(hashtable-ref scenarios keys #f)))))
2017-08-15 20:37:45 +05:30
(define (test-dir cwd keys)
(apply string-append cwd "/"
(intersperse "/" (map symbol->string keys))))
(define (log-exceptions thunk)
(with-exception-handler
(lambda (x)
(let-values (((txt-port get) (open-string-output-port)))
(display-condition x txt-port)
(log-error (get)))
(raise x))
thunk))
2017-08-15 20:37:45 +05:30
(define-syntax define-scenario
(lambda (x)
(syntax-case x ()
((k keys desc b1 b2 ...)
#'(add-scenario 'keys
(make-scenario desc
(lambda ()
(with-dir (test-dir "." 'keys)
(with-log-port (open-file-output-port
(string-append (working-directory) "/log.txt")
(file-options no-fail)
(buffer-mode line)
(native-transcoder))
(log-exceptions (lambda () b1 b2 ...)))))))))))
2017-08-15 20:37:45 +05:30
(define (fail msg)
(raise (condition
(make-error)
(make-message-condition msg))))
(define (run-scenario syms)
(let ((s (hashtable-ref scenarios syms #f)))
(display syms)
2017-08-15 20:37:45 +05:30
(display " ... ")
((scenario-thunk s))
(display "pass")
(newline)))
;; Returns #f if an error was raised, otherwise #t (the values from thunk are
;; discarded).
(define (try thunk)
(call/cc
(lambda (k)
(with-exception-handler
(lambda (x)
(if (error? x)
(k #f)
(raise x)))
(lambda ()
(thunk)
#t)))))
;; Returns #t if all tests pass.
2017-08-15 20:37:45 +05:30
(define (run-scenarios ss)
(let ((pass 0)
(fail 0)
(fail-keys '()))
(fmt-scenarios ss
(lambda (keys)
(let ((s (hashtable-ref scenarios keys #f)))
(if (try (scenario-thunk s))
(begin (inc! pass)
(dsp "pass"))
(begin (inc! fail)
(set! fail-keys (cons keys fail-keys))
2017-08-22 14:17:00 +05:30
(dsp "fail"))))))
(unless (or (zero? fail) (zero? pass))
(fmt #t nl (dsp "There were failures:") nl)
(fmt-scenarios fail-keys
(lambda (_)
(dsp "fail"))))
(fmt #t (cat nl
(num pass)
(dsp "/")
(num (+ pass fail))
(dsp " tests passed")
(if (zero? fail)
(dsp #\.)
(cat (dsp ", ")
(num fail)
(dsp " failures.")))
nl))
(zero? fail)))
;;-----------------------------------------------
(define tools-version
(chomp
(with-input-from-file "../VERSION"
(lambda ()
(get-line (current-input-port))))))
;;-----------------------------------------------
;; A 'tool' is a function that builds up a command line. This can then be
;; passed to the functions in the (process) library.
(define (tool-path sym)
(define (to-underscore c)
(if (eq? #\- c) #\_ c))
(string-append "../bin/"
(list->string
(map to-underscore
(string->list
(symbol->string sym))))))
(define-syntax define-tool
(syntax-rules ()
((_ sym) (define sym
(let ((path (tool-path 'sym)))
(lambda args
(build-command-line (cons path args))))))))
(define (assert-equal str1 str2)
(unless (equal? str1 str2)
(fail (fmt #f (dsp "values differ: ")
(wrt str1)
(dsp ", ")
(wrt str2)))))
(define (assert-eof obj)
(unless (eof-object? obj)
(fail (fmt #f (dsp "object is not an #!eof: ") (dsp obj)))))
(define (starts-with prefix str)
(and (>= (string-length str) (string-length prefix))
(equal? (substring str 0 (string-length prefix))
prefix)))
(define (assert-starts-with prefix str)
(unless (starts-with prefix str)
(fail (fmt #f (dsp "string should begin with: ")
(wrt prefix)
(dsp ", ")
(wrt str)))))
2017-09-15 19:52:04 +05:30
(define (assert-matches pattern str)
(unless ((regex pattern) str)
(fail (fmt #f "string should match: " pattern ", " str))))
(define (all-zeroes? ptr count)
(let ((u8-ptr (make-ftype-pointer unsigned-8 ptr)))
(let loop ((i 0))
(if (= count i)
#t
(if (zero? (ftype-ref unsigned-8 () u8-ptr i))
(loop (+ i 1))
#f)))))
(define (assert-superblock-untouched md)
(with-bcache (cache md 1)
(with-block (b cache 0 (get-flags))
(unless (all-zeroes? (block-data b) 4096)
(fail "superblock contains non-zero data")))))
(define (assert-member? x xs)
(unless (member x xs)
(fail (fmt #f "expected " (wrt x) "to be a member of " (wrt xs)))))
(define (assert-raises-thunk thunk)
(call/cc
(lambda (k)
(with-exception-handler
(lambda (x)
(if (error? x)
(k #f)
(raise x)))
thunk)
(fail "expected an exception to be raised"))))
(define-syntax assert-raises
(syntax-rules ()
((_ b1 b2 ...)
(assert-raises-thunk
(lambda ()
b1 b2 ...)))))
(define (assert-every pred . args)
(unless (apply every pred args)
(fail "assert-every failed")))
)
2017-08-15 20:37:45 +05:30