From 2ad95ba1b45cff7c08b662adfa5d2bfcf6c5870e Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 19 Apr 2012 19:14:31 +0200 Subject: [PATCH] added EventHandlers, endSession, closeConnection --- src/Data/Conduit/TLS.hs | 8 +++++-- src/Network/XMPP/Concurrent/Monad.hs | 31 +++++++++++++++++++++++++- src/Network/XMPP/Concurrent/Threads.hs | 8 ++++--- src/Network/XMPP/Concurrent/Types.hs | 12 ++++++++++ src/Network/XMPP/Monad.hs | 12 +++++++++- src/Network/XMPP/SASL.hs | 1 - src/Network/XMPP/TLS.hs | 3 ++- src/Network/XMPP/Types.hs | 3 +-- 8 files changed, 67 insertions(+), 11 deletions(-) diff --git a/src/Data/Conduit/TLS.hs b/src/Data/Conduit/TLS.hs index 4a7d4f0..642ba6e 100644 --- a/src/Data/Conduit/TLS.hs +++ b/src/Data/Conduit/TLS.hs @@ -26,7 +26,9 @@ tlsinit TLSParams -> Handle -> m ( Source m1 BS.ByteString , Sink BS.ByteString m1 () - , BS.ByteString -> IO ()) + , BS.ByteString -> IO () + , TLSCtx Handle + ) tlsinit tlsParams handle = do gen <- liftIO $ (newGenIO :: IO SystemRandom) -- TODO: Find better random source? clientContext <- client tlsParams gen handle @@ -41,5 +43,7 @@ tlsinit tlsParams handle = do (\_ -> return ()) return ( src , snk - , \s -> sendData clientContext $ BL.fromChunks [s] ) + , \s -> sendData clientContext $ BL.fromChunks [s] + , clientContext + ) diff --git a/src/Network/XMPP/Concurrent/Monad.hs b/src/Network/XMPP/Concurrent/Monad.hs index a39ce1b..017db4e 100644 --- a/src/Network/XMPP/Concurrent/Monad.hs +++ b/src/Network/XMPP/Concurrent/Monad.hs @@ -14,6 +14,7 @@ import qualified Data.Map as Map import Data.Text(Text) import Network.XMPP.Concurrent.Types +import Network.XMPP.Monad -- | Register a new IQ listener. IQ requests matching the type and namespace will -- be put in the channel. @@ -162,8 +163,36 @@ withConnection a = do putTMVar stateRef s' return res +-- | Send a presence Stanza sendPresence :: Presence -> XMPPThread () sendPresence = sendS . PresenceS +-- | Send a Message Stanza sendMessage :: Message -> XMPPThread () -sendMessage = sendS . MessageS \ No newline at end of file +sendMessage = sendS . MessageS + + +modifyHandlers :: (EventHandlers -> EventHandlers) -> XMPPThread () +modifyHandlers f = do + eh <- asks eventHandlers + liftIO . atomically $ modifyTVar eh f + +setSessionEndHandler :: XMPPThread () -> XMPPThread () +setSessionEndHandler eh = modifyHandlers (\s -> s{sessionEndHandler = eh}) + +-- | run an event handler +runHandler :: (EventHandlers -> XMPPThread a) -> XMPPThread a +runHandler h = do + eh <- liftIO . atomically . readTVar =<< asks eventHandlers + h eh + +-- | End the current xmpp session +endSession :: XMPPThread () +endSession = do -- TODO: This has to be idempotent (is it?) + withConnection xmppKillConnection + liftIO =<< asks stopThreads + runHandler sessionEndHandler + +-- | Close the connection to the server +closeConnection :: XMPPThread () +closeConnection = withConnection xmppKillConnection diff --git a/src/Network/XMPP/Concurrent/Threads.hs b/src/Network/XMPP/Concurrent/Threads.hs index 04ab8d6..961fd68 100644 --- a/src/Network/XMPP/Concurrent/Threads.hs +++ b/src/Network/XMPP/Concurrent/Threads.hs @@ -130,6 +130,7 @@ startThreads , TMVar (BS.ByteString -> IO ()) , TMVar XMPPConState , ThreadId + , TVar EventHandlers ) startThreads = do @@ -139,6 +140,7 @@ startThreads = do iqC <- liftIO newTChanIO outC <- liftIO newTChanIO handlers <- liftIO $ newTVarIO ( Map.empty, Map.empty) + eh <- liftIO $ newTVarIO zeroEventHandlers conS <- liftIO . newTMVarIO =<< get lw <- liftIO . forkIO $ writeWorker outC writeLock cp <- liftIO . forkIO $ connPersist writeLock @@ -146,7 +148,7 @@ startThreads = do rd <- liftIO . forkIO $ readWorker messageC presenceC handlers conS return (messageC, presenceC, handlers, outC , killConnection writeLock [lw, rd, cp] - , writeLock, conS ,rd) + , writeLock, conS ,rd, eh) where killConnection writeLock threads = liftIO $ do _ <- atomically $ takeTMVar writeLock -- Should we put it back? @@ -159,7 +161,7 @@ runThreaded :: XMPPThread a -> XMPPConMonad a runThreaded a = do liftIO . putStrLn $ "starting threads" - (mC, pC, hand, outC, _stopThreads, writeR, conS, rdr ) <- startThreads + (mC, pC, hand, outC, stopThreads', writeR, conS, rdr, eh) <- startThreads liftIO . putStrLn $ "threads running" workermCh <- liftIO . newIORef $ Nothing workerpCh <- liftIO . newIORef $ Nothing @@ -170,7 +172,7 @@ runThreaded a = do return . read. show $ curId s <- get liftIO . putStrLn $ "starting application" - liftIO $ runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR rdr getId conS) + liftIO $ runReaderT a (Thread workermCh workerpCh mC pC outC hand writeR rdr getId conS eh stopThreads') -- | Sends a blank space every 30 seconds to keep the connection alive diff --git a/src/Network/XMPP/Concurrent/Types.hs b/src/Network/XMPP/Concurrent/Types.hs index 14f0d04..26b9418 100644 --- a/src/Network/XMPP/Concurrent/Types.hs +++ b/src/Network/XMPP/Concurrent/Types.hs @@ -21,6 +21,16 @@ type IQHandlers = (Map.Map (IQRequestType, Text) (TChan (IQRequest, TVar Bool)) , Map.Map StanzaId (TMVar IQResponse) ) +data EventHandlers = EventHandlers + { sessionEndHandler :: XMPPThread () + , connectionClosedHandler :: XMPPThread () + } + +zeroEventHandlers = EventHandlers + { sessionEndHandler = return () + , connectionClosedHandler = return () + } + data Thread = Thread { messagesRef :: IORef (Maybe ( TChan (Either MessageError Message @@ -39,6 +49,8 @@ data Thread = Thread { messagesRef :: IORef (Maybe ( TChan (Either , readerThread :: ThreadId , idGenerator :: IO StanzaId , conStateRef :: TMVar XMPPConState + , eventHandlers :: TVar EventHandlers + , stopThreads :: IO () } type XMPPThread a = ReaderT Thread IO a diff --git a/src/Network/XMPP/Monad.hs b/src/Network/XMPP/Monad.hs index cf3b634..2ff458e 100644 --- a/src/Network/XMPP/Monad.hs +++ b/src/Network/XMPP/Monad.hs @@ -80,10 +80,11 @@ xmppFromHandle handle hostname username res f = do (Just hostname) (Just username) res + (hClose handle) runStateT f st zeroSource :: Source IO output -zeroSource = sourceState () (\_ -> forever $ threadDelay 10000000) +zeroSource = liftIO . forever $ threadDelay 10000000 xmppZeroConState :: XMPPConState xmppZeroConState = XMPPConState @@ -96,6 +97,7 @@ xmppZeroConState = XMPPConState , sHostname = Nothing , sUsername = Nothing , sResource = Nothing + , sCloseConnection = return () } xmppRawConnect :: HostName -> Text -> XMPPConMonad () @@ -117,8 +119,16 @@ xmppRawConnect host hostname = do (Just hostname) uname Nothing + (hClose con) put st + withNewSession :: XMPPConMonad a -> IO (a, XMPPConState) withNewSession action = do runStateT action xmppZeroConState + +xmppKillConnection :: XMPPConMonad () +xmppKillConnection = do + cc <- gets sCloseConnection + liftIO cc + put xmppZeroConState diff --git a/src/Network/XMPP/SASL.hs b/src/Network/XMPP/SASL.hs index bd9d713..589146d 100644 --- a/src/Network/XMPP/SASL.hs +++ b/src/Network/XMPP/SASL.hs @@ -163,7 +163,6 @@ md5Digest uname realm password digestURI nc qop nonce cnonce= ha2 = hash ["AUTHENTICATE", digestURI] in hash [ha1,nonce, nc, cnonce,qop,ha2] - -- Pickling failurePickle :: PU [Node] (SASLFailure) failurePickle = xpWrap (\(txt,(failure,_,_)) diff --git a/src/Network/XMPP/TLS.hs b/src/Network/XMPP/TLS.hs index 7b9f159..df88b46 100644 --- a/src/Network/XMPP/TLS.hs +++ b/src/Network/XMPP/TLS.hs @@ -68,12 +68,13 @@ xmppStartTLS params = Ex.handle (return . Left . TLSError) case answer of Element "{urn:ietf:params:xml:ns:xmpp-tls}proceed" [] [] -> return () _ -> throwError $ TLSStreamError StreamXMLError - (raw, snk, psh) <- lift $ TLS.tlsinit params handle + (raw, snk, psh, ctx) <- lift $ TLS.tlsinit params handle lift $ modify (\x -> x { sRawSrc = raw -- , sConSrc = -- Note: this momentarily leaves us in an -- inconsistent state , sConPushBS = psh + , sCloseConnection = TLS.bye ctx >> sCloseConnection x }) ErrorT $ (left TLSStreamError) <$> xmppRestartStream modify (\s -> s{sHaveTLS = True}) diff --git a/src/Network/XMPP/Types.hs b/src/Network/XMPP/Types.hs index f4ea65f..e6eace6 100644 --- a/src/Network/XMPP/Types.hs +++ b/src/Network/XMPP/Types.hs @@ -535,8 +535,6 @@ instance Read SASLError where readsPrec _ "not-authorized" = [(SASLNotAuthorized , "")] readsPrec _ "temporary-auth-failure" = [(SASLTemporaryAuthFailure , "")] - - -- | Readability type for host name Texts. -- type HostName = Text -- This is defined in Network as well @@ -659,6 +657,7 @@ data XMPPConState = XMPPConState , sHostname :: Maybe Text , sUsername :: Maybe Text , sResource :: Maybe Text + , sCloseConnection :: IO () } -- |