From df146e39752edbe7ab918292bfd9e9c1f5fe37e6 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Mon, 4 Nov 2013 13:13:05 +0100 Subject: [PATCH] add plugin interface --- source/Network/Xmpp/Concurrent.hs | 51 ++++++++++++++++--------- source/Network/Xmpp/Concurrent/Basic.hs | 14 ++++++- source/Network/Xmpp/Concurrent/Types.hs | 8 +++- source/Network/Xmpp/IM/Roster.hs | 8 ++-- source/Network/Xmpp/Stream.hs | 2 +- source/Network/Xmpp/Types.hs | 2 +- 6 files changed, 56 insertions(+), 29 deletions(-) diff --git a/source/Network/Xmpp/Concurrent.hs b/source/Network/Xmpp/Concurrent.hs index 8bf20ba..a4503ce 100644 --- a/source/Network/Xmpp/Concurrent.hs +++ b/source/Network/Xmpp/Concurrent.hs @@ -24,6 +24,7 @@ import Control.Concurrent.STM import qualified Control.Exception as Ex import Control.Monad import Control.Monad.Error +import qualified Data.List as List import qualified Data.Map as Map import Data.Maybe import Data.Text as Text @@ -48,11 +49,11 @@ import System.Random (randomRIO) import Control.Monad.State.Strict -runHandlers :: WriteSemaphore -> [StanzaHandler] -> Stanza -> IO () -runHandlers _ [] _ = return () -runHandlers sem (h:hands) sta = do - res <- h sem sta - forM_ res (runHandlers sem hands) +runHandlers :: [Stanza -> IO [Stanza]] -> Stanza -> IO () +runHandlers [] _ = return () +runHandlers (h:hands) sta = do + res <- h sta + forM_ res $ runHandlers hands toChan :: TChan Stanza -> StanzaHandler toChan stanzaC _ sta = do @@ -61,7 +62,7 @@ toChan stanzaC _ sta = do handleIQ :: TVar IQHandlers -> StanzaHandler -handleIQ iqHands writeSem sta = do +handleIQ iqHands out sta = do case sta of IQRequestS i -> handleIQRequest iqHands i >> return [] IQResultS i -> handleIQResponse iqHands (Right i) >> return [] @@ -71,7 +72,7 @@ handleIQ iqHands writeSem sta = do -- If the IQ request has a namespace, send it through the appropriate channel. handleIQRequest :: TVar IQHandlers -> IQRequest -> IO () handleIQRequest handlers iq = do - out <- atomically $ do + res <- atomically $ do (byNS, _) <- readTVar handlers let iqNS = fromMaybe "" (nameNamespace . elementName $ iqRequestPayload iq) @@ -95,7 +96,7 @@ handleIQ iqHands writeSem sta = do atomically $ putTMVar sentRef True return Nothing False -> do - didSend <- writeStanza writeSem response + didSend <- out response case didSend of True -> do atomically $ putTMVar sentRef True @@ -105,7 +106,7 @@ handleIQ iqHands writeSem sta = do return $ Just False writeTChan ch $ IQRequestTicket answerT iq return Nothing - maybe (return ()) (void . writeStanza writeSem) out + maybe (return ()) (void . out) res serviceUnavailable (IQRequest iqid from _to lang _tp bd) = IQErrorS $ IQError iqid Nothing from lang err (Just bd) err = StanzaError Cancel ServiceUnavailable Nothing Nothing @@ -137,16 +138,15 @@ 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 - else \ _ sta -> return [sta] - let stanzaHandler = runHandlers writeSem - $ Prelude.concat [ [ toChan stanzaChan ] - , extraStanzaHandlers - config - , [ handleIQ iqHands - , rosterH - ] - ] + let rosterH = if (enableRoster config) then [handleRoster ros $ out writeSem] + else [] + let stanzaHandler = runHandlers $ List.concat + [ pluginHandlers writeSem + , [ toChan stanzaChan (out writeSem) + , handleIQ iqHands (out writeSem) + ] + , rosterH + ] (kill, wLock, streamState, reader) <- ErrorT $ startThreadsWith writeSem stanzaHandler eh stream idGen <- liftIO $ sessionStanzaIDs config let sess = Session { stanzaCh = stanzaChan @@ -166,6 +166,19 @@ newSession stream config realm mbSasl = runErrorT $ do liftIO . atomically $ putTMVar eh $ EventHandlers { connectionClosedHandler = onConnectionClosed config 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) connectStream :: HostName -> SessionConfiguration diff --git a/source/Network/Xmpp/Concurrent/Basic.hs b/source/Network/Xmpp/Concurrent/Basic.hs index 7de23f7..37771a4 100644 --- a/source/Network/Xmpp/Concurrent/Basic.hs +++ b/source/Network/Xmpp/Concurrent/Basic.hs @@ -1,6 +1,7 @@ {-# 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 @@ -21,9 +22,18 @@ writeStanza sem a = do let outData = renderElement $ nsHack (pickleElem xpStanza a) semWrite sem outData --- | Send a stanza to the server. + +-- | Send a stanza to the server without running plugins. (The stanza is sent as +-- is) +sendRawStanza :: Stanza -> Session -> IO Bool +sendRawStanza a session = writeStanza (writeSemaphore session) a + + +-- | Send a stanza to the server, handing it to plugins. sendStanza :: Stanza -> Session -> IO Bool -sendStanza a session = writeStanza (writeSemaphore session) a +sendStanza a session = do + let ts = outHandler <$> plugins (conf session) + foldr ($) (flip sendRawStanza session) ts $ a -- | Get the channel of incoming stanzas. diff --git a/source/Network/Xmpp/Concurrent/Types.hs b/source/Network/Xmpp/Concurrent/Types.hs index 4fad6be..5e45118 100644 --- a/source/Network/Xmpp/Concurrent/Types.hs +++ b/source/Network/Xmpp/Concurrent/Types.hs @@ -19,6 +19,10 @@ import Network.Xmpp.Types import Network.Xmpp.Sasl.Types +data Plugin = Plugin { inHandler :: StanzaHandler + , outHandler :: (Stanza -> IO Bool) -> Stanza -> IO Bool + } + -- | Configuration for the @Session@ object. data SessionConfiguration = SessionConfiguration { -- | Configuration for the @Stream@ object. @@ -27,7 +31,7 @@ data SessionConfiguration = SessionConfiguration , onConnectionClosed :: Session -> XmppFailure -> IO () -- | Function to generate the stream of stanza identifiers. , sessionStanzaIDs :: IO (IO Text) - , extraStanzaHandlers :: [StanzaHandler] + , plugins :: [Plugin] , enableRoster :: Bool } @@ -40,7 +44,7 @@ instance Default SessionConfiguration where curId <- readTVar idRef writeTVar idRef (curId + 1 :: Integer) return . Text.pack . show $ curId - , extraStanzaHandlers = [] + , plugins = [] , enableRoster = True } diff --git a/source/Network/Xmpp/IM/Roster.hs b/source/Network/Xmpp/IM/Roster.hs index f71ef91..e0f4425 100644 --- a/source/Network/Xmpp/IM/Roster.hs +++ b/source/Network/Xmpp/IM/Roster.hs @@ -81,8 +81,8 @@ initRoster session = do "Server did not return a roster" Just roster -> atomically $ writeTVar (rosterRef session) roster -handleRoster :: TVar Roster -> WriteSemaphore -> Stanza -> IO [Stanza] -handleRoster ref sem sta = case sta of +handleRoster :: TVar Roster -> StanzaHandler +handleRoster ref out sta = case sta of IQRequestS (iqr@IQRequest{iqRequestPayload = iqb@Element{elementName = en}}) | nameNamespace en == Just "jabber:iq:roster" -> do @@ -94,11 +94,11 @@ handleRoster ref sem sta = case sta of , queryItems = [update] } -> do handleUpdate v update - _ <- writeStanza sem $ result iqr + _ <- out $ result iqr return [] _ -> do errorM "Pontarius.Xmpp" "Invalid roster query" - _ <- writeStanza sem $ badRequest iqr + _ <- out $ badRequest iqr return [] _ -> return [sta] where diff --git a/source/Network/Xmpp/Stream.hs b/source/Network/Xmpp/Stream.hs index 8dba80f..47dfaf2 100644 --- a/source/Network/Xmpp/Stream.hs +++ b/source/Network/Xmpp/Stream.hs @@ -92,7 +92,7 @@ streamUnpickleElem p x = do type StreamSink a = ErrorT XmppFailure (ConduitM Event Void IO) a -- Discards all events before the first EventBeginElement. -throwOutJunk :: Monad m => Sink Event m () +throwOutJunk :: Monad m => ConduitM Event a m () throwOutJunk = do next <- CL.peek case next of diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 811dd4d..da12cc6 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -1035,7 +1035,7 @@ instance Default StreamConfiguration where } } -type StanzaHandler = TMVar (BS.ByteString -> IO Bool) -- ^ outgoing stanza +type StanzaHandler = (Stanza -> IO Bool) -- ^ outgoing stanza -> Stanza -- ^ stanza to handle -> IO [Stanza] -- ^ modified stanzas (if any)