Adds error handling for line parsing and command formatting.

master
Abhinav Sarkar 8 years ago
parent fdf641d187
commit 5f7983e1f8
  1. 53
      hask-irc-core/Network/IRC/Bot.hs
  2. 7
      hask-irc-core/Network/IRC/Internal/Types.hs
  3. 18
      hask-irc-core/Network/IRC/Message/Types.hs
  4. 9
      hask-irc-core/Network/IRC/MessageBus.hs
  5. 74
      hask-irc-core/Network/IRC/Protocol.hs

@ -1,4 +1,4 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts, TemplateHaskell #-}
module Network.IRC.Bot
( In
@ -13,7 +13,7 @@ import qualified System.Log.Logger as HSL
import ClassyPrelude
import Control.Concurrent.Lifted (threadDelay)
import Control.Exception.Lifted (mask_, mask)
import Control.Exception.Lifted (evaluate)
import Control.Monad.State.Strict (get, put, evalStateT)
import Data.Time (addUTCTime)
import System.IO (hIsEOF)
@ -31,15 +31,46 @@ $(deriveLoggers "HSL" [HSL.INFO, HSL.ERROR])
data RawIn = Line !UTCTime !Text | EOS deriving (Show, Eq)
data In = Timeout | EOD | Msg !Message deriving (Show, Eq)
formatCommand :: (Exception e) => BotConfig -> Message -> IO ([e], [Text])
formatCommand botConfig@BotConfig { .. } message =
map (second catMaybes . partitionEithers)
. forM (defaultCommandFormatter : cmdFormatters) $ \formatter ->
try . evaluate $ formatter botConfig message
parseLine :: (Exception e)
=> BotConfig -> UTCTime -> Text -> Map MessageParserId [MessagePart]
-> IO ([e], [Message], Map MessageParserId [MessagePart])
parseLine botConfig@BotConfig { .. } time line msgParts =
map mconcat . forM parsers $ \MessageParser { .. } -> do
let parserMsgParts = concat . maybeToList $ lookup msgParserId msgParts
let parserMsgPartsMap = singletonMap msgParserId parserMsgParts
eresult <- try . evaluate $ msgParser botConfig time line parserMsgParts
return $ case eresult of
Left e -> ([e], [] , parserMsgPartsMap)
Right ParseReject -> ([] , [] , parserMsgPartsMap)
Right (ParsePartial msgParts') -> ([] , [] , singletonMap msgParserId msgParts')
Right (ParseDone message msgParts') -> ([] , [message], singletonMap msgParserId msgParts')
where
parsers = defaultParsers ++ msgParsers
sendCommandLoop :: MessageChannel Message -> Bot -> IO ()
sendCommandLoop commandChan bot@Bot { .. } = do
msg@(Message _ _ cmd) <- receiveMessage commandChan
let mline = formatCommand botConfig msg
handle (\(e :: SomeException) ->
errorM ("Error while writing to connection: " ++ show e) >> closeMessageChannel commandChan) $ do
whenJust mline $ \line -> do
TF.hprint botSocket "{}\r\n" $ TF.Only line
infoM . unpack $ "> " ++ line
(exs, lines_) <- formatCommand botConfig msg
forM_ exs $ \(ex :: SomeException) ->
errorM ("Error while formatting command: " ++ show cmd ++ "\nError: " ++ show ex)
when (not . null $ lines_) $
handle (\(e :: SomeException) -> do
errorM ("Error while writing to connection: " ++ show e)
closeMessageChannel commandChan) $ do
forM_ lines_ $ \line -> do
TF.hprint botSocket "{}\r\n" $ TF.Only line
infoM . unpack $ "> " ++ line
commandChanClosed <- isClosedMessageChannel commandChan
when (not commandChanClosed) $
case fromMessage cmd of
Just QuitCmd -> closeMessageChannel commandChan
_ -> sendCommandLoop commandChan bot
@ -63,8 +94,12 @@ readMessageLoop mvBotStatus inChan Bot { .. } timeoutDelay = evalStateT loop mem
sendMessage inChan EOD >> return msgParts
Right Nothing -> sendMessage inChan Timeout >> return msgParts
Right (Just (Line time line)) -> do
let (msgs, msgParts') = parseLine botConfig time line msgParts
(exs, msgs, msgParts') <- parseLine botConfig time line msgParts
forM_ exs $ \(ex :: SomeException) ->
errorM ("Error while parsing line: " ++ unpack line ++ "\nError: " ++ show ex)
forM_ msgs $ sendMessage inChan . Msg
return msgParts'
Right (Just EOS) -> sendMessage inChan EOD >> return msgParts

@ -29,9 +29,9 @@ data MessagePart = MessagePart { msgPartTarget :: !Text
-- | The result of parsing a message line.
data MessageParseResult =
Done !Message ![MessagePart] -- ^ A fully parsed message and leftover message parts.
| Partial ![MessagePart] -- ^ A partial message with message parts received yet.
| Reject -- ^ Returned if a message line cannot be parsed by a particular parser.
ParseDone !Message ![MessagePart] -- ^ A fully parsed message and leftover message parts.
| ParsePartial ![MessagePart] -- ^ A partial message with message parts received yet.
| ParseReject -- ^ Returned if a message line cannot be parsed by a particular parser.
deriving (Eq, Show)
-- | A message parser used for parsing text lines from the server to 'Message's.
@ -59,6 +59,7 @@ data BotConfig = BotConfig
, botPort :: !Int
-- | The channel to join.
, botChannel :: !Text
-- | Original nick of the bot.
, botOrigNick :: !Nick
-- | Current nick of the bot.
, botNick :: !Nick

@ -37,7 +37,7 @@ data User
data Message = Message
{ msgTime :: !UTCTime -- ^ The time when the message was received/sent.
, msgLine :: !Text -- ^ The raw message.
, message :: MessageW -- ^ The details of the parsed message.
, message :: !MessageW -- ^ The details of the parsed message.
} deriving (Show, Eq)
-- | The typeclass for different types of messages.
@ -49,7 +49,7 @@ class (Typeable msg, Show msg, Eq msg, Ord msg) => MessageC msg where
fromMessage (MessageW msg) = cast msg
-- | A wrapper over all types of messages.
data MessageW = forall m . MessageC m => MessageW m deriving (Typeable)
data MessageW = forall m . MessageC m => MessageW !m deriving (Typeable)
instance Show MessageW where
show (MessageW m) = show m
@ -121,8 +121,11 @@ data KickMsg = KickMsg { kickUser :: !User, kickedNick :: !Nick, kickMsg :
instance MessageC KickMsg
-- | A /MODE/ message received when a user's mode changes.
data ModeMsg = ModeMsg { modeUser :: !User, modeTarget :: !Text, mode :: !Text , modeArgs :: ![Text] }
deriving (Typeable, Show, Eq, Ord)
data ModeMsg = ModeMsg { modeUser :: !User
, modeTarget :: !Text
, mode :: !Text
, modeArgs :: ![Text]
} deriving (Typeable, Show, Eq, Ord)
instance MessageC ModeMsg
data WhoisReplyMsg = WhoisNoSuchNick { whoisNick :: !Nick }
@ -138,8 +141,11 @@ data WhoisReplyMsg = WhoisNoSuchNick { whoisNick :: !Nick }
instance MessageC WhoisReplyMsg
-- | All other messages which are not parsed as any of the above types.
data OtherMsg = OtherMsg { msgSource :: !Text, msgCommand :: !Text, msgTarget :: !Text , msg :: !Text }
deriving (Typeable, Show, Eq, Ord)
data OtherMsg = OtherMsg { msgSource :: !Text
, msgCommand :: !Text
, msgTarget :: !Text
, msg :: !Text
} deriving (Typeable, Show, Eq, Ord)
instance MessageC OtherMsg

@ -12,7 +12,8 @@ module Network.IRC.MessageBus
, receiveMessage
, receiveMessageEither
, closeMessageChannel
, awaitMessageChannel ) where
, awaitMessageChannel
, isClosedMessageChannel ) where
import ClassyPrelude
@ -27,6 +28,9 @@ doLatch (Latch mv) = putMVar mv ()
awaitLatch :: Latch -> IO ()
awaitLatch (Latch mv) = void $ takeMVar mv
latched :: Latch -> IO Bool
latched (Latch mv) = map isJust . tryReadMVar $ mv
newtype MessageBus a = MessageBus (TChan a)
newMessageBus :: IO (MessageBus a)
@ -62,6 +66,9 @@ closeMessageChannel (MessageChannel latch _ _) = doLatch latch
awaitMessageChannel :: MessageChannel a -> IO ()
awaitMessageChannel (MessageChannel latch _ _) = awaitLatch latch
isClosedMessageChannel :: MessageChannel a -> IO Bool
isClosedMessageChannel (MessageChannel latch _ _) = latched latch
receiveMessageEither :: MessageChannel a -> MessageChannel b -> IO (Either a b)
receiveMessageEither chan1 chan2 = atomically $
map Left (receiveMessageSTM chan1) `orElseSTM` map Right (receiveMessageSTM chan2)

@ -1,31 +1,21 @@
module Network.IRC.Protocol (parseLine, formatCommand) where
module Network.IRC.Protocol
( defaultParsers
, defaultCommandFormatter
) where
import ClassyPrelude
import Data.Foldable (msum)
import Data.Maybe (fromJust)
import Data.List ((!!))
import Data.Text (strip)
import Data.Maybe (fromJust)
import Data.List ((!!))
import Data.Text (strip)
import Network.IRC.Types
parseLine :: BotConfig -> UTCTime -> Text -> Map MessageParserId [MessagePart]
-> ([Message], Map MessageParserId [MessagePart])
parseLine botConfig@BotConfig { .. } time line msgParts =
mconcat . flip map parsers $ \MessageParser { .. } ->
let parserMsgParts = concat . maybeToList $ lookup msgParserId msgParts
in case msgParser botConfig time line parserMsgParts of
Reject -> ([], (singletonMap msgParserId parserMsgParts))
Partial msgParts' -> ([], (singletonMap msgParserId msgParts'))
Done message msgParts' -> ([message], (singletonMap msgParserId msgParts'))
where
parsers = [pingParser, namesParser, whoisParser, lineParser] ++ msgParsers ++ [defaultParser]
pingParser :: MessageParser
pingParser = MessageParser "ping" go
where
go _ time line _
| "PING :" `isPrefixOf` line = Done (Message time line . toMessage . PingMsg . drop 6 $ line) []
| otherwise = Reject
| "PING :" `isPrefixOf` line = ParseDone (Message time line . toMessage . PingMsg . drop 6 $ line) []
| otherwise = ParseReject
parseMsgLine :: Text -> ([Text], Text, Text, Text, Text)
parseMsgLine line = (splits, command, source, target, message)
@ -40,7 +30,7 @@ lineParser :: MessageParser
lineParser = MessageParser "line" go
where
go BotConfig { .. } time line _
| "PING :" `isPrefixOf` line = Reject
| "PING :" `isPrefixOf` line = ParseReject
| otherwise = case command of
"PONG" -> done $ toMessage $ PongMsg message
"JOIN" -> done $ toMessage $ JoinMsg user
@ -52,12 +42,13 @@ lineParser = MessageParser "line" go
else ModeMsg user target mode modeArgs
"NICK" -> done $ toMessage $ NickMsg user $ Nick (drop 1 target)
"433" -> done $ toMessage NickInUseMsg
"PRIVMSG" | target /= botChannel -> done $ toMessage $ PrivMsg user message
| isActionMsg -> done $ toMessage $ ActionMsg user (initDef . drop 8 $ message)
| otherwise -> done $ toMessage $ ChannelMsg user message
_ -> Reject
"PRIVMSG"
| target /= botChannel -> done $ toMessage $ PrivMsg user message
| isActionMsg -> done $ toMessage $ ActionMsg user (initDef . drop 8 $ message)
| otherwise -> done $ toMessage $ ChannelMsg user message
_ -> ParseReject
where
done = flip Done [] . Message time line
done = flip ParseDone [] . Message time line
(splits, command, source, target, message) = parseMsgLine line
quitMessage = strip . drop 1 . unwords . drop 2 $ splits
@ -72,9 +63,9 @@ defaultParser :: MessageParser
defaultParser = MessageParser "default" go
where
go _ time line _
| "PING :" `isPrefixOf` line = Reject
| "PING :" `isPrefixOf` line = ParseReject
| otherwise =
flip Done [] . Message time line $ toMessage $ OtherMsg source command target message
flip ParseDone [] . Message time line $ toMessage $ OtherMsg source command target message
where
(_, command, source, target, message) = parseMsgLine line
@ -82,15 +73,15 @@ namesParser :: MessageParser
namesParser = MessageParser "names" go
where
go BotConfig { .. } time line msgParts
| "PING :" `isPrefixOf` line = Reject
| "PING :" `isPrefixOf` line = ParseReject
| otherwise = case command of
"353" -> Partial $ MessagePart target time line : msgParts
"353" -> ParsePartial $ MessagePart target time line : msgParts
"366" -> let
(myMsgParts, otherMsgParts) = partition ((target ==) . msgPartTarget) msgParts
(nicks, allLines) = concat *** intercalate "\r\n" . (++ [line])
(nicks, allLines) = concat *** intercalate "\r\n" . (++ [line])
$ unzip $ map (\MessagePart { .. } -> (namesNicks msgPartLine, msgPartLine)) myMsgParts
in Done (Message time allLines . toMessage $ NamesMsg nicks) otherMsgParts
_ -> Reject
in ParseDone (Message time allLines . toMessage $ NamesMsg nicks) otherMsgParts
_ -> ParseReject
where
(_, command, _ , target, _) = parseMsgLine line
stripNickPrefix = pack . dropWhile (`elem` ("~&@%+" :: String)) . unpack
@ -101,14 +92,14 @@ whoisParser :: MessageParser
whoisParser = MessageParser "whois" go
where
go BotConfig { .. } time line msgParts
| "PING :" `isPrefixOf` line = Reject
| "PING :" `isPrefixOf` line = ParseReject
| command `elem` ["401", "311", "319", "312", "317"] =
Partial $ MessagePart target time line : msgParts
ParsePartial $ MessagePart target time line : msgParts
| command == "318" = let
(myMsgParts, otherMsgParts) = partition ((target ==) . msgPartTarget) msgParts
allLines = intercalate "\r\n" . reverse . (line :) . map msgPartLine $ myMsgParts
in Done (Message time allLines . toMessage $ parse myMsgParts) otherMsgParts
| otherwise = Reject
in ParseDone (Message time allLines . toMessage $ parse myMsgParts) otherMsgParts
| otherwise = ParseReject
where
(_, command, _, target, _) = parseMsgLine line
@ -125,15 +116,18 @@ whoisParser = MessageParser "whois" go
user = splits311 !! 4
host = splits311 !! 5
realName = drop 1 $ splits311 !! 7
channels = mconcat . maybeToList . map (words . drop 1 . unwords . drop 4 . words) . lookup "319" $ partMap
channels = mconcat
. maybeToList
. map (words . drop 1 . unwords . drop 4 . words)
. lookup "319"
$ partMap
splits312 = words . fromJust . lookup "312" $ partMap
server = splits312 !! 4
serverInfo = drop 1 $ splits312 !! 5
in WhoisReplyMsg nick user host realName channels server serverInfo
formatCommand :: CommandFormatter
formatCommand botConfig@BotConfig { .. } message =
msum . map (\formatter -> formatter botConfig message) $ defaultCommandFormatter : cmdFormatters
defaultParsers :: [MessageParser]
defaultParsers = [pingParser, namesParser, whoisParser, lineParser, defaultParser]
defaultCommandFormatter :: CommandFormatter
defaultCommandFormatter BotConfig { .. } Message { .. }

Loading…
Cancel
Save