diff options
Diffstat (limited to '')
| -rw-r--r-- | Hsbot.hs | 2 | ||||
| -rw-r--r-- | Hsbot/Core.hs | 163 | ||||
| -rw-r--r-- | Hsbot/IRC.hs | 121 | ||||
| -rw-r--r-- | Hsbot/IRCParser.hs | 26 | ||||
| -rw-r--r-- | Hsbot/Main.hs | 75 |
5 files changed, 218 insertions, 169 deletions
@@ -4,6 +4,7 @@ module Hsbot , module Hsbot.IRC , module Hsbot.IRCParser , module Hsbot.Main + , module Hsbot.Plugin ) where import Config @@ -11,4 +12,5 @@ import Hsbot.Core import Hsbot.IRC import Hsbot.IRCParser import Hsbot.Main +import Hsbot.Plugin diff --git a/Hsbot/Core.hs b/Hsbot/Core.hs index fddcb72..41340ba 100644 --- a/Hsbot/Core.hs +++ b/Hsbot/Core.hs @@ -1,56 +1,163 @@ module Hsbot.Core ( Bot(..) + , Channel(..) , Config(..) , IrcServer(..) - , isConnected - , newbot - , sendstr - , saveServersStates + , IrcBot + , IrcMsg(..) + , Plugin(..) + , connectServer + , disconnectServer + , inColor + , serializeIrcMsg + , traceM + , writeMsg ) where -import qualified Data.Map as M -import System.IO (Handle) -import Text.Printf (hPrintf) +import Control.Concurrent +import Control.Concurrent.Chan +import Control.Monad.State +import Data.List +import Network +import System.IO +import System.Plugins +import System.Time (ClockTime, getClockTime) --- | An IRC Bot server state (socket handles) -data Bot = Bot - { joinedServers :: M.Map IrcServer Handle -- servers we are connected to - } deriving (Eq, Show) +-- | 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 @[\'>\',\'@\',\'?\']@ - ircServers :: [IrcServer] -- list of 'Server's to connect to -} deriving (Eq,Show) + ircServer :: IrcServer -- list of 'Server's to connect to +} deriving (Show) -- | An IRC server data IrcServer = IrcServer { address :: String -- the server's address - , port :: Int -- the server's port + , 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 - } deriving (Eq, Ord, Show) + } + +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 + +-- Connect to the server and return the initial bot state +connectServer :: IrcServer -> IO Bot +connectServer server = do + let name = address server + starttime <- getClockTime + putStr $ "Connecting to " ++ name ++ "... " + handle <- connectTo name $ port server + hSetBuffering handle NoBuffering + putStrLn "done." + putStr $ "Opening server communication channel... " + chan <- newChan :: IO (Chan IrcMsg) + threadId <- forkIO $ botWriter 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 + 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 --- | Returns a new, empty bot -newbot :: Bot -newbot = Bot (M.empty) +-- |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 = hPrintf handle "%s\r\n" str +sendstr handle str = do + trace $ inColor ("--> " ++ str) [33] + hPutStr handle (str ++ "\r\n") --- | Are we already connected to this server? -isConnected :: Bot -> IrcServer -> Bool -isConnected (Bot bot) ircServer = ircServer `M.member` bot +-- | Log a message string +trace :: String -> IO () +trace msg = putStrLn msg -saveServerState :: Handle -> IrcServer -> Bot -> Bot -saveServerState handle ircServer x@(Bot bot) = - if ircServer `M.member` bot then x - else (Bot $ M.insert ircServer handle bot) +-- | Log a message string +traceM :: String -> IrcBot () +traceM msg = liftIO $ putStrLn msg -saveServersStates :: [(IrcServer, Handle)] -> Bot -> Bot -saveServersStates liste bot = foldl (\bot' (ircServer, handle) -> saveServerState handle ircServer bot') bot liste +-- |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 diff --git a/Hsbot/IRC.hs b/Hsbot/IRC.hs index 76853e2..d3a3114 100644 --- a/Hsbot/IRC.hs +++ b/Hsbot/IRC.hs @@ -1,82 +1,63 @@ module Hsbot.IRC - ( IrcLine(..) - , connectServer - , initServer - , parseIrcMsg - , ping - , pong - , sendPrivmsg - )where + ( initServer + , runServer + ) where -import Control.Monad -import Data.List(isPrefixOf) -import Data.Maybe -import Network -import qualified Network.IRC as IRC +import Control.Concurrent.Chan +import Control.Monad.State import System.IO import Hsbot.Core import Hsbot.IRCParser -type User = String -type Channel = String -type Command = String -type Args = [String] - --- | An IRC line -data IrcLine = Privmsg (String, [String]) -- statement (chan, sentence...) - | Quit (IrcServer, Handle) -- a quit message from a server - | Join (IrcServer, Channel) -- joined a channel - | Part (IrcServer, Channel) -- parted the channel - | Ping (String) -- pinged by the server - | Reboot -- reboot message sent - | Nil -- signifies thread death, only happens after reboot - deriving (Eq,Show) - --- | Parses an IrcInput -parseIrcMsg :: String -> IrcLine -parseIrcMsg str = - case (ircParser str) of - Left err -> Nil - Right x -> eval x - where - eval :: IrcMsg -> IrcLine - eval x@(IrcMsg statement cmd stuff) - | cmd == "PING" = Ping $ head stuff - | cmd == "PRIVMSG" = - case statement of - Nothing -> Nil - Just statement' -> if stuff!!1 == "reboot" then Reboot - else Privmsg $ (statement', stuff) - | otherwise = Nil - --- | Connects to a server -connectServer :: IrcServer -> IO (IrcServer, Handle) -connectServer server = do - let name = address server - port_number = port server - handle <- connectTo name (PortNumber $ fromIntegral port_number) - hSetBuffering handle NoBuffering - return (server, handle) - -- | Setup a newly connected server by sending nick and join stuff -initServer :: (IrcServer, Handle) -> IO () -initServer (server, handle) = do - sendstr handle (IRC.encode . IRC.nick $ nickname server) - sendstr handle (IRC.encode $ IRC.user (nickname server) "0" "*" (realname server)) +initServer :: IrcBot () +initServer = do + server <- gets serverConfig + writeMsg $ IrcMsg Nothing "NICK" [(nickname server)] + writeMsg $ IrcMsg Nothing "USER" [(nickname server), "0", "*", (realname server)] when (not . null $ password server) $ do - sendstr handle (IRC.encode $ IRC.privmsg "nickserv" ("identify" ++ (password server))) - mapM_ (sendstr handle . IRC.encode . IRC.joinChan) (channels server) + writeMsg $ IrcMsg Nothing "PRIVMSG" ["nickserv", "identify", (password server)] + joinChans return () --- | Check if a message is a PING -ping :: String -> Bool -ping = isPrefixOf "PING :" - --- | Send a pong message given a ping message -pong :: Handle -> String -> IO () -pong handle str = sendstr handle $ "PONG " ++ (drop 5 str) - -sendPrivmsg :: (IrcServer, Handle) -> [String] -> IO () -sendPrivmsg (server, handle) stuff' = sendstr handle (IRC.encode $ IRC.privmsg (head stuff') (unwords . tail $ stuff')) +-- | Run a server +runServer :: IrcBot () +runServer = do + handle <- gets botHandle + plugins <- gets botPlugins + str <- liftIO $ hGetLine handle + traceM $ inColor ("<-- " ++ str) [33] + let msg = parseIrcMsg str + case msg of + Right msg' -> do + mapM_ (sendPlugin msg') plugins + return () + _ -> do + return () + traceM $ show msg + 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 + bot <- get + let oldChannels = chans bot + newChannel = Channel name + (nickname $ serverConfig bot) + (administrators $ serverConfig bot) + traceM $ " Joining " ++ name + writeMsg $ IrcMsg Nothing "JOIN" [name] + put $ bot { chans = newChannel : oldChannels } diff --git a/Hsbot/IRCParser.hs b/Hsbot/IRCParser.hs index a76e22a..5c1034e 100644 --- a/Hsbot/IRCParser.hs +++ b/Hsbot/IRCParser.hs @@ -1,36 +1,40 @@ module Hsbot.IRCParser - ( IrcMsg (..) - , ircParser + ( ParseError + , parseIrcMsg ) where ---import Text.Parsec -import Text.ParserCombinators.Parsec +import Control.Monad.Identity +-- import Data.List +import Text.Parsec --- |An IRC message. -data IrcMsg = IrcMsg (Maybe String) String [String] -- (Maybe first statement) cmd [chan, params/sentence] - deriving (Show) +import Hsbot.Core ---ircParser :: String -> IrcInput -ircParser :: String -> Either ParseError IrcMsg -ircParser str = parse pMsg "" str +-- | Parses an IrcInput +parseIrcMsg :: String -> Either ParseError IrcMsg +parseIrcMsg line = parse pMsg "" line +pMsg :: ParsecT String u Identity IrcMsg pMsg = do pfx <- optionMaybe pPrefix cmd <- pCommand params <- many (char ' ' >> (pLongParam <|> pShortParam)) - char '\r' + --char '\r' eof return $ IrcMsg pfx cmd params +pPrefix :: ParsecT String u Identity [Char] pPrefix = do char ':' pfx <- many1 (noneOf " ") space return pfx +pCommand :: ParsecT String u Identity [Char] pCommand = count 3 digit <|> many1 upper +pLongParam :: ParsecT String u Identity [Char] pLongParam = char ':' >> (many1 (noneOf "\r")) +pShortParam :: ParsecT String u Identity [Char] pShortParam = many1 (noneOf " \r") diff --git a/Hsbot/Main.hs b/Hsbot/Main.hs index 8972022..3cb0ce5 100644 --- a/Hsbot/Main.hs +++ b/Hsbot/Main.hs @@ -1,71 +1,26 @@ module Hsbot.Main ( imain - , imain' ) where -import Control.Concurrent -import Control.Concurrent.Chan -import Control.Monad -import qualified Data.Map as M +import Control.Monad.State import System.IO -import System.Plugins -import qualified Config as C +import Config import Hsbot.Core import Hsbot.IRC - -type Reboot = (Module -> Bot -> (Chan IrcLine) -> IO ()) - --- | Bot's first main entry point -imain :: Module -> Reboot -> IO () -imain modul' reboot = do - chan <- newChan :: IO (Chan IrcLine) - imain' modul' reboot newbot chan +import Hsbot.Plugin -- | Bot's main entry point -imain' :: Module -> Reboot -> Bot -> (Chan IrcLine) -> IO () -imain' modul' reboot bot chan = do - -- The chan passing to reboot (or another way to keep it) is still missing - let newServers = filter (not . isConnected bot) (ircServers C.config) - putStrLn $ "Connecting servers : " ++ show (map address newServers) - newServers' <- mapM connectServer newServers - putStrLn $ "Joining channels : " ++ show (map channels newServers) - mapM_ initServer newServers' - putStrLn "Spawning threads..." - let bot' = saveServersStates newServers' bot - Bot x = bot' - mapM_ (forkIO . listener chan) newServers' -- (M.toList x) - bot'' <- monitor chan bot' - reboot modul' bot'' chan - --- | Bot main loop, monitors the threads states and handle reboot -monitor :: (Chan IrcLine) -> Bot -> IO Bot -monitor chan bot = do - loop bot - where - loop bot' = do - input <- readChan chan :: IO IrcLine - case input of - Reboot -> do - putStrLn "Got reboot message, rebooting" - return bot' - _ -> loop bot' - --- | Thread entry point for socket listeners -listener :: (Chan IrcLine) -> (IrcServer, Handle) -> IO () -listener chan (server, handle) = forever $ do - str <- hGetLine handle - let msg = parseIrcMsg str - writeChan chan msg - eval msg - where - eval :: IrcLine -> IO () - eval (Privmsg (statement, stuff')) = sendPrivmsg (server, handle) stuff' - eval (Quit (ircServer, handle')) = return () - eval (Join (ircServer, handle')) = return () - eval (Part (ircServer, handle')) = return () - eval (Ping (string)) = do pong handle string - eval stuff' = case stuff' of - Reboot -> return () - Nil -> return () +imain :: IO () +imain = do + bot <- connectServer $ ircServer config + (runStateT run bot) `catch` (const $ return ((), bot)) + disconnectServer bot + +-- | The Bot monad main function +run :: IrcBot () +run = do + initServer + mapM_ loadPlugin defaultPlugins + runServer |