summaryrefslogtreecommitdiff
path: root/Hsbot
diff options
context:
space:
mode:
authorJulien Dessaux2010-02-04 23:34:15 +0100
committerJulien Dessaux2010-02-04 23:34:15 +0100
commit416460886da9f8d835200ca46c9062a4ebd78fe7 (patch)
treef76663fd592d13031f494674c8c602e624f1d03d /Hsbot
parentBegan a complete rewrite of command and plugin management. (diff)
downloadhsbot-416460886da9f8d835200ca46c9062a4ebd78fe7.tar.gz
hsbot-416460886da9f8d835200ca46c9062a4ebd78fe7.tar.bz2
hsbot-416460886da9f8d835200ca46c9062a4ebd78fe7.zip
Continue rewriting, found a problem in the way I kill plugins.
Diffstat (limited to '')
-rw-r--r--Hsbot/Command.hs7
-rw-r--r--Hsbot/Core.hs12
-rw-r--r--Hsbot/IRCPlugin.hs1
-rw-r--r--Hsbot/Main.hs4
-rw-r--r--Hsbot/Plugin.hs20
-rw-r--r--Hsbot/Utils.hs8
6 files changed, 32 insertions, 20 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