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 ++++----
 6 files changed, 32 insertions(+), 20 deletions(-)

(limited to 'Hsbot')

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
 
-- 
cgit v1.2.3