Menu
▾
▴
[SCM] emacs-jabber branch, roster-optimisation, updated. 5e5f6de6e2c8b4bd4de7d9b3a910b31b3fa6a25d
|
From: Magnus H. <leg...@us...> - 2015-04-17 10:12:40
|
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "emacs-jabber".
The branch, roster-optimisation has been updated
via 5e5f6de6e2c8b4bd4de7d9b3a910b31b3fa6a25d (commit)
from 3d32b14025e9eebd69f8dcdb2288d1a2e1431dba (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 5e5f6de6e2c8b4bd4de7d9b3a910b31b3fa6a25d
Author: Magnus Henoch <mag...@gm...>
Date: Fri Apr 17 10:49:35 2015 +0100
Add QuickCheck test
The test will be skipped unless the driver program has been explicitly
compiled before.
diff --git a/tests/.gitignore b/tests/.gitignore
index e2f3fd3..22e9adb 100644
--- a/tests/.gitignore
+++ b/tests/.gitignore
@@ -1,2 +1,5 @@
*.log
-*.trs
\ No newline at end of file
+*.trs
+roster-display
+roster-display.hi
+roster-display.o
diff --git a/tests/Makefile.am b/tests/Makefile.am
index 216b4ff..8e8a9c3 100644
--- a/tests/Makefile.am
+++ b/tests/Makefile.am
@@ -2,5 +2,8 @@
# check" or "make distcheck" to work with earlier versions.
LOG_COMPILER = env top_builddir=$(top_builddir) $(EMACS) -batch -L $(top_builddir) -L $(top_srcdir) -L $(srcdir) -l
TESTS = load-all.el skip-tag-forward.el history.el jabberd.el nick-change-fail.el
-TESTS += caps-hash.el roster-display.el
+TESTS += caps-hash.el roster-display.el roster-display-qc.el
dist_noinst_DATA = $(TESTS)
+
+roster-display: roster-display.hs
+ ghc $<
diff --git a/tests/roster-display-qc.el b/tests/roster-display-qc.el
new file mode 100644
index 0000000..ffc319f
--- /dev/null
+++ b/tests/roster-display-qc.el
@@ -0,0 +1,107 @@
+(require 'jabberd)
+(require 'cl)
+
+(setq jabber-roster-show-bindings nil)
+
+(jabberd-connect)
+
+(with-timeout (5 (progn
+ (princ (with-current-buffer "*fsm-debug*" (buffer-string)))
+ (error "Timeout")))
+ (while (not (equal "" *jabber-current-show*))
+ (sit-for 0.1)))
+
+(princ (format "in %s now\n" default-directory))
+
+(defun rd-clear-roster ()
+ (let ((state-data (fsm-get-state-data (car jabber-connections))))
+ ;; First unintern everything:
+ (jabber-clear-roster)
+ (plist-put state-data :roster nil)
+ (plist-put state-data :roster-hash nil)))
+
+(let* ((program (expand-file-name "roster-display" (file-name-directory load-file-name)))
+ (p (if (not (file-executable-p program))
+ (progn
+ (princ
+ (format "%s not found or not executable; skipping Quickcheck test\n"
+ program))
+ ;; Exit code 77 means "skip" to automake
+ (kill-emacs 77))
+ (start-process "roster-display" "*roster-display*" program)))
+ done)
+ (with-current-buffer (process-buffer p)
+ (while (not done)
+ (while (progn (goto-char (point-min)) (not (search-forward-regexp "^[a-z]" nil t)))
+ (accept-process-output p))
+ (goto-char (match-beginning 0))
+ (cond
+ ((looking-at "success")
+ (setq done t)
+ (princ "Success!\n"))
+ ((looking-at "failure")
+ (while (process-live-p p)
+ (accept-process-output p))
+ (princ (buffer-substring (point) (point-max)))
+ (error "it failed"))
+ ((looking-at "check")
+ (let ((all-messages-s (delete-and-extract-region (point-min) (point)))
+ all-messages
+ roster-1 roster-2)
+ (delete-region (point-min) (point-max))
+ (with-temp-buffer
+ (insert all-messages-s)
+ (goto-char (point-min))
+ (while
+ (condition-case e
+ (push (read (current-buffer)) all-messages)
+ (end-of-file
+ nil))))
+ (setq all-messages (nreverse all-messages))
+ (dolist (m all-messages)
+ (jabber-process-input (car jabber-connections) m))
+
+ ;; The presence stanza causes an asynchronous :roster-update message
+ ;; to be sent. Let's wait for that.
+ (accept-process-output nil 0.1)
+
+ ;; Roster updates are batched. Force a timeout.
+ (fsm-send-sync (car jabber-connections) :timeout)
+
+ (with-current-buffer jabber-roster-buffer
+ (setq roster-1 (buffer-substring-no-properties (point-min) (point-max))))
+
+ (jabber-display-roster)
+
+ (with-current-buffer jabber-roster-buffer
+ (setq roster-2 (buffer-substring-no-properties (point-min) (point-max))))
+
+ (if (equal roster-1 roster-2)
+ (process-send-string p "t\n")
+ (let ((result (mismatch roster-1 roster-2)))
+ (if (null result)
+ (princ "match\n")
+ (princ "mismatch! Expected:\n")
+ (prin1 roster-2)
+ (princ "\nBut got:\n")
+ (prin1 (substring roster-1 0 result))
+ (princ " ***mismatch here*** ")
+ (prin1 (substring roster-1 result))
+ (princ "\n")))
+ (process-send-string p "nil\n"))
+ (rd-clear-roster)
+
+ (jabber-disconnect)
+ (jabberd-connect)
+
+ (setq *jabber-current-show* nil)
+ (with-timeout (5 (progn
+ (princ (with-current-buffer "*fsm-debug*" (buffer-string)))
+ (error "Timeout")))
+ (while (not (equal "" *jabber-current-show*))
+ (sit-for 0.1)))
+
+ (jabber-display-roster)))
+ (t
+ (princ (concat "What's that?\n'" (buffer-substring (point) (point-max))))
+ (error "???"))))))
diff --git a/tests/roster-display.hs b/tests/roster-display.hs
new file mode 100644
index 0000000..2be41bd
--- /dev/null
+++ b/tests/roster-display.hs
@@ -0,0 +1,89 @@
+import Test.QuickCheck (Arbitrary, arbitrary, shrink, Property, quickCheck, (==>), choose,
+ oneof, quickCheckWithResult, stdArgs, Args(..), Result(..))
+import Test.QuickCheck.Arbitrary (shrinkList, shrinkNothing)
+import Test.QuickCheck.Monadic (assert, monadicIO, pick, pre, run)
+import Test.QuickCheck.Property (printTestCase)
+import Test.QuickCheck.Gen (Gen)
+import Data.List (nub)
+import Data.Char (toLower)
+import Control.Monad (liftM, mfilter)
+
+data RosterEvent = IqRoster JID [Group] (Maybe String) |
+ Presence JID PresenceType |
+ Noop
+ deriving (Show, Eq)
+instance Arbitrary RosterEvent where
+ arbitrary = do jid <- arbitrary
+ oneof
+ [ do groups <- arbitrary
+ maybeName <- arbitraryName
+ return $ IqRoster jid (nub groups) maybeName,
+ do presenceType <- arbitrary
+ return $ Presence jid presenceType]
+ where arbitraryName :: Gen (Maybe String)
+ arbitraryName = oneof [return Nothing,
+ liftM Just arbitrarySensibleString]
+ shrink Noop = []
+ shrink (IqRoster (JID j) groups name) =
+ [Noop] ++
+ [IqRoster (JID j) newGroups newName |
+ newGroups <- (shrinkList shrink groups),
+ newName <- shrink name]
+ shrink _ = [Noop]
+
+arbitrarySensibleString =
+ do arbitraryString <- arbitrary
+ return $ filter (\c -> c >= ' ' && c <= '~') arbitraryString
+
+data JID = JID String deriving (Eq)
+instance Arbitrary JID where
+ arbitrary = do
+ x <- choose ('a', 'e')
+ return . JID $ [x] ++ "@example.com"
+instance Show JID where
+ show (JID s) = s
+
+data Group = Group String deriving (Eq)
+instance Arbitrary Group where
+ arbitrary = do
+ x <- choose ('a', 'e')
+ return . Group $ [x]
+ shrink (Group (x:[])) = [Group [y] | y <- ['a' .. (pred x)]]
+instance Show Group where
+ show (Group s) = s
+
+data PresenceType = Unavailable | Online | Chat | Away | XA | DND deriving (Show, Eq)
+instance Arbitrary PresenceType where
+ arbitrary = oneof $ map return [Unavailable, Online, Chat, Away, XA, DND]
+
+main = do result <- quickCheckWithResult (stdArgs { chatty = False }) prop_rosterEvents
+ case result of
+ Success {} -> putStrLn "success"
+ Failure { output = o } -> putStrLn $ "failure: " ++ o
+
+prop_rosterEvents :: [RosterEvent] -> Property
+prop_rosterEvents events =
+ printTestCase ("counterexample: " ++ unlines asLisp) $ monadicIO test
+ where test = do result <- run testIO
+ assert (result == "t")
+ testIO = do mapM putStrLn asLisp
+ putStrLn "check"
+ getLine
+ asLisp = map toLisp events
+
+toLisp (IqRoster (JID jid) groups maybeName) =
+ "(iq ((type . \"set\"))"++
+ " (query ((xmlns . \"jabber:iq:roster\"))" ++
+ " (item ((jid . \""++jid++"\")" ++
+ maybe "" (\name -> " (name . " ++ show name ++ ")") maybeName ++
+ ") "++
+ concat ["(group () \""++group++"\")" | (Group group) <- groups] ++
+ " )))"
+toLisp (Presence (JID jid) Unavailable) =
+ "(presence ((from . \""++jid++"\") (type . \"unavailable\")))"
+toLisp (Presence (JID jid) Online) =
+ "(presence ((from . \""++jid++"\")))"
+toLisp (Presence (JID jid) presenceType) =
+ "(presence ((from . \""++jid++"\")) "++
+ " (show () \""++(map toLower (show presenceType))++"\"))"
+toLisp Noop = ""
-----------------------------------------------------------------------
Summary of changes:
tests/.gitignore | 5 ++-
tests/Makefile.am | 5 ++-
tests/roster-display-qc.el | 107 ++++++++++++++++++++++++++++++++++++++++++++
tests/roster-display.hs | 89 ++++++++++++++++++++++++++++++++++++
4 files changed, 204 insertions(+), 2 deletions(-)
create mode 100644 tests/roster-display-qc.el
create mode 100644 tests/roster-display.hs
hooks/post-receive
--
emacs-jabber
|
