From 53870767c32f61f756861d7bf18b5a55cd45a2e2 Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Thu, 4 Feb 2010 20:55:54 +0100 Subject: Rewrote command handling, added the Quote module and cleaned input handling. --- Hsbot/Command.hs | 81 +++++++++++++++++++++++++++++++------------------------- Hsbot/Core.hs | 4 +++ Hsbot/IRC.hs | 13 +++------ Hsbot/Plugin.hs | 7 ----- Hsbot/Types.hs | 7 ++--- Hsbot/Utils.hs | 5 ++++ 6 files changed, 61 insertions(+), 56 deletions(-) (limited to 'Hsbot') diff --git a/Hsbot/Command.hs b/Hsbot/Command.hs index 92f304c..bab592e 100644 --- a/Hsbot/Command.hs +++ b/Hsbot/Command.hs @@ -1,5 +1,6 @@ module Hsbot.Command - ( dispatchCommand + ( dispatchMessage + , processInternalCommand , registerCommand , unregisterCommand ) where @@ -14,46 +15,20 @@ import Hsbot.Plugin import Hsbot.Types import Hsbot.Utils --- TODO : unregister command - -dispatchCommand :: BotMsg -> IrcBot () -dispatchCommand (InputMsg inputMsg) = do - plugins <- gets botPlugins - cmds <- gets botCommands - if command inputMsg == "PRIVMSG" - then -- The first word matters as the command - let msg = (parameters inputMsg) !! 1 - pfx = commandPrefix config - in if (head msg) == pfx - then - let key = tail msg -- all but the cmd prefix - pluginNames = fromMaybe [] $ M.lookup key cmds - plugins' = fromMaybe [] $ mapM (flip M.lookup plugins) pluginNames - in mapM_ (sendToPlugin (InputMsg inputMsg)) plugins' - else - mapM_ (sendToPlugin (InputMsg inputMsg)) (M.elems plugins) - else - return () -dispatchCommand _ = return () - +-- | Registers a plugin's command registerCommand :: String -> String -> IrcBot () registerCommand cmd pluginName' = do bot <- get cmds <- gets botCommands - exists <- pluginExists pluginName' - -- TODO : improve this crap and remove at least one if! - if exists - then - let cmds' = if cmd `M.member` cmds - then cmds - else M.singleton cmd [] - -- TODO : remove duplicates ? - newCmds = M.adjust (++ [pluginName']) cmd cmds' - in put $ bot { botCommands = newCmds } - else - traceM $ inColor ("Couldn't register command \"" ++ cmd ++ "\" for plugin \"" - ++ pluginName' ++ "\" : plugin does not exists") [31] + plugins <- gets botPlugins + case M.lookup pluginName' plugins of + Just _ -> let pluginNames = pluginName' : fromMaybe [] (M.lookup cmd cmds) -- TODO : remove/check for duplicates ? + newCmds = M.insert cmd pluginNames cmds + in put $ bot { botCommands = newCmds } + Nothing -> traceM $ inColor ("Couldn't register command \"" ++ cmd ++ "\" for plugin \"" + ++ pluginName' ++ "\" : plugin does not exists") [31] +-- | Unregisters a plugin's command unregisterCommand :: String -> String -> IrcBot () unregisterCommand cmd pluginName' = do bot <- get @@ -61,3 +36,37 @@ unregisterCommand cmd pluginName' = do let newCmds = M.adjust (L.delete pluginName') cmd cmds put $ bot { botCommands = newCmds } +-- +-- TODO Clean this crap +-- +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 () +dispatchMessage _ = return () + +-- | 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] +processInternalCommand _ = return () + diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs index 621e670..546358b 100644 --- a/Hsbot/Core.hs +++ b/Hsbot/Core.hs @@ -1,6 +1,7 @@ module Hsbot.Core ( connectServer , disconnectServer + , emptyMsg ) where import Control.Concurrent @@ -52,3 +53,6 @@ botReader handle chan = forever $ do _ -> do return () +emptyMsg :: IrcMsg +emptyMsg = IrcMsg Nothing "EMPTY" [] + diff --git a/Hsbot/IRC.hs b/Hsbot/IRC.hs index c10467e..a489ee9 100644 --- a/Hsbot/IRC.hs +++ b/Hsbot/IRC.hs @@ -5,11 +5,9 @@ module Hsbot.IRC import Control.Concurrent.Chan import Control.Monad.State -import qualified Data.Map as M import Hsbot.Command import Hsbot.IRCParser -import Hsbot.Plugin import Hsbot.Types import Hsbot.Utils @@ -27,17 +25,12 @@ initServer = do runServer :: IrcBot () runServer = do chan <- gets botChannel - plugins <- gets botPlugins let input = readChan chan msg <- liftIO input case msg of - InputMsg inputMsg -> do - dispatchCommand $ InputMsg inputMsg - mapM_ (sendToPlugin (InputMsg inputMsg) . snd) (M.toList plugins) - OutputMsg outputMsg -> - sendstr (serializeIrcMsg outputMsg) - InternalCmd _ -> - traceM "TODO internal command" + InputMsg inputMsg -> dispatchMessage $ InputMsg inputMsg + OutputMsg outputMsg -> sendstr (serializeIrcMsg outputMsg) + InternalCmd internalCmd -> processInternalCommand $ InternalCmd internalCmd runServer -- | Joins a chan diff --git a/Hsbot/Plugin.hs b/Hsbot/Plugin.hs index 2121c7d..7d4f0ca 100644 --- a/Hsbot/Plugin.hs +++ b/Hsbot/Plugin.hs @@ -1,6 +1,5 @@ module Hsbot.Plugin ( loadPlugin - , pluginExists , sendToPlugin ) where @@ -61,9 +60,3 @@ sendToPlugin msg plugin = do let chan = pluginChannel plugin liftIO $ writeChan chan msg --- | Tells if a plugin is loaded or not -pluginExists :: String -> IrcBot Bool -pluginExists name = do - plugins <- gets botPlugins - return $ name `M.member` plugins - diff --git a/Hsbot/Types.hs b/Hsbot/Types.hs index 5522404..25a7732 100644 --- a/Hsbot/Types.hs +++ b/Hsbot/Types.hs @@ -84,10 +84,11 @@ 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 - { intCmd :: String -- the internal command - , intMsg :: IrcMsg -- the IrcMsg associated with the command - } + { internalCommand :: String -- the internal command + , internalCommandMsg :: IrcMsg -- the IrcMsg associated with the command + } deriving (Show) -- | A plugin definition data Plugin = Plugin diff --git a/Hsbot/Utils.hs b/Hsbot/Utils.hs index 640d16f..1c40362 100644 --- a/Hsbot/Utils.hs +++ b/Hsbot/Utils.hs @@ -31,3 +31,8 @@ trace msg = putStrLn msg traceM :: String -> IrcBot () traceM msg = liftIO $ putStrLn msg +----------------- +-- | Helpers | -- +----------------- +-- sendRegister + -- cgit v1.2.3