add plugin interface

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

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.

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
                                }
 

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

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

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)