149 lines
4.7 KiB
Common Lisp
149 lines
4.7 KiB
Common Lisp
;;;; cl-scopes/test-core - testing for the scopes-core system.
|
|
|
|
(defpackage :scopes/test-core
|
|
(:use :common-lisp)
|
|
(:local-nicknames (:alx :alexandria)
|
|
(:actor :scopes/core/actor)
|
|
(:async :scopes/util/async)
|
|
(:config :scopes/config)
|
|
(:core :scopes/core)
|
|
(:crypt :scopes/util/crypt)
|
|
(:iter :scopes/util/iter)
|
|
(:logging :scopes/logging)
|
|
(:message :scopes/core/message)
|
|
(:shape :scopes/shape)
|
|
(:util :scopes/util)
|
|
(:t :scopes/testing))
|
|
(:export #:run #:user #:password)
|
|
(:import-from :scopes/testing #:deftest #:== #:!=))
|
|
|
|
(in-package :scopes/test-core)
|
|
|
|
;;;; core/testing: test-receiver
|
|
|
|
(defclass test-receiver (core:context)
|
|
((expected :accessor expected
|
|
:initform (make-hash-table :test #'equalp))))
|
|
|
|
(defun setup (cfg)
|
|
(core:default-setup cfg 'test-receiver))
|
|
|
|
(defun check-message (ctx msg)
|
|
(let ((key (shape:head msg)))
|
|
(multiple-value-bind (val found) (gethash key (expected ctx))
|
|
(if found
|
|
(progn
|
|
(if (not (equalp (shape:data msg) val))
|
|
(t:failure "data mismatch: ~s, expected: ~s" msg val))
|
|
(remhash key (expected ctx)))
|
|
(t:failure "unexpected: ~s" msg)))))
|
|
|
|
(defun expect (ctx msg)
|
|
(setf (gethash (shape:head msg) (expected ctx))
|
|
(shape:data msg)))
|
|
|
|
(defun check-expected ()
|
|
(let ((exp (alx:hash-table-keys (expected (receiver t:*test-suite*)))))
|
|
(if exp
|
|
(t:failure "unused messages: ~s" exp))))
|
|
|
|
;;;; test runner
|
|
|
|
(defclass test-suite (t:test-suite)
|
|
((receiver :accessor receiver :initarg :receiver)))
|
|
|
|
(defun run ()
|
|
(let* ((t:*test-suite* (make-instance 'test-suite :name "core")))
|
|
(load (t:test-path "config-core" "etc"))
|
|
(unwind-protect
|
|
(progn
|
|
(test-util)
|
|
(test-util-async)
|
|
(test-util-crypt)
|
|
(test-util-iter)
|
|
(test-shape)
|
|
(core:setup-services)
|
|
(test-actor)
|
|
(setf (receiver t:*test-suite*) (core:find-service :test-receiver))
|
|
(test-send))
|
|
(core:shutdown)
|
|
(check-expected)
|
|
(t:show-result))))
|
|
|
|
(deftest test-util ()
|
|
(let ((now (get-universal-time)))
|
|
(== (util:from-unix-time (util:to-unix-time now)) now))
|
|
(let* ((x (util:ptr))
|
|
(y x))
|
|
(setf (aref y) 42)
|
|
(== (aref x) 42))
|
|
(== (util:rfill '(1 2 3 4 5) '(a b c)) '(a b c nil nil))
|
|
(== (util:rtrim '(1 2 nil 3 nil)) '(1 2 nil 3))
|
|
(== (util:to-keyword "hello-kitty") :hello-kitty)
|
|
(== (util:loop-plist '(:a "a" :b "b") k v collect (string-upcase k)) '("A" "B"))
|
|
(== (util:plist-pairs '(:a "a" :b "b")) '((:a "a") (:b "b")))
|
|
(let ((pl '(:a 0)))
|
|
(== (util:plist-add pl :b 1) '(:b 1 :a 0))
|
|
(== pl '(:b 1 :a 0))))
|
|
|
|
(deftest test-util-async ()
|
|
(async:init)
|
|
(let ((tsk (async:make-task :startup (lambda (&rest args) (sleep 0.01)))))
|
|
(== (async:status tsk) :new)
|
|
(async:start tsk)
|
|
(== (async:status tsk) :running)
|
|
(async:stop tsk)
|
|
(== (async:status tsk) :done))
|
|
(let ((tsk (async:make-task :handle-message
|
|
#'(lambda (tsk msg) (push msg (async:data tsk))))))
|
|
(== (async:status tsk) :new)
|
|
(async:start tsk)
|
|
(== (async:status tsk) :running)
|
|
(async:send tsk :hello)
|
|
(== (async:stop tsk) '(:hello))
|
|
(== (async:status tsk) :done))
|
|
(async:finish))
|
|
|
|
(deftest test-util-crypt ()
|
|
(let ((s1 (crypt:create-secret))
|
|
(s2 (crypt:create-secret)))
|
|
(!= s1 s2)))
|
|
|
|
(deftest test-util-iter ()
|
|
(let ((it (iter:list-iterator '(a b c))))
|
|
(== (iter:value it) nil)
|
|
(== (iter:next it) nil)
|
|
(== (iter:value it) 'a))
|
|
(let ((it (iter:string-iterator "a b c")))
|
|
(== (iter:value it) nil)
|
|
(== (iter:next it) nil)
|
|
(== (string (iter:value it)) "A")))
|
|
|
|
(deftest test-shape ()
|
|
(let ((rec (make-instance 'shape:record :head '(:t1))))
|
|
(== (shape:head rec) '(:t1 nil))
|
|
(== (shape:head-value rec :taskid) :t1)
|
|
(setf (shape:head-value rec :username) :u1)
|
|
(== (shape:head-value rec :username) :u1)))
|
|
|
|
(deftest test-actor ()
|
|
(let* ((calc (actor:create (actor:calculator) 'actor:bg-actor))
|
|
val
|
|
(collector
|
|
(actor:create
|
|
#'(lambda (ac msg) (setf val (actor:content msg))))))
|
|
(actor:send calc '(actor:plus 2))
|
|
(actor:send calc '(actor:minus 3))
|
|
(actor:send calc '(actor:show))
|
|
(actor:send calc '(actor:send-value) :customer collector)
|
|
(sleep 0.1)
|
|
(== val -1)
|
|
))
|
|
|
|
(deftest test-send ()
|
|
(let ((rcvr (receiver t:*test-suite*))
|
|
(msg (message:create '(:test :dummy) :data "dummy payload"))
|
|
(msg-exp (message:create '(:test :dummy) :data "dummy payload")))
|
|
(expect rcvr msg-exp)
|
|
(== (core:name rcvr) :test-receiver)
|
|
(actor:send rcvr msg)))
|