You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
99 lines
3.6 KiB
99 lines
3.6 KiB
12 years ago
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||
|
|
{-# LANGUAGE OverloadedStrings #-}
|
||
|
|
{-# LANGUAGE QuasiQuotes #-}
|
||
|
|
{-# LANGUAGE PatternGuards #-}
|
||
|
|
{-# LANGUAGE LambdaCase #-}
|
||
|
|
|
||
|
|
module Run.SendReceive 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.Exit
|
||
|
|
import System.Log.Logger
|
||
|
|
import System.Timeout
|
||
|
|
import Test.HUnit
|
||
|
|
import Test.Hspec.Expectations
|
||
|
|
|
||
|
|
import Run.Payload
|
||
|
|
import Run.Config
|
||
|
|
|
||
|
|
xmppConfig :: ConnectionDetails -> SessionConfiguration
|
||
|
|
xmppConfig det = def{sessionStreamConfiguration
|
||
|
|
= def{connectionDetails = det}
|
||
|
|
, onConnectionClosed = \sess _ -> do
|
||
|
|
_ <- reconnect' sess
|
||
|
|
_ <- sendPresence presenceOnline sess
|
||
|
|
return ()
|
||
|
|
}
|
||
|
|
|
||
|
|
-- | 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 åäü>"
|
||
|
|
)]
|
||
|
|
|
||
|
|
run :: IO ()
|
||
|
|
run = 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)
|
||
|
|
_ <- configuredLoglevel conf
|
||
|
|
mbSess1 <- session realm (simpleAuth uname1 pwd1)
|
||
|
|
((xmppConfig conDetails))
|
||
|
|
sess1 <- case mbSess1 of
|
||
|
|
Left e -> do
|
||
|
|
assertFailure $ "session 1 could not be initialized" ++ show e
|
||
|
|
exitFailure
|
||
|
|
Right r -> return r
|
||
|
|
mbSess2 <- session realm (simpleAuth uname2 pwd2)
|
||
|
|
((xmppConfig conDetails))
|
||
|
|
sess2 <- case mbSess2 of
|
||
|
|
Left e -> do
|
||
|
|
assertFailure $ "session 2 could not be initialized" ++ show e
|
||
|
|
exitFailure
|
||
|
|
Right r -> return r
|
||
|
|
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"
|