From d2f793c9b6144de4b68251d1a2b90bc311af477e Mon Sep 17 00:00:00 2001
From: Philipp Balzarek <p.balzarek@googlemail.com>
Date: Thu, 10 May 2012 16:18:32 +0200
Subject: [PATCH] add IQRequestTicket

---
 src/Network/XMPP.hs                    | 5 +++--
 src/Network/XMPP/Concurrent/IQ.hs      | 7 +++++--
 src/Network/XMPP/Concurrent/Monad.hs   | 2 +-
 src/Network/XMPP/Concurrent/Threads.hs | 3 +--
 src/Network/XMPP/Concurrent/Types.hs   | 7 ++++++-
 src/Tests.hs                           | 5 +++--
 6 files changed, 19 insertions(+), 10 deletions(-)

diff --git a/src/Network/XMPP.hs b/src/Network/XMPP.hs
index 53d7ba9..8047c81 100644
--- a/src/Network/XMPP.hs
+++ b/src/Network/XMPP.hs
@@ -113,6 +113,8 @@ module Network.XMPP
   --
   -- <http://xmpp.org/rfcs/rfc6120.html#stanzas-semantics-iq>
   , IQRequest(..)
+  , IQRequestTicket
+  , iqRequestBody
   , IQRequestType(..)
   , IQResult(..)
   , IQError(..)
@@ -136,8 +138,7 @@ import Network
 import qualified Network.TLS as TLS
 import Network.XMPP.Bind
 import Network.XMPP.Concurrent
-import Network.XMPP.IM.Presence hiding (presence)
-import Network.XMPP.IM.Message
+import Network.XMPP.Concurrent.Types
 import Network.XMPP.Message
 import Network.XMPP.Monad
 import Network.XMPP.Presence
diff --git a/src/Network/XMPP/Concurrent/IQ.hs b/src/Network/XMPP/Concurrent/IQ.hs
index 500719c..ba5bd72 100644
--- a/src/Network/XMPP/Concurrent/IQ.hs
+++ b/src/Network/XMPP/Concurrent/IQ.hs
@@ -40,10 +40,13 @@ sendIQ' to tp lang body = do
   ref <- sendIQ to tp lang body
   liftIO . atomically $ takeTMVar ref
 
-answerIQ :: (IQRequest, TVar Bool)
+answerIQ :: IQRequestTicket
          -> Either StanzaError (Maybe Element)
          -> XMPP Bool
-answerIQ ((IQRequest iqid from _to lang _tp bd), sentRef) answer = do
+answerIQ (IQRequestTicket
+              sentRef
+              (IQRequest iqid from _to lang _tp bd))
+           answer = do
   out <- asks outCh
   let response = case answer of
         Left err  -> IQErrorS $ IQError iqid Nothing from lang err (Just bd)
diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs
index 5ed5508..815ce8a 100644
--- a/src/Network/XMPP/Concurrent/Monad.hs
+++ b/src/Network/XMPP/Concurrent/Monad.hs
@@ -24,7 +24,7 @@ import           Network.XMPP.Monad
 -- combination was alread handled
 listenIQChan :: IQRequestType  -- ^ type of IQs to receive (Get / Set)
                 -> Text -- ^ namespace of the child element
-                -> XMPP (Maybe ( TChan (IQRequest, TVar Bool)))
+                -> XMPP (Maybe ( TChan IQRequestTicket))
 listenIQChan tp ns = do
   handlers <- asks iqHandlers
   liftIO . atomically $ do
diff --git a/src/Network/XMPP/Concurrent/Threads.hs b/src/Network/XMPP/Concurrent/Threads.hs
index 3109771..4f6a1d7 100644
--- a/src/Network/XMPP/Concurrent/Threads.hs
+++ b/src/Network/XMPP/Concurrent/Threads.hs
@@ -107,8 +107,7 @@ handleIQRequest handlers iq = do
       Nothing -> return () -- TODO: send error stanza
       Just ch -> do
         sent <- newTVar False
-        writeTChan ch (iq, sent)
-
+        writeTChan ch $ IQRequestTicket sent iq
 handleIQResponse :: TVar IQHandlers -> Either IQError IQResult -> STM ()
 handleIQResponse handlers iq = do
   (byNS, byID) <- readTVar handlers
diff --git a/src/Network/XMPP/Concurrent/Types.hs b/src/Network/XMPP/Concurrent/Types.hs
index c9e6cab..964d126 100644
--- a/src/Network/XMPP/Concurrent/Types.hs
+++ b/src/Network/XMPP/Concurrent/Types.hs
@@ -18,7 +18,7 @@ import           Data.Typeable
 import           Network.XMPP.Types
 
 
-type IQHandlers = (Map.Map (IQRequestType, Text) (TChan (IQRequest, TVar Bool))
+type IQHandlers = (Map.Map (IQRequestType, Text) (TChan IQRequestTicket)
                   , Map.Map StanzaId (TMVar IQResponse)
                   )
 
@@ -60,3 +60,8 @@ type XMPP a = ReaderT Session IO a
 data Interrupt = Interrupt (TMVar ()) deriving Typeable
 instance Show Interrupt where show _ = "<Interrupt>"
 instance Ex.Exception Interrupt
+
+data IQRequestTicket = IQRequestTicket
+                           { sentRef     :: (TVar Bool)
+                           , iqRequestBody :: IQRequest
+                           }
diff --git a/src/Tests.hs b/src/Tests.hs
index 4b4532d..76b826f 100644
--- a/src/Tests.hs
+++ b/src/Tests.hs
@@ -60,8 +60,9 @@ iqResponder = do
                      >> error "hanging up"
       Just c -> return c
   forever $ do
-    next@(iq,_) <- liftIO . atomically $ readTChan chan
-    let Right payload = unpickleElem payloadP $ iqRequestPayload iq
+    next <- liftIO . atomically $ readTChan chan
+    let Right payload = unpickleElem payloadP . iqRequestPayload $
+                          iqRequestBody next
     let answerPayload = invertPayload payload
     let answerBody = pickleElem payloadP answerPayload
     answerIQ next (Right $ Just answerBody)