From a5b6900972b5ea003ea6c477f93860786b9aecdb Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 6 Mar 2014 21:20:33 +0100 Subject: [PATCH] add run tests We lacked a test suite that even just tried connecting to a server and bouncing a few stanzas back and forth. The "runtests" suite does just that. It connects to 2 accounts on a server (set in a config file ~/.pontarius-xmpp-tests/pontarius-xmpp-tests.conf) and tries passing some messages and IQ stanzas back and forth. This should clear the way for more interesting scenarios. --- pontarius-xmpp.cabal | 22 +++++++ tests/Run.hs | 108 +++++++++++++++++++++++++++++++ tests/Run/Payload.hs | 117 ++++++++++++++++++++++++++++++++++ tests/Tests/Arbitrary/Xmpp.hs | 2 +- tests/Tests/Parsers.hs | 2 +- tests/Tests/Picklers.hs | 3 +- 6 files changed, 250 insertions(+), 4 deletions(-) create mode 100644 tests/Run.hs create mode 100644 tests/Run/Payload.hs diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index da1d218..b8c5125 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -168,6 +168,28 @@ Test-Suite doctest , derive , quickcheck-instances +Test-Suite runtests + Type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Run.hs + other-modules: Run.Payload + GHC-Options: -Wall -threaded + Build-Depends: base + , HUnit + , configurator + , directory + , filepath + , hslogger + , hspec + , hspec-expectations + , mtl + , network + , pontarius-xmpp + , stm + , text + , xml-picklers + , xml-types + benchmark benchmarks type: exitcode-stdio-1.0 build-depends: base diff --git a/tests/Run.hs b/tests/Run.hs new file mode 100644 index 0000000..32b110f --- /dev/null +++ b/tests/Run.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE LambdaCase #-} + +module Main where + +import Control.Applicative +import Control.Concurrent +import Control.Monad +import qualified Data.Configurator as Conf +import qualified Data.Configurator.Types as Conf +import Data.Maybe +import qualified Data.Text as Text +import Network +import Network.Xmpp +import System.Directory +import System.FilePath +import System.Log.Logger +import System.Timeout +import Test.HUnit +import Test.Hspec.Expectations + +import Run.Payload + +xmppConfig :: ConnectionDetails -> SessionConfiguration +xmppConfig det = def{sessionStreamConfiguration + = def{connectionDetails = det} + , onConnectionClosed = \sess _ -> do + _ <- reconnect' sess + _ <- sendPresence presenceOnline sess + return () + } + +-- | Load the configuration files +loadConfig :: IO Conf.Config +loadConfig = do + appData <- getAppUserDataDirectory "pontarius-xmpp-tests" + home <- getHomeDirectory + Conf.load [ Conf.Optional $ appData "pontarius-xmpp-tests.conf" + , Conf.Optional $ home ".pontarius-xmpp-tests.conf" + ] + +-- | reflect messages to their origin +reflect :: Session -> IO b +reflect sess = forever $ do + m <- getMessage sess + case answerMessage m (messagePayload m) of + Nothing -> return () + Just am -> + void $ sendMessage am{messageAttributes = messageAttributes m} sess + +testAttributes = [( "{org.pontarius.xmpp.test}testattr" + , "testvalue 12321 åäü>" + )] + +main :: IO () +main = void $ do + conf <- loadConfig + uname1 <- Conf.require conf "xmpp.user1" + pwd1 <- Conf.require conf "xmpp.password1" + uname2 <- Conf.require conf "xmpp.user1" + pwd2 <- Conf.require conf "xmpp.password1" + realm <- Conf.require conf "xmpp.realm" + server <- Conf.lookup conf "xmpp.server" + port <- Conf.lookup conf "xmpp.port" :: IO (Maybe Integer) + let conDetails = case server of + Nothing -> UseRealm + Just srv -> case port of + Nothing -> UseSrv srv + Just p -> UseHost srv (PortNumber $ fromIntegral p) + loglevel <- Conf.lookup conf "loglevel" >>= \case + (Nothing :: Maybe Text.Text) -> return ERROR + Just "debug" -> return DEBUG + Just "info" -> return INFO + Just "notice" -> return NOTICE + Just "warning" -> return WARNING + Just "error" -> return ERROR + Just "critical" -> return CRITICAL + Just "alert" -> return ALERT + Just "emergency" -> return EMERGENCY + Just e -> error $ "Log level " ++ (Text.unpack e) ++ " unknown" + updateGlobalLogger "Pontarius.Xmpp" $ setLevel loglevel + Right sess1 <- session realm (simpleAuth uname1 pwd1) + ((xmppConfig conDetails)) + Right sess2 <- session realm (simpleAuth uname2 pwd2) + ((xmppConfig conDetails)) + Just jid1 <- getJid sess1 + Just jid2 <- getJid sess2 + _ <- sendPresence presenceOnline sess1 + _ <- forkIO $ reflect sess1 + forkIO $ iqResponder sess1 + _ <- sendPresence presenceOnline sess2 + -- check message responsiveness + infoM "Pontarius.Xmpp" "Running message mirror" + sendMessage message{ messageTo = Just jid1 + , messageAttributes = testAttributes + } sess2 + resp <- timeout 3000000 $ waitForMessage (\m -> messageFrom m == Just jid1) + sess2 + case resp of + Nothing -> assertFailure "Did not receive message answer" + Just am -> messageAttributes am `shouldBe` testAttributes + infoM "Pontarius.Xmpp" "Done running message mirror" + infoM "Pontarius.Xmpp" "Running IQ tests" + testPayload jid1 sess2 + infoM "Pontarius.Xmpp" "Done running IQ tests" diff --git a/tests/Run/Payload.hs b/tests/Run/Payload.hs new file mode 100644 index 0000000..e28c113 --- /dev/null +++ b/tests/Run/Payload.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE LambdaCase #-} + + +module Run.Payload where + +import Control.Monad +import Control.Monad.STM +import qualified Data.Text as Text +import Data.XML.Pickle +import Data.XML.Types +import Network.Xmpp +import Network.Xmpp.Internal +import System.Log.Logger +import Test.HUnit hiding (Node) +import Test.Hspec.Expectations + +data Payload = Payload + { payloadCounter :: !Int + , ignoreFlag :: !Bool + , errorFlag :: !Bool + , payloadText :: !Text.Text + } deriving (Eq, Show) + +testNS :: Text.Text +testNS = "xmpp:library:test" + +payloadP :: PU [Node] Payload +payloadP = xpWrap (\((counter,iFlag, eFlag) , message) + -> Payload counter iFlag eFlag message) + (\(Payload counter iFlag eFlag message) + ->((counter,iFlag, eFlag) , message)) $ + xpElem (Name "request" (Just testNS) Nothing) + (xp3Tuple + (xpAttr "counter" xpPrim) + (xpAttr "ignoreFlag" xpPrim) + (xpAttr "errorFlag" xpPrim) + ) + (xpElemNodes (Name "message" (Just testNS) Nothing) + (xpContent xpId)) + +invertPayload :: Payload -> Payload +invertPayload (Payload count _iFlag _eFlag message) = + Payload (count + 1) False False (Text.reverse message) + +iqResponder :: Session -> IO () +iqResponder context = do + chan' <- listenIQ Set testNS context + chan <- case chan' of + Left _ -> do + assertFailure "Channel was already taken" + undefined + Right c -> return c + forever $ do + next <- atomically $ chan + let Right payload = unpickleElem payloadP . iqRequestPayload $ + iqRequestBody next + let answerPayload = invertPayload payload + let answerBody = pickleElem payloadP answerPayload + unless (ignoreFlag payload) . void $ + case errorFlag payload of + False -> answerIQ next (Right $ Just answerBody) [] + True -> answerIQ next (Left $ mkStanzaError NotAcceptable) [] + +testString :: Text.Text +testString = "abc ÄÖ>" + +testPayload :: Jid -> Session -> IO () +testPayload them session = do + infoM "Pontarius.Xmpp" "Testing IQ send/receive" + let pl1 = Payload 1 False False testString + body1 = pickleElem payloadP pl1 + resp <- sendIQ' (Just 3000000) (Just them) Set Nothing body1 [] session + + case resp of + Left e -> assertFailure $ "Could not send pl1" ++ show e + Right (IQResponseError e) -> + assertFailure $ "Unexpected IQ error" ++ show e + Right (IQResponseResult IQResult{iqResultPayload = Just pl}) -> do + case unpickleElem payloadP pl of + Left e -> assertFailure $ "Error unpickling response p1" + ++ ppUnpickleError e + Right r -> do + payloadCounter r `shouldBe` 2 + payloadText r `shouldBe` Text.reverse testString + Right (IQResponseResult _) -> + assertFailure "IQ result didn't contain payload" + infoM "Pontarius.Xmpp" "Done testing IQ send/receive" + ---------------------- + -- Timeout test + ---------------------- + let pl2 = Payload 2 True False testString + body2 = pickleElem payloadP pl2 + infoM "Pontarius.Xmpp" "Testing timeout" + resp <- sendIQ' (Just 1000000) (Just them) Set Nothing body2 [] session + case resp of + Left IQTimeOut -> return () + Left e -> assertFailure $ "Unexpected send error" ++ show e + Right r -> assertFailure $ "Unexpected IQ answer" ++ show r + infoM "Pontarius.Xmpp" "IQ timed out (as expected)" + ---------------------- + -- Error test + ---------------------- + infoM "Pontarius.Xmpp" "Testing IQ error" + let pl3 = Payload 3 False True testString + body3 = pickleElem payloadP pl3 + resp <- sendIQ' (Just 3000000) (Just them) Set Nothing body3 [] session + case resp of + Left e -> assertFailure $ "Unexpected send error" ++ show e + Right (IQResponseError e) -> + stanzaErrorCondition (iqErrorStanzaError e) `shouldBe` NotAcceptable + + Right r -> assertFailure $ "Received unexpected IQ response" ++ show r + infoM "Pontarius.Xmpp" "Received expected error" diff --git a/tests/Tests/Arbitrary/Xmpp.hs b/tests/Tests/Arbitrary/Xmpp.hs index 6c842c6..158e334 100644 --- a/tests/Tests/Arbitrary/Xmpp.hs +++ b/tests/Tests/Arbitrary/Xmpp.hs @@ -5,7 +5,7 @@ import Control.Applicative ((<$>), (<*>)) import Data.Char import Data.Maybe import qualified Data.Text as Text -import Network.Xmpp.Types +import Network.Xmpp.Internal hiding (elements) import Test.QuickCheck import Test.QuickCheck.Instances() import qualified Text.CharRanges as Ranges diff --git a/tests/Tests/Parsers.hs b/tests/Tests/Parsers.hs index 7081d6d..f799a79 100644 --- a/tests/Tests/Parsers.hs +++ b/tests/Tests/Parsers.hs @@ -5,7 +5,7 @@ module Tests.Parsers where import Control.Applicative ((<$>)) -import Network.Xmpp.Types +import Network.Xmpp.Internal import Test.Hspec import Test.Tasty.QuickCheck import Test.Tasty diff --git a/tests/Tests/Picklers.hs b/tests/Tests/Picklers.hs index a2d2fbc..650b717 100644 --- a/tests/Tests/Picklers.hs +++ b/tests/Tests/Picklers.hs @@ -4,8 +4,7 @@ module Tests.Picklers where import Tests.Arbitrary () import Data.XML.Pickle -import Network.Xmpp.Marshal -import Network.Xmpp.Types +import Network.Xmpp.Internal import Test.Tasty import Test.Tasty.TH import Test.Tasty.QuickCheck