From 884c6c9f2e3a03d6666c8dd6c6d6b6513db88ad5 Mon Sep 17 00:00:00 2001 From: Julien Dessaux Date: Thu, 4 Feb 2010 20:36:58 +0100 Subject: Reorganized code and types, changed slightly the architecture. --- Hsbot/Core.hs | 152 ++++++++--------------------------------------------- Hsbot/IRC.hs | 47 ++++++----------- Hsbot/IRCParser.hs | 15 +++++- Hsbot/Main.hs | 1 + Hsbot/Plugin.hs | 56 ++++++++++++++++++++ Hsbot/Types.hs | 104 ++++++++++++++++++++++++++++++++++++ Hsbot/Utils.hs | 33 ++++++++++++ 7 files changed, 245 insertions(+), 163 deletions(-) create mode 100644 Hsbot/Plugin.hs create mode 100644 Hsbot/Types.hs create mode 100644 Hsbot/Utils.hs (limited to 'Hsbot') diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs index 41340ba..b0efc03 100644 --- a/Hsbot/Core.hs +++ b/Hsbot/Core.hs @@ -1,17 +1,6 @@ module Hsbot.Core - ( Bot(..) - , Channel(..) - , Config(..) - , IrcServer(..) - , IrcBot - , IrcMsg(..) - , Plugin(..) - , connectServer + ( connectServer , disconnectServer - , inColor - , serializeIrcMsg - , traceM - , writeMsg ) where import Control.Concurrent @@ -20,82 +9,11 @@ import Control.Monad.State import Data.List import Network import System.IO -import System.Plugins -import System.Time (ClockTime, getClockTime) +import System.Time (getClockTime) --- | TODO : a monad for a channel, and a monad for a server, all together driven by a Bot? - --- | Configuration data type -data Config = Config { - commandPrefixes :: String, -- command prefixes, for example @[\'>\',\'@\',\'?\']@ - ircServer :: IrcServer -- list of 'Server's to connect to -} deriving (Show) - --- | An IRC server -data IrcServer = IrcServer - { address :: String -- the server's address - , port :: PortID -- the server's port - , channels :: [String] -- a list of channels to join - , nickname :: String -- the hsbot's nickname - , password :: String -- the hsbot's password, optional - , realname :: String -- the hsbot's real name, optional - , administrators :: [String] -- bot admins nicknames - } - -instance Show IrcServer where - show (IrcServer a p c n pa r ad) = (show a) - ++ (case p of - PortNumber num -> show num - Service s -> show s - 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 - --- | An IRC Bot server state -data Bot = Bot - { serverConfig :: IrcServer -- original server config we are connected to - , startTime :: ClockTime -- the bot's uptime - , botHandle :: Handle -- the socket/handle - , chans :: [Channel] -- the list of channels we have joined - , botPlugins :: [Plugin] -- The list of loaded plugins - , serverChannel :: Chan IrcMsg -- The bot's communication channel - , serverThreadId :: ThreadId -- The bot's thread ID - } - -instance Show Bot where - show (Bot _ s h c p _ _) = (show s) ++ (show h) ++ (show c) ++ (show p) - --- | A channel connection -data Channel = Channel - { channelName :: String -- the channel's name - , channelNick :: String -- our nickname - , channelAdmins :: [String] -- the bot administrators - } deriving (Show) - --- |An IRC message. -data IrcMsg = IrcMsg - { prefix :: Maybe String -- the message prefix - , command :: String -- the message command - , parameters :: [String] -- the message parameters - } deriving (Show) - --- | A plugin definition -data Plugin = Plugin - { pluginName :: String -- The plugin's name - , pluginModule :: Module -- The plugin himself - , pluginThreadId :: ThreadId -- The plugin thread - , pluginChannel :: Chan IrcMsg -- The plugin channel - } - -instance Show Plugin where - show (Plugin name _ _ _) = show name +import Hsbot.IRCParser +import Hsbot.Types +import Hsbot.Utils -- Connect to the server and return the initial bot state connectServer :: IrcServer -> IO Bot @@ -107,57 +25,29 @@ connectServer server = do hSetBuffering handle NoBuffering putStrLn "done." putStr $ "Opening server communication channel... " - chan <- newChan :: IO (Chan IrcMsg) - threadId <- forkIO $ botWriter handle chan + chan <- newChan :: IO (Chan BotMsg) + threadId <- forkIO $ botReader handle chan putStrLn "done." return (Bot server starttime handle [] [] chan threadId) -- | Disconnect from the server disconnectServer :: Bot -> IO () -- IO Bot ? disconnectServer bot = do - killThread $ serverThreadId bot + killThread $ readerThreadId bot + mapM_ (killThread . pluginThreadId) (botPlugins bot) hClose $ botHandle bot return () --- | Processing loop -botWriter :: Handle -> Chan IrcMsg -> IO () -botWriter handle chan = forever $ do - input <- readChan chan :: IO IrcMsg - sendstr handle (serializeIrcMsg input) - --- | Write an IRC message to the bot's writer -writeMsg :: IrcMsg -> IrcBot () -writeMsg msg = do - chan <- gets serverChannel - liftIO $ writeChan chan msg - --- |Serialize an IRC message to a string. -serializeIrcMsg :: IrcMsg -> String -serializeIrcMsg (IrcMsg pfx cmd params) = pfxStr ++ cmd ++ paramStr - where pfxStr = case pfx of - Nothing -> "" - Just pfx' -> ":" ++ pfx' ++ " " - paramStr = concat (map paramToStr (init params) - ++ [lastParamToStr (last params)]) - paramToStr p = " " ++ p - lastParamToStr p = " :" ++ p - --- | Send a string over handle -sendstr :: Handle -> String -> IO () -sendstr handle str = do - trace $ inColor ("--> " ++ str) [33] - hPutStr handle (str ++ "\r\n") - --- | Log a message string -trace :: String -> IO () -trace msg = putStrLn msg - --- | Log a message string -traceM :: String -> IrcBot () -traceM msg = liftIO $ putStrLn msg - --- |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 +-- | Socket reading loop +botReader :: Handle -> Chan BotMsg -> IO () +botReader handle chan = forever $ do + -- TODO : detect end of connection! + str <- hGetLine handle + let msg = parseIrcMsg str + case msg of + Right msg' -> do + trace $ inColor ("<-- " ++ (show msg')) [33] + writeChan chan (InputMsg msg') + _ -> do + return () diff --git a/Hsbot/IRC.hs b/Hsbot/IRC.hs index d3a3114..3fe2181 100644 --- a/Hsbot/IRC.hs +++ b/Hsbot/IRC.hs @@ -5,50 +5,38 @@ module Hsbot.IRC import Control.Concurrent.Chan import Control.Monad.State -import System.IO -import Hsbot.Core import Hsbot.IRCParser +import Hsbot.Plugin +import Hsbot.Types +import Hsbot.Utils -- | Setup a newly connected server by sending nick and join stuff initServer :: IrcBot () initServer = do server <- gets serverConfig - writeMsg $ IrcMsg Nothing "NICK" [(nickname server)] - writeMsg $ 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 - writeMsg $ IrcMsg Nothing "PRIVMSG" ["nickserv", "identify", (password server)] - joinChans - return () + sendstr $ serializeIrcMsg $ IrcMsg Nothing "PRIVMSG" ["nickserv", "identify", (password server)] + mapM_ joinChan (channels server) -- | Run a server runServer :: IrcBot () runServer = do - handle <- gets botHandle + chan <- gets botChannel plugins <- gets botPlugins - str <- liftIO $ hGetLine handle - traceM $ inColor ("<-- " ++ str) [33] - let msg = parseIrcMsg str + let input = readChan chan + msg <- liftIO input case msg of - Right msg' -> do - mapM_ (sendPlugin msg') plugins - return () - _ -> do - return () - traceM $ show msg + InputMsg inputMsg -> + mapM_ (sendToPlugin $ InputMsg inputMsg) plugins + OutputMsg outputMsg -> + sendstr (serializeIrcMsg outputMsg) + InternalCmd internalCmd -> + traceM "TODO" runServer -sendPlugin :: IrcMsg -> Plugin -> IrcBot () -sendPlugin msg plugin = do - let chan = pluginChannel plugin - liftIO $ writeChan chan msg - --- | Join chans -joinChans :: IrcBot () -joinChans = do - server <- gets serverConfig - mapM_ joinChan (channels server) - -- | Joins a chan joinChan :: String -> IrcBot () joinChan name = do @@ -57,7 +45,6 @@ joinChan name = do newChannel = Channel name (nickname $ serverConfig bot) (administrators $ serverConfig bot) - traceM $ " Joining " ++ name - writeMsg $ 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 5c1034e..ebf8f71 100644 --- a/Hsbot/IRCParser.hs +++ b/Hsbot/IRCParser.hs @@ -1,13 +1,13 @@ module Hsbot.IRCParser ( ParseError , parseIrcMsg + , serializeIrcMsg ) where import Control.Monad.Identity --- import Data.List import Text.Parsec -import Hsbot.Core +import Hsbot.Types -- | Parses an IrcInput parseIrcMsg :: String -> Either ParseError IrcMsg @@ -38,3 +38,14 @@ pLongParam = char ':' >> (many1 (noneOf "\r")) pShortParam :: ParsecT String u Identity [Char] pShortParam = many1 (noneOf " \r") +-- |Serialize an IRC message to a string. +serializeIrcMsg :: IrcMsg -> String +serializeIrcMsg (IrcMsg pfx cmd params) = pfxStr ++ cmd ++ paramStr + where pfxStr = case pfx of + Nothing -> "" + Just pfx' -> ":" ++ pfx' ++ " " + paramStr = concat (map paramToStr (init params) + ++ [lastParamToStr (last params)]) + paramToStr p = " " ++ p + lastParamToStr p = " :" ++ p + diff --git a/Hsbot/Main.hs b/Hsbot/Main.hs index 3cb0ce5..c73a2e5 100644 --- a/Hsbot/Main.hs +++ b/Hsbot/Main.hs @@ -9,6 +9,7 @@ import Config import Hsbot.Core import Hsbot.IRC import Hsbot.Plugin +import Hsbot.Types -- | Bot's main entry point imain :: IO () diff --git a/Hsbot/Plugin.hs b/Hsbot/Plugin.hs new file mode 100644 index 0000000..662f8e9 --- /dev/null +++ b/Hsbot/Plugin.hs @@ -0,0 +1,56 @@ +module Hsbot.Plugin + ( loadPlugin + , sendToPlugin + ) where + +import Control.Concurrent +import Control.Concurrent.Chan +import Control.Monad.State +import System.IO +import System.Plugins + +import Hsbot.Types +import Hsbot.Utils + +-- | Loads a plugin into an ircBot +loadPlugin :: String -> IrcBot () +loadPlugin name = do + bot <- get + plugin <- liftIO $ effectivelyLoadPlugin name (botChannel bot) + case plugin of + Just plugin' -> do + let oldPlugins = botPlugins bot + put $ bot { botPlugins = plugin' : oldPlugins } -- TODO : clean with a correct append + Nothing -> return () + +-- | Effectively try to load a plugin +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 + ldstat <- load_ ("Plugins/" ++ name ++ ".o") [".","Hsbot","Hsbot/Plugins"] ("main" ++ name) + case ldstat of + LoadSuccess v entryPoint -> do + putStrLn $ inColor ("Loaded plugin: " ++ name) [32] + chan <- newChan :: IO (Chan BotMsg) + threadId <- forkIO $ entryPoint serverChan chan + return $ Just (Plugin name v threadId chan) + LoadFailure e -> do + putStrLn $ inColor ("Couldn't load plugin: " ++ name) [31] + mapM_ putStrLn e + return Nothing + MakeFailure e -> do + putStrLn $ inColor ("FATAL: Couldn't compile plugin: " ++ name) [31] + mapM_ putStrLn e + return Nothing + return plugin + +-- | Sends a msg to a plugin +sendToPlugin :: BotMsg -> Plugin -> IrcBot () +sendToPlugin msg plugin = do + let chan = pluginChannel plugin + liftIO $ writeChan chan msg + diff --git a/Hsbot/Types.hs b/Hsbot/Types.hs new file mode 100644 index 0000000..7a37035 --- /dev/null +++ b/Hsbot/Types.hs @@ -0,0 +1,104 @@ +module Hsbot.Types + ( Bot(..) + , BotMsg(..) + , Channel(..) + , Config(..) + , IntCmd(..) + , IrcServer(..) + , IrcBot + , IrcMsg(..) + , Plugin(..) + ) where + +import Control.Concurrent +import Control.Concurrent.Chan +import Control.Monad.State +import qualified Data.Map as M +import Network +import System.IO +import System.Plugins +import System.Time (ClockTime) + +-- | TODO : a monad for a channel, and a monad for a server, all together driven by a Bot? + +-- | Configuration data type +data Config = Config { + commandPrefixes :: String, -- command prefixes, for example @[\'>\',\'@\',\'?\']@ + ircServer :: IrcServer -- list of 'Server's to connect to +} deriving (Show) + +-- | An IRC server +data IrcServer = IrcServer + { address :: String -- the server's address + , port :: PortID -- the server's port + , channels :: [String] -- a list of channels to join + , nickname :: String -- the hsbot's nickname + , password :: String -- the hsbot's password, optional + , realname :: String -- the hsbot's real name, optional + , administrators :: [String] -- bot admins nicknames + } + +instance Show IrcServer where + show (IrcServer a p c n pa r ad) = (show a) + ++ (case p of + PortNumber num -> show num + Service s -> show s + 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 + +-- | An IRC Bot server state +data Bot = Bot + { serverConfig :: IrcServer -- original server config we are connected to + , startTime :: ClockTime -- the bot's uptime + , botHandle :: Handle -- the socket/handle + , chans :: [Channel] -- the list of channels we have joined + , botPlugins :: M.Map String Plugin -- Loaded plugins + , botChannel :: Chan BotMsg -- The bot's communication channel + , readerThreadId :: ThreadId -- The bot's thread ID + , botCommands :: M.Map String [String] -- Registered commands ("command", ["pluginName"]) + } + +instance Show Bot where + show (Bot _ s h c p _ _ cmds) = (show s) ++ (show h) ++ (show c) ++ (show p) ++ (show cmds) + +-- | A channel connection +data Channel = Channel + { channelName :: String -- the channel's name + , channelNick :: String -- our nickname + , channelAdmins :: [String] -- the bot administrators + } deriving (Show) + +-- | A Bot command +data IntCmd = IntCmd + { intCmd :: String -- the bot's internal command + , intCmdParams :: [String] -- the parameters + } deriving (Show) + +-- |An IRC message. +data IrcMsg = IrcMsg + { prefix :: Maybe String -- the message prefix + , command :: String -- the message command + , parameters :: [String] -- the message parameters + } deriving (Show) + +-- | A plugin definition +data Plugin = Plugin + { pluginName :: String -- The plugin's name + , pluginModule :: Module -- The plugin himself + , pluginThreadId :: ThreadId -- The plugin thread + , pluginChannel :: Chan BotMsg -- The plugin channel + } + +instance Show Plugin where + show (Plugin name _ _ _) = show name + +data BotMsg = InputMsg IrcMsg | OutputMsg IrcMsg | InternalCmd IntCmd + diff --git a/Hsbot/Utils.hs b/Hsbot/Utils.hs new file mode 100644 index 0000000..640d16f --- /dev/null +++ b/Hsbot/Utils.hs @@ -0,0 +1,33 @@ +module Hsbot.Utils + ( inColor + , sendstr + , trace + , traceM + ) where + +import Control.Monad.State +import Data.List +import System.IO + +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 + +-- | Sends a string over handle +sendstr :: String -> IrcBot () +sendstr str = do + handle <- gets botHandle + traceM $ inColor ("--> " ++ str) [33] + liftIO $ hPutStr handle (str ++ "\r\n") + +-- | Log a message string +trace :: String -> IO () +trace msg = putStrLn msg + +-- | Log a message string +traceM :: String -> IrcBot () +traceM msg = liftIO $ putStrLn msg + -- cgit v1.2.3