added concurrent startSession

added pickler testcase
updated test client

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

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 ()

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

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
+      when active $ do
-        forM [1..10] $ \count -> do
+        liftIO $ threadDelay 1000000 -- Wait for the other thread to go online
-            let message = Text.pack . show $ localpart we
+        void . forkXMPP $ do
-            let payload = Payload count (even count) (Text.pack $ show count)
+          forM [1..10] $ \count -> do
-            let body = pickleElem payloadP payload
+              let message = Text.pack . show $ localpart we
-            Right answer <- sendIQ' (Just them) Get Nothing body
+              let payload = Payload count (even count) (Text.pack $ show count)
-            let Right answerPayload = unpickleElem payloadP
+              let body = pickleElem payloadP payload
-                                  (fromJust $ iqResultPayload answer)
+              debug' "sending"
-            expect debug' (invertPayload payload) answerPayload
+              Right answer <- sendIQ' (Just them) Get Nothing body
-            liftIO $ threadDelay 100000
+              debug' "received"
-        sendUser "All tests done"
+              let Right answerPayload = unpickleElem payloadP
-      liftIO  . forever $ threadDelay 10000000
+                                    (fromJust $ iqResultPayload answer)
+              expect debug' (invertPayload payload) answerPayload
+              liftIO $ threadDelay 100000
+          sendUser "All tests done"
+          endSession
+      liftIO . atomically $ takeTMVar wait
       return ()
   return ()
 

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