From 10c22f41f0d420600565ec6bbbc24f0b5e16df75 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Sat, 5 May 2012 12:56:53 +0200 Subject: [PATCH] changed sConPushBS to return a boolen (False on Failure, True otherwise) --- src/Network/XMPP/Concurrent/Monad.hs | 4 ++++ src/Network/XMPP/Concurrent/Threads.hs | 8 ++++---- src/Network/XMPP/Concurrent/Types.hs | 2 +- src/Network/XMPP/Monad.hs | 20 +++++++++++++------- src/Network/XMPP/TLS.hs | 2 +- src/Network/XMPP/Types.hs | 2 +- 6 files changed, 24 insertions(+), 14 deletions(-) diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs index 91dad05..dc4ebdc 100644 --- a/src/Network/XMPP/Concurrent/Monad.hs +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -200,6 +200,10 @@ modifyHandlers f = do setSessionEndHandler :: XMPP () -> XMPP () setSessionEndHandler eh = modifyHandlers (\s -> s{sessionEndHandler = eh}) +setConnectionClosedHandler :: XMPP () -> XMPP () +setConnectionClosedHandler eh = modifyHandlers + (\s -> s{connectionClosedHandler = eh}) + -- | run an event handler runHandler :: (EventHandlers -> XMPP a) -> XMPP a runHandler h = do diff --git a/src/Network/XMPP/Concurrent/Threads.hs b/src/Network/XMPP/Concurrent/Threads.hs index aaa5d47..146ff52 100644 --- a/src/Network/XMPP/Concurrent/Threads.hs +++ b/src/Network/XMPP/Concurrent/Threads.hs @@ -116,7 +116,7 @@ handleIQResponse handlers iq = do iqID (Left err) = iqErrorID err iqID (Right iq') = iqResultID iq' -writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO ()) -> IO () +writeWorker :: TChan Stanza -> TMVar (BS.ByteString -> IO Bool) -> IO () writeWorker stCh writeR = forever $ do (write, next) <- atomically $ (,) <$> takeTMVar writeR <*> @@ -134,14 +134,14 @@ startThreads , TVar IQHandlers , TChan Stanza , IO () - , TMVar (BS.ByteString -> IO ()) + , TMVar (BS.ByteString -> IO Bool) , TMVar XmppConnection , ThreadId , TVar EventHandlers ) startThreads = do - writeLock <- newTMVarIO (\_ -> return ()) + writeLock <- newTMVarIO (\_ -> return False) messageC <- newTChanIO presenceC <- newTChanIO outC <- newTChanIO @@ -183,7 +183,7 @@ withSession :: Session -> XMPP a -> IO a withSession = flip runReaderT -- | Sends a blank space every 30 seconds to keep the connection alive -connPersist :: TMVar (BS.ByteString -> IO ()) -> IO () +connPersist :: TMVar (BS.ByteString -> IO Bool) -> IO () connPersist lock = forever $ do pushBS <- atomically $ takeTMVar lock pushBS " " diff --git a/src/Network/XMPP/Concurrent/Types.hs b/src/Network/XMPP/Concurrent/Types.hs index d075797..0fff9c4 100644 --- a/src/Network/XMPP/Concurrent/Types.hs +++ b/src/Network/XMPP/Concurrent/Types.hs @@ -47,7 +47,7 @@ data Session = Session { messagesRef :: IORef (Maybe ( TChan (Either -- the original chan , outCh :: TChan Stanza , iqHandlers :: TVar IQHandlers - , writeRef :: TMVar (BS.ByteString -> IO () ) + , writeRef :: TMVar (BS.ByteString -> IO Bool ) , readerThread :: ThreadId , idGenerator :: IO StanzaId , conStateRef :: TMVar XmppConnection diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 278ab56..7206646 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -9,6 +9,7 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class --import Control.Monad.Trans.Resource import qualified Control.Exception as Ex +import qualified GHC.IO.Exception as Ex import Control.Monad.State.Strict import Data.ByteString as BS @@ -30,19 +31,18 @@ import System.IO import Text.XML.Stream.Elements import Text.XML.Stream.Parse as XP -pushN :: Element -> XMPPConMonad () +pushN :: Element -> XMPPConMonad Bool pushN x = do sink <- gets sConPushBS liftIO . sink $ renderElement x -push :: Stanza -> XMPPConMonad () +push :: Stanza -> XMPPConMonad Bool push = pushN . pickleElem xpStanza -pushOpen :: Element -> XMPPConMonad () +pushOpen :: Element -> XMPPConMonad Bool pushOpen e = do sink <- gets sConPushBS liftIO . sink $ renderOpenElement e - return () pullSink :: Sink Event IO b -> XMPPConMonad b pullSink snk = do @@ -71,6 +71,12 @@ pullStanza = do Left e -> liftIO . Ex.throwIO $ StreamError e Right r -> return r +catchPush p = Ex.catch (p >> return True) + (\e -> case Ex.ioe_type e of + Ex.ResourceVanished -> return False + _ -> Ex.throwIO e + ) + xmppFromHandle :: Handle -> Text -> XMPPConMonad a @@ -82,7 +88,7 @@ xmppFromHandle handle hostname f = do let st = XmppConnection src (raw) - (BS.hPut handle) + (catchPush . BS.hPut handle) (Just handle) (SF Nothing [] []) XmppConnectionPlain @@ -99,7 +105,7 @@ xmppNoConnection :: XmppConnection xmppNoConnection = XmppConnection { sConSrc = zeroSource , sRawSrc = zeroSource - , sConPushBS = \_ -> return () + , sConPushBS = \_ -> return False , sConHandle = Nothing , sFeatures = SF Nothing [] [] , sConnectionState = XmppConnectionClosed @@ -121,7 +127,7 @@ xmppRawConnect host hostname = do let st = XmppConnection src (raw) - (BS.hPut con) + (catchPush . BS.hPut con) (Just con) (SF Nothing [] []) XmppConnectionPlain diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index d4b8ce0..0013bcf 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -66,7 +66,7 @@ startTLS params = Ex.handle (return . Left . TLSError) { sRawSrc = raw -- , sConSrc = -- Note: this momentarily leaves us in an -- inconsistent state - , sConPushBS = psh + , sConPushBS = catchPush . psh , sCloseConnection = TLS.bye ctx >> sCloseConnection x }) either (lift . Ex.throwIO) return =<< lift xmppRestartStream diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index e71f9b2..c7c8e51 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -718,7 +718,7 @@ data XmppConnectionState = XmppConnectionClosed -- ^ No connection at data XmppConnection = XmppConnection { sConSrc :: Source IO Event , sRawSrc :: Source IO BS.ByteString - , sConPushBS :: BS.ByteString -> IO () + , sConPushBS :: BS.ByteString -> IO Bool , sConHandle :: Maybe Handle , sFeatures :: ServerFeatures , sConnectionState :: XmppConnectionState