Added message formatters
parent
f412e28801
commit
5d49e4e201
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
{
|
{
|
||||||
|
|
|
@ -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'
|
||||||
|
|
|
@ -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 (..)
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue