Added message formatters

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

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
   {

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'

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 (..)

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

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