summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-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
-rw-r--r--Plugins/Core.hs10
-rw-r--r--Plugins/Quote.hs8
-rw-r--r--TODO3
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-15 01:41:12 +0000