Added message formatters

master
Abhinav Sarkar 2014-06-08 05:33:03 +05:30
parent f412e28801
commit 5d49e4e201
6 changed files with 57 additions and 34 deletions

View File

@ -48,7 +48,7 @@ readLine = readChan
sendCommandLoop :: Channel Command -> Bot -> IO () sendCommandLoop :: Channel Command -> Bot -> IO ()
sendCommandLoop (commandChan, latch) bot@Bot { .. } = do sendCommandLoop (commandChan, latch) bot@Bot { .. } = do
cmd <- readChan commandChan cmd <- readChan commandChan
let mline = lineFromCommand botConfig cmd let mline = formatCommand botConfig cmd
handle (\(e :: SomeException) -> handle (\(e :: SomeException) ->
errorM ("Error while writing to connection: " ++ show e) >> latchIt latch) $ do errorM ("Error while writing to connection: " ++ show e) >> latchIt latch) $ do
whenJust mline $ \line -> do whenJust mline $ \line -> do

View File

@ -200,12 +200,17 @@ data MessageParseResult =
| Reject -- ^ Returned if a message line cannot be parsed by a particular parser. | Reject -- ^ Returned if a message line cannot be parsed by a particular parser.
deriving (Eq, Show) deriving (Eq, Show)
-- | A message parser. -- | A message parser used for parsing text lines from the server to 'Message's.
data MessageParser = MessageParser data MessageParser = MessageParser
{ msgParserId :: !MessageParserId { msgParserId :: !MessageParserId
, msgParser :: !(BotConfig -> UTCTime -> Text -> [MessagePart] -> MessageParseResult) , msgParser :: !(BotConfig -> UTCTime -> Text -> [MessagePart] -> MessageParseResult)
} }
-- ** Command Formatting
-- | A command formatter which optinally formats commands to texts which are then send to the server.
type CommandFormatter = BotConfig -> Command -> Maybe Text
-- ** Events -- ** Events
-- | Events are used for communication between message handlers. To send events, write them to the -- | Events are used for communication between message handlers. To send events, write them to the
@ -274,6 +279,8 @@ data BotConfig = BotConfig
, msgHandlerMakers :: ![MsgHandlerMaker] , msgHandlerMakers :: ![MsgHandlerMaker]
-- | A list of extra message parsers. Note that these parsers will always be called after the built-in ones. -- | A list of extra message parsers. Note that these parsers will always be called after the built-in ones.
, msgParsers :: ![MessageParser] , msgParsers :: ![MessageParser]
-- | A list of extra command formatters. Note that these formatters will always be called after the built-in ones.
, cmdFormatters :: ![CommandFormatter]
-- | All the bot configuration so that message handlers can lookup their own specific configs. -- | All the bot configuration so that message handlers can lookup their own specific configs.
, config :: !Config , config :: !Config
} }
@ -286,6 +293,18 @@ instance Show BotConfig where
"timeout = " ++ show botTimeout ++ "\n" ++ "timeout = " ++ show botTimeout ++ "\n" ++
"handlers = " ++ show (mapKeys msgHandlerInfo) "handlers = " ++ show (mapKeys msgHandlerInfo)
-- | Creates a new bot config with some fields as empty.
newBotConfig :: Text -- ^ server
-> Int -- ^ port
-> Text -- ^ channel
-> Nick -- ^ botNick
-> Int -- ^ botTimeout
-> Map MsgHandlerName (Map Text Text) -- ^ msgHandlerInfo
-> Config -- ^ config
-> BotConfig
newBotConfig server port channel botNick botTimeout msgHandlerInfo =
BotConfig server port channel botNick botTimeout msgHandlerInfo [] [] []
-- | The bot. -- | The bot.
data Bot = Bot data Bot = Bot
{ {

View File

@ -1,25 +1,23 @@
module Network.IRC.Protocol module Network.IRC.Protocol
( MessagePart (..) ( MessagePart (..)
, parseLine , parseLine
, lineFromCommand) where , formatCommand) where
import ClassyPrelude import ClassyPrelude
import Data.List ((!!)) import Data.Foldable (msum)
import Data.Text (strip) import Data.List ((!!))
import Data.Text (strip)
import Network.IRC.Types import Network.IRC.Types
parseLine :: BotConfig -> UTCTime -> Text -> [MessagePart] -> (Maybe FullMessage, [MessagePart]) parseLine :: BotConfig -> UTCTime -> Text -> [MessagePart] -> (Maybe FullMessage, [MessagePart])
parseLine botConfig@BotConfig { .. } time line msgParts = parseLine botConfig@BotConfig { .. } time line msgParts =
fromMaybe (Nothing, msgParts) . flip (`foldl'` Nothing) parsers $ \parseResult MessageParser { .. } -> fromMaybe (Nothing, msgParts) . msum . flip map parsers $ \MessageParser { .. } -> let
case parseResult of (parserMsgParts, otherParserMsgParts) = partition ((msgParserId ==) . msgPartParserId) msgParts
Just _ -> parseResult in case msgParser botConfig time line parserMsgParts of
Nothing -> let Reject -> Nothing
(parserMsgParts, otherParserMsgParts) = partition ((msgParserId ==) . msgPartParserId) msgParts Partial msgParts' -> Just (Nothing, msgParts' ++ otherParserMsgParts)
in case msgParser botConfig time line parserMsgParts of Done message' msgParts' -> Just (Just message', msgParts' ++ otherParserMsgParts)
Reject -> Nothing
Partial msgParts' -> Just (Nothing, msgParts' ++ otherParserMsgParts)
Done message' msgParts' -> Just (Just message', msgParts' ++ otherParserMsgParts)
where where
parsers = [pingParser, namesParser, lineParser] ++ msgParsers ++ [defaultParser] parsers = [pingParser, namesParser, lineParser] ++ msgParsers ++ [defaultParser]
@ -95,8 +93,12 @@ namesParser = MessageParser "names" go
namesNicks line' = namesNicks line' =
map (Nick . stripNickPrefix) . words . drop 1 . unwords . drop 5 . words $ line' map (Nick . stripNickPrefix) . words . drop 1 . unwords . drop 5 . words $ line'
lineFromCommand :: BotConfig -> Command -> Maybe Text formatCommand :: CommandFormatter
lineFromCommand BotConfig { .. } command formatCommand botConfig@BotConfig { .. } command =
msum . map (\formatter -> formatter botConfig command) $ defaultCommandFormatter : cmdFormatters
defaultCommandFormatter :: CommandFormatter
defaultCommandFormatter BotConfig { .. } command
| Just (PongCmd msg) <- fromCommand command = Just $ "PONG :" ++ msg | Just (PongCmd msg) <- fromCommand command = Just $ "PONG :" ++ msg
| Just (PingCmd msg) <- fromCommand command = Just $ "PING :" ++ msg | Just (PingCmd msg) <- fromCommand command = Just $ "PING :" ++ msg
| Just NickCmd <- fromCommand command = Just $ "NICK " ++ botNick' | Just NickCmd <- fromCommand command = Just $ "NICK " ++ botNick'

