From 8b33600f3818edd9aa9dedfa7a9a03d6e2af3276 Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Mon, 24 May 2010 23:50:59 +0200 Subject: Implemented update message handling in the bot's core. --- Hsbot/Core.hs | 78 +++++++++++++++++++++++++++------------------------- Hsbot/Irc/Core.hs | 2 +- Hsbot/Irc/Types.hs | 2 +- Hsbot/Message.hs | 40 +++++++++++++++++++-------- Hsbot/Plugin.hs | 35 ++++++++++++++--------- Hsbot/PluginUtils.hs | 15 ++++++++++ Hsbot/Types.hs | 50 +++++++++++++++++++++++++++++++++ 7 files changed, 159 insertions(+), 63 deletions(-) create mode 100644 Hsbot/PluginUtils.hs create mode 100644 Hsbot/Types.hs (limited to 'Hsbot') diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs index 772a31a..0ae337b 100644 --- a/Hsbot/Core.hs +++ b/Hsbot/Core.hs @@ -12,21 +12,9 @@ import Prelude hiding (catch) import System.IO() import Hsbot.Config -import Hsbot.Irc.Config -import Hsbot.Irc.Core import Hsbot.Message import Hsbot.Plugin - --- | The Bot monad -type Bot = StateT BotState IO - --- | An Hsbot state -data BotState = BotState - { botStartTime :: UTCTime -- the bot's uptime - , botPlugins :: M.Map String (PluginState, ThreadId) -- Loaded plugins - , botChan :: Chan BotMsg -- The bot's communication channel - , botConfig :: Config -- the bot's starting config - } +import Hsbot.Types -- | Bot's main entry point hsbot :: Config -> IO () @@ -34,38 +22,54 @@ hsbot config = do startTime <- getCurrentTime putStrLn "[Hsbot] Opening communication channel... " chan <- newChan :: IO (Chan BotMsg) + putStrLn "[Hsbot] Spawning bot state manager... " + processUpdateChan <- newChan :: IO (Chan String) + reportUpdateChan <- newChan :: IO (Chan String) + updaterThreadId <- forkIO $ readUpdates processUpdateChan reportUpdateChan "" putStrLn "[Hsbot] Spawning IrcBot plugins... " - botState <- execStateT spawnIrcPlugins BotState { botStartTime = startTime - , botPlugins = M.empty - , botChan = chan - , botConfig = config } + botState <- execStateT spawnIrcPlugins BotState { botStartTime = startTime + , botPlugins = M.empty + , botChan = chan + , botConfig = config + , botUpdateChan = processUpdateChan + , botResumeData = M.empty } putStrLn "[Hsbot] Entering main loop... " - botState' <- (execStateT botLoop botState) `catch` (\(_ :: IOException) -> return botState) + _ <- (execStateT botLoop botState) `catch` (\(_ :: IOException) -> return botState) + killThread updaterThreadId + resumeData <- readChan reportUpdateChan + print resumeData return () -- | Run the bot main loop botLoop :: Bot () botLoop = forever $ do chan <- gets botChan - msg <- liftIO $ readChan chan - -- process messages - return () + msg <- liftIO $ readChan chan + case msg of + InMsg _ -> return () + OutMsg _ -> return () + IntMsg intMsg -> do + processInternalMessage $ IntMsg intMsg + reportUpdate + +-- | Reports an update to the master bot +reportUpdate :: Bot () +reportUpdate = do + bot <- get + let updateChan = botUpdateChan bot + stuff = show $ botResumeData bot + liftIO $ writeChan updateChan stuff --- | spawns IrcPlugins -spawnIrcPlugins :: Bot () -spawnIrcPlugins = do - config <- gets botConfig - mapM_ (spawnIrcPlugin) (ircConfigs config) +-- | Runs bot updates' manager thread +readUpdates :: Chan String -> Chan String -> String -> IO () +readUpdates processChan reportChan resumeData = do + resumeData' <- (readChan processChan) `catch` handleException + readUpdates processChan reportChan resumeData' where - spawnIrcPlugin :: IrcConfig -> Bot () - spawnIrcPlugin config = do - bot <- get - let chan = botChan bot - pchan <- liftIO (newChan :: IO (Chan BotMsg)) - threadId <- liftIO $ forkIO (startIrcbot config chan pchan) - let plugin = PluginState { pluginName = ircConfigName config - , pluginChan = pchan - , pluginHandles = M.empty } - plugins = botPlugins bot - put $ bot { botPlugins = M.insert (pluginName plugin) (plugin, threadId) plugins } + handleException :: AsyncException -> IO (String) + handleException _ = do + writeChan reportChan resumeData + myId <- myThreadId + killThread myId + return "" diff --git a/Hsbot/Irc/Core.hs b/Hsbot/Irc/Core.hs index 1a51a5c..936ced6 100644 --- a/Hsbot/Irc/Core.hs +++ b/Hsbot/Irc/Core.hs @@ -19,7 +19,7 @@ import Hsbot.Irc.Message import Hsbot.Irc.Plugin import Hsbot.Irc.Server import Hsbot.Irc.Types -import Hsbot.Message +import Hsbot.Types -- | IrcBot's main entry point startIrcbot :: IrcConfig -> Chan BotMsg -> Chan BotMsg -> IO () diff --git a/Hsbot/Irc/Types.hs b/Hsbot/Irc/Types.hs index 90bd728..440de64 100644 --- a/Hsbot/Irc/Types.hs +++ b/Hsbot/Irc/Types.hs @@ -14,7 +14,7 @@ import System.IO import Hsbot.Irc.Config import Hsbot.Irc.Message import Hsbot.Irc.Plugin.Utils -import Hsbot.Message +import Hsbot.Types -- | The Ircbot monad type IrcBot = StateT IrcBotState IO diff --git a/Hsbot/Message.hs b/Hsbot/Message.hs index 83d4c08..d2cb085 100644 --- a/Hsbot/Message.hs +++ b/Hsbot/Message.hs @@ -1,18 +1,36 @@ module Hsbot.Message - ( BotMsg (..) - , Msg (..) - , processInternalMessage + ( processInternalMessage ) where +import Control.Monad.State +import qualified Data.Map as M + import Hsbot.PluginUtils +import Hsbot.Types + +-- | Processes an internal message +processInternalMessage :: BotMsg -> Bot () +processInternalMessage (IntMsg msg) + | msgTo msg == "CORE" = processCoreMessage msg + | otherwise = do + plugins <- gets botPlugins + case M.lookup (msgTo msg) plugins of + Just (plugin, _) -> sendToPlugin (IntMsg msg) plugin + Nothing -> return () +processInternalMessage _ = return () --- | A hsbot message -data Msg = Msg - { msgType :: String -- the message type - , msgFrom :: String -- who issues it - , msgTo :: String -- who it is destinated to - , msgCmd :: String -- the message to be transfered - } deriving (Show) +processCoreMessage :: Msg -> Bot () +processCoreMessage msg = do + case msgCmd msg of + "UPDATE" -> processUpdateCommand msg + _ -> return () -data BotMsg = InMsg Msg | OutMsg Msg | IntMsg Msg deriving (Show) +-- | Process an update command +processUpdateCommand :: Msg -> Bot () +processUpdateCommand msg = do + bot <- get + let oldData = botResumeData bot + from = msgFrom msg + stuff = msgCmd msg + put $ bot { botResumeData = M.insert from stuff oldData } diff --git a/Hsbot/Plugin.hs b/Hsbot/Plugin.hs index 47dd0f5..aafa495 100644 --- a/Hsbot/Plugin.hs +++ b/Hsbot/Plugin.hs @@ -1,23 +1,32 @@ module Hsbot.Plugin - ( Plugin - , PluginState (..) + ( spawnIrcPlugins ) where import Control.Concurrent import Control.Concurrent.Chan () import Control.Monad.State import qualified Data.Map as M -import IO (Handle) -import Hsbot.Message +import Hsbot.Config +import Hsbot.Irc.Config +import Hsbot.Irc.Core +import Hsbot.Types --- | The Plugin monad -type Plugin = StateT PluginState IO - --- | A plugin state -data PluginState = PluginState - { pluginName :: String -- The plugin's name - , pluginChan :: Chan BotMsg -- The plugin chan - , pluginHandles :: M.Map String Handle -- the plugins's handles - } +-- | spawns IrcPlugins +spawnIrcPlugins :: Bot () +spawnIrcPlugins = do + config <- gets botConfig + mapM_ (spawnIrcPlugin) (ircConfigs config) + where + spawnIrcPlugin :: IrcConfig -> Bot () + spawnIrcPlugin config = do + bot <- get + let chan = botChan bot + pchan <- liftIO (newChan :: IO (Chan BotMsg)) + threadId <- liftIO $ forkIO (startIrcbot config chan pchan) + let plugin = PluginState { pluginName = ircConfigName config + , pluginChan = pchan + , pluginHandles = M.empty } + plugins = botPlugins bot + put $ bot { botPlugins = M.insert (pluginName plugin) (plugin, threadId) plugins } diff --git a/Hsbot/PluginUtils.hs b/Hsbot/PluginUtils.hs new file mode 100644 index 0000000..d09b3b4 --- /dev/null +++ b/Hsbot/PluginUtils.hs @@ -0,0 +1,15 @@ +module Hsbot.PluginUtils + ( sendToPlugin + ) where + +import Control.Concurrent +import Control.Concurrent.Chan () +import Control.Monad.State + +import Hsbot.Types + +-- | Sends a msg to a plugin +sendToPlugin :: BotMsg -> PluginState -> Bot () +sendToPlugin botMsg plugin = do + liftIO $ writeChan (pluginChan plugin) botMsg + diff --git a/Hsbot/Types.hs b/Hsbot/Types.hs new file mode 100644 index 0000000..3afbff5 --- /dev/null +++ b/Hsbot/Types.hs @@ -0,0 +1,50 @@ +module Hsbot.Types + ( Bot + , BotMsg (..) + , BotState (..) + , Msg (..) + , Plugin + , PluginState (..) + ) where + +import Control.Concurrent +import Control.Monad.State +import qualified Data.Map as M +import Data.Time +import System.IO + +import Hsbot.Config + +-- | The Bot monad +type Bot = StateT BotState IO + +-- | An Hsbot state +data BotState = BotState + { botStartTime :: UTCTime -- the bot's uptime + , botPlugins :: M.Map String (PluginState, ThreadId) -- Loaded plugins + , botChan :: Chan BotMsg -- the bot's communication channel + , botConfig :: Config -- the bot's starting config + , botUpdateChan :: Chan String -- the bot's chan to report updates on + , botResumeData :: M.Map String String -- the necessary data to resume the bot's operations on reboot + } + +-- | The Plugin monad +type Plugin = StateT PluginState IO + +-- | A plugin state +data PluginState = PluginState + { pluginName :: String -- The plugin's name + , pluginChan :: Chan BotMsg -- The plugin chan + , pluginHandles :: M.Map String Handle -- the plugins's handles + } + +-- | A hsbot message +data Msg = Msg + { msgType :: String -- the message type + , msgFrom :: String -- who issues it + , msgTo :: String -- who it is destinated to + , msgCmd :: String -- the message to be transfered + } deriving (Show) + +data BotMsg = InMsg Msg | OutMsg Msg | IntMsg Msg deriving (Show) + -- cgit v1.2.3