Browse Source
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.master
Philipp Balzarek
12 years ago
6 changed files with 250 additions and 4 deletions
@ -0,0 +1,108 @@
@@ -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" |
||||
@ -0,0 +1,117 @@
@@ -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" |
||||
Loading…
Reference in new issue