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

@@ -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'

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

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

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 \"<jid>\"".
 instance Show LangTag where
   show l = "parseLangTag " ++ show (langTagToText l)