From 45edfcc56fc2910f2a7d7c0f1ae2a499a7b31326 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Fri, 4 May 2012 14:05:43 +0200 Subject: [PATCH] Add conection state to connection object, rename some types rename XMPPConState to XmppConnection rename xmppZeroCon to xmppNoConnection add XmppConnectionState remove sHaveTLS from XmppConnection add (sConnectionState :: XmppConnectionState) to XmppConnection --- src/Network/XMPP/Concurrent/Monad.hs | 3 +- src/Network/XMPP/Concurrent/Threads.hs | 6 ++-- src/Network/XMPP/Concurrent/Types.hs | 2 +- src/Network/XMPP/Monad.hs | 38 +++++++++++------------ src/Network/XMPP/TLS.hs | 2 +- src/Network/XMPP/Types.hs | 42 ++++++++++++++++---------- 6 files changed, 51 insertions(+), 42 deletions(-) diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs index 515d55b..748ed9f 100644 --- a/src/Network/XMPP/Concurrent/Monad.hs +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -152,8 +152,7 @@ waitForPresence f = do -- Reader and writer workers will be temporarily stopped -- and resumed with the new session details once the action returns. -- The Action will run in the calling thread/ --- NB: This will /not/ catch any exceptions. If you action dies, deadlocks --- or otherwisely exits abnormaly the XMPP session will be dead. +-- Any uncaught exceptions will be interpreted as connection failure withConnection :: XMPPConMonad a -> XMPP a withConnection a = do readerId <- asks readerThread diff --git a/src/Network/XMPP/Concurrent/Threads.hs b/src/Network/XMPP/Concurrent/Threads.hs index 5377d37..f6e397f 100644 --- a/src/Network/XMPP/Concurrent/Threads.hs +++ b/src/Network/XMPP/Concurrent/Threads.hs @@ -40,7 +40,7 @@ handleInterrupts ts = readWorker :: TChan (Either MessageError Message) -> TChan (Either PresenceError Presence) -> TVar IQHandlers - -> TMVar XMPPConState + -> TMVar XmppConnection -> IO () readWorker messageC presenceC handlers stateRef = Ex.mask_ . forever $ do @@ -131,7 +131,7 @@ startThreads , TChan Stanza , IO () , TMVar (BS.ByteString -> IO ()) - , TMVar XMPPConState + , TMVar XmppConnection , ThreadId , TVar EventHandlers ) @@ -143,7 +143,7 @@ startThreads = do outC <- newTChanIO handlers <- newTVarIO ( Map.empty, Map.empty) eh <- newTVarIO zeroEventHandlers - conS <- newTMVarIO xmppZeroConState + conS <- newTMVarIO xmppNoConnection lw <- forkIO $ writeWorker outC writeLock cp <- forkIO $ connPersist writeLock rd <- forkIO $ readWorker messageC presenceC handlers conS diff --git a/src/Network/XMPP/Concurrent/Types.hs b/src/Network/XMPP/Concurrent/Types.hs index 37aa821..d075797 100644 --- a/src/Network/XMPP/Concurrent/Types.hs +++ b/src/Network/XMPP/Concurrent/Types.hs @@ -50,7 +50,7 @@ data Session = Session { messagesRef :: IORef (Maybe ( TChan (Either , writeRef :: TMVar (BS.ByteString -> IO () ) , readerThread :: ThreadId , idGenerator :: IO StanzaId - , conStateRef :: TMVar XMPPConState + , conStateRef :: TMVar XmppConnection , eventHandlers :: TVar EventHandlers , stopThreads :: IO () } diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index 163d091..6621f12 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -8,7 +8,6 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Class --import Control.Monad.Trans.Resource -import Control.Concurrent import qualified Control.Exception as Ex import Control.Monad.State.Strict @@ -69,38 +68,36 @@ pullStanza = do xmppFromHandle :: Handle -> Text - -> Text - -> Maybe Text -> XMPPConMonad a - -> IO (a, XMPPConState) -xmppFromHandle handle hostname username res f = do + -> IO (a, XmppConnection) +xmppFromHandle handle hostname f = do liftIO $ hSetBuffering handle NoBuffering let raw = sourceHandle handle let src = raw $= XP.parseBytes def - let st = XMPPConState + let st = XmppConnection src (raw) (BS.hPut handle) (Just handle) (SF Nothing [] []) - False + XmppConnectionPlain (Just hostname) - (Just username) - res + Nothing + Nothing (hClose handle) runStateT f st zeroSource :: Source IO output -zeroSource = liftIO . forever $ threadDelay 10000000 +zeroSource = liftIO . Ex.throwIO $ XmppNoConnection -xmppZeroConState :: XMPPConState -xmppZeroConState = XMPPConState +xmppNoConnection :: XmppConnection +xmppNoConnection = XmppConnection { sConSrc = zeroSource , sRawSrc = zeroSource - , sConPushBS = (\_ -> return ()) + , sConPushBS = \_ -> Ex.throwIO $ XmppNoConnection , sConHandle = Nothing , sFeatures = SF Nothing [] [] - , sHaveTLS = False + , sConnectionState = XmppConnectionClosed , sHostname = Nothing , sUsername = Nothing , sResource = Nothing @@ -116,29 +113,32 @@ xmppRawConnect host hostname = do return con let raw = sourceHandle con src <- liftIO . bufferSource $ raw $= XP.parseBytes def - let st = XMPPConState + let st = XmppConnection src (raw) (BS.hPut con) (Just con) (SF Nothing [] []) - False + XmppConnectionPlain (Just hostname) uname Nothing (hClose con) put st -xmppNewSession :: XMPPConMonad a -> IO (a, XMPPConState) +xmppNewSession :: XMPPConMonad a -> IO (a, XmppConnection) xmppNewSession action = do - runStateT action xmppZeroConState + runStateT action xmppNoConnection xmppKillConnection :: XMPPConMonad () xmppKillConnection = do cc <- gets sCloseConnection void . liftIO $ (Ex.try cc :: IO (Either Ex.SomeException ())) - put xmppZeroConState + put xmppNoConnection +xmppSendIQ' :: StanzaId -> Maybe JID -> IQRequestType + -> Maybe LangTag -> Element + -> XMPPConMonad (Either IQError IQResult) xmppSendIQ' iqID to tp lang body = do push . IQRequestS $ IQRequest iqID Nothing to lang tp body res <- pullPickle $ xpEither xpIQError xpIQResult diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index c80a8a5..d4b8ce0 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -70,6 +70,6 @@ startTLS params = Ex.handle (return . Left . TLSError) , sCloseConnection = TLS.bye ctx >> sCloseConnection x }) either (lift . Ex.throwIO) return =<< lift xmppRestartStream - modify (\s -> s{sHaveTLS = True}) + modify (\s -> s{sConnectionState = XmppConnectionSecured}) return () diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index 52009ce..1c86f07 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -38,7 +38,9 @@ module Network.XMPP.Types , StreamError(..) , Version(..) , XMPPConMonad - , XMPPConState(..) + , XmppConnection(..) + , XmppConnectionState(..) + , XmppNoConnection(..) , XMPPT(..) , XmppStreamError(..) , parseLangTag @@ -704,16 +706,24 @@ data ServerFeatures = SF , other :: [Element] } deriving Show -data XMPPConState = XMPPConState - { sConSrc :: Source IO Event - , sRawSrc :: Source IO BS.ByteString - , sConPushBS :: BS.ByteString -> IO () - , sConHandle :: Maybe Handle - , sFeatures :: ServerFeatures - , sHaveTLS :: Bool - , sHostname :: Maybe Text - , sUsername :: Maybe Text - , sResource :: Maybe Text +data XmppConnectionState = XmppConnectionClosed -- ^ No connection at + -- this point + | XmppConnectionPlain -- ^ Connection + -- established, but + -- not secured + | XmppConnectionSecured -- ^ Connection + -- established and + -- secured via TLS +data XmppConnection = XmppConnection + { sConSrc :: Source IO Event + , sRawSrc :: Source IO BS.ByteString + , sConPushBS :: BS.ByteString -> IO () + , sConHandle :: Maybe Handle + , sFeatures :: ServerFeatures + , sConnectionState :: XmppConnectionState + , sHostname :: Maybe Text + , sUsername :: Maybe Text + , sResource :: Maybe Text , sCloseConnection :: IO () -- TODO: add default Language } @@ -723,14 +733,14 @@ data XMPPConState = XMPPConState -- work with Pontarius. Pontarius clients needs to operate in this -- context. -newtype XMPPT m a = XMPPT { runXMPPT :: StateT XMPPConState m a } deriving (Monad, MonadIO) +newtype XMPPT m a = XMPPT { runXMPPT :: StateT XmppConnection m a } deriving (Monad, MonadIO) -type XMPPConMonad a = StateT XMPPConState IO a +type XMPPConMonad a = StateT XmppConnection IO a -- Make XMPPT derive the Monad and MonadIO instances. -deriving instance (Monad m, MonadIO m) => MonadState (XMPPConState) (XMPPT m) +deriving instance (Monad m, MonadIO m) => MonadState (XmppConnection) (XMPPT m) +data XmppNoConnection = XmppNoConnection deriving (Show, Typeable) +instance Exception XmppNoConnection --- We need a channel because multiple threads needs to append events, --- and we need to wait for events when there are none.