Browse Source

return a service-unavailable un unmatched IQ requests

master
Philipp Balzarek 13 years ago
parent
commit
1e7bed93c5
  1. 14
      source/Network/Xmpp/Concurrent.hs

14
source/Network/Xmpp/Concurrent.hs

@ -48,10 +48,11 @@ import Control.Monad.Error
import Data.Default import Data.Default
toChans :: TChan Stanza toChans :: TChan Stanza
-> TChan Stanza
-> TVar IQHandlers -> TVar IQHandlers
-> Stanza -> Stanza
-> IO () -> IO ()
toChans stanzaC iqHands sta = atomically $ do toChans stanzaC outC iqHands sta = atomically $ do
writeTChan stanzaC sta writeTChan stanzaC sta
case sta of case sta of
IQRequestS i -> handleIQRequest iqHands i IQRequestS i -> handleIQRequest iqHands i
@ -65,10 +66,14 @@ toChans stanzaC iqHands sta = atomically $ do
(byNS, _) <- readTVar handlers (byNS, _) <- readTVar handlers
let iqNS = fromMaybe "" (nameNamespace . elementName $ iqRequestPayload iq) let iqNS = fromMaybe "" (nameNamespace . elementName $ iqRequestPayload iq)
case Map.lookup (iqRequestType iq, iqNS) byNS of case Map.lookup (iqRequestType iq, iqNS) byNS of
Nothing -> return () -- TODO: send error stanza Nothing -> writeTChan outC $ serviceUnavailable iq
Just ch -> do Just ch -> do
sent <- newTVar False sent <- newTVar False
writeTChan ch $ IQRequestTicket sent iq writeTChan ch $ IQRequestTicket sent iq
serviceUnavailable (IQRequest iqid from _to lang _tp bd) =
IQErrorS $ IQError iqid Nothing from lang err (Just bd)
err = StanzaError Cancel ServiceUnavailable Nothing Nothing
handleIQResponse :: TVar IQHandlers -> Either IQError IQResult -> STM () handleIQResponse :: TVar IQHandlers -> Either IQError IQResult -> STM ()
handleIQResponse handlers iq = do handleIQResponse handlers iq = do
(byNS, byID) <- readTVar handlers (byNS, byID) <- readTVar handlers
@ -82,7 +87,6 @@ toChans stanzaC iqHands sta = atomically $ do
iqID (Left err) = iqErrorID err iqID (Left err) = iqErrorID err
iqID (Right iq') = iqResultID iq' iqID (Right iq') = iqResultID iq'
-- | Creates and initializes a new Xmpp context. -- | Creates and initializes a new Xmpp context.
newSession :: TMVar Stream -> IO (Either XmppFailure Session) newSession :: TMVar Stream -> IO (Either XmppFailure Session)
newSession stream = runErrorT $ do newSession stream = runErrorT $ do
@ -90,7 +94,7 @@ newSession stream = runErrorT $ do
stanzaChan <- lift newTChanIO stanzaChan <- lift newTChanIO
iqHandlers <- lift $ newTVarIO (Map.empty, Map.empty) iqHandlers <- lift $ newTVarIO (Map.empty, Map.empty)
eh <- lift $ newTVarIO $ EventHandlers { connectionClosedHandler = \_ -> return () } eh <- lift $ newTVarIO $ EventHandlers { connectionClosedHandler = \_ -> return () }
let stanzaHandler = toChans stanzaChan iqHandlers let stanzaHandler = toChans stanzaChan outC iqHandlers
(kill, wLock, streamState, readerThread) <- ErrorT $ startThreadsWith stanzaHandler eh stream (kill, wLock, streamState, readerThread) <- ErrorT $ startThreadsWith stanzaHandler eh stream
writer <- lift $ forkIO $ writeWorker outC wLock writer <- lift $ forkIO $ writeWorker outC wLock
idRef <- lift $ newTVarIO 1 idRef <- lift $ newTVarIO 1
@ -123,7 +127,7 @@ writeWorker stCh writeR = forever $ do
threadDelay 250000 -- Avoid free spinning. threadDelay 250000 -- Avoid free spinning.
-- | Creates a 'Session' object by setting up a connection with an XMPP server. -- | Creates a 'Session' object by setting up a connection with an XMPP server.
-- --
-- Will connect to the specified host. If the fourth parameters is a 'Just' -- Will connect to the specified host. If the fourth parameters is a 'Just'
-- value, @session@ will attempt to secure the connection with TLS. If the fifth -- value, @session@ will attempt to secure the connection with TLS. If the fifth
-- parameters is a 'Just' value, @session@ will attempt to authenticate and -- parameters is a 'Just' value, @session@ will attempt to authenticate and

Loading…
Cancel
Save