Added message formatters
This commit is contained in:
parent
f412e28801
commit
5d49e4e201
@ -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…
Reference in New Issue
Block a user