diff --git a/hask-irc-core/Network/IRC/Bot.hs b/hask-irc-core/Network/IRC/Bot.hs index 4e1f5b5..7d7aef8 100644 --- a/hask-irc-core/Network/IRC/Bot.hs +++ b/hask-irc-core/Network/IRC/Bot.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 diff --git a/hask-irc-core/Network/IRC/Internal/Types.hs b/hask-irc-core/Network/IRC/Internal/Types.hs index d997e97..8b47ae8 100644 --- a/hask-irc-core/Network/IRC/Internal/Types.hs +++ b/hask-irc-core/Network/IRC/Internal/Types.hs @@ -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 { diff --git a/hask-irc-core/Network/IRC/Protocol.hs b/hask-irc-core/Network/IRC/Protocol.hs index 48d9fe0..d74140a 100644 --- a/hask-irc-core/Network/IRC/Protocol.hs +++ b/hask-irc-core/Network/IRC/Protocol.hs @@ -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' diff --git a/hask-irc-core/Network/IRC/Types.hs b/hask-irc-core/Network/IRC/Types.hs index 916d551..5e05934 100644 --- a/hask-irc-core/Network/IRC/Types.hs +++ b/hask-irc-core/Network/IRC/Types.hs @@ -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 (..) diff --git a/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs b/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs index 1a89bec..4b7a493 100644 --- a/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs +++ b/hask-irc-handlers/Network/IRC/Handlers/MessageLogger.hs @@ -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 diff --git a/hask-irc-runner/Network/IRC/Config.hs b/hask-irc-runner/Network/IRC/Config.hs index 7506595..d45c085 100644 --- a/hask-irc-runner/Network/IRC/Config.hs +++ b/hask-irc-runner/Network/IRC/Config.hs @@ -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