diff options
| -rw-r--r-- | Hsbot/Main.hs | 6 | ||||
| -rw-r--r-- | Hsbot/Plugin.hs | 9 | ||||
| -rw-r--r-- | Makefile | 2 | ||||
| -rw-r--r-- | Plugins/Core.hs | 15 | ||||
| -rw-r--r-- | Plugins/Ping.hs | 4 | ||||
| -rw-r--r-- | Plugins/Quote.hs | 21 | ||||
| -rw-r--r-- | TODO | 3 |
7 files changed, 27 insertions, 33 deletions
diff --git a/Hsbot/Main.hs b/Hsbot/Main.hs index ea1bf16..592fefa 100644 --- a/Hsbot/Main.hs +++ b/Hsbot/Main.hs @@ -2,7 +2,9 @@ module Hsbot.Main ( imain ) where +import Control.Exception import Control.Monad.State +import Prelude hiding (catch) import System.IO import Config @@ -15,8 +17,8 @@ import Hsbot.Types imain :: IO () imain = do bot <- connectServer $ ircServer config - bot' <- (execStateT run bot) `catch` (const $ return bot) - evalStateT disconnectServer bot' + (execStateT run bot) `catch` (\(ex :: IOException) -> return bot) + evalStateT disconnectServer bot -- | The Bot monad main function run :: IrcBot () diff --git a/Hsbot/Plugin.hs b/Hsbot/Plugin.hs index d75fe8e..63d8256 100644 --- a/Hsbot/Plugin.hs +++ b/Hsbot/Plugin.hs @@ -7,9 +7,10 @@ module Hsbot.Plugin import Control.Concurrent import Control.Concurrent.Chan -import Control.Exception.Extensible +import Control.Exception import Control.Monad.State import qualified Data.Map as M +import Data.Maybe import System.IO import System.Plugins @@ -36,7 +37,7 @@ loadPlugin name = do effectivelyLoadPlugin :: String -> Chan BotMsg -> IO (Maybe Plugin) effectivelyLoadPlugin name serverChan = do -- TODO : test if Plugins/ ++ name ++ .hs exists - m <- liftIO $ makeAll ("Plugins/" ++ name ++ ".hs") [] + m <- liftIO $ makeAll ("Plugins/" ++ name ++ ".hs") ["-XScopedTypeVariables"] plugin <- case m of MakeSuccess _ _ -> do ldstat <- load_ ("Plugins/" ++ name ++ ".o") [".","Hsbot","Hsbot/Plugins"] ("main" ++ name) @@ -57,6 +58,7 @@ effectivelyLoadPlugin name serverChan = do return plugin -- | Reloads a plugin +-- TODO : make it a safe reload (compile before unloading) reloadPlugin :: String -> IrcBot () reloadPlugin name = do unloadPlugin name @@ -70,8 +72,7 @@ unloadPlugin name = do case M.lookup name oldPlugins of Just plugin -> do let newPlugins = M.delete name oldPlugins - liftIO $ throwTo (pluginThreadId plugin) UserInterrupt -- TODO : fix this! - --sendToPlugin (InternalCmd $ IntCmd "STOP" "CORE" name "") plugin + liftIO $ throwTo (pluginThreadId plugin) UserInterrupt liftIO $ unloadAll $ pluginModule plugin put $ bot { botPlugins = newPlugins } Nothing -> return () @@ -1,5 +1,5 @@ all: - ghc --make -Wall -O2 Main.hs -o hsbot + ghc --make -Wall -O2 Main.hs -o hsbot -XScopedTypeVariables clean: - rm hsbot diff --git a/Plugins/Core.hs b/Plugins/Core.hs index 99abfc0..b05e9aa 100644 --- a/Plugins/Core.hs +++ b/Plugins/Core.hs @@ -3,7 +3,9 @@ module Plugins.Core ) where import Control.Concurrent.Chan +import Control.Exception import Control.Monad.State +import Prelude hiding (catch) import Hsbot.IRCPlugin import Hsbot.Types @@ -13,18 +15,13 @@ import Hsbot.Utils mainCore :: Chan BotMsg -> Chan BotMsg -> IO () mainCore serverChan chan = do let plugin = PluginInstance "Core" serverChan chan - (runStateT run plugin) `catch` (const $ return ((), plugin)) - return () + evalStateT (mapM_ sendRegisterCommand ["list", "load", "reload", "unload"]) plugin + (execStateT run plugin) `catch` (\(ex :: AsyncException) -> return plugin) + evalStateT (mapM_ sendUnregisterCommand ["list", "load", "reload", "unload"]) plugin -- | The IrcPlugin monad main function run :: IrcPlugin () -run = do - mapM_ sendRegisterCommand ["load", "reload", "unload"] - runPlugin - mapM_ sendUnregisterCommand ["load", "reload", "unload"] - -runPlugin :: IrcPlugin () -runPlugin = forever $ do +run = forever $ do msg <- readMsg eval msg where diff --git a/Plugins/Ping.hs b/Plugins/Ping.hs index 6102fe4..8258bcf 100644 --- a/Plugins/Ping.hs +++ b/Plugins/Ping.hs @@ -3,7 +3,9 @@ module Plugins.Ping ) where import Control.Concurrent.Chan +import Control.Exception import Control.Monad.State +import Prelude hiding (catch) import Hsbot.IRCPlugin import Hsbot.Types @@ -12,7 +14,7 @@ import Hsbot.Types mainPing :: Chan BotMsg -> Chan BotMsg -> IO () mainPing serverChan chan = do let plugin = PluginInstance "Ping" serverChan chan - (runStateT run plugin) `catch` (const $ return ((), plugin)) + (execStateT run plugin) `catch` (\(ex :: AsyncException) -> return plugin) return () -- | The IrcPlugin monad main function diff --git a/Plugins/Quote.hs b/Plugins/Quote.hs index fd36e11..df16006 100644 --- a/Plugins/Quote.hs +++ b/Plugins/Quote.hs @@ -3,7 +3,9 @@ module Plugins.Quote ) where import Control.Concurrent.Chan +import Control.Exception import Control.Monad.State +import Prelude hiding (catch) import System.Time (ClockTime) import Hsbot.IRCPlugin @@ -28,24 +30,13 @@ type QuoteBot a = StateT QuoteDB IO a mainQuote :: Chan BotMsg -> Chan BotMsg -> IO () mainQuote serverChan chan = do let plugin = PluginInstance "Quote" serverChan chan - plugin' <- (execStateT run plugin) `catch` (const $ return plugin) - putStrLn "graou" - evalStateT stop plugin' + evalStateT (mapM_ sendRegisterCommand ["quote"]) plugin + (execStateT run plugin) `catch` (\(ex :: AsyncException) -> return plugin) + evalStateT (mapM_ sendUnregisterCommand ["quote"]) plugin -- | The IrcPlugin monad main function run :: IrcPlugin () -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 - -runPlugin :: IrcPlugin () -runPlugin = forever $ do +run = forever $ do msg <- readMsg eval msg where @@ -1,7 +1,8 @@ :julien!~julien@ogu21.corp PRIVMSG #shbot :@quote graou snif -* fix unload plugins +* throwto exception to main thread * list plugins +* write a safe reload : try reload before unloading * discard all trace with a color param and replace those with functions info/warn/error/debug * clean the plugin module |