|
|
|
@ -23,28 +23,28 @@ sendIQ :: Maybe Int -- ^ Timeout |
|
|
|
-> Maybe LangTag -- ^ Language tag of the payload (@Nothing@ for |
|
|
|
-> Maybe LangTag -- ^ Language tag of the payload (@Nothing@ for |
|
|
|
-- default) |
|
|
|
-- default) |
|
|
|
-> Element -- ^ The IQ body (there has to be exactly one) |
|
|
|
-> Element -- ^ The IQ body (there has to be exactly one) |
|
|
|
-> CSession |
|
|
|
-> Context |
|
|
|
-> IO (TMVar IQResponse) |
|
|
|
-> IO (TMVar IQResponse) |
|
|
|
sendIQ timeOut to tp lang body csession = do -- TODO: Add timeout |
|
|
|
sendIQ timeOut to tp lang body context = do -- TODO: Add timeout |
|
|
|
newId <- idGenerator (session csession) |
|
|
|
newId <- idGenerator (session context) |
|
|
|
ref <- atomically $ do |
|
|
|
ref <- atomically $ do |
|
|
|
resRef <- newEmptyTMVar |
|
|
|
resRef <- newEmptyTMVar |
|
|
|
(byNS, byId) <- readTVar (iqHandlers csession) |
|
|
|
(byNS, byId) <- readTVar (iqHandlers context) |
|
|
|
writeTVar (iqHandlers csession) (byNS, Map.insert newId resRef byId) |
|
|
|
writeTVar (iqHandlers context) (byNS, Map.insert newId resRef byId) |
|
|
|
-- TODO: Check for id collisions (shouldn't happen?) |
|
|
|
-- TODO: Check for id collisions (shouldn't happen?) |
|
|
|
return resRef |
|
|
|
return resRef |
|
|
|
sendStanza (IQRequestS $ IQRequest newId Nothing to lang tp body) csession |
|
|
|
sendStanza (IQRequestS $ IQRequest newId Nothing to lang tp body) context |
|
|
|
case timeOut of |
|
|
|
case timeOut of |
|
|
|
Nothing -> return () |
|
|
|
Nothing -> return () |
|
|
|
Just t -> void . forkIO $ do |
|
|
|
Just t -> void . forkIO $ do |
|
|
|
threadDelay t |
|
|
|
threadDelay t |
|
|
|
doTimeOut (iqHandlers csession) newId ref |
|
|
|
doTimeOut (iqHandlers context) newId ref |
|
|
|
return ref |
|
|
|
return ref |
|
|
|
where |
|
|
|
where |
|
|
|
doTimeOut handlers iqid var = atomically $ do |
|
|
|
doTimeOut handlers iqid var = atomically $ do |
|
|
|
p <- tryPutTMVar var IQResponseTimeout |
|
|
|
p <- tryPutTMVar var IQResponseTimeout |
|
|
|
when p $ do |
|
|
|
when p $ do |
|
|
|
(byNS, byId) <- readTVar (iqHandlers csession) |
|
|
|
(byNS, byId) <- readTVar (iqHandlers context) |
|
|
|
writeTVar handlers (byNS, Map.delete iqid byId) |
|
|
|
writeTVar handlers (byNS, Map.delete iqid byId) |
|
|
|
return () |
|
|
|
return () |
|
|
|
|
|
|
|
|
|
|
|
@ -54,10 +54,10 @@ sendIQ' :: Maybe Jid |
|
|
|
-> IQRequestType |
|
|
|
-> IQRequestType |
|
|
|
-> Maybe LangTag |
|
|
|
-> Maybe LangTag |
|
|
|
-> Element |
|
|
|
-> Element |
|
|
|
-> CSession |
|
|
|
-> Context |
|
|
|
-> IO IQResponse |
|
|
|
-> IO IQResponse |
|
|
|
sendIQ' to tp lang body csession = do |
|
|
|
sendIQ' to tp lang body context = do |
|
|
|
ref <- sendIQ (Just 3000000) to tp lang body csession |
|
|
|
ref <- sendIQ (Just 3000000) to tp lang body context |
|
|
|
atomically $ takeTMVar ref |
|
|
|
atomically $ takeTMVar ref |
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
@ -68,10 +68,10 @@ sendIQ' to tp lang body csession = do |
|
|
|
-- to interfere with existing consumers. |
|
|
|
-- to interfere with existing consumers. |
|
|
|
listenIQChan :: IQRequestType -- ^ Type of IQs to receive (@Get@ or @Set@) |
|
|
|
listenIQChan :: IQRequestType -- ^ Type of IQs to receive (@Get@ or @Set@) |
|
|
|
-> Text -- ^ Namespace of the child element |
|
|
|
-> Text -- ^ Namespace of the child element |
|
|
|
-> CSession |
|
|
|
-> Context |
|
|
|
-> IO (Either (TChan IQRequestTicket) (TChan IQRequestTicket)) |
|
|
|
-> IO (Either (TChan IQRequestTicket) (TChan IQRequestTicket)) |
|
|
|
listenIQChan tp ns csession = do |
|
|
|
listenIQChan tp ns context = do |
|
|
|
let handlers = (iqHandlers csession) |
|
|
|
let handlers = (iqHandlers context) |
|
|
|
atomically $ do |
|
|
|
atomically $ do |
|
|
|
(byNS, byID) <- readTVar handlers |
|
|
|
(byNS, byID) <- readTVar handlers |
|
|
|
iqCh <- newTChan |
|
|
|
iqCh <- newTChan |
|
|
|
@ -87,12 +87,12 @@ listenIQChan tp ns csession = do |
|
|
|
|
|
|
|
|
|
|
|
answerIQ :: IQRequestTicket |
|
|
|
answerIQ :: IQRequestTicket |
|
|
|
-> Either StanzaError (Maybe Element) |
|
|
|
-> Either StanzaError (Maybe Element) |
|
|
|
-> CSession |
|
|
|
-> Context |
|
|
|
-> IO Bool |
|
|
|
-> IO Bool |
|
|
|
answerIQ (IQRequestTicket |
|
|
|
answerIQ (IQRequestTicket |
|
|
|
sentRef |
|
|
|
sentRef |
|
|
|
(IQRequest iqid from _to lang _tp bd)) |
|
|
|
(IQRequest iqid from _to lang _tp bd)) |
|
|
|
answer csession = do |
|
|
|
answer context = do |
|
|
|
let response = case answer of |
|
|
|
let response = case answer of |
|
|
|
Left err -> IQErrorS $ IQError iqid Nothing from lang err (Just bd) |
|
|
|
Left err -> IQErrorS $ IQError iqid Nothing from lang err (Just bd) |
|
|
|
Right res -> IQResultS $ IQResult iqid Nothing from lang res |
|
|
|
Right res -> IQResultS $ IQResult iqid Nothing from lang res |
|
|
|
@ -102,6 +102,6 @@ answerIQ (IQRequestTicket |
|
|
|
False -> do |
|
|
|
False -> do |
|
|
|
writeTVar sentRef True |
|
|
|
writeTVar sentRef True |
|
|
|
|
|
|
|
|
|
|
|
writeTChan (outCh csession) response |
|
|
|
writeTChan (outCh context) response |
|
|
|
return True |
|
|
|
return True |
|
|
|
True -> return False |
|
|
|
True -> return False |
|
|
|
|