View File

@ -48,6 +48,8 @@ module Network.IRC.Types
, MessagePart (..) , MessagePart (..)
, MessageParseResult (..) , MessageParseResult (..)
, MessageParser (..) , MessageParser (..)
-- * Command Formatting
, CommandFormatter
-- * Events -- * Events
, EventC (..) , EventC (..)
, Event , Event
@ -55,9 +57,10 @@ module Network.IRC.Types
, QuitEvent(..) , QuitEvent(..)
-- * Bot -- * Bot
, BotConfig (..) , BotConfig (..)
, newBotConfig
, Bot (..) , Bot (..)
, BotStatus (..) , BotStatus (..)
-- * Message handlers -- * Message Handlers
, MsgHandlerName , MsgHandlerName
, MonadMsgHandler , MonadMsgHandler
, MsgHandler (..) , MsgHandler (..)

View File

@ -75,21 +75,21 @@ withLogFile action state = do
messageLogger :: MonadMsgHandler m => FullMessage -> IORef LoggerState -> m [Command] messageLogger :: MonadMsgHandler m => FullMessage -> IORef LoggerState -> m [Command]
messageLogger FullMessage { .. } messageLogger FullMessage { .. }
| Just (ChannelMsg user msg) <- fromMessage message = | Just (ChannelMsg user msg) <- fromMessage message =
log "<{}> {}" [nick user, msg] log "<{}> {}" [nick user, msg]
| Just (ActionMsg user msg) <- fromMessage message = | Just (ActionMsg user msg) <- fromMessage message =
log "<{}> {} {}" [nick user, nick user, msg] log "<{}> {} {}" [nick user, nick user, msg]
| Just (KickMsg user kickedNick msg) <- fromMessage message = | Just (KickMsg user kickedNick msg) <- fromMessage message =
log "** {} KICKED {} :{}" [nick user, nickToText kickedNick, msg] log "** {} KICKED {} :{}" [nick user, nickToText kickedNick, msg]
| Just (JoinMsg user) <- fromMessage message = | Just (JoinMsg user) <- fromMessage message =
log "** {} JOINED" [nick user] log "** {} JOINED" [nick user]
| Just (PartMsg user msg) <- fromMessage message = | Just (PartMsg user msg) <- fromMessage message =
log "** {} PARTED :{}" [nick user, msg] log "** {} PARTED :{}" [nick user, msg]
| Just (QuitMsg user msg) <- fromMessage message = | Just (QuitMsg user msg) <- fromMessage message =
log "** {} QUIT :{}" [nick user, msg] log "** {} QUIT :{}" [nick user, msg]
| Just (NickMsg user newNick) <- fromMessage message = | Just (NickMsg user newNick) <- fromMessage message =
log "** {} CHANGED NICK TO {}" [nick user, nickToText newNick] log "** {} CHANGED NICK TO {}" [nick user, nickToText newNick]
| Just (NamesMsg nicks) <- fromMessage message = | Just (NamesMsg nicks) <- fromMessage message =
log "** USERS {}" [unwords . map nickToText $ nicks] log "** USERS {}" [unwords . map nickToText $ nicks]
| otherwise = const $ return [] | otherwise = const $ return []
where where

View File

@ -23,16 +23,15 @@ loadBotConfig configFile = do
eBotConfig <- try $ do eBotConfig <- try $ do
handlers :: [Text] <- CF.require cfg "msghandlers" handlers :: [Text] <- CF.require cfg "msghandlers"
let handlerInfo = foldl' (\m h -> insertMap h mempty m) mempty handlers let handlerInfo = foldl' (\m h -> insertMap h mempty m) mempty handlers
BotConfig <$> botConfig <- newBotConfig <$>
CF.require cfg "server" <*> CF.require cfg "server" <*>
CF.require cfg "port" <*> CF.require cfg "port" <*>
CF.require cfg "channel" <*> CF.require cfg "channel" <*>
(Nick <$> CF.require cfg "nick") <*> (Nick <$> CF.require cfg "nick") <*>
CF.require cfg "timeout" <*> CF.require cfg "timeout" <*>
pure handlerInfo <*> pure handlerInfo <*>
pure allMsgHandlerMakers <*> pure cfg
pure [] <*> return botConfig { msgHandlerMakers = allMsgHandlerMakers }
pure cfg
case eBotConfig of case eBotConfig of
Left (KeyError k) -> error $ "Error while reading key from config: " ++ unpack k Left (KeyError k) -> error $ "Error while reading key from config: " ++ unpack k