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 @@ |
|||||||
|
{-# 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 @@ |
|||||||
|
{-# 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