[SCM] emacs-jabber branch, roster-optimisation, updated. 5e5f6de6e2c8b4bd4de7d9b3a910b31b3fa6a25d

[Magnus H. <leg...@us...>]

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