From 416460886da9f8d835200ca46c9062a4ebd78fe7 Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Thu, 4 Feb 2010 23:34:15 +0100 Subject: Continue rewriting, found a problem in the way I kill plugins. --- Hsbot/Command.hs | 7 ++++++- Hsbot/Core.hs | 12 +++++++----- Hsbot/IRCPlugin.hs | 1 + Hsbot/Main.hs | 4 ++-- Hsbot/Plugin.hs | 20 ++++++++++++-------- Hsbot/Utils.hs | 8 ++++---- Plugins/Core.hs | 10 ++++++++-- Plugins/Quote.hs | 8 ++++++-- TODO | 3 ++- 9 files changed, 48 insertions(+), 25 deletions(-) diff --git a/Hsbot/Command.hs b/Hsbot/Command.hs index 054653d..76f1d04 100644 --- a/Hsbot/Command.hs +++ b/Hsbot/Command.hs @@ -67,7 +67,9 @@ processInternalCommand (InternalCmd intCmd) = do plugins <- gets botPlugins if intCmdTo intCmd == "CORE" then processCoreCommand intCmd - else sendToPlugin (InternalCmd intCmd) $ fromMaybe [] (M.lookup plugins (intCmdTo intCmd)) + else case M.lookup (intCmdTo intCmd) plugins of + Just plugin -> sendToPlugin (InternalCmd intCmd) plugin + Nothing -> errorM $ "Invalid destination in message : " ++ (show intCmd) processInternalCommand _ = return () -- | Processes a core command @@ -76,8 +78,11 @@ processCoreCommand intCmd = do let command' = intCmdCmd intCmd case command' of "LOAD" -> loadPlugin $ intCmdMsg intCmd + "RELOAD" -> reloadPlugin $ intCmdMsg intCmd "UNLOAD" -> unloadPlugin $ intCmdMsg intCmd "REGISTER" -> registerCommand (intCmdMsg intCmd) (intCmdFrom intCmd) "UNREGISTER" -> unregisterCommand (intCmdMsg intCmd) (intCmdFrom intCmd) _ -> traceM $ inColor ("Invalid command : " ++ (show intCmd)) [31] + bot' <- get + traceM $ show bot' diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs index 2de1507..a8f29ec 100644 --- a/Hsbot/Core.hs +++ b/Hsbot/Core.hs @@ -13,6 +13,7 @@ import System.IO import System.Time (getClockTime) import Hsbot.IRCParser +import Hsbot.Plugin import Hsbot.Types import Hsbot.Utils @@ -32,11 +33,12 @@ connectServer server = do return $ Bot server starttime handle [] M.empty chan threadId M.empty -- | Disconnect from the server -disconnectServer :: Bot -> IO () -- IO Bot ? -disconnectServer bot = do - killThread $ readerThreadId bot - mapM_ (killThread . pluginThreadId . snd) (M.toList $ botPlugins bot) - hClose $ botHandle bot +disconnectServer :: IrcBot () +disconnectServer = do + bot <- get + liftIO $ killThread $ readerThreadId bot + mapM_ unloadPlugin (M.keys $ botPlugins bot) + liftIO $ hClose $ botHandle bot return () -- | Socket reading loop diff --git a/Hsbot/IRCPlugin.hs b/Hsbot/IRCPlugin.hs index 8c5eb86..d4dcb82 100644 --- a/Hsbot/IRCPlugin.hs +++ b/Hsbot/IRCPlugin.hs @@ -1,5 +1,6 @@ module Hsbot.IRCPlugin ( readMsg + , sendCommand , sendRegisterCommand , sendUnregisterCommand , writeMsg diff --git a/Hsbot/Main.hs b/Hsbot/Main.hs index c73a2e5..ea1bf16 100644 --- a/Hsbot/Main.hs +++ b/Hsbot/Main.hs @@ -15,8 +15,8 @@ import Hsbot.Types imain :: IO () imain = do bot <- connectServer $ ircServer config - (runStateT run bot) `catch` (const $ return ((), bot)) - disconnectServer bot + bot' <- (execStateT run bot) `catch` (const $ return bot) + evalStateT disconnectServer bot' -- | The Bot monad main function run :: IrcBot () diff --git a/Hsbot/Plugin.hs b/Hsbot/Plugin.hs index e6f425a..d75fe8e 100644 --- a/Hsbot/Plugin.hs +++ b/Hsbot/Plugin.hs @@ -1,10 +1,13 @@ module Hsbot.Plugin ( loadPlugin , sendToPlugin + , reloadPlugin + , unloadPlugin ) where import Control.Concurrent import Control.Concurrent.Chan +import Control.Exception.Extensible import Control.Monad.State import qualified Data.Map as M import System.IO @@ -53,6 +56,12 @@ effectivelyLoadPlugin name serverChan = do return Nothing return plugin +-- | Reloads a plugin +reloadPlugin :: String -> IrcBot () +reloadPlugin name = do + unloadPlugin name + loadPlugin name + -- | Unloads a plugin unloadPlugin :: String -> IrcBot () unloadPlugin name = do @@ -61,17 +70,12 @@ unloadPlugin name = do case M.lookup name oldPlugins of Just plugin -> do let newPlugins = M.delete name oldPlugins - liftIO $ killPlugin plugin -- TODO : forkIO to get this asynchronous and non blocking - -- or let's see if closing one's chan kills him. - unloadAll $ pluginModule $ M.lookup name oldPlugins + liftIO $ throwTo (pluginThreadId plugin) UserInterrupt -- TODO : fix this! + --sendToPlugin (InternalCmd $ IntCmd "STOP" "CORE" name "") plugin + liftIO $ unloadAll $ pluginModule plugin put $ bot { botPlugins = newPlugins } Nothing -> return () --- | stop a plugin -killPlugin :: Plugin -> IO () -killPlugin plugin = do - -- TODO : send stop, sleep and kill thread (if necessary) and remove its commands - -- | Sends a msg to a plugin sendToPlugin :: BotMsg -> Plugin -> IrcBot () sendToPlugin msg plugin = do diff --git a/Hsbot/Utils.hs b/Hsbot/Utils.hs index b84b028..a58fd0c 100644 --- a/Hsbot/Utils.hs +++ b/Hsbot/Utils.hs @@ -34,9 +34,9 @@ traceM :: String -> IrcBot () traceM msg = liftIO $ trace msg -- | Logs an error message -error :: String -> IO () -error msg = trace $ inColor msg [31] +traceRed :: String -> IO () +traceRed msg = trace $ inColor msg [31] -errorM :: String -> a () -error msg = liftIO $ error msg +errorM :: String -> IrcBot () +errorM msg = liftIO $ traceRed msg diff --git a/Plugins/Core.hs b/Plugins/Core.hs index a15cc62..99abfc0 100644 --- a/Plugins/Core.hs +++ b/Plugins/Core.hs @@ -3,6 +3,7 @@ module Plugins.Core ) where import Control.Concurrent.Chan +import Control.Monad.State import Hsbot.IRCPlugin import Hsbot.Types @@ -18,9 +19,9 @@ mainCore serverChan chan = do -- | The IrcPlugin monad main function run :: IrcPlugin () run = do - mapM_ sendRegisterCommand ["load", "unload"] + mapM_ sendRegisterCommand ["load", "reload", "unload"] runPlugin - mapM_ sendUnregisterCommand ["load", "unload"] + mapM_ sendUnregisterCommand ["load", "reload", "unload"] runPlugin :: IrcPlugin () runPlugin = forever $ do @@ -33,6 +34,7 @@ runPlugin = forever $ do "RUN" -> let stuff = words $ intCmdMsg intCmd in case head stuff of "load" -> loadPlugin $ tail stuff + "reload" -> reloadPlugin $ tail stuff "unload" -> unloadPlugin $ tail stuff _ -> lift $ trace $ show intCmd -- TODO : help message _ -> lift $ trace $ show intCmd @@ -43,6 +45,10 @@ runPlugin = forever $ do loadPlugin :: [String] -> IrcPlugin () loadPlugin pluginNames = mapM_ (sendCommand "LOAD" "CORE") pluginNames +-- | The reload command +reloadPlugin :: [String] -> IrcPlugin () +reloadPlugin pluginNames = mapM_ (sendCommand "RELOAD" "CORE") pluginNames + -- | The unload command unloadPlugin :: [String] -> IrcPlugin () unloadPlugin pluginNames = mapM_ (sendCommand "UNLOAD" "CORE") pluginNames diff --git a/Plugins/Quote.hs b/Plugins/Quote.hs index 4c6e22c..fd36e11 100644 --- a/Plugins/Quote.hs +++ b/Plugins/Quote.hs @@ -28,8 +28,9 @@ type QuoteBot a = StateT QuoteDB IO a mainQuote :: Chan BotMsg -> Chan BotMsg -> IO () mainQuote serverChan chan = do let plugin = PluginInstance "Quote" serverChan chan - (runStateT run plugin) `catch` (const $ return ((), plugin)) - return () + plugin' <- (execStateT run plugin) `catch` (const $ return plugin) + putStrLn "graou" + evalStateT stop plugin' -- | The IrcPlugin monad main function run :: IrcPlugin () @@ -37,6 +38,9 @@ run = do -- TODO : init quote handling (sqlite + structure to handle temporary stuff) sendRegisterCommand "quote" runPlugin + +stop :: IrcPlugin () +stop = do sendUnregisterCommand "quote" -- TODO : send cancel messages for all temporary stuff diff --git a/TODO b/TODO index ebe4450..c866e91 100644 --- a/TODO +++ b/TODO @@ -1,7 +1,8 @@ :julien!~julien@ogu21.corp PRIVMSG #shbot :@quote graou snif +* fix unload plugins +* list plugins * discard all trace with a color param and replace those with functions info/warn/error/debug -* unload plugin * clean the plugin module * kill threads -- cgit v1.2.3