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

(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
    assert-starts-with
    assert-matches
    assert-superblock-untouched
    assert-member?
    assert-raises-thunk
    assert-raises
    assert-every)

  (import
    (chezscheme)
    (bcache block-manager)
    (fmt fmt)
    (list-utils)
    (logging)
    (process)
    (regex)
    (temp-file)
    (utils)
    (only (srfi s1 lists) every)
    (srfi s8 receive))

  ;;;--------------------------------------------------------------------

  (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))))))

  (define (list-scenarios)
    (define (fmt-keys ks)
      (fmt #f (dsp ks)))

    (vector->list
      (vector-sort-by string<? fmt-keys (hashtable-keys scenarios))))

  (define (fmt-scenarios keys fn)
    (define (flush)
      (flush-output-port (current-output-port)))

    (define (describe prev-keys keys)
      (fmt #t
           (cat (fmt-keys prev-keys keys)
                (dsp #\space)
                (pad-char #\. (space-to 60))
                (dsp #\space)))
      (flush)
      (fmt #t (cat (fn keys) nl))
      (flush))

    (unless (null? keys)
        (for-each describe (cons '() (reverse (cdr (reverse keys)))) keys)))

  (define (describe-scenarios keys)
    (fmt-scenarios keys
                   (lambda (keys)
                     (scenario-desc
                       (hashtable-ref scenarios keys #f)))))

  (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))

  (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 ...)))))))))))

  (define (fail msg)
    (raise (condition
             (make-error)
             (make-message-condition msg))))

  (define (run-scenario syms)
    (let ((s (hashtable-ref scenarios syms #f)))
     (display syms)
     (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.
  (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))
                                   (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)))))

  (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")))
  )