From 7f22610d7c5284f4413fd5a888cb1a593f849559 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 5 Apr 2012 20:49:40 +0200 Subject: [PATCH] fixed IQ handling --- src/Example.hs | 5 ++-- src/Network/XMPP/Bind.hs | 26 ++++++++++++++---- src/Network/XMPP/Concurrent.hs | 50 ++++++++++++++++++---------------- 3 files changed, 50 insertions(+), 31 deletions(-) diff --git a/src/Example.hs b/src/Example.hs index c17b738..916ceb2 100644 --- a/src/Example.hs +++ b/src/Example.hs @@ -38,9 +38,10 @@ mirror = forever $ do main :: IO () main = do sessionConnect "localhost" "species64739.dyndns.org" "bot" Nothing $ do - singleThreaded $ xmppStartTLS exampleParams +-- singleThreaded $ xmppStartTLS exampleParams singleThreaded $ xmppSASL "pwd" - singleThreaded $ xmppBind (Just "botsi") + xmppThreadedBind (Just "botsi") +-- singleThreaded $ xmppBind (Just "botsi") singleThreaded $ xmppSession forkXMPP autoAccept forkXMPP mirror diff --git a/src/Network/XMPP/Bind.hs b/src/Network/XMPP/Bind.hs index 1434e79..e8610df 100644 --- a/src/Network/XMPP/Bind.hs +++ b/src/Network/XMPP/Bind.hs @@ -12,15 +12,18 @@ import Data.XML.Types import Network.XMPP.Monad import Network.XMPP.Types import Network.XMPP.Pickle +import Network.XMPP.Concurrent +import Control.Monad.IO.Class + +bindBody :: Maybe Text -> Element +bindBody rsrc = (pickleElem + (bindP . xpOption $ xpElemNodes "resource" (xpContent xpId)) + rsrc + ) bindReqIQ :: Maybe Text -> Stanza -bindReqIQ rsrc= SIQ $ IQ Nothing Nothing "bind" Set - (pickleElem - (bindP . xpOption - $ xpElemNodes "resource" (xpContent xpId)) - rsrc - ) +bindReqIQ rsrc= SIQ $ IQ Nothing Nothing "bind" Set (bindBody rsrc) jidP :: PU [Node] JID jidP = bindP $ xpElemNodes "jid" (xpContent xpPrim) @@ -37,3 +40,14 @@ bindP :: PU [Node] b -> PU [Node] b bindP c = xpElemNodes "{urn:ietf:params:xml:ns:xmpp-bind}bind" c +xmppThreadedBind :: Maybe Text -> XMPPThread Text +xmppThreadedBind rsrc = do + liftIO $ putStrLn "bind..." + answer <- sendIQ' Nothing Set (bindBody rsrc) + liftIO . putStrLn $ "Answer: " ++ show answer + let (IQ Nothing Nothing _ Result b) = answer + let (JID _n _d (Just r)) = unpickleElem jidP b + return r + + + diff --git a/src/Network/XMPP/Concurrent.hs b/src/Network/XMPP/Concurrent.hs index 9c9299b..595d154 100644 --- a/src/Network/XMPP/Concurrent.hs +++ b/src/Network/XMPP/Concurrent.hs @@ -27,6 +27,7 @@ import qualified Data.Conduit.List as CL import Data.Default (def) import Data.IORef import qualified Data.Map as Map +import Data.Maybe import qualified Data.Text as Text import Data.Text(Text) import Data.Typeable @@ -78,7 +79,6 @@ readWorker messageC presenceC iqC s = Ex.catch (forever . flip runStateT s $ do return () SIQ i -> liftIO . atomically $ do writeTChan iqC i - _ <-readTChan iqC return () ) ( \(ReaderSignal a) -> do @@ -96,29 +96,26 @@ writeWorker stCh writeR = forever $ do _ <- forM outBS write atomically $ putTMVar writeR write - handleIQs :: MonadIO m => TVar IQHandlers -> TChan IQ -> m a handleIQs handlers iqC = liftIO . forever . atomically $ do iq <- readTChan iqC (byNS, byID) <- readTVar handlers - let iqNS' = nameNamespace . elementName . iqBody $ iq - case iqNS' of - Nothing -> return () -- TODO: send error stanza - Just iqNS -> case iqType iq of - Get -> case Map.lookup (Get, iqNS) byNS of - Nothing -> return () -- TODO: send error stanza - Just ch -> writeTChan ch iq - Set -> case Map.lookup (Set, iqNS) byNS of - Nothing -> return () -- TODO: send error stanza - Just ch -> writeTChan ch iq - -- Result / Error : - _ -> case Map.updateLookupWithKey (\_ _ -> Nothing) - (iqId iq) byID of - (Nothing, _) -> return () -- we are not supposed - -- to send an error - (Just tmvar, byID') -> do - _ <- tryPutTMVar tmvar iq -- don't block - writeTVar handlers (byNS, byID') + let iqNS = fromMaybe ("") (nameNamespace . elementName . iqBody $ iq) + case iqType iq of + Get -> case Map.lookup (Get, iqNS) byNS of + Nothing -> return () -- TODO: send error stanza + Just ch -> writeTChan ch iq + Set -> case Map.lookup (Set, iqNS) byNS of + Nothing -> return () -- TODO: send error stanza + Just ch -> writeTChan ch iq + -- Result / Error : + _ -> case Map.updateLookupWithKey (\_ _ -> Nothing) + (iqId iq) byID of + (Nothing, _) -> return () -- we are not supposed + -- to send an error + (Just tmvar, byID') -> do + _ <- tryPutTMVar tmvar iq -- don't block + writeTVar handlers (byNS, byID') @@ -313,7 +310,10 @@ singleThreaded a = do -- | Sends an IQ, returns a 'TMVar' that will be filled with the first inbound -- IQ with a matching ID that has type @result@ or @error@ -sendIQ :: JID -> IQType -> Element -> XMPPThread (TMVar IQ) +sendIQ :: Maybe JID -- ^ Recipient (to) + -> IQType -- ^ IQ type (Get or Set) + -> Element -- ^ The iq body (there has to be exactly one) + -> XMPPThread (TMVar IQ) sendIQ to tp body = do -- TODO: add timeout newId <- liftIO =<< asks idGenerator handlers <- asks iqHandlers @@ -323,7 +323,11 @@ sendIQ to tp body = do -- TODO: add timeout writeTVar handlers (byNS, Map.insert newId resRef byId) -- TODO: Check for id collisions (shouldn't happen?) return resRef - sendS . SIQ $ IQ Nothing (Just to) newId tp body + sendS . SIQ $ IQ Nothing (to) newId tp body return ref - +-- | like 'sendIQ', but waits for the answer IQ +sendIQ' :: Maybe JID -> IQType -> Element -> XMPPThread IQ +sendIQ' to tp body = do + ref <- sendIQ to tp body + liftIO . atomically $ takeTMVar ref \ No newline at end of file