Fixed the clean killing of plugin's threads, fixed exception management and cleaned plugins' main functions.

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)
+    (execStateT run bot) `catch` (\(ex :: IOException) -> return bot)
-    evalStateT disconnectServer bot'
+    evalStateT disconnectServer bot
 
 -- | The Bot monad main function
 run :: IrcBot ()

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!
+            liftIO $ throwTo (pluginThreadId plugin) UserInterrupt
-            --sendToPlugin (InternalCmd $ IntCmd "STOP" "CORE" name "") plugin
             liftIO $ unloadAll $ pluginModule plugin
             put $ bot { botPlugins = newPlugins }
         Nothing -> return ()

Makefile

@@ -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

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))
+    evalStateT (mapM_ sendRegisterCommand ["list", "load", "reload", "unload"]) plugin
-    return ()
+    (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
+run = forever $ do
-    mapM_ sendRegisterCommand ["load", "reload", "unload"]
-    runPlugin
-    mapM_ sendUnregisterCommand ["load", "reload", "unload"]
-
-runPlugin :: IrcPlugin ()
-runPlugin = forever $ do
     msg <- readMsg
     eval msg
   where

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

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)
+    evalStateT (mapM_ sendRegisterCommand ["quote"]) plugin
-    putStrLn "graou"
+    (execStateT run plugin) `catch` (\(ex :: AsyncException) -> return plugin)
-    evalStateT stop plugin'
+    evalStateT (mapM_ sendUnregisterCommand ["quote"]) plugin
 
 -- | The IrcPlugin monad main function
 run :: IrcPlugin ()
-run = do
+run = forever $ 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
     msg <- readMsg
     eval msg
   where

TODO

@@ -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