From a12e4927728c9907537b221257c5e2914f5f1c48 Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Mon, 24 May 2010 22:46:20 +0200 Subject: Implemented ircbot update messages. --- Hsbot/Irc/Command.hs | 14 ++++++++++++-- Hsbot/Irc/Core.hs | 46 ++++++++++++++++++++++++++-------------------- Hsbot/Irc/Plugin.hs | 32 ++++++++++++++++++++------------ Hsbot/Irc/Types.hs | 21 +++++++++++---------- Hsbot/Message.hs | 3 +++ 5 files changed, 72 insertions(+), 44 deletions(-) (limited to 'Hsbot') diff --git a/Hsbot/Irc/Command.hs b/Hsbot/Irc/Command.hs index e5c033e..ef1ef27 100644 --- a/Hsbot/Irc/Command.hs +++ b/Hsbot/Irc/Command.hs @@ -36,7 +36,7 @@ unregisterCommand cmd pluginName' = do -- | Processes an internal command processInternalCommand :: IrcBotMsg -> IrcBot () processInternalCommand (IntIrcCmd ircCmd) - | ircCmdTo ircCmd == "CORE" = processCoreCommand ircCmd + | ircCmdTo ircCmd == "CORE" = processCoreCommand ircCmd | otherwise = do plugins <- gets ircBotPlugins case M.lookup (ircCmdTo ircCmd) plugins of @@ -52,8 +52,18 @@ processCoreCommand ircCmd = do case command' of "LIST" -> listPlugins originalRequest (ircCmdFrom ircCmd) "LOAD" -> loadIrcPlugin $ ircCmdMsg ircCmd - "UNLOAD" -> unloadPlugin $ ircCmdMsg ircCmd + "UNLOAD" -> unloadIrcPlugin $ ircCmdMsg ircCmd + "UPDATE" -> processUpdateCommand ircCmd "REGISTER" -> registerCommand (ircCmdMsg ircCmd) (ircCmdFrom ircCmd) "UNREGISTER" -> unregisterCommand (ircCmdMsg ircCmd) (ircCmdFrom ircCmd) _ -> return () +-- | Process an update command +processUpdateCommand :: IrcCmd -> IrcBot () +processUpdateCommand ircCmd = do + ircbot <- get + let oldData = ircBotResumeData ircbot + from = ircCmdFrom ircCmd + stuff = ircCmdMsg ircCmd + put $ ircbot { ircBotResumeData = M.insert from stuff oldData } + diff --git a/Hsbot/Irc/Core.hs b/Hsbot/Irc/Core.hs index 2c455ce..1a51a5c 100644 --- a/Hsbot/Irc/Core.hs +++ b/Hsbot/Irc/Core.hs @@ -11,6 +11,7 @@ import Data.Time import Network import Prelude hiding (catch) import System.IO +import System.Posix.IO (handleToFd) import Hsbot.Irc.Command import Hsbot.Irc.Config @@ -18,7 +19,7 @@ import Hsbot.Irc.Message import Hsbot.Irc.Plugin import Hsbot.Irc.Server import Hsbot.Irc.Types -import Hsbot.Message (BotMsg) +import Hsbot.Message -- | IrcBot's main entry point startIrcbot :: IrcConfig -> Chan BotMsg -> Chan BotMsg -> IO () @@ -29,8 +30,9 @@ startIrcbot config masterChan myChan = do putStrLn $ concat ["[IrcBot] Connecting to ", ircConfigAddress config, "... "] handle <- connectTo (ircConfigAddress config) (ircConfigPort config) hSetBuffering handle NoBuffering - myOwnThreadId <- myThreadId + fd <- handleToFd handle putStrLn "[IrcBot] Spawning reader threads..." + myOwnThreadId <- myThreadId readerThreadId <- forkIO $ ircBotReader handle chan myOwnThreadId masterReaderThreadId <- forkIO $ ircBotMasterReader masterChan chan putStrLn "[IrcBot] Initializing server connection..." @@ -49,10 +51,13 @@ startIrcbot config masterChan myChan = do , ircBotHandle = handle , ircBotConfig = config , ircBotReaderThreadId = readerThreadId - , ircBotMasterReaderThreadId = masterReaderThreadId } + , ircBotMasterReaderThreadId = masterReaderThreadId + , ircBotResumeData = M.singleton "HANDLE" (show fd) } ircBotState' <- execStateT (initBotServerConnection config) ircBotState - putStrLn "[IrcBot] Entering main loop... " - _ <- ircBotLoop ircBotState' `catch` (\(_ :: IOException) -> return ()) + putStrLn "[IrcBot] Spawning plugins..." + ircBotState'' <- execStateT spawnIrcPlugins ircBotState' + putStrLn "[IrcBot] Entering Core loop... " + _ <- (execStateT ircBotLoop ircBotState'') `catch` (\(_ :: IOException) -> return (ircBotState'')) return () --resumeIrcBot @@ -89,28 +94,17 @@ initBotServerConnection config = do ircServerState' <- execStateT (initServerConnection config) ircServerState put $ ircBot { ircBotServerState = ircServerState' } --- | IrcBot's loop that can catch ircbot's states' updates -ircBotLoop :: IrcBotState -> IO () -ircBotLoop ircBotState = do - putStrLn "[IrcBot] Spawning plugins..." - ircBotState' <- execStateT spawnIrcPlugins ircBotState - -- Todo : throw new ircbotstate to hsbot - putStrLn "[IrcBot] Entering Core loop... " - _ <- (execStateT ircBotCore ircBotState') -- `catch` (\(_ :: NewBotStateException) -> return ircBotState') - return () - -- TODO : loop! - -- | Run the IrcBot's main loop -ircBotCore :: IrcBot () -ircBotCore = forever $ do - ircBot <- get - let chan = ircBotChan ircBot +ircBotLoop :: IrcBot () +ircBotLoop = forever $ do + chan <- gets ircBotChan msg <- liftIO $ readChan chan case msg of InIrcMsg inIrcMsg -> dispatchMessage $ InIrcMsg inIrcMsg OutIrcMsg outIrcMsg -> sendThisMessage outIrcMsg IntIrcCmd intIrcCmd -> do processInternalCommand $ IntIrcCmd intIrcCmd + reportUpdate where sendThisMessage :: IrcMsg -> IrcBot () sendThisMessage outputMsg = do @@ -143,3 +137,15 @@ dispatchMessage (InIrcMsg inIrcMsg) = do getMsgContent = unwords . tail $ ircMsgParameters inIrcMsg dispatchMessage _ = return () +-- | Reports an update to the master bot +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 + } + liftIO $ writeChan masterChan msg + diff --git a/Hsbot/Irc/Plugin.hs b/Hsbot/Irc/Plugin.hs index 3e6bef0..d972db2 100644 --- a/Hsbot/Irc/Plugin.hs +++ b/Hsbot/Irc/Plugin.hs @@ -5,7 +5,7 @@ module Hsbot.Irc.Plugin , loadIrcPlugin , sendToPlugin , spawnIrcPlugins - , unloadPlugin + , unloadIrcPlugin ) where import Control.Concurrent @@ -45,16 +45,20 @@ loadIrcPlugin pluginName = do "Ping" -> ircBotPluginPing "Quote" -> ircBotPluginQuote _ -> ircBotPluginDummy - let oldPlugins = ircBotPlugins ircbot + let oldPlugins = ircBotPlugins ircbot + oldResumeData = ircBotResumeData ircbot -- We check for unicity case M.lookup pluginName oldPlugins of Just _ -> return () Nothing -> do threadId <- liftIO $ forkIO (entryPoint pluginChan masterChan) - let plugin = IrcPluginState { ircPluginName = pluginName - , ircPluginChan = pluginChan - , ircPluginMasterChan = masterChan } - put $ ircbot { ircBotPlugins = M.insert pluginName (plugin, threadId) oldPlugins } + let plugin = IrcPluginState { ircPluginName = pluginName + , ircPluginChan = pluginChan + , ircPluginMasterChan = masterChan } + newPlugins = M.insert pluginName (plugin, threadId) oldPlugins + newResumeData = M.insert "PLUGINS" (show $ M.keys newPlugins) oldResumeData + put $ ircbot { ircBotPlugins = newPlugins + , ircBotResumeData = newResumeData } -- | Sends a list of loaded plugins listPlugins :: IrcMsg -> String -> IrcBot () @@ -66,14 +70,18 @@ listPlugins originalRequest dest = do Nothing -> return () -- | Unloads a plugin -unloadPlugin :: String -> IrcBot () -unloadPlugin name = do - bot <- get - let oldPlugins = ircBotPlugins bot +unloadIrcPlugin :: String -> IrcBot () +unloadIrcPlugin name = do + ircbot <- get + let oldPlugins = ircBotPlugins ircbot + oldResumeData = ircBotResumeData ircbot + -- We check if the plugin exists case M.lookup name oldPlugins of Just (_, threadId) -> do - let newPlugins = M.delete name oldPlugins + let newPlugins = M.delete name oldPlugins + newResumeData = M.insert "PLUGINS" (show $ M.keys newPlugins) oldResumeData liftIO $ throwTo threadId UserInterrupt - put $ bot { ircBotPlugins = newPlugins } + put $ ircbot { ircBotPlugins = newPlugins + , ircBotResumeData = newResumeData } Nothing -> return () diff --git a/Hsbot/Irc/Types.hs b/Hsbot/Irc/Types.hs index 78e663b..90bd728 100644 --- a/Hsbot/Irc/Types.hs +++ b/Hsbot/Irc/Types.hs @@ -21,17 +21,18 @@ type IrcBot = StateT IrcBotState IO -- | An Ircbot state data IrcBotState = IrcBotState - { ircBotStartTime :: UTCTime -- the bot's uptime + { ircBotStartTime :: UTCTime -- the bot's uptime , ircBotPlugins :: M.Map String (IrcPluginState, ThreadId) -- Loaded plugins - , ircBotCommands :: M.Map String [String] -- Loaded plugins - , ircBotChan :: Chan IrcBotMsg -- The IrcBot's communication channel - , ircBotMasterChan :: Chan BotMsg -- The Hsbot communication channel - , ircBotMyChan :: Chan BotMsg -- The Hsbot communication channel - , ircBotServerState :: IrcServerState -- The state of the IrcServer - , ircBotHandle :: Handle -- The server's socket/handle - , ircBotConfig :: IrcConfig -- The starting configuration - , ircBotReaderThreadId :: ThreadId - , ircBotMasterReaderThreadId :: ThreadId + , ircBotCommands :: M.Map String [String] -- Loaded plugins + , ircBotChan :: Chan IrcBotMsg -- The IrcBot's communication channel + , ircBotMasterChan :: Chan BotMsg -- The Hsbot communication channel + , ircBotMyChan :: Chan BotMsg -- The Hsbot communication channel + , ircBotServerState :: IrcServerState -- The state of the IrcServer + , ircBotHandle :: Handle -- The server's socket/handle + , ircBotConfig :: IrcConfig -- The starting configuration + , ircBotReaderThreadId :: ThreadId -- the thread that process inputs from the socket + , ircBotMasterReaderThreadId :: ThreadId -- the thread that process inputs from the master bot + , ircBotResumeData :: M.Map String String -- the necessary data to resume the bot's operations on reboot } -- | The IrcServer monad diff --git a/Hsbot/Message.hs b/Hsbot/Message.hs index 7532211..83d4c08 100644 --- a/Hsbot/Message.hs +++ b/Hsbot/Message.hs @@ -1,8 +1,11 @@ module Hsbot.Message ( BotMsg (..) , Msg (..) + , processInternalMessage ) where +import Hsbot.PluginUtils + -- | A hsbot message data Msg = Msg { msgType :: String -- the message type -- cgit v1.2.3