Adds error handling for line parsing and command formatting.

hask-irc-core/Network/IRC/Bot.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
 

hask-irc-core/Network/IRC/Internal/Types.hs

@@ -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

hask-irc-core/Network/IRC/Message/Types.hs

@@ -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
 
 

hask-irc-core/Network/IRC/MessageBus.hs

@@ -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)

hask-irc-core/Network/IRC/Protocol.hs

@@ -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 { .. }