diff options
Diffstat (limited to 'Hsbot')
| -rw-r--r-- | Hsbot/Core.hs | 23 | ||||
| -rw-r--r-- | Hsbot/Message.hs | 6 | ||||
| -rw-r--r-- | Hsbot/Plugin.hs | 38 | ||||
| -rw-r--r-- | Hsbot/Plugin/Ping.hs | 25 | ||||
| -rw-r--r-- | Hsbot/Types.hs | 6 |
5 files changed, 66 insertions, 32 deletions
diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs index 8eb4643..1f017ce 100644 --- a/Hsbot/Core.hs +++ b/Hsbot/Core.hs @@ -19,6 +19,7 @@ import Prelude hiding (catch) import System.IO import System.Log.Logger +import Hsbot.Plugin import Hsbot.Types import Hsbot.Utils @@ -77,7 +78,7 @@ runHsbot = do chan <- lift $ asks envChan (liftIO . forkIO $ botReader connhdl tlsCtx chan myOwnThreadId) >>= lift . addThreadIdToQuitMVar -- Then we spawn all plugins - -- asks envSocket >>= mapM_ ( ----- what's next? the core server handling! ----- ) + (lift $ asks envConfig) >>= mapM_ loadPlugin . configPlugins -- Finally we spawn the main bot loop bot <- get finalStateMVar <- liftIO newEmptyMVar @@ -86,6 +87,7 @@ runHsbot = do code <- asks envQuitMv >>= liftIO . takeMVar -- and we clean things up asks envThreadIdsMv >>= liftIO . readMVar >>= liftIO . mapM_ killThread + -- TODO : kill plugin threads return code storeFinalState :: MVar BotState -> BotState -> Env IO () storeFinalState finalStateMVar finalState = liftIO $ putMVar finalStateMVar finalState @@ -103,8 +105,16 @@ botReader handle Nothing chan fatherThreadId = forever $ killThread myId return "" +handleIncomingStr :: Chan Message -> String -> IO () +handleIncomingStr chan str = do + case IRC.decode str of + Just msg -> do + debugM "Ircd.Reader" $ "<-- " ++ (show msg) + writeChan chan $ IncomingMsg msg + Nothing -> debugM "Ircd.Reader" $ "Error: couldn't decode : " ++ str -- TODO: spam control + botLoop :: Bot (Env IO) () -botLoop = do +botLoop = forever $ do chan <- lift $ asks envChan hooks <- gets botHooks msg <- liftIO $ readChan chan @@ -115,16 +125,9 @@ botLoop = do env <- lift ask let connhdl = envHandle env tlsCtx = envTLSCtx env + liftIO $ debugM "Ircd.Reader" $ "--> " ++ (show outMsg) liftIO . sendStr connhdl tlsCtx $ IRC.encode outMsg -handleIncomingStr :: Chan Message -> String -> IO () -handleIncomingStr chan str = do - case IRC.decode str of - Just msg -> do - debugM "Ircd.Reader" $ "<-- " ++ (show msg) - writeChan chan $ IncomingMsg msg - Nothing -> debugM "Ircd.Reader" $ "Error: couldn't decode : " ++ str -- TODO: spam control - terminateHsbot :: Env IO () terminateHsbot = do liftIO $ infoM "Hsbot.Core" "Closing connection" diff --git a/Hsbot/Message.hs b/Hsbot/Message.hs index e95c3e7..133ff92 100644 --- a/Hsbot/Message.hs +++ b/Hsbot/Message.hs @@ -11,13 +11,13 @@ import qualified Network.IRC as IRC import Hsbot.Types -- Plugin Utils -readMsg :: Plugin IO (Message) +readMsg :: Plugin (Env IO) (Message) readMsg = gets pluginChan >>= liftIO . readChan >>= return -writeMsg :: Message -> Plugin IO () +writeMsg :: Message -> Plugin (Env IO) () writeMsg msg = gets pluginMaster >>= liftIO . flip writeChan msg -answerMsg :: IRC.Message -> String -> Plugin IO () +answerMsg :: IRC.Message -> String -> Plugin (Env IO) () answerMsg request msg = case IRC.msg_params request of sender:_ -> writeMsg . OutgoingMsg $ IRC.Message Nothing "PRIVMSG" [sender, msg] diff --git a/Hsbot/Plugin.hs b/Hsbot/Plugin.hs new file mode 100644 index 0000000..3191a15 --- /dev/null +++ b/Hsbot/Plugin.hs @@ -0,0 +1,38 @@ +module Hsbot.Plugin + ( loadPlugin + ) where + +import Control.Concurrent +import qualified Data.Map as M +import Control.Monad.Reader +import Control.Monad.State +import System.Log.Logger + +import Hsbot.Types + +loadPlugin :: PluginId -> Bot (Env IO) () +loadPlugin pId = do + bot <- get + chan <- liftIO (newChan :: IO (Chan Message)) + master <- lift $ asks envChan + let name = pluginName pId + loop = pluginEp pId + oldPlugins = botPlugins bot + pState = PluginState { pluginId = pId + , pluginChan = chan + , pluginMaster = master } + -- We check for unicity + case M.lookup name oldPlugins of + Just _ -> liftIO . warningM "Hsbot.Core.LoadPlugin" $ "Not loading already loaded plugin : " ++ name + Nothing -> do + liftIO . infoM "Hsbot.Core.LoadPlugin" $ "Loading plugin : " ++ name + env <- lift ask + finalStateMVar <- liftIO newEmptyMVar + threadId <- liftIO . forkIO $ runReaderT (execStateT loop pState >>= storeFinalState finalStateMVar) env + let newPlugins = M.insert name (pState, finalStateMVar, threadId) oldPlugins + put $ bot { botPlugins = newPlugins + , botHooks = chan : botHooks bot } + where + storeFinalState :: MVar PluginState -> PluginState -> Env IO () + storeFinalState finalStateMVar finalState = liftIO $ putMVar finalStateMVar finalState + diff --git a/Hsbot/Plugin/Ping.hs b/Hsbot/Plugin/Ping.hs index 192bab4..d399ab8 100644 --- a/Hsbot/Plugin/Ping.hs +++ b/Hsbot/Plugin/Ping.hs @@ -1,35 +1,28 @@ module Hsbot.Plugin.Ping - ( pingId - , ping + ( ping + , thePing ) where import Control.Concurrent.Chan () -import Control.Exception -import Control.Monad.State (execStateT, forever) +import Control.Monad.State import qualified Network.IRC as IRC import Prelude hiding (catch) import Hsbot.Message import Hsbot.Types -pingId :: PluginId -pingId = PluginId +ping :: PluginId +ping = PluginId { pluginName = "ping" - , pluginEp = ping } - --- | The plugin's main entry point -ping :: PluginState -> IO () -ping state = do - _ <- (execStateT run state) `catch` (\(_ :: AsyncException) -> return state) - return () + , pluginEp = thePing } -- | The IrcPlugin monad main function -run :: Plugin IO () -run = forever $ do +thePing :: Plugin (Env IO) () +thePing = forever $ do msg <- readMsg eval msg where - eval :: Message -> Plugin IO () + eval :: Message -> Plugin (Env IO) () eval (IncomingMsg msg) | (IRC.msg_command msg) == "PING" = writeMsg . OutgoingMsg . IRC.Message Nothing "PONG" $ IRC.msg_params msg | otherwise = return () diff --git a/Hsbot/Types.hs b/Hsbot/Types.hs index e906a10..3e00fb2 100644 --- a/Hsbot/Types.hs +++ b/Hsbot/Types.hs @@ -38,7 +38,7 @@ data BotEnv = BotEnv type Bot = StateT BotState data BotState = BotState - { botPlugins :: M.Map String (PluginState, MVar (), ThreadId) + { botPlugins :: M.Map String (PluginState, MVar PluginState, ThreadId) , botHooks :: [Chan Message] , botChannels :: [String] , botNickname :: String @@ -55,7 +55,7 @@ data PluginState = PluginState data PluginId = PluginId { pluginName :: String - , pluginEp :: PluginState -> IO () + , pluginEp :: Plugin (Env IO) () } -- Messaging @@ -73,7 +73,7 @@ data Config = Config , configChannels :: [String] , configNicknames :: [String] , configRealname :: String - , configPlugins :: [(String, Chan Message -> Chan Message -> IO ())] + , configPlugins :: [PluginId] } data TLSConfig = TLSConfig |