Added message formatters

master
Abhinav Sarkar 9 years ago
parent f412e28801
commit 5d49e4e201
  1. 2
      hask-irc-core/Network/IRC/Bot.hs
  2. 21
      hask-irc-core/Network/IRC/Internal/Types.hs
  3. 30
      hask-irc-core/Network/IRC/Protocol.hs
  4. 5
      hask-irc-core/Network/IRC/Types.hs
  5. 14
      hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs
  6. 19
      hask-irc-runner/Network/IRC/Config.hs

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

@ -200,12 +200,17 @@ data MessageParseResult =
| Reject -- ^ Returned if a message line cannot be parsed by a particular parser.
deriving (Eq, Show)
-- | A message parser.
-- | A message parser used for parsing text lines from the server to 'Message's.
data MessageParser = MessageParser
{ msgParserId :: !MessageParserId
, 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 are used for communication between message handlers. To send events, write them to the
@ -274,6 +279,8 @@ data BotConfig = BotConfig
, msgHandlerMakers :: ![MsgHandlerMaker]
-- | A list of extra message parsers. Note that these parsers will always be called after the built-in ones.
, 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.
, config :: !Config
}
@ -286,6 +293,18 @@ instance Show BotConfig where
"timeout = " ++ show botTimeout ++ "\n" ++
"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.
data Bot = Bot
{

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

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

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

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

Loading…
Cancel
Save