From 3f22f8d9d67bab42fb1b57117f77b5f4164d7534 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Fri, 8 Nov 2013 15:09:33 +0100 Subject: [PATCH] improve plugin interface Plugins will now be handed the xmpp session once it is created so they can tie the knot if necessary --- source/Network/Xmpp/Concurrent.hs | 56 ++++++++++++------------- source/Network/Xmpp/Concurrent/Basic.hs | 9 +--- source/Network/Xmpp/Concurrent/Types.hs | 16 +++++-- 3 files changed, 41 insertions(+), 40 deletions(-) diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index a4503ce..0ea5c4d 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -138,47 +138,45 @@ newSession stream config realm mbSasl = runErrorT $ do eh <- lift $ newEmptyTMVarIO ros <- liftIO . newTVarIO $ Roster Nothing Map.empty rew <- lift $ newTVarIO 60 - let rosterH = if (enableRoster config) then [handleRoster ros $ out writeSem] + let out = writeStanza writeSem + let rosterH = if (enableRoster config) then [handleRoster ros out ] else [] + (sStanza, ps) <- initPlugins out $ plugins config let stanzaHandler = runHandlers $ List.concat - [ pluginHandlers writeSem - , [ toChan stanzaChan (out writeSem) - , handleIQ iqHands (out writeSem) + [ inHandler <$> ps + , [ toChan stanzaChan out + , handleIQ iqHands out ] , rosterH ] (kill, wLock, streamState, reader) <- ErrorT $ startThreadsWith writeSem stanzaHandler eh stream idGen <- liftIO $ sessionStanzaIDs config let sess = Session { stanzaCh = stanzaChan - , iqHandlers = iqHands - , writeSemaphore = wLock - , readerThread = reader - , idGenerator = idGen - , streamRef = streamState - , eventHandlers = eh - , stopThreads = kill - , conf = config - , rosterRef = ros - , sRealm = realm - , sSaslCredentials = mbSasl - , reconnectWait = rew - } + , iqHandlers = iqHands + , writeSemaphore = wLock + , readerThread = reader + , idGenerator = idGen + , streamRef = streamState + , eventHandlers = eh + , stopThreads = kill + , conf = config + , rosterRef = ros + , sendStanza' = sStanza + , sRealm = realm + , sSaslCredentials = mbSasl + , reconnectWait = rew + } liftIO . atomically $ putTMVar eh $ EventHandlers { connectionClosedHandler = onConnectionClosed config sess } + liftIO . forM_ ps $ \p -> onSessionUp p sess return sess where - -- Each inbound plugin may need to send outbound stanzas. Those stanzas have - -- to be treated by the plugins "outward" of the handling plugin. We generate - -- the list of outbound plugins with "reverse . tails $ outHandler <$> - -- (plugins config)) - pluginHandlers ws = List.zipWith ($) - (inHandler <$> List.reverse (plugins config)) - (List.map (runOut ws) . List.reverse . List.tails - $ outHandler <$> (plugins config)) - -- Treat stanza with all plugins - out ws = runOut ws $ outHandler <$> (plugins config) - -- Compose a list of Stanza transformers - runOut ws = List.foldr ($) (writeStanza ws) + initPlugins out' = go out' [] + where + go out ps' [] = return (out, ps') + go out ps' (p:ps) = do + p' <- p out + go (outHandler p') (p' : ps') ps connectStream :: HostName -> SessionConfiguration diff --git a/source/Network/Xmpp/Concurrent/Basic.hs b/source/Network/Xmpp/Concurrent/Basic.hs index 37771a4..271995f 100644 --- a/source/Network/Xmpp/Concurrent/Basic.hs +++ b/source/Network/Xmpp/Concurrent/Basic.hs @@ -1,7 +1,6 @@ {-# OPTIONS_HADDOCK hide #-} module Network.Xmpp.Concurrent.Basic where -import Control.Applicative ((<$>)) import Control.Concurrent.STM import qualified Control.Exception as Ex import Control.Monad.State.Strict @@ -28,13 +27,9 @@ writeStanza sem a = do sendRawStanza :: Stanza -> Session -> IO Bool sendRawStanza a session = writeStanza (writeSemaphore session) a - --- | Send a stanza to the server, handing it to plugins. +-- | Send a stanza to the server, managed by plugins sendStanza :: Stanza -> Session -> IO Bool -sendStanza a session = do - let ts = outHandler <$> plugins (conf session) - foldr ($) (flip sendRawStanza session) ts $ a - +sendStanza = flip sendStanza' -- | Get the channel of incoming stanzas. getStanzaChan :: Session -> TChan Stanza diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index 5e45118..5d27cb1 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -6,6 +6,7 @@ module Network.Xmpp.Concurrent.Types where import Control.Concurrent import Control.Concurrent.STM import qualified Control.Exception.Lifted as Ex +import Control.Monad.Error import qualified Data.ByteString as BS import Data.Default import qualified Data.Map as Map @@ -15,13 +16,19 @@ import Data.Typeable import Data.XML.Types (Element) import Network import Network.Xmpp.IM.Roster.Types -import Network.Xmpp.Types import Network.Xmpp.Sasl.Types +import Network.Xmpp.Types + +data Plugin' = Plugin' { inHandler :: Stanza -> IO [Stanza] + , outHandler :: Stanza -> IO Bool + -- | In order to allow plugins to tie the knot (Plugin + -- / Session) we pass the plugin the completed Session + -- once it exists + , onSessionUp :: Session -> IO () + } -data Plugin = Plugin { inHandler :: StanzaHandler - , outHandler :: (Stanza -> IO Bool) -> Stanza -> IO Bool - } +type Plugin = (Stanza -> IO Bool) -> ErrorT XmppFailure IO Plugin' -- | Configuration for the @Session@ object. data SessionConfiguration = SessionConfiguration @@ -80,6 +87,7 @@ data Session = Session , stopThreads :: IO () , rosterRef :: TVar Roster , conf :: SessionConfiguration + , sendStanza' :: Stanza -> IO Bool , sRealm :: HostName , sSaslCredentials :: Maybe (ConnectionState -> [SaslHandler] , Maybe Text) , reconnectWait :: TVar Int