Adds error handling for line parsing and command formatting.
parent
fdf641d187
commit
5f7983e1f8
|
|
@ -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
|
||||
(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 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
|
||||
"PRIVMSG"
|
||||
| target /= botChannel -> done $ toMessage $ PrivMsg user message
|
||||
| isActionMsg -> done $ toMessage $ ActionMsg user (initDef . drop 8 $ message)
|
||||
| otherwise -> done $ toMessage $ ChannelMsg user message
|
||||
_ -> Reject
|
||||
_ -> 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])
|
||||
$ 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…
Reference in New Issue