From 79e23b8cdde99d0120bec88992c1053ae1d04200 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Fri, 20 Apr 2012 12:02:55 +0200 Subject: [PATCH] added concurrent startSession added pickler testcase updated test client --- src/Network/XMPP/Pickle.hs | 6 ------ src/Network/XMPP/Session.hs | 11 +++++++--- src/Network/XMPP/Types.hs | 1 + src/Tests.hs | 41 ++++++++++++++++++++++++------------- tests/Stanzas.hs | 17 +++++++++++++++ 5 files changed, 53 insertions(+), 23 deletions(-) create mode 100644 tests/Stanzas.hs diff --git a/src/Network/XMPP/Pickle.hs b/src/Network/XMPP/Pickle.hs index 45eeab2..347e8a5 100644 --- a/src/Network/XMPP/Pickle.hs +++ b/src/Network/XMPP/Pickle.hs @@ -29,12 +29,6 @@ xmlLang = Name "lang" Nothing (Just "xml") xpLangTag :: PU [Attribute] (Maybe LangTag) xpLangTag = xpAttrImplied xmlLang xpPrim --- xpElemExists :: Name -> PU [Node] Bool --- xpElemExists name = xpWrap (\x -> mbToBool x) --- (\x -> if x then Just () else Nothing) $ --- xpOption (xpElemEmpty name) - - xpNodeElem :: PU [Node] a -> PU Element a xpNodeElem xp = PU { pickleTree = \x -> head $ (pickleTree xp x) >>= \y -> case y of diff --git a/src/Network/XMPP/Session.hs b/src/Network/XMPP/Session.hs index 7b37a44..5a355b0 100644 --- a/src/Network/XMPP/Session.hs +++ b/src/Network/XMPP/Session.hs @@ -8,15 +8,14 @@ import Data.XML.Types(Element) import Network.XMPP.Monad import Network.XMPP.Pickle import Network.XMPP.Types +import Network.XMPP.Concurrent + sessionXML :: Element sessionXML = pickleElem (xpElemBlank "{urn:ietf:params:xml:ns:xmpp-session}session" ) () - - - sessionIQ :: Stanza sessionIQ = IQRequestS $ IQRequest { iqRequestID = "sess" , iqRequestFrom = Nothing @@ -33,3 +32,9 @@ xmppSession = do let IQResultS (IQResult "sess" Nothing Nothing _lang _body) = answer return () +startSession :: XMPPThread () +startSession = do + answer <- sendIQ' Nothing Set Nothing sessionXML + case answer of + Left e -> error $ show e + Right _ -> return () diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index e6eace6..1f59194 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -122,6 +122,7 @@ data Stanza = IQRequestS IQRequest | MessageErrorS MessageError | PresenceS Presence | PresenceErrorS PresenceError + deriving Show -- | -- A "request" Info/Query (IQ) stanza is one with either "get" or diff --git a/src/Tests.hs b/src/Tests.hs index 3b46959..d5621ab 100644 --- a/src/Tests.hs +++ b/src/Tests.hs @@ -34,7 +34,11 @@ attXmpp = liftIO . atomically testNS :: Text testNS = "xmpp:library:test" -data Payload = Payload Int Bool Text deriving (Eq, Show) +data Payload = Payload + { payloadCounter ::Int + , payloadFlag :: Bool + , payloadText :: Text + } deriving (Eq, Show) payloadP = xpWrap (\((counter,flag) , message) -> Payload counter flag message) (\(Payload counter flag message) ->((counter,flag) , message)) $ @@ -58,6 +62,7 @@ iqResponder = do let answerPayload = invertPayload payload let answerBody = pickleElem payloadP answerPayload answerIQ next (Right $ Just answerBody) + when (payloadCounter payload == 10) endSession autoAccept :: XMPPThread () autoAccept = forever $ do @@ -84,7 +89,9 @@ runMain debug number = do _ -> error "Need either 1 or 2" let debug' = liftIO . atomically . debug . (("Thread " ++ show number ++ ":") ++) + wait <- newEmptyTMVarIO xmppNewSession $ do + setSessionEndHandler (liftIO . atomically $ putTMVar wait ()) debug' "running" connect "localhost" "species64739.dyndns.org" startTLS exampleParams @@ -93,23 +100,29 @@ runMain debug number = do Right _ -> return () Left e -> error e xmppThreadedBind (resourcepart we) - withConnection $ xmppSession +-- startSession debug' "session standing" sendPresence presenceOnline forkXMPP autoAccept + sendPresence $ presenceSubscribe them forkXMPP iqResponder - when active . void . forkXMPP $ do - forM [1..10] $ \count -> do - let message = Text.pack . show $ localpart we - let payload = Payload count (even count) (Text.pack $ show count) - let body = pickleElem payloadP payload - Right answer <- sendIQ' (Just them) Get Nothing body - let Right answerPayload = unpickleElem payloadP - (fromJust $ iqResultPayload answer) - expect debug' (invertPayload payload) answerPayload - liftIO $ threadDelay 100000 - sendUser "All tests done" - liftIO . forever $ threadDelay 10000000 + when active $ do + liftIO $ threadDelay 1000000 -- Wait for the other thread to go online + void . forkXMPP $ do + forM [1..10] $ \count -> do + let message = Text.pack . show $ localpart we + let payload = Payload count (even count) (Text.pack $ show count) + let body = pickleElem payloadP payload + debug' "sending" + Right answer <- sendIQ' (Just them) Get Nothing body + debug' "received" + let Right answerPayload = unpickleElem payloadP + (fromJust $ iqResultPayload answer) + expect debug' (invertPayload payload) answerPayload + liftIO $ threadDelay 100000 + sendUser "All tests done" + endSession + liftIO . atomically $ takeTMVar wait return () return () diff --git a/tests/Stanzas.hs b/tests/Stanzas.hs new file mode 100644 index 0000000..23f6250 --- /dev/null +++ b/tests/Stanzas.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} +module Tests.Stanzas where + +import Data.Either +import Data.XML.Types +import Network.XMPP +import Network.XMPP.Marshal +import Network.XMPP.Pickle +import Network.XMPP.Types + +xml1 = Element {elementName = Name {nameLocalName = "iq", nameNamespace = Just "jabber:client", namePrefix = Nothing}, elementAttributes = [(Name {nameLocalName = "id", nameNamespace = Nothing, namePrefix = Nothing},[ContentText "2"]), (Name {nameLocalName = "type", nameNamespace = Nothing, namePrefix = Nothing},[ContentText "error"]),(Name {nameLocalName = "to", nameNamespace = Nothing, namePrefix = Nothing},[ContentText "testuser1@species64739.dyndns.org/bot1"]),(Name {nameLocalName = "from", nameNamespace = Nothing, namePrefix = Nothing},[ContentText "testuser2@species64739.dyndns.org/bot2"])], elementNodes = [NodeElement (Element {elementName = Name {nameLocalName = "error", nameNamespace = Just "jabber:client", namePrefix = Nothing}, elementAttributes = [(Name {nameLocalName = "type", nameNamespace = Nothing, namePrefix = Nothing},[ContentText "cancel"])], elementNodes = [NodeElement (Element {elementName = Name {nameLocalName = "service-unavailable", nameNamespace = Just "urn:ietf:params:xml:ns:xmpp-stanzas", namePrefix = Nothing}, elementAttributes = [], elementNodes = []})]})]} + +isRight (Right _) = True +isRight _ = False + + +testXML1 = isRight $ unpickleElem stanzaP xml1 \ No newline at end of file