From 664daa540aa05e097f2fc012cff8f35b8dc9f037 Mon Sep 17 00:00:00 2001
From: Philipp Balzarek <p.balzarek@googlemail.com>
Date: Tue, 12 Nov 2013 17:18:59 +0100
Subject: [PATCH] add timeout parameter to sendIQ'

---
 pontarius-xmpp.cabal                 |  1 +
 source/Network/Xmpp/Concurrent/IQ.hs | 26 ++++++++++++++------------
 source/Network/Xmpp/IM/Roster.hs     | 14 +++++++++-----
 3 files changed, 24 insertions(+), 17 deletions(-)

diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal
index 046fc86..7d54ba2 100644
--- a/pontarius-xmpp.cabal
+++ b/pontarius-xmpp.cabal
@@ -67,6 +67,7 @@ Library
                , tls                  >=1.1.3
                , tls-extra            >=0.6.0
                , transformers         >=0.2.2.0
+               , unbounded-delays     >=0.1
                , void                 >=0.5.5
                , xml-types            >=0.3.1
                , xml-conduit          >=1.1.0.7
diff --git a/source/Network/Xmpp/Concurrent/IQ.hs b/source/Network/Xmpp/Concurrent/IQ.hs
index 2204493..9055875 100644
--- a/source/Network/Xmpp/Concurrent/IQ.hs
+++ b/source/Network/Xmpp/Concurrent/IQ.hs
@@ -1,8 +1,10 @@
 {-# OPTIONS_HADDOCK hide #-}
 module Network.Xmpp.Concurrent.IQ where
 
-import           Control.Concurrent (forkIO, threadDelay)
+import           Control.Concurrent (forkIO)
+import           Control.Concurrent.Thread.Delay (delay)
 import           Control.Concurrent.STM
+
 import           Control.Monad
 
 import qualified Data.Map as Map
@@ -16,17 +18,17 @@ import           Network.Xmpp.Types
 -- | Sends an IQ, returns Just a 'TMVar' that will be filled with the first
 -- inbound IQ with a matching ID that has type @result@ or @error@ or Nothing if
 -- the stanza could not be sent
-sendIQ :: Maybe Int -- ^ Timeout . When the timeout is reached the response
-                    -- TMVar will be filled with 'IQResponseTimeout' and the id
-                    -- is removed from the list of IQ handlers. 'Nothing'
-                    -- deactivates the timeout
+sendIQ :: Maybe Integer -- ^ Timeout . When the timeout is reached the response
+                        -- TMVar will be filled with 'IQResponseTimeout' and the
+                        -- id is removed from the list of IQ handlers. 'Nothing'
+                        -- deactivates the timeout
        -> Maybe Jid -- ^ Recipient (to)
        -> IQRequestType  -- ^ IQ type (@Get@ or @Set@)
        -> Maybe LangTag  -- ^ Language tag of the payload (@Nothing@ for
                          -- default)
        -> Element -- ^ The IQ body (there has to be exactly one)
        -> Session
-       -> IO (Maybe (TMVar IQResponse))
+       -> IO (Maybe (TMVar (Maybe IQResponse)))
 sendIQ timeOut to tp lang body session = do -- TODO: Add timeout
     newId <- idGenerator session
     ref <- atomically $ do
@@ -41,7 +43,7 @@ sendIQ timeOut to tp lang body session = do -- TODO: Add timeout
             case timeOut of
                 Nothing -> return ()
                 Just t -> void . forkIO $ do
-                          threadDelay t
+                          delay t
                           doTimeOut (iqHandlers session) newId ref
             return $ Just ref
         else return Nothing
@@ -53,16 +55,16 @@ sendIQ timeOut to tp lang body session = do -- TODO: Add timeout
           writeTVar handlers (byNS, Map.delete iqid byId)
       return ()
 
-
--- | Like 'sendIQ', but waits for the answer IQ. Times out after 30 seconds
-sendIQ' :: Maybe Jid
+-- | Like 'sendIQ', but waits for the answer IQ.
+sendIQ' :: Maybe Integer
+        -> Maybe Jid
         -> IQRequestType
         -> Maybe LangTag
         -> Element
         -> Session
         -> IO (Maybe IQResponse)
-sendIQ' to tp lang body session = do
-    ref <- sendIQ (Just 30000000) to tp lang body session
+sendIQ' timeout to tp lang body session = do
+    ref <- sendIQ timeout to tp lang body session
     maybe (return Nothing) (fmap Just . atomically . takeTMVar) ref
 
 
diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs
index e0f4425..5e1a8aa 100644
--- a/source/Network/Xmpp/IM/Roster.hs
+++ b/source/Network/Xmpp/IM/Roster.hs
@@ -27,12 +27,16 @@ import           Network.Xmpp.IM.Roster.Types
 import           Network.Xmpp.Marshal
 import           Network.Xmpp.Types
 
+-- | Timeout to use with IQ requests
+timeout :: Maybe Integer
+timeout = Just 3000000 -- 3 seconds
+
 -- | Push a roster item to the server. The values for approved and ask are
 -- ignored and all values for subsciption except "remove" are ignored
 rosterPush :: Item -> Session -> IO (Maybe IQResponse)
 rosterPush item session = do
     let el = pickleElem xpQuery (Query Nothing [fromItem item])
-    sendIQ'  Nothing Set Nothing el session
+    sendIQ' timeout  Nothing Set Nothing el session
 
 -- | Add or update an item to the roster.
 --
@@ -51,7 +55,7 @@ rosterAdd j n gs session = do
                                             , qiSubscription = Nothing
                                             , qiGroups = nub gs
                                             }])
-    sendIQ'  Nothing Set Nothing el session
+    sendIQ' timeout Nothing Set Nothing el session
 
 -- | Remove an item from the roster. Return True when the item is sucessfully
 -- removed or if it wasn't in the roster to begin with.
@@ -121,9 +125,9 @@ retrieveRoster mbOldRoster sess = do
                       Nothing -> Just ""
                       Just oldRoster -> ver oldRoster
                 else Nothing
-    res <- sendIQ' Nothing Get Nothing
-        (pickleElem xpQuery (Query version []))
-        sess
+    res <- sendIQ' timeout Nothing Get Nothing
+                   (pickleElem xpQuery (Query version []))
+                   sess
     case res of
         Nothing -> do
             errorM "Pontarius.Xmpp.Roster" "getRoster: sending stanza failed"