@ -10,17 +10,14 @@ module Network.Xmpp.Concurrent
, module Network.Xmpp.Concurrent.IQ , module Network.Xmpp.Concurrent.IQ
, StanzaHandler , StanzaHandler
, newSession , newSession
, writeWorker
, session , session
, newStanzaID , newStanzaID
) where ) where
import Control.Applicative ( ( <$> ) , ( <*> ) )
import Control.Concurrent
import Control.Concurrent.STM import Control.Concurrent.STM
import Control.Monad import Control.Monad
import Control.Monad.Error import Control.Monad.Error
import qualified Data.ByteString as BS import qualified Control.Exception as Ex
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Maybe import Data.Maybe
import Data.Text as Text import Data.Text as Text
@ -35,22 +32,20 @@ import Network.Xmpp.Concurrent.Threads
import Network.Xmpp.Concurrent.Types import Network.Xmpp.Concurrent.Types
import Network.Xmpp.IM.Roster.Types import Network.Xmpp.IM.Roster.Types
import Network.Xmpp.IM.Roster import Network.Xmpp.IM.Roster
import Network.Xmpp.Marshal
import Network.Xmpp.Sasl import Network.Xmpp.Sasl
import Network.Xmpp.Sasl.Types import Network.Xmpp.Sasl.Types
import Network.Xmpp.Stream import Network.Xmpp.Stream
import Network.Xmpp.Tls import Network.Xmpp.Tls
import Network.Xmpp.Types import Network.Xmpp.Types
import Network.Xmpp.Utilities
import Control.Monad.State.Strict import Control.Monad.State.Strict
runHandlers :: ( TChan Stanza ) -> [ StanzaHandler ] -> Stanza -> IO () runHandlers :: WriteSemaphore -> [ StanzaHandler ] -> Stanza -> IO ()
runHandlers _ [] _ = return () runHandlers _ [] _ = return ()
runHandlers outC ( h : hands ) sta = do runHandlers sem ( h : hands ) sta = do
res <- h outC sta res <- h sem sta
case res of case res of
True -> runHandlers outC hands sta True -> runHandlers sem hands sta
False -> return () False -> return ()
toChan :: TChan Stanza -> StanzaHandler toChan :: TChan Stanza -> StanzaHandler
@ -61,7 +56,7 @@ toChan stanzaC _ sta = do
handleIQ :: TVar IQHandlers handleIQ :: TVar IQHandlers
-> StanzaHandler -> StanzaHandler
handleIQ iqHands outC sta = atomically $ do handleIQ iqHands writeSem sta = do
case sta of case sta of
IQRequestS i -> handleIQRequest iqHands i >> return False IQRequestS i -> handleIQRequest iqHands i >> return False
IQResultS i -> handleIQResponse iqHands ( Right i ) >> return False IQResultS i -> handleIQResponse iqHands ( Right i ) >> return False
@ -69,37 +64,49 @@ handleIQ iqHands outC sta = atomically $ do
_ -> return True _ -> return True
where where
-- If the IQ request has a namespace, send it through the appropriate channel. -- If the IQ request has a namespace, send it through the appropriate channel.
handleIQRequest :: TVar IQHandlers -> IQRequest -> STM () handleIQRequest :: TVar IQHandlers -> IQRequest -> IO ()
handleIQRequest handlers iq = do handleIQRequest handlers iq = do
( byNS , _ ) <- readTVar handlers out <- atomically $ do
let iqNS = fromMaybe " " ( nameNamespace . elementName $ iqRequestPayload iq ) ( byNS , _ ) <- readTVar handlers
case Map . lookup ( iqRequestType iq , iqNS ) byNS of let iqNS = fromMaybe " " ( nameNamespace . elementName
Nothing -> writeTChan outC $ serviceUnavailable iq $ iqRequestPayload iq )
Just ch -> do case Map . lookup ( iqRequestType iq , iqNS ) byNS of
sentRef <- newTVar False Nothing -> return . Just $ serviceUnavailable iq
let answerT answer = do Just ch -> do
let IQRequest iqid from _to lang _tp bd = iq sentRef <- newTMVar False
response = case answer of let answerT answer = do
Left er -> IQErrorS $ IQError iqid Nothing let IQRequest iqid from _to lang _tp bd = iq
from lang er response = case answer of
( Just bd ) Left er -> IQErrorS $ IQError iqid Nothing
Right res -> IQResultS $ IQResult iqid Nothing from lang er
from lang res ( Just bd )
atomically $ do Right res -> IQResultS $ IQResult iqid Nothing
sent <- readTVar sentRef from lang res
case sent of Ex . bracketOnError ( atomically $ takeTMVar sentRef )
False -> do ( atomically . putTMVar sentRef )
writeTVar sentRef True $ \ wasSent -> do
writeTChan outC response case wasSent of
return True True -> do
True -> return False atomically $ putTMVar sentRef True
writeTChan ch $ IQRequestTicket answerT iq return Nothing
False -> do
didSend <- writeStanza writeSem response
case didSend of
True -> do
atomically $ putTMVar sentRef True
return $ Just True
False -> do
atomically $ putTMVar sentRef False
return $ Just False
writeTChan ch $ IQRequestTicket answerT iq
return Nothing
maybe ( return () ) ( void . writeStanza writeSem ) out
serviceUnavailable ( IQRequest iqid from _to lang _tp bd ) = serviceUnavailable ( IQRequest iqid from _to lang _tp bd ) =
IQErrorS $ IQError iqid Nothing from lang err ( Just bd ) IQErrorS $ IQError iqid Nothing from lang err ( Just bd )
err = StanzaError Cancel ServiceUnavailable Nothing Nothing err = StanzaError Cancel ServiceUnavailable Nothing Nothing
handleIQResponse :: TVar IQHandlers -> Either IQError IQResult -> STM () handleIQResponse :: TVar IQHandlers -> Either IQError IQResult -> IO ()
handleIQResponse handlers iq = do handleIQResponse handlers iq = atomically $ do
( byNS , byID ) <- readTVar handlers ( byNS , byID ) <- readTVar handlers
case Map . updateLookupWithKey ( \ _ _ -> Nothing ) ( iqID iq ) byID of case Map . updateLookupWithKey ( \ _ _ -> Nothing ) ( iqID iq ) byID of
( Nothing , _ ) -> return () -- We are not supposed to send an error. ( Nothing , _ ) -> return () -- We are not supposed to send an error.
@ -114,51 +121,36 @@ handleIQ iqHands outC sta = atomically $ do
-- | Creates and initializes a new Xmpp context. -- | Creates and initializes a new Xmpp context.
newSession :: Stream -> SessionConfiguration -> IO ( Either XmppFailure Session ) newSession :: Stream -> SessionConfiguration -> IO ( Either XmppFailure Session )
newSession stream config = runErrorT $ do newSession stream config = runErrorT $ do
outC <- lift newTChanIO write' <- liftIO $ withStream' ( gets $ streamSend . streamHandle ) stream
writeSem <- liftIO $ newTMVarIO write'
stanzaChan <- lift newTChanIO stanzaChan <- lift newTChanIO
iqHands <- lift $ newTVarIO ( Map . empty , Map . empty ) iqHands <- lift $ newTVarIO ( Map . empty , Map . empty )
eh <- lift $ newTVarIO $ EventHandlers { connectionClosedHandler = onConnectionClosed config } eh <- lift $ newTVarIO $ EventHandlers { connectionClosedHandler = onConnectionClosed config }
ros <- liftIO . newTVarIO $ Roster Nothing Map . empty ros <- liftIO . newTVarIO $ Roster Nothing Map . empty
let rosterH = if ( enableRoster config ) then handleRoster ros let rosterH = if ( enableRoster config ) then handleRoster ros
else \ _ _ -> return True else \ _ _ -> return True
let stanzaHandler = runHandlers outC $ Prelude . concat [ [ toChan stanzaChan ] let stanzaHandler = runHandlers writeSem
, extraStanzaHandlers $ Prelude . concat [ [ toChan stanzaChan ]
config , extraStanzaHandlers
, [ handleIQ iqHands config
, rosterH , [ handleIQ iqHands
] , rosterH
] ]
( kill , wLock , streamState , reader ) <- ErrorT $ startThreadsWith stanzaHandler eh stream ]
writer <- lift $ forkIO $ writeWorker outC wLock ( kill , wLock , streamState , reader ) <- ErrorT $ startThreadsWith writeSem stanzaHandler eh stream
idGen <- liftIO $ sessionStanzaIDs config idGen <- liftIO $ sessionStanzaIDs config
return $ Session { stanzaCh = stanzaChan return $ Session { stanzaCh = stanzaChan
, outCh = outC
, iqHandlers = iqHands , iqHandlers = iqHands
, writeRef = wLock , writeSemaphore = wLock
, readerThread = reader , readerThread = reader
, idGenerator = idGen , idGenerator = idGen
, streamRef = streamState , streamRef = streamState
, eventHandlers = eh , eventHandlers = eh
, stopThreads = kill >> killThread writer , stopThreads = kill
, conf = config , conf = config
, rosterRef = ros , rosterRef = ros
} }
-- Worker to write stanzas to the stream concurrently.
writeWorker :: TChan Stanza -> TMVar ( BS . ByteString -> IO Bool ) -> IO ()
writeWorker stCh writeR = forever $ do
( write , next ) <- atomically $ ( , ) <$>
takeTMVar writeR <*>
readTChan stCh
let outData = renderElement $ nsHack ( pickleElem xpStanza next )
debugOut outData
r <- write outData
atomically $ putTMVar writeR write
unless r $ do
atomically $ unGetTChan stCh next -- If the writing failed, the
-- connection is dead.
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 with the provided configuration. If the -- Will connect to the specified host with the provided configuration. If the
@ -186,4 +178,3 @@ session realm mbSasl config = runErrorT $ do
newStanzaID :: Session -> IO StanzaID newStanzaID :: Session -> IO StanzaID
newStanzaID = idGenerator newStanzaID = idGenerator
Philipp Balzarek
13 years ago