From fd8d5faf5f4ab085b01316e15403779ca30cf3f9 Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Thu, 4 Feb 2010 21:05:37 +0100 Subject: Began a complete rewrite of command and plugin management. Wrote a command routing statement, added an IrcPlugin monad. --- Hsbot/Command.hs | 59 ++++++++++++++++++++++++++++++++---------------------- Hsbot/Core.hs | 6 +----- Hsbot/IRCPlugin.hs | 39 ++++++++++++++++++++++++++++++++++++ Hsbot/Plugin.hs | 24 +++++++++++++++++++--- Hsbot/Types.hs | 31 +++++++++++++++++++++------- Hsbot/Utils.hs | 16 +++++++++------ 6 files changed, 130 insertions(+), 45 deletions(-) create mode 100644 Hsbot/IRCPlugin.hs (limited to 'Hsbot') diff --git a/Hsbot/Command.hs b/Hsbot/Command.hs index bab592e..054653d 100644 --- a/Hsbot/Command.hs +++ b/Hsbot/Command.hs @@ -36,37 +36,48 @@ unregisterCommand cmd pluginName' = do let newCmds = M.adjust (L.delete pluginName') cmd cmds put $ bot { botCommands = newCmds } --- --- TODO Clean this crap --- +-- | Dispatches an input message dispatchMessage :: BotMsg -> IrcBot () dispatchMessage (InputMsg inputMsg) = do plugins <- gets botPlugins cmds <- gets botCommands - case command inputMsg of - "PRIVMSG" -> -- The first word matters as the command - let msg = (parameters inputMsg) !! 1 - pfx = commandPrefix config - in if (head msg) == pfx - then - let msg' = tail msg -- all but the cmd prefix - key = head $ words msg' - pluginNames = fromMaybe [] $ M.lookup key cmds - plugins' = fromMaybe [] $ mapM (flip M.lookup plugins) pluginNames - in mapM_ (sendToPlugin $ InternalCmd $ IntCmd ("runCommand " ++ key) inputMsg) plugins' - else - mapM_ (sendToPlugin (InputMsg inputMsg)) (M.elems plugins) - _ -> return () + if isPluginCommand --TODO : how to get rid of this if? + then + 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) plugins' + else + mapM_ (sendToPlugin (InputMsg inputMsg)) (M.elems plugins) + where + isPluginCommand :: Bool + isPluginCommand = + and [ command inputMsg == "PRIVMSG" + , (head getMsgContent) == (commandPrefix config) ] + sendRunCommand :: String -> Plugin -> IrcBot () + sendRunCommand cmd plugin = do + sendToPlugin (InternalCmd $ IntCmd "RUN" "CORE" (pluginName plugin) cmd) plugin + getMsgContent :: String + getMsgContent = (parameters inputMsg) !! 1 dispatchMessage _ = return () --- | Processes an internal command +-- | Processes an internal command processInternalCommand :: BotMsg -> IrcBot () processInternalCommand (InternalCmd intCmd) = do - let command' = words $ internalCommand intCmd - case command' !! 0 of - "REGISTER" -> case command' !! 1 of - "COMMAND" -> registerCommand (command' !! 2) (command' !! 3) - _ -> traceM $ inColor ("Invalid argument for the REGISTER command : " ++ (command' !! 2)) [31] - _ -> traceM $ inColor ("Invalid command : " ++ (command' !! 1)) [31] + plugins <- gets botPlugins + if intCmdTo intCmd == "CORE" + then processCoreCommand intCmd + else sendToPlugin (InternalCmd intCmd) $ fromMaybe [] (M.lookup plugins (intCmdTo intCmd)) processInternalCommand _ = return () +-- | Processes a core command +processCoreCommand :: IntCmd -> IrcBot () +processCoreCommand intCmd = do + let command' = intCmdCmd intCmd + case command' of + "LOAD" -> loadPlugin $ 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] + diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs index 40e8e59..2de1507 100644 --- a/Hsbot/Core.hs +++ b/Hsbot/Core.hs @@ -1,7 +1,6 @@ module Hsbot.Core ( connectServer , disconnectServer - , emptyMsg ) where import Control.Concurrent @@ -30,7 +29,7 @@ connectServer server = do chan <- newChan :: IO (Chan BotMsg) threadId <- forkIO $ botReader handle chan putStrLn "done." - return (Bot server starttime handle [] M.empty chan threadId M.empty) + return $ Bot server starttime handle [] M.empty chan threadId M.empty -- | Disconnect from the server disconnectServer :: Bot -> IO () -- IO Bot ? @@ -53,6 +52,3 @@ botReader handle chan = forever $ do _ -> do return () -emptyMsg :: IrcMsg -emptyMsg = IrcMsg Nothing "EMPTY" [] - diff --git a/Hsbot/IRCPlugin.hs b/Hsbot/IRCPlugin.hs new file mode 100644 index 0000000..8c5eb86 --- /dev/null +++ b/Hsbot/IRCPlugin.hs @@ -0,0 +1,39 @@ +module Hsbot.IRCPlugin + ( readMsg + , sendRegisterCommand + , sendUnregisterCommand + , writeMsg + ) where + +import Control.Concurrent.Chan +import Control.Monad.State + +import Hsbot.Types + +-- | Basic input output for IrcPlugins +readMsg :: IrcPlugin (BotMsg) +readMsg = do + chan <- gets instanceChan + input <- liftIO $ readChan chan + return input + +writeMsg :: BotMsg -> IrcPlugin () +writeMsg botMsg = do + serverChan <- gets instanceServerChan + liftIO $ writeChan serverChan $ botMsg + +-- | Commands management +sendCommand :: String -> String -> String -> IrcPlugin () +sendCommand cmd to params = do + serverChan <- gets instanceServerChan + from <- gets instanceName + liftIO $ writeChan serverChan $ InternalCmd $ IntCmd cmd from to params + +sendRegisterCommand :: String -> IrcPlugin () +sendRegisterCommand cmd = sendCommand "REGISTER" "CORE" cmd + +sendUnregisterCommand :: String -> IrcPlugin () +sendUnregisterCommand cmd = sendCommand "UNREGISTER" "CORE" cmd + +-- | a isAdmin helper : I need an admin plugin (to track admins' status around chans) + diff --git a/Hsbot/Plugin.hs b/Hsbot/Plugin.hs index 7d4f0ca..e6f425a 100644 --- a/Hsbot/Plugin.hs +++ b/Hsbot/Plugin.hs @@ -13,7 +13,7 @@ import System.Plugins import Hsbot.Types import Hsbot.Utils --- TODO : unload plugin, reload plugin, list plugins, etc +-- TODO : reload plugin, list plugins, etc -- | Loads a plugin into an ircBot loadPlugin :: String -> IrcBot () @@ -21,7 +21,7 @@ loadPlugin name = do bot <- get let oldPlugins = botPlugins bot if name `M.member` oldPlugins - then traceM $ inColor ("Can't load plugin \"" ++ name ++ "\", this identifier has already been registered.") [31] + then traceM $ inColor ("Can't load plugin \"" ++ name ++ "\", this identifier has already been registered.") [31] -- or a wait, smthg like that? else do plugin <- liftIO $ effectivelyLoadPlugin name (botChannel bot) case plugin of @@ -33,7 +33,6 @@ loadPlugin name = do effectivelyLoadPlugin :: String -> Chan BotMsg -> IO (Maybe Plugin) effectivelyLoadPlugin name serverChan = do -- TODO : test if Plugins/ ++ name ++ .hs exists - -- Just load, do not compile if .o already present m <- liftIO $ makeAll ("Plugins/" ++ name ++ ".hs") [] plugin <- case m of MakeSuccess _ _ -> do @@ -54,6 +53,25 @@ effectivelyLoadPlugin name serverChan = do return Nothing return plugin +-- | Unloads a plugin +unloadPlugin :: String -> IrcBot () +unloadPlugin name = do + bot <- get + let oldPlugins = botPlugins bot + 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 + 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/Types.hs b/Hsbot/Types.hs index 4e002db..99619ee 100644 --- a/Hsbot/Types.hs +++ b/Hsbot/Types.hs @@ -7,7 +7,9 @@ module Hsbot.Types , IrcServer(..) , IrcBot , IrcMsg(..) + , IrcPlugin , Plugin(..) + , PluginInstance(..) ) where import Control.Concurrent @@ -23,7 +25,7 @@ import System.Time (ClockTime) -- | Configuration data type data Config = Config - { commandPrefix :: Char -- command prefixes, for example @[\'>\',\'@\',\'?\']@ + { commandPrefix :: Char -- command prefixe, for example @[\'>\',\'@\',\'?\']@ , ircServer :: IrcServer -- list of 'Server's to connect to } deriving (Show) @@ -67,7 +69,11 @@ data Bot = Bot } instance Show Bot where - show (Bot _ s h c p _ _ cmds) = (show s) ++ (show h) ++ (show c) ++ (show p) ++ (show cmds) + show (Bot _ s h c p _ _ cmds) = "Start time : " ++ (show s) ++ "\n" + ++ "Handle : " ++ (show h) ++ "\n" + ++ "Channels : " ++ (show c) ++ "\n" + ++ "Plugins : " ++ (show p) ++ "\n" + ++ "Commands : " ++ (show cmds) ++ "\n" -- | A channel connection data Channel = Channel @@ -84,13 +90,16 @@ data IrcMsg = IrcMsg } deriving (Show) -- | An internal command --- TODO : make it with a FROM and a TO for plugins handling, and make it usefull threw the helpers. data IntCmd = IntCmd - { internalCommand :: String -- the internal command - , internalCommandMsg :: IrcMsg -- the IrcMsg associated with the command + { intCmdCmd :: String -- the internal command + , intCmdFrom :: String -- who issues it + , intCmdTo :: String -- who it is destinated to + , intCmdMsg :: String -- the IrcMsg associated with the command } deriving (Show) --- | A plugin definition +data BotMsg = InputMsg IrcMsg | OutputMsg IrcMsg | InternalCmd IntCmd + +-- | A plugin (core side) data Plugin = Plugin { pluginName :: String -- The plugin's name , pluginModule :: Module -- The plugin himself @@ -101,5 +110,13 @@ data Plugin = Plugin instance Show Plugin where show (Plugin name _ _ _) = show name -data BotMsg = InputMsg IrcMsg | OutputMsg IrcMsg | InternalCmd IntCmd +-- | A IrcPlugin ("user" side) +data PluginInstance = PluginInstance + { instanceName :: String -- The plugin's name + , instanceServerChan :: Chan BotMsg -- The server channel + , instanceChan :: Chan BotMsg -- The plugin channel + } + +-- | The IrcPlugin monad +type IrcPlugin a = StateT PluginInstance IO a diff --git a/Hsbot/Utils.hs b/Hsbot/Utils.hs index 1c40362..b84b028 100644 --- a/Hsbot/Utils.hs +++ b/Hsbot/Utils.hs @@ -1,5 +1,7 @@ module Hsbot.Utils - ( inColor + ( error + , errorM + , inColor , sendstr , trace , traceM @@ -29,10 +31,12 @@ trace msg = putStrLn msg -- | Log a message string traceM :: String -> IrcBot () -traceM msg = liftIO $ putStrLn msg +traceM msg = liftIO $ trace msg ------------------ --- | Helpers | -- ------------------ --- sendRegister +-- | Logs an error message +error :: String -> IO () +error msg = trace $ inColor msg [31] + +errorM :: String -> a () +error msg = liftIO $ error msg -- cgit v1.2.3