diff options
| -rw-r--r-- | Config.hs | 10 | ||||
| -rw-r--r-- | Hsbot.hs | 2 | ||||
| -rw-r--r-- | Hsbot/Command.hs | 59 | ||||
| -rw-r--r-- | Hsbot/Core.hs | 6 | ||||
| -rw-r--r-- | Hsbot/IRCPlugin.hs | 39 | ||||
| -rw-r--r-- | Hsbot/Plugin.hs | 24 | ||||
| -rw-r--r-- | Hsbot/Types.hs | 31 | ||||
| -rw-r--r-- | Hsbot/Utils.hs | 16 | ||||
| -rw-r--r-- | Plugins/Core.hs | 49 | ||||
| -rw-r--r-- | Plugins/Ping.hs | 29 | ||||
| -rw-r--r-- | Plugins/Quote.hs | 49 | ||||
| -rw-r--r-- | TODO | 17 |
12 files changed, 244 insertions, 87 deletions
@@ -9,12 +9,12 @@ import Hsbot.Types -- | Imported plugins goes there defaultPlugins :: [String] -defaultPlugins = [ "Ping", "Quote" ] +defaultPlugins = [ "Ping", "Core" ] -- | User server -kro :: IrcServer -kro = IrcServer - { serverAddress = "perseus" +localhost :: IrcServer +localhost = IrcServer + { serverAddress = "localhost" , serverPort = PortNumber 6667 , joinChannels = ["#shbot"] , nickname = "hsbot" @@ -27,6 +27,6 @@ kro = IrcServer config :: Config config = Config { commandPrefix = '@' - , ircServer = kro + , ircServer = localhost } @@ -4,6 +4,7 @@ module Hsbot , module Hsbot.Core , module Hsbot.IRC , module Hsbot.IRCParser + , module Hsbot.IRCPlugin , module Hsbot.Main , module Hsbot.Plugin , module Hsbot.Types @@ -15,6 +16,7 @@ import Hsbot.Command import Hsbot.Core import Hsbot.IRC import Hsbot.IRCParser +import Hsbot.IRCPlugin import Hsbot.Main import Hsbot.Plugin import Hsbot.Types 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 diff --git a/Plugins/Core.hs b/Plugins/Core.hs new file mode 100644 index 0000000..a15cc62 --- /dev/null +++ b/Plugins/Core.hs @@ -0,0 +1,49 @@ +module Plugins.Core + ( mainCore + ) where + +import Control.Concurrent.Chan + +import Hsbot.IRCPlugin +import Hsbot.Types +import Hsbot.Utils + +-- | The plugin's main entry point +mainCore :: Chan BotMsg -> Chan BotMsg -> IO () +mainCore serverChan chan = do + let plugin = PluginInstance "Core" serverChan chan + (runStateT run plugin) `catch` (const $ return ((), plugin)) + return () + +-- | The IrcPlugin monad main function +run :: IrcPlugin () +run = do + mapM_ sendRegisterCommand ["load", "unload"] + runPlugin + mapM_ sendUnregisterCommand ["load", "unload"] + +runPlugin :: IrcPlugin () +runPlugin = forever $ do + msg <- readMsg + eval msg + where + eval :: BotMsg -> IrcPlugin () + eval (InternalCmd intCmd) = do + case intCmdCmd intCmd of + "RUN" -> let stuff = words $ intCmdMsg intCmd + in case head stuff of + "load" -> loadPlugin $ tail stuff + "unload" -> unloadPlugin $ tail stuff + _ -> lift $ trace $ show intCmd -- TODO : help message + _ -> lift $ trace $ show intCmd + eval (InputMsg msg) = return () + eval _ = return () + +-- | The load command +loadPlugin :: [String] -> IrcPlugin () +loadPlugin pluginNames = mapM_ (sendCommand "LOAD" "CORE") pluginNames + +-- | The unload command +unloadPlugin :: [String] -> IrcPlugin () +unloadPlugin pluginNames = mapM_ (sendCommand "UNLOAD" "CORE") pluginNames + diff --git a/Plugins/Ping.hs b/Plugins/Ping.hs index 46351aa..6102fe4 100644 --- a/Plugins/Ping.hs +++ b/Plugins/Ping.hs @@ -3,20 +3,27 @@ module Plugins.Ping ) where import Control.Concurrent.Chan +import Control.Monad.State +import Hsbot.IRCPlugin import Hsbot.Types +-- | The plugin's main entry point mainPing :: Chan BotMsg -> Chan BotMsg -> IO () mainPing serverChan chan = do - loop - where - loop = do - input <- readChan chan - eval input - loop - eval :: BotMsg -> IO () - eval (InputMsg msg) - | (command msg) == "PING" = writeChan serverChan $ OutputMsg $ IrcMsg Nothing "PONG" (parameters msg) - | otherwise = return () - eval _ = return () + let plugin = PluginInstance "Ping" serverChan chan + (runStateT run plugin) `catch` (const $ return ((), plugin)) + return () + +-- | The IrcPlugin monad main function +run :: IrcPlugin () +run = forever $ do + msg <- readMsg + eval msg + where + eval :: BotMsg -> IrcPlugin () + eval (InputMsg msg) + | (command msg) == "PING" = writeMsg $ OutputMsg $ IrcMsg Nothing "PONG" (parameters msg) + | otherwise = return () + eval _ = return () diff --git a/Plugins/Quote.hs b/Plugins/Quote.hs index 6547cd1..4c6e22c 100644 --- a/Plugins/Quote.hs +++ b/Plugins/Quote.hs @@ -6,7 +6,7 @@ import Control.Concurrent.Chan import Control.Monad.State import System.Time (ClockTime) -import Hsbot.Core +import Hsbot.IRCPlugin import Hsbot.Types import Hsbot.Utils @@ -24,24 +24,35 @@ type QuoteDB = [Quote] -- | The QuoteBot monad type QuoteBot a = StateT QuoteDB IO a --- | The main function of the Quote module +-- | The plugin's main entry point mainQuote :: Chan BotMsg -> Chan BotMsg -> IO () mainQuote serverChan chan = do - writeChan serverChan $ InternalCmd $ IntCmd "REGISTER COMMAND quote Quote" emptyMsg - loop - where - loop = do - input <- readChan chan - eval input - loop - eval :: BotMsg -> IO () - eval (InternalCmd intCmd) = do - let command' = words $ internalCommand intCmd - case command' !! 0 of - "runCommand" -> case (command' !! 1) of - "quote" -> writeChan serverChan $ OutputMsg $ internalCommandMsg intCmd - _ -> trace $ show command' -- TODO : help message - _ -> trace $ show command' - eval (InputMsg msg) = return () - eval _ = return () + let plugin = PluginInstance "Quote" serverChan chan + (runStateT run plugin) `catch` (const $ return ((), plugin)) + return () + +-- | The IrcPlugin monad main function +run :: IrcPlugin () +run = do + -- TODO : init quote handling (sqlite + structure to handle temporary stuff) + sendRegisterCommand "quote" + runPlugin + sendUnregisterCommand "quote" + -- TODO : send cancel messages for all temporary stuff + +runPlugin :: IrcPlugin () +runPlugin = forever $ do + msg <- readMsg + eval msg + where + eval :: BotMsg -> IrcPlugin () + eval (InternalCmd intCmd) = do + case intCmdCmd intCmd of + "RUN" -> let stuff = words $ intCmdMsg intCmd + in case head stuff of + "quote" -> lift $ trace $ "Quote module has been invoked for: " ++ (show intCmd) + _ -> lift $ trace $ show intCmd -- TODO : help message + _ -> lift $ trace $ show intCmd + eval (InputMsg msg) = return () + eval _ = return () @@ -1,14 +1,17 @@ -* implement InternalCommands "register command" and "unregister command" -* implement helpers for command parsing in plugins - we need a monad "Plugin" in order to manage the from and to message fields. -* clean command module -* clean plugin module -* kill threads +:julien!~julien@ogu21.corp PRIVMSG #shbot :@quote graou snif + +* discard all trace with a color param and replace those with functions info/warn/error/debug * unload plugin + +* clean the plugin module +* kill threads * plugin reload * list modules command * part chan -* add admin check for cmds + +* add admin checks for cmds +* add register for casual conversations for plugins? +* add a "I have stuff to save so don't kill me too hard" status for plugins * restore \r in IRCParser |