diff options
Diffstat (limited to 'Hsbot/Irc')
| -rw-r--r-- | Hsbot/Irc/Command.hs | 15 | ||||
| -rw-r--r-- | Hsbot/Irc/Core.hs | 6 | ||||
| -rw-r--r-- | Hsbot/Irc/Plugin.hs | 10 | ||||
| -rw-r--r-- | Hsbot/Irc/Types.hs | 6 |
4 files changed, 23 insertions, 14 deletions
diff --git a/Hsbot/Irc/Command.hs b/Hsbot/Irc/Command.hs index 242e12d..51c2187 100644 --- a/Hsbot/Irc/Command.hs +++ b/Hsbot/Irc/Command.hs @@ -12,6 +12,7 @@ import Data.Maybe import Hsbot.Irc.Message import Hsbot.Irc.Plugin import Hsbot.Irc.Types +import Hsbot.Types -- | Registers a plugin's command registerCommand :: String -> String -> IrcBot () @@ -34,19 +35,19 @@ unregisterCommand cmd pluginName' = do put $ ircBot { ircBotCommands = newCmds } -- | Processes an internal command -processInternalCommand :: IrcBotMsg -> IrcBot (Bool) +processInternalCommand :: IrcBotMsg -> IrcBot (BotStatus) processInternalCommand (IntIrcCmd ircCmd) | ircCmdTo ircCmd == "CORE" = processCoreCommand ircCmd | otherwise = do plugins <- gets ircBotPlugins case M.lookup (ircCmdTo ircCmd) plugins of - Just (plugin, _) -> sendToPlugin (IntIrcCmd ircCmd) plugin + Just (plugin, _, _) -> sendToPlugin (IntIrcCmd ircCmd) plugin Nothing -> return () - return False -processInternalCommand _ = return (False) + return BotContinue +processInternalCommand _ = return (BotContinue) -- | Processes a core command -processCoreCommand :: IrcCmd -> IrcBot (Bool) +processCoreCommand :: IrcCmd -> IrcBot (BotStatus) processCoreCommand ircCmd = do let command' = ircCmdCmd ircCmd originalRequest = ircCmdBotMsg ircCmd @@ -58,7 +59,9 @@ processCoreCommand ircCmd = do "UNREGISTER" -> unregisterCommand (ircCmdMsg ircCmd) (ircCmdFrom ircCmd) "UPDATE" -> processUpdateCommand ircCmd _ -> return () - return $ command' == "REBOOT" + if command' == "REBOOT" + then return BotReboot + else return BotContinue -- | Process an update command processUpdateCommand :: IrcCmd -> IrcBot () diff --git a/Hsbot/Irc/Core.hs b/Hsbot/Irc/Core.hs index 229fef8..51032a8 100644 --- a/Hsbot/Irc/Core.hs +++ b/Hsbot/Irc/Core.hs @@ -110,7 +110,7 @@ ircBotLoop = forever $ do IntIrcCmd intIrcCmd -> do reboot <- processInternalCommand $ IntIrcCmd intIrcCmd reportUpdate - if reboot + if reboot == BotReboot then processRebootCommand else return () where @@ -131,9 +131,9 @@ dispatchMessage (InIrcMsg inIrcMsg) = do let key = tail . head $ words getMsgContent pluginNames = fromMaybe [] $ M.lookup key cmds plugins' = fromMaybe [] $ mapM (flip M.lookup plugins) pluginNames - in mapM_ (sendRunCommand (tail getMsgContent) . fst) plugins' + in mapM_ (sendRunCommand (tail getMsgContent) . first) plugins' else - mapM_ (sendToPlugin (InIrcMsg inIrcMsg) . fst) (M.elems plugins) + mapM_ (sendToPlugin (InIrcMsg inIrcMsg) . first) (M.elems plugins) where isPluginCommand :: IrcConfig -> Bool isPluginCommand config = diff --git a/Hsbot/Irc/Plugin.hs b/Hsbot/Irc/Plugin.hs index 28026aa..2c8e84b 100644 --- a/Hsbot/Irc/Plugin.hs +++ b/Hsbot/Irc/Plugin.hs @@ -52,11 +52,12 @@ loadIrcPlugin pluginName = do case M.lookup pluginName oldPlugins of Just _ -> return () Nothing -> do - threadId <- liftIO $ forkIO (entryPoint pluginChan masterChan) + mvar <- liftIO newEmptyMVar + threadId <- liftIO . forkIO $ finally (entryPoint pluginChan masterChan) (putMVar mvar ()) let plugin = IrcPluginState { ircPluginName = pluginName , ircPluginChan = pluginChan , ircPluginMasterChan = masterChan } - newPlugins = M.insert pluginName (plugin, threadId) oldPlugins + newPlugins = M.insert pluginName (plugin, mvar, threadId) oldPlugins newResumeData = M.insert "PLUGINS" (show $ M.keys newPlugins) oldResumeData put $ ircbot { ircBotPlugins = newPlugins , ircBotResumeData = newResumeData } @@ -67,7 +68,7 @@ listPlugins originalRequest dest = do plugins <- gets ircBotPlugins let listing = unwords $ M.keys plugins case M.lookup dest plugins of - Just (plugin, _) -> sendToPlugin (IntIrcCmd $ IrcCmd "ANSWER" "CORE" dest listing originalRequest) plugin + Just (plugin, _, _) -> sendToPlugin (IntIrcCmd $ IrcCmd "ANSWER" "CORE" dest listing originalRequest) plugin Nothing -> return () -- | Unloads a plugin @@ -87,9 +88,10 @@ killIrcPlugin name = do let oldPlugins = ircBotPlugins ircbot -- We check if the plugin exists case M.lookup name oldPlugins of - Just (_, threadId) -> do + Just (_, mvar, threadId) -> do let newPlugins = M.delete name oldPlugins liftIO $ throwTo threadId UserInterrupt put $ ircbot { ircBotPlugins = newPlugins } + liftIO $ takeMVar mvar Nothing -> return () diff --git a/Hsbot/Irc/Types.hs b/Hsbot/Irc/Types.hs index fe70ea4..4b75085 100644 --- a/Hsbot/Irc/Types.hs +++ b/Hsbot/Irc/Types.hs @@ -3,6 +3,7 @@ module Hsbot.Irc.Types , IrcBotState (..) , IrcServer , IrcServerState (..) + , first ) where import Control.Concurrent @@ -22,7 +23,7 @@ type IrcBot = StateT IrcBotState IO -- | An Ircbot state data IrcBotState = IrcBotState { ircBotStartTime :: UTCTime -- the bot's uptime - , ircBotPlugins :: M.Map String (IrcPluginState, ThreadId) -- Loaded plugins + , ircBotPlugins :: M.Map String (IrcPluginState, MVar (), ThreadId) -- Loaded plugins , ircBotCommands :: M.Map String [String] -- Loaded plugins , ircBotChan :: Chan IrcBotMsg -- The IrcBot's communication channel , ircBotMasterChan :: Chan BotMsg -- The Hsbot communication channel @@ -44,3 +45,6 @@ data IrcServerState = IrcServerState , ircServerChan :: Chan IrcBotMsg -- the IrcBot channel } +-- | Utilities for triplets +first :: (a, b, c) -> a +first (a, _, _) = a |