diff options
author | Julien Dessaux | 2010-04-25 16:43:01 +0200 |
---|---|---|
committer | Julien Dessaux | 2010-04-25 16:43:01 +0200 |
commit | b6d119cf5b14fd7198552e939d8f49b15307e74e (patch) | |
tree | 1f2188a89b159d6800ff89ed3346437aebfb2782 /Hsbot | |
parent | Added an utility function to correctly answer a message we receive (aka /msg) (diff) | |
download | hsbot-b6d119cf5b14fd7198552e939d8f49b15307e74e.tar.gz hsbot-b6d119cf5b14fd7198552e939d8f49b15307e74e.tar.bz2 hsbot-b6d119cf5b14fd7198552e939d8f49b15307e74e.zip |
Some refactoring + cosmetics.
Diffstat (limited to '')
-rw-r--r-- | Hsbot/Command.hs | 4 | ||||
-rw-r--r-- | Hsbot/Core.hs | 8 | ||||
-rw-r--r-- | Hsbot/IRC.hs | 8 | ||||
-rw-r--r-- | Hsbot/IRCParser.hs | 2 | ||||
-rw-r--r-- | Hsbot/IRCPlugin.hs | 33 | ||||
-rw-r--r-- | Hsbot/Plugin.hs | 2 | ||||
-rw-r--r-- | Hsbot/Types.hs | 41 | ||||
-rw-r--r-- | Hsbot/Utils.hs | 2 |
8 files changed, 49 insertions, 51 deletions
diff --git a/Hsbot/Command.hs b/Hsbot/Command.hs index 711aa32..4653618 100644 --- a/Hsbot/Command.hs +++ b/Hsbot/Command.hs @@ -42,7 +42,7 @@ dispatchMessage (InputMsg inputMsg) | isPluginCommand = do plugins <- gets botPlugins cmds <- gets botCommands - let key = tail $ head $ words getMsgContent + let key = tail . head $ words getMsgContent pluginNames = fromMaybe [] $ M.lookup key cmds plugins' = fromMaybe [] $ mapM (flip M.lookup plugins) pluginNames mapM_ (sendRunCommand $ tail getMsgContent) plugins' @@ -56,7 +56,7 @@ dispatchMessage (InputMsg inputMsg) , (head getMsgContent) == (commandPrefix config) ] sendRunCommand :: String -> Plugin -> IrcBot () sendRunCommand cmd plugin = do - sendToPlugin (InternalCmd $ IntCmd "RUN" "CORE" (pluginName plugin) cmd (Just inputMsg)) plugin + sendToPlugin (InternalCmd $ IntCmd "RUN" "CORE" (pluginName plugin) cmd inputMsg) plugin getMsgContent :: String getMsgContent = unwords . tail $ parameters inputMsg dispatchMessage _ = return () diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs index 2195525..ab2989a 100644 --- a/Hsbot/Core.hs +++ b/Hsbot/Core.hs @@ -5,7 +5,7 @@ module Hsbot.Core import Control.Concurrent import Control.Concurrent.Chan() -import Control.Exception +import Control.Exception(IOException, catch) import Control.Monad.State import Data.List() import qualified Data.Map as M @@ -44,10 +44,10 @@ disconnectServer = do mapM_ unloadPlugin (M.keys $ botPlugins bot) liftIO $ putStrLn"done." liftIO $ putStr "Closing server communication channel... " - liftIO $ killThread $ readerThreadId bot + liftIO . killThread $ readerThreadId bot liftIO $ putStrLn "done." - liftIO $ putStr $ "Disconnecting from " ++ name ++ "... " - liftIO $ hClose $ botHandle bot + liftIO . putStr $ "Disconnecting from " ++ name ++ "... " + liftIO . hClose $ botHandle bot liftIO $ putStrLn "done." -- | Socket reading loop diff --git a/Hsbot/IRC.hs b/Hsbot/IRC.hs index 1eac2d8..4a0e5f8 100644 --- a/Hsbot/IRC.hs +++ b/Hsbot/IRC.hs @@ -15,10 +15,10 @@ import Hsbot.Utils initServer :: IrcBot () initServer = do server <- gets serverConfig - sendstr $ serializeIrcMsg $ IrcMsg Nothing "NICK" [(nickname server)] - sendstr $ serializeIrcMsg $ IrcMsg Nothing "USER" [(nickname server), "0", "*", (realname server)] + sendstr . serializeIrcMsg $ IrcMsg Nothing "NICK" [(nickname server)] + sendstr . serializeIrcMsg $ IrcMsg Nothing "USER" [(nickname server), "0", "*", (realname server)] when (not . null $ password server) $ do - sendstr $ serializeIrcMsg $ IrcMsg Nothing "PRIVMSG" ["nickserv", "identify", (password server)] + sendstr . serializeIrcMsg $ IrcMsg Nothing "PRIVMSG" ["nickserv", "identify", (password server)] mapM_ joinChan (joinChannels server) -- | Run a server @@ -40,6 +40,6 @@ joinChan name = do newChannel = Channel name (nickname $ serverConfig bot) (administrators $ serverConfig bot) - sendstr $ serializeIrcMsg $ IrcMsg Nothing "JOIN" [name] + sendstr . serializeIrcMsg $ IrcMsg Nothing "JOIN" [name] put $ bot { chans = newChannel : oldChannels } diff --git a/Hsbot/IRCParser.hs b/Hsbot/IRCParser.hs index 263ac1f..d284377 100644 --- a/Hsbot/IRCParser.hs +++ b/Hsbot/IRCParser.hs @@ -18,7 +18,7 @@ pMsg = do pfx <- optionMaybe pPrefix cmd <- pCommand params <- many (char ' ' >> (pLongParam <|> pShortParam)) - char '\r' + _ <- char '\r' --eof return $ IrcMsg pfx cmd params diff --git a/Hsbot/IRCPlugin.hs b/Hsbot/IRCPlugin.hs index 4707ce1..e0299fc 100644 --- a/Hsbot/IRCPlugin.hs +++ b/Hsbot/IRCPlugin.hs @@ -1,5 +1,7 @@ module Hsbot.IRCPlugin - ( answerMsg + ( IrcPlugin + , PluginState(..) + , answerMsg , readMsg , sendCommand , sendCommandWithRequest @@ -14,6 +16,16 @@ import Data.Maybe(fromMaybe) import Hsbot.Types +-- | The IrcPlugin monad +type IrcPlugin a = StateT PluginState IO a + +-- | An IRCPlugin state +data PluginState = PluginState + { instanceName :: String -- The plugin's name + , instanceServerChan :: Chan BotMsg -- The server channel + , instanceChan :: Chan BotMsg -- The plugin channel + } + -- | Basic input output for IrcPlugins readMsg :: IrcPlugin (BotMsg) readMsg = do @@ -24,26 +36,25 @@ readMsg = do writeMsg :: BotMsg -> IrcPlugin () writeMsg botMsg = do serverChan <- gets instanceServerChan - liftIO $ writeChan serverChan $ botMsg + liftIO . writeChan serverChan $ botMsg -answerMsg :: Maybe IrcMsg -> String -> IrcPlugin () +answerMsg :: IrcMsg -> String -> IrcPlugin () answerMsg request msg = do - let incoming = fromMaybe (IrcMsg Nothing "ARGH" []) request - chanOrigin = head $ parameters (incoming) - sender = takeWhile (/= '!') $ fromMaybe "ARGH" (prefix incoming) + let chanOrigin = head $ parameters request + sender = takeWhile (/= '!') $ fromMaybe "" (prefix request) case head chanOrigin of - '#' -> writeMsg $ OutputMsg $ IrcMsg Nothing "PRIVMSG" [chanOrigin, msg] - _ -> writeMsg $ OutputMsg $ IrcMsg Nothing "PRIVMSG" [sender, msg] + '#' -> writeMsg . OutputMsg $ IrcMsg Nothing "PRIVMSG" [chanOrigin, msg] + _ -> writeMsg . OutputMsg $ IrcMsg Nothing "PRIVMSG" [sender, msg] -- | Commands management sendCommand :: String -> String -> String -> IrcPlugin () -sendCommand cmd to params = sendCommandWithRequest cmd to params Nothing +sendCommand cmd to params = sendCommandWithRequest cmd to params emptyIrcMsg -sendCommandWithRequest :: String -> String -> String -> Maybe IrcMsg -> IrcPlugin () +sendCommandWithRequest :: String -> String -> String -> IrcMsg -> IrcPlugin () sendCommandWithRequest cmd to params originalRequest = do serverChan <- gets instanceServerChan from <- gets instanceName - liftIO $ writeChan serverChan $ InternalCmd $ IntCmd cmd from to params originalRequest + liftIO . writeChan serverChan . InternalCmd $ IntCmd cmd from to params originalRequest sendRegisterCommand :: String -> IrcPlugin () sendRegisterCommand cmd = sendCommand "REGISTER" "CORE" cmd diff --git a/Hsbot/Plugin.hs b/Hsbot/Plugin.hs index 43ce0fb..13d0efc 100644 --- a/Hsbot/Plugin.hs +++ b/Hsbot/Plugin.hs @@ -33,7 +33,7 @@ effectivelyLoadPlugin name entryPoint serverChan = do return $ Plugin name threadId chan -- | Sends a list of loaded plugins -listPlugins :: Maybe IrcMsg -> String -> IrcBot () +listPlugins :: IrcMsg -> String -> IrcBot () listPlugins originalRequest dest = do plugins <- gets botPlugins let listing = unwords $ M.keys plugins diff --git a/Hsbot/Types.hs b/Hsbot/Types.hs index 436bbdf..aa45f8b 100644 --- a/Hsbot/Types.hs +++ b/Hsbot/Types.hs @@ -7,9 +7,8 @@ module Hsbot.Types , IrcServer(..) , IrcBot , IrcMsg(..) - , IrcPlugin , Plugin(..) - , PluginInstance(..) + , emptyIrcMsg ) where import Control.Concurrent @@ -47,11 +46,6 @@ instance Show IrcServer where UnixSocket u -> show u) ++ (show c) ++ (show n) ++ (show pa) ++ (show r) ++ (show ad) --- instance Show PortID where --- show (PortNumber n) = show n --- show (Service s) = show s --- show (UnixSocket g) = show g - -- | The IrcBot monad type IrcBot a = StateT Bot IO a @@ -68,11 +62,11 @@ data Bot = Bot } instance Show Bot where - 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" + show (Bot _ s h c p _ _ cmds) = unlines [ "Start time : " ++ (show s) + , "Handle : " ++ (show h) + , "Channels : " ++ (show c) + , "Plugins : " ++ (show p) + , "Commands : " ++ (show cmds)] -- | A channel connection data Channel = Channel @@ -88,13 +82,16 @@ data IrcMsg = IrcMsg , parameters :: [String] -- the message parameters } deriving (Show) +emptyIrcMsg :: IrcMsg +emptyIrcMsg = IrcMsg Nothing "" [] + -- | An internal command data IntCmd = IntCmd - { intCmdCmd :: String -- the internal command - , intCmdFrom :: String -- who issues it - , intCmdTo :: String -- who it is destinated to - , intCmdMsg :: String -- the message to be transfered - , intCmdBotMsg :: Maybe IrcMsg -- An IrcMsg attached to the command + { intCmdCmd :: String -- the internal command + , intCmdFrom :: String -- who issues it + , intCmdTo :: String -- who it is destinated to + , intCmdMsg :: String -- the message to be transfered + , intCmdBotMsg :: IrcMsg -- An IrcMsg attached to the command } deriving (Show) data BotMsg = InputMsg IrcMsg | OutputMsg IrcMsg | InternalCmd IntCmd deriving (Show) @@ -109,13 +106,3 @@ data Plugin = Plugin instance Show Plugin where show (Plugin name _ _) = show name --- | 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 a58fd0c..247a65c 100644 --- a/Hsbot/Utils.hs +++ b/Hsbot/Utils.hs @@ -16,7 +16,7 @@ import Hsbot.Types -- |Wrap a string with ANSI escape sequences. inColor :: String -> [Int] -> String inColor str vals = "\ESC[" ++ valstr ++ "m" ++ str ++ "\ESC[0m" - where valstr = concat $ intersperse ";" $ map show vals + where valstr = concat . intersperse ";" $ map show vals -- | Sends a string over handle sendstr :: String -> IrcBot () |