Continue rewriting, found a problem in the way I kill plugins.

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