From 30a14086897b8f552953146473c7fa38714639fc Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 3 Feb 2014 17:18:37 +0100 Subject: [PATCH] fix handling IQ responses IQs sent to the server may evoke responses with "from" attribute different from the "to" attribute the request was sent to. Specifically, it might be either empty, the JID of the server (that is, only domain part set) or either the bare or full JID of the client. --- source/Network/Xmpp/Concurrent.hs | 32 +++++++++++++++++++------ source/Network/Xmpp/Concurrent/IQ.hs | 15 ++++++------ source/Network/Xmpp/Concurrent/Types.hs | 3 ++- source/Network/Xmpp/Types.hs | 14 +++++++++++ 4 files changed, 48 insertions(+), 16 deletions(-) diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index dd7137f..65f22d2 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -121,13 +121,31 @@ handleIQ iqHands out sta as = do handleIQResponse :: TVar IQHandlers -> Either IQError IQResult -> IO () handleIQResponse handlers iq = atomically $ do (byNS, byID) <- readTVar handlers - case Map.updateLookupWithKey (\_ _ -> Nothing) (iqID iq, iqFrom iq) - byID of - (Nothing, _) -> return () -- We are not supposed to send an error. - (Just tmvar, byID') -> do - let answer = Just (either IQResponseError IQResponseResult iq, as) - _ <- tryPutTMVar tmvar answer -- Don't block. - writeTVar handlers (byNS, byID') + case Map.updateLookupWithKey (\_ _ -> Nothing) (iqID iq) byID of + (Nothing, _) -> return () -- The handler might be removed due to + -- timeout + (Just (expectedJid, tmvar), byID') -> do + let expected = case expectedJid of + -- IQ was sent to the server and we didn't have a bound JID + -- We just accept any matching response + Left Nothing -> True + -- IQ was sent to the server and we had a bound JID. Valid + -- responses might have no to attribute, the domain of the + -- server, our bare JID or our full JID + Left (Just j) -> case iqFrom iq of + Nothing -> True + Just jf -> jf <~ j + -- IQ was sent to a (full) JID. The answer has to come from + -- the same exact JID. + Right j -> iqFrom iq == Just j + _ -> False + case expected of + True -> do + let answer = Just (either IQResponseError + IQResponseResult iq, as) + _ <- tryPutTMVar tmvar answer -- Don't block. + writeTVar handlers (byNS, byID') + False -> return () where iqID (Left err') = iqErrorID err' iqID (Right iq') = iqResultID iq' diff --git a/source/Network/Xmpp/Concurrent/IQ.hs b/source/Network/Xmpp/Concurrent/IQ.hs index 4234ff6..6817c24 100644 --- a/source/Network/Xmpp/Concurrent/IQ.hs +++ b/source/Network/Xmpp/Concurrent/IQ.hs @@ -5,13 +5,10 @@ import Control.Applicative ((<$>)) import Control.Concurrent (forkIO) import Control.Concurrent.STM import Control.Concurrent.Thread.Delay (delay) - import Control.Monad - import qualified Data.Map as Map import Data.Text (Text) import Data.XML.Types - import Network.Xmpp.Concurrent.Basic import Network.Xmpp.Concurrent.Types import Network.Xmpp.Types @@ -31,14 +28,16 @@ sendIQ :: Maybe Integer -- ^ Timeout . When the timeout is reached the response -> Element -- ^ The IQ body (there has to be exactly one) -> Session -> IO (Either XmppFailure (TMVar (Maybe (Annotated IQResponse)))) -sendIQ timeOut to tp lang body session = do -- TODO: Add timeout +sendIQ timeOut to tp lang body session = do newId <- idGenerator session - let key = (newId, to) + j <- case to of + Just t -> return $ Right t + Nothing -> Left <$> getJid session ref <- atomically $ do resRef <- newEmptyTMVar + let value = (j, resRef) (byNS, byId) <- readTVar (iqHandlers session) - writeTVar (iqHandlers session) (byNS, Map.insert key resRef byId) - -- TODO: Check for id collisions (shouldn't happen?) + writeTVar (iqHandlers session) (byNS, Map.insert newId value byId) return resRef res <- sendStanza (IQRequestS $ IQRequest newId Nothing to lang tp body) session case res of @@ -47,7 +46,7 @@ sendIQ timeOut to tp lang body session = do -- TODO: Add timeout Nothing -> return () Just t -> void . forkIO $ do delay t - doTimeOut (iqHandlers session) key ref + doTimeOut (iqHandlers session) newId ref return $ Right ref Left e -> return $ Left e where diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index 4f2b605..415c1c4 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -135,7 +135,8 @@ data Session = Session -- TMVars of and TMVars for expected IQ responses (the second Text represent a -- stanza identifier. type IQHandlers = ( Map.Map (IQRequestType, Text) (TChan IQRequestTicket) - , Map.Map (Text, Maybe Jid) (TMVar (Maybe (Annotated IQResponse))) + , Map.Map Text (Either (Maybe Jid) Jid, + TMVar (Maybe (Annotated IQResponse))) ) -- | Contains whether or not a reply has been sent, and the IQ request body to diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index d14e4dd..6bd35a2 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -61,6 +61,7 @@ module Network.Xmpp.Types , isFull , jidFromText , jidFromTexts + , (<~) , nodeprepProfile , resourceprepProfile , jidToText @@ -878,6 +879,19 @@ jidQ :: QuasiQuoter jidQ = jidQ #endif +-- | The partial order of "definiteness". JID1 is less than or equal JID2 iff +-- the domain parts are equal and JID1's local part and resource part each are +-- either Nothing or equal to Jid2's +(<~) :: Jid -> Jid -> Bool +(Jid lp1 dp1 rp1) <~ (Jid lp2 dp2 rp2) = + dp1 == dp2 && + lp1 ~<~ lp2 && + rp1 ~<~ rp2 + where + Nothing ~<~ _ = True + Just x ~<~ Just y = x == y + _ ~<~ _ = False + -- Produces a LangTag value in the format "parseLangTag \"\"". instance Show LangTag where show l = "parseLangTag " ++ show (langTagToText l)