module Network.Xmpp.Concurrent.IQ where
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.STM
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
sendIQ :: Maybe Int
-> Maybe Jid
-> IQRequestType
-> Maybe LangTag
-> Element
-> Session
-> IO (Maybe (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
res <- sendStanza (IQRequestS $ IQRequest newId Nothing to lang tp body) session
if res
then do
case timeOut of
Nothing -> return ()
Just t -> void . forkIO $ do
threadDelay t
doTimeOut (iqHandlers session) newId ref
return $ Just ref
else return Nothing
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 (Maybe IQResponse)
sendIQ' to tp lang body session = do
ref <- sendIQ (Just 30000000) to tp lang body session
maybe (return Nothing) (fmap Just . 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'
dropIQChan :: IQRequestType
-> Text
-> Session
-> IO ()
dropIQChan tp ns session = do
let handlers = (iqHandlers session)
atomically $ do
(byNS, byID) <- readTVar handlers
let byNS' = Map.delete (tp, ns) byNS
writeTVar handlers (byNS', byID)
return ()
answerIQ :: IQRequestTicket
-> Either StanzaError (Maybe Element)
-> IO (Maybe Bool)
answerIQ ticket = answerTicket ticket