asakul
/
pontarius-xmpp
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
Browse Source

minor formatting and documentation additions

master
Jon Kristensen 14 years ago
parent
2c62b2d9e8
commit
8430e74195
2 changed files with 139 additions and 120 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Unified View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 2
      src/Network/XMPP/Concurrent/Monad.hs
  2. 257
      src/Network/XMPP/Concurrent/Threads.hs

2
src/Network/XMPP/Concurrent/Monad.hs
Unescape View File

@ -75,7 +75,7 @@ dropMessageChan = do
r <- asks messagesRef r <- asks messagesRef
liftIO $ writeIORef r Nothing liftIO $ writeIORef r Nothing
-- | Abakigiys to 'dropMessageChan'. -- | Analogous to 'dropMessageChan'.
dropPresenceChan :: XMPP () dropPresenceChan :: XMPP ()
dropPresenceChan = do dropPresenceChan = do
r <- asks presenceRef r <- asks presenceRef

257
src/Network/XMPP/Concurrent/Threads.hs
Unescape View File

@ -29,6 +29,8 @@ import Text.XML.Stream.Elements
import GHC.IO (unsafeUnmask) import GHC.IO (unsafeUnmask)
-- Worker to read stanzas from the stream and concurrently distribute them to
-- all listener threads.
readWorker :: TChan (Either MessageError Message) readWorker :: TChan (Either MessageError Message)
-> TChan (Either PresenceError Presence) -> TChan (Either PresenceError Presence)
-> TVar IQHandlers -> TVar IQHandlers
@ -36,138 +38,141 @@ readWorker :: TChan (Either MessageError Message)
-> TMVar XmppConnection -> TMVar XmppConnection
-> IO () -> IO ()
readWorker messageC presenceC iqHands handlers stateRef = readWorker messageC presenceC iqHands handlers stateRef =
Ex.mask_ . forever $ do Ex.mask_ . forever $ do -- Suppress exceptions for the time-being.
res <- liftIO $ Ex.catches ( do res <- liftIO $ Ex.catches
-- we don't know whether pull will (do
-- necessarily be interruptible -- We don't know whether pull will necessarily be.
s <- liftIO . atomically $ do -- interruptible. TODO: Will this matter?
sr <- readTMVar stateRef s <- liftIO . atomically $ do
when (sConnectionState sr == XmppConnectionClosed) sr <- readTMVar stateRef
retry when (sConnectionState sr == XmppConnectionClosed) retry
return sr return sr
allowInterrupt allowInterrupt
Just . fst <$> runStateT pullStanza s Just . fst <$> runStateT pullStanza s
) )
[ Ex.Handler $ \(Interrupt t) -> do [ Ex.Handler $ \(Interrupt t) -> do
void $ handleInterrupts [t] void $ handleInterrupts [t]
return Nothing return Nothing
, Ex.Handler $ \e -> noCon handlers (e :: StreamError) , Ex.Handler $ \e -> noCon handlers (e :: StreamError)
] ]
liftIO . atomically $ do liftIO . atomically $ do
case res of case res of
Nothing -> return () Nothing -> return ()
Just sta -> do Just sta -> do
case sta of case sta of
MessageS m -> do writeTChan messageC $ Right m MessageS m -> do
_ <- readTChan messageC -- Sic! writeTChan messageC $ Right m
return () _ <- readTChan messageC -- Sic!
-- this may seem ridiculous, but to prevent return ()
-- the channel from filling up we -- This may seem ridiculous, but to prevent the
-- immedtiately remove the -- channel from filling up we immedtiately remove the
-- Stanza we just put in. It will still be -- Stanza we just put in. It will still be available
-- available in duplicates. -- in duplicates.
MessageErrorS m -> do writeTChan messageC $ Left m MessageErrorS m -> do
_ <- readTChan messageC writeTChan messageC $ Left m
return () _ <- readTChan messageC
PresenceS p -> do return ()
writeTChan presenceC $ Right p PresenceS p -> do
_ <- readTChan presenceC writeTChan presenceC $ Right p
return () _ <- readTChan presenceC
PresenceErrorS p -> do return ()
writeTChan presenceC $ Left p PresenceErrorS p -> do
_ <- readTChan presenceC writeTChan presenceC $ Left p
return () _ <- readTChan presenceC
return ()
IQRequestS i -> handleIQRequest iqHands i IQRequestS i -> handleIQRequest iqHands i
IQResultS i -> handleIQResponse iqHands (Right i) IQResultS i -> handleIQResponse iqHands (Right i)
IQErrorS i -> handleIQResponse iqHands (Left i) IQErrorS i -> handleIQResponse iqHands (Left i)
where where
-- Defining an Control.Exception.allowInterrupt equivalent for -- Defining an Control.Exception.allowInterrupt equivalent for GHC 7
-- GHC 7 compatibility. -- compatibility.
allowInterrupt :: IO () allowInterrupt :: IO ()
allowInterrupt = unsafeUnmask $ return () allowInterrupt = unsafeUnmask $ return ()
-- Call the connection closed handlers.
noCon :: TVar EventHandlers -> StreamError -> IO (Maybe a) noCon :: TVar EventHandlers -> StreamError -> IO (Maybe a)
noCon h e = do noCon h e = do
hands <- atomically $ readTVar h hands <- atomically $ readTVar h
_ <- forkIO $ connectionClosedHandler hands e _ <- forkIO $ connectionClosedHandler hands e
return Nothing return Nothing
-- While waiting for the first semaphore(s) to flip we might receive -- While waiting for the first semaphore(s) to flip we might receive another
-- another interrupt. When that happens we add it's semaphore to the -- interrupt. When that happens we add it's semaphore to the list and retry
-- list and retry waiting -- waiting. We do this because we might receive another interrupt while
-- recovering from the last one.
handleInterrupts :: [TMVar ()] -> IO [()] handleInterrupts :: [TMVar ()] -> IO [()]
handleInterrupts ts = handleInterrupts ts =
Ex.catch (atomically $ forM ts takeTMVar) Ex.catch (atomically $ forM ts takeTMVar)
( \(Interrupt t) -> handleInterrupts (t:ts)) (\(Interrupt t) -> handleInterrupts (t:ts))
-- If the IQ request has a namespace, sent it through the appropriate channel.
handleIQRequest :: TVar IQHandlers -> IQRequest -> STM () handleIQRequest :: TVar IQHandlers -> IQRequest -> STM ()
handleIQRequest handlers iq = do handleIQRequest handlers iq = 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 -> return () -- TODO: send error stanza
Just ch -> do Just ch -> do
sent <- newTVar False sent <- newTVar False
writeTChan ch (iq, sent) writeTChan ch (iq, sent)
-- Update the TMVar to contain the IQ response.
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
case Map.updateLookupWithKey (\_ _ -> Nothing) (iqID iq) byID of case Map.updateLookupWithKey (\_ _ -> Nothing) (iqID iq) byID of
(Nothing, _) -> return () -- we are not supposed (Nothing, _) -> return () -- We are not supposed to send an error.
-- to send an error (Just tmvar, byID') -> do
(Just tmvar, byID') -> do _ <- tryPutTMVar tmvar iq -- Don't block.
_ <- tryPutTMVar tmvar iq -- don't block writeTVar handlers (byNS, byID')
writeTVar handlers (byNS, byID') where
where iqID (Left err) = iqErrorID err
iqID (Left err) = iqErrorID err iqID (Right iq') = iqResultID iq'
iqID (Right iq') = iqResultID iq'
-- Worker to write stanzas to the stream concurrently.
writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO Bool) -> IO () writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO Bool) -> IO ()
writeWorker stCh writeR = forever $ do writeWorker stCh writeR = forever $ do
(write, next) <- atomically $ (,) <$> (write, next) <- atomically $ (,) <$>
takeTMVar writeR <*> takeTMVar writeR <*>
readTChan stCh readTChan stCh
r <- write $ renderElement (pickleElem xpStanza next) r <- write $ renderElement (pickleElem xpStanza next)
unless r $ do unless r $ do -- If the writing failed, the connection is dead.
atomically $ unGetTChan stCh next -- connection is dead atomically $ unGetTChan stCh next
threadDelay 250000 -- avoid free spinning threadDelay 250000 -- Avoid free spinning.
atomically $ putTMVar writeR write atomically $ putTMVar writeR write -- Put it back.
-- Two streams: input and output. Threads read from input stream and write to output stream. -- Two streams: input and output. Threads read from input stream and write to
-- | Runs thread in XmppState monad -- output stream.
-- returns channel of incoming and outgoing stances, respectively -- | Runs thread in XmppState monad. Returns channel of incoming and outgoing
-- and an Action to stop the Threads and close the connection -- stances, respectively, and an Action to stop the Threads and close the
startThreads -- connection.
:: IO ( TChan (Either MessageError Message) startThreads :: IO ( TChan (Either MessageError Message)
, TChan (Either PresenceError Presence) , TChan (Either PresenceError Presence)
, TVar IQHandlers , TVar IQHandlers
, TChan Stanza , TChan Stanza
, IO () , IO ()
, TMVar (BS.ByteString -> IO Bool) , TMVar (BS.ByteString -> IO Bool)
, TMVar XmppConnection , TMVar XmppConnection
, ThreadId , ThreadId
, TVar EventHandlers , TVar EventHandlers
) )
startThreads = do startThreads = do
writeLock <- newTMVarIO (\_ -> return False) writeLock <- newTMVarIO (\_ -> return False)
messageC <- newTChanIO messageC <- newTChanIO
presenceC <- newTChanIO presenceC <- newTChanIO
outC <- newTChanIO outC <- newTChanIO
handlers <- newTVarIO ( Map.empty, Map.empty) handlers <- newTVarIO ( Map.empty, Map.empty)
eh <- newTVarIO zeroEventHandlers eh <- newTVarIO zeroEventHandlers
conS <- newTMVarIO xmppNoConnection conS <- newTMVarIO xmppNoConnection
lw <- forkIO $ writeWorker outC writeLock lw <- forkIO $ writeWorker outC writeLock
cp <- forkIO $ connPersist writeLock cp <- forkIO $ connPersist writeLock
rd <- forkIO $ readWorker messageC presenceC handlers eh conS rd <- forkIO $ readWorker messageC presenceC handlers eh conS
return (messageC, presenceC, handlers, outC return (messageC, presenceC, handlers, outC
, killConnection writeLock [lw, rd, cp] , killConnection writeLock [lw, rd, cp]
, writeLock, conS ,rd, eh) , writeLock, conS ,rd, eh)
where where
killConnection writeLock threads = liftIO $ do killConnection writeLock threads = liftIO $ do
_ <- atomically $ takeTMVar writeLock -- Should we put it back? _ <- atomically $ takeTMVar writeLock -- Should we put it back?
_ <- forM threads killThread _ <- forM threads killThread
return() return ()
-- | Creates and initializes a new XMPP session. -- | Creates and initializes a new XMPP session.
newSession :: IO Session newSession :: IO Session
@ -180,21 +185,35 @@ newSession = do
curId <- readTVar idRef curId <- readTVar idRef
writeTVar idRef (curId + 1 :: Integer) writeTVar idRef (curId + 1 :: Integer)
return . read. show $ curId return . read. show $ curId
return (Session workermCh workerpCh mC pC outC hand writeR rdr getId conS eh stopThreads') return $ Session
workermCh
workerpCh
mC
pC
outC
hand
writeR
rdr
getId
conS
eh
stopThreads'
-- | Creates a new session and runs the given XMPP computation.
withNewSession :: XMPP b -> IO (Session, b) withNewSession :: XMPP b -> IO (Session, b)
withNewSession a = do withNewSession a = do
sess <- newSession sess <- newSession
ret <- runReaderT a sess ret <- runReaderT a sess
return (sess, ret) return (sess, ret)
-- | Runs the given XMPP computation in the given session.
withSession :: Session -> XMPP a -> IO a withSession :: Session -> XMPP a -> IO a
withSession = flip runReaderT withSession = flip runReaderT
-- | Sends a blank space every 30 seconds to keep the connection alive -- | Sends a blank space every 30 seconds to keep the connection alive.
connPersist :: TMVar (BS.ByteString -> IO Bool) -> IO () connPersist :: TMVar (BS.ByteString -> IO Bool) -> IO ()
connPersist lock = forever $ do connPersist lock = forever $ do
pushBS <- atomically $ takeTMVar lock pushBS <- atomically $ takeTMVar lock
_ <- pushBS " " _ <- pushBS " "
atomically $ putTMVar lock pushBS atomically $ putTMVar lock pushBS
threadDelay 30000000 threadDelay 30000000
Write Preview
Loading…
Cancel
Save