From 451564ef5b13302912080d58a9aee6ff0968f70e Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Tue, 25 May 2010 21:54:33 +0200 Subject: Cleaned that ugly update message handling and added a reboot command to the ircbot. --- Hsbot/Core.hs | 56 +++++++++++++++++++++--------------------------- Hsbot/Irc/Command.hs | 12 ++++++----- Hsbot/Irc/Core.hs | 29 +++++++++++++++++++------ Hsbot/Irc/Plugin/Core.hs | 9 ++++++-- Hsbot/Message.hs | 16 ++++++++------ Hsbot/Types.hs | 10 ++++----- 6 files changed, 74 insertions(+), 58 deletions(-) (limited to 'Hsbot') diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs index 0ae337b..80846ab 100644 --- a/Hsbot/Core.hs +++ b/Hsbot/Core.hs @@ -2,8 +2,8 @@ module Hsbot.Core ( hsbot ) where -import Control.Concurrent -import Control.Concurrent.Chan () +import Control.Concurrent.Chan +import Control.Concurrent.MVar import Control.Exception import Control.Monad.State import qualified Data.Map as M @@ -22,54 +22,46 @@ 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 "" + mvar <- newMVar "" :: IO (MVar String) putStrLn "[Hsbot] Spawning IrcBot plugins... " botState <- execStateT spawnIrcPlugins BotState { botStartTime = startTime , botPlugins = M.empty , botChan = chan , botConfig = config - , botUpdateChan = processUpdateChan + , botMVar = mvar , botResumeData = M.empty } putStrLn "[Hsbot] Entering main loop... " - _ <- (execStateT botLoop botState) `catch` (\(_ :: IOException) -> return botState) - killThread updaterThreadId - resumeData <- readChan reportUpdateChan + (reboot, botState') <- (runStateT botLoop botState) `catch` (\(_ :: IOException) -> return (False, botState)) + resumeData <- takeMVar mvar + if reboot + then resumeHsbot botState' resumeData + else return () + +resumeHsbot :: BotState -> String -> IO () +resumeHsbot botState resumeData = do print resumeData - return () -- | Run the bot main loop -botLoop :: Bot () -botLoop = forever $ do +botLoop :: Bot (Bool) +botLoop = do chan <- gets botChan msg <- liftIO $ readChan chan case msg of - InMsg _ -> return () - OutMsg _ -> return () + InMsg _ -> botLoop + OutMsg _ -> botLoop IntMsg intMsg -> do - processInternalMessage $ IntMsg intMsg + reboot <- processInternalMessage $ IntMsg intMsg reportUpdate + if not reboot + then botLoop + else return (True) -- | 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 - --- | 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 - handleException :: AsyncException -> IO (String) - handleException _ = do - writeChan reportChan resumeData - myId <- myThreadId - killThread myId - return "" + let mvar = botMVar bot + stuff = show $ botResumeData bot + _ <- liftIO $ swapMVar mvar stuff + return () diff --git a/Hsbot/Irc/Command.hs b/Hsbot/Irc/Command.hs index ef1ef27..242e12d 100644 --- a/Hsbot/Irc/Command.hs +++ b/Hsbot/Irc/Command.hs @@ -34,7 +34,7 @@ unregisterCommand cmd pluginName' = do put $ ircBot { ircBotCommands = newCmds } -- | Processes an internal command -processInternalCommand :: IrcBotMsg -> IrcBot () +processInternalCommand :: IrcBotMsg -> IrcBot (Bool) processInternalCommand (IntIrcCmd ircCmd) | ircCmdTo ircCmd == "CORE" = processCoreCommand ircCmd | otherwise = do @@ -42,21 +42,23 @@ processInternalCommand (IntIrcCmd ircCmd) case M.lookup (ircCmdTo ircCmd) plugins of Just (plugin, _) -> sendToPlugin (IntIrcCmd ircCmd) plugin Nothing -> return () -processInternalCommand _ = return () + return False +processInternalCommand _ = return (False) -- | Processes a core command -processCoreCommand :: IrcCmd -> IrcBot () +processCoreCommand :: IrcCmd -> IrcBot (Bool) processCoreCommand ircCmd = do let command' = ircCmdCmd ircCmd originalRequest = ircCmdBotMsg ircCmd case command' of "LIST" -> listPlugins originalRequest (ircCmdFrom ircCmd) "LOAD" -> loadIrcPlugin $ ircCmdMsg ircCmd - "UNLOAD" -> unloadIrcPlugin $ ircCmdMsg ircCmd - "UPDATE" -> processUpdateCommand ircCmd "REGISTER" -> registerCommand (ircCmdMsg ircCmd) (ircCmdFrom ircCmd) + "UNLOAD" -> unloadIrcPlugin $ ircCmdMsg ircCmd "UNREGISTER" -> unregisterCommand (ircCmdMsg ircCmd) (ircCmdFrom ircCmd) + "UPDATE" -> processUpdateCommand ircCmd _ -> return () + return $ command' == "REBOOT" -- | Process an update command processUpdateCommand :: IrcCmd -> IrcBot () diff --git a/Hsbot/Irc/Core.hs b/Hsbot/Irc/Core.hs index 936ced6..b1aee02 100644 --- a/Hsbot/Irc/Core.hs +++ b/Hsbot/Irc/Core.hs @@ -57,7 +57,7 @@ startIrcbot config masterChan myChan = do putStrLn "[IrcBot] Spawning plugins..." ircBotState'' <- execStateT spawnIrcPlugins ircBotState' putStrLn "[IrcBot] Entering Core loop... " - _ <- (execStateT ircBotLoop ircBotState'') `catch` (\(_ :: IOException) -> return (ircBotState'')) + (evalStateT ircBotLoop ircBotState'') `catch` (\(_ :: IOException) -> return ()) return () --resumeIrcBot @@ -103,8 +103,11 @@ ircBotLoop = forever $ do InIrcMsg inIrcMsg -> dispatchMessage $ InIrcMsg inIrcMsg OutIrcMsg outIrcMsg -> sendThisMessage outIrcMsg IntIrcCmd intIrcCmd -> do - processInternalCommand $ IntIrcCmd intIrcCmd + reboot <- processInternalCommand $ IntIrcCmd intIrcCmd reportUpdate + if reboot + then processRebootCommand + else return () where sendThisMessage :: IrcMsg -> IrcBot () sendThisMessage outputMsg = do @@ -142,10 +145,22 @@ reportUpdate :: IrcBot () reportUpdate = do ircbot <- get let masterChan = ircBotMasterChan ircbot - msg = IntMsg $ Msg { msgType = "UPDATE" - , msgFrom = ircConfigName $ ircBotConfig ircbot - , msgTo = "CORE" - , msgCmd = show $ ircBotResumeData ircbot - } + msg = IntMsg $ Msg { msgType = "UPDATE" + , msgFrom = ircConfigName $ ircBotConfig ircbot + , msgTo = "CORE" + , msgStuff = show $ ircBotResumeData ircbot + } + liftIO $ writeChan masterChan msg + +-- | Process a reboot command +processRebootCommand :: IrcBot () +processRebootCommand = do + ircbot <- get + let masterChan = ircBotMasterChan ircbot + msg = IntMsg $ Msg { msgType = "REBOOT" + , msgFrom = ircConfigName $ ircBotConfig ircbot + , msgTo = "CORE" + , msgStuff = show $ ircBotResumeData ircbot + } liftIO $ writeChan masterChan msg diff --git a/Hsbot/Irc/Plugin/Core.hs b/Hsbot/Irc/Plugin/Core.hs index 0297e2c..114ced8 100644 --- a/Hsbot/Irc/Plugin/Core.hs +++ b/Hsbot/Irc/Plugin/Core.hs @@ -16,9 +16,9 @@ ircBotPluginCore myChan masterChan = do let plugin = IrcPluginState { ircPluginName = "Core" , ircPluginChan = myChan , ircPluginMasterChan = masterChan } - evalStateT (mapM_ sendRegisterCommand ["list", "load", "reload", "unload"]) plugin + evalStateT (mapM_ sendRegisterCommand ["list", "load", "reload", "unload", "reboot"]) plugin plugin' <- (execStateT run plugin) `catch` (\(_ :: AsyncException) -> return plugin) - evalStateT (mapM_ sendUnregisterCommand ["list", "load", "reload", "unload"]) plugin' + evalStateT (mapM_ sendUnregisterCommand ["list", "load", "reload", "unload", "reboot"]) plugin' -- | The IrcPlugin monad main function run :: IrcPlugin () @@ -36,6 +36,7 @@ run = forever $ do "load" -> loadPlugin $ tail stuff "reload" -> reloadPlugin $ tail stuff "unload" -> unloadPlugin $ tail stuff + "reboot" -> rebootBot $ tail stuff _ -> return () -- TODO : help message "ANSWER" -> let stuff = ircCmdMsg intCmd in answerMsg request ("Loaded plugins : " ++ stuff) @@ -59,3 +60,7 @@ reloadPlugin pluginNames = mapM_ (sendCommand "RELOAD" "CORE") pluginNames unloadPlugin :: [String] -> IrcPlugin () unloadPlugin pluginNames = mapM_ (sendCommand "UNLOAD" "CORE") pluginNames +-- | The reboot command +rebootBot :: [String] -> IrcPlugin () +rebootBot stuff = sendCommand "REBOOT" "CORE" $ unwords stuff + diff --git a/Hsbot/Message.hs b/Hsbot/Message.hs index d2cb085..c632019 100644 --- a/Hsbot/Message.hs +++ b/Hsbot/Message.hs @@ -9,7 +9,7 @@ import Hsbot.PluginUtils import Hsbot.Types -- | Processes an internal message -processInternalMessage :: BotMsg -> Bot () +processInternalMessage :: BotMsg -> Bot (Bool) processInternalMessage (IntMsg msg) | msgTo msg == "CORE" = processCoreMessage msg | otherwise = do @@ -17,13 +17,15 @@ processInternalMessage (IntMsg msg) case M.lookup (msgTo msg) plugins of Just (plugin, _) -> sendToPlugin (IntMsg msg) plugin Nothing -> return () -processInternalMessage _ = return () + return False +processInternalMessage _ = return (False) -processCoreMessage :: Msg -> Bot () +processCoreMessage :: Msg -> Bot (Bool) processCoreMessage msg = do - case msgCmd msg of - "UPDATE" -> processUpdateCommand msg - _ -> return () + case msgType msg of + "UPDATE" -> processUpdateCommand msg + _ -> return () + return $ (msgType msg) == "REBOOT" -- | Process an update command processUpdateCommand :: Msg -> Bot () @@ -31,6 +33,6 @@ processUpdateCommand msg = do bot <- get let oldData = botResumeData bot from = msgFrom msg - stuff = msgCmd msg + stuff = msgStuff msg put $ bot { botResumeData = M.insert from stuff oldData } diff --git a/Hsbot/Types.hs b/Hsbot/Types.hs index 3afbff5..9ea7ff6 100644 --- a/Hsbot/Types.hs +++ b/Hsbot/Types.hs @@ -24,7 +24,7 @@ data BotState = BotState , 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 + , botMVar :: MVar String -- the place where to put resume data , botResumeData :: M.Map String String -- the necessary data to resume the bot's operations on reboot } @@ -40,10 +40,10 @@ data PluginState = PluginState -- | 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 + { msgType :: String -- the message type + , msgFrom :: String -- who issues it + , msgTo :: String -- who it is destinated to + , msgStuff :: String -- the message to be transfered } deriving (Show) data BotMsg = InMsg Msg | OutMsg Msg | IntMsg Msg deriving (Show) -- cgit v1.2.3