module Network.Xmpp.Concurrent.IQ where
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
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
sendIQ :: Maybe Int
-> Maybe Jid
-> IQRequestType
-> Maybe LangTag
-> Element
-> Session
-> IO (TMVar IQResponse)
sendIQ timeOut to tp lang body session = do
newId <- idGenerator session
ref <- atomically $ do
resRef <- newEmptyTMVar
(byNS, byId) <- readTVar (iqHandlers session)
writeTVar (iqHandlers session) (byNS, Map.insert newId resRef byId)
return resRef
sendStanza (IQRequestS $ IQRequest newId Nothing to lang tp body) session
case timeOut of
Nothing -> return ()
Just t -> void . forkIO $ do
threadDelay t
doTimeOut (iqHandlers session) newId ref
return ref
where
doTimeOut handlers iqid var = atomically $ do
p <- tryPutTMVar var IQResponseTimeout
when p $ do
(byNS, byId) <- readTVar (iqHandlers session)
writeTVar handlers (byNS, Map.delete iqid byId)
return ()
sendIQ' :: Maybe Jid
-> IQRequestType
-> Maybe LangTag
-> Element
-> Session
-> IO IQResponse
sendIQ' to tp lang body session = do
ref <- sendIQ (Just 3000000) to tp lang body session
atomically $ takeTMVar ref
listenIQChan :: IQRequestType
-> Text
-> Session
-> IO (Either (TChan IQRequestTicket) (TChan IQRequestTicket))
listenIQChan tp ns session = do
let handlers = (iqHandlers session)
atomically $ do
(byNS, byID) <- readTVar handlers
iqCh <- newTChan
let (present, byNS') = Map.insertLookupWithKey'
(\_ _ old -> old)
(tp, ns)
iqCh
byNS
writeTVar handlers (byNS', byID)
return $ case present of
Nothing -> Right iqCh
Just iqCh' -> Left iqCh'
answerIQ :: IQRequestTicket
-> Either StanzaError (Maybe Element)
-> Session
-> IO Bool
answerIQ (IQRequestTicket
sentRef
(IQRequest iqid from _to lang _tp bd))
answer session = do
let response = case answer of
Left err -> IQErrorS $ IQError iqid Nothing from lang err (Just bd)
Right res -> IQResultS $ IQResult iqid Nothing from lang res
atomically $ do
sent <- readTVar sentRef
case sent of
False -> do
writeTVar sentRef True
writeTChan (outCh session) response
return True
True -> return False