diff --git a/hask-irc-core/Network/IRC/Bot.hs b/hask-irc-core/Network/IRC/Bot.hs index eb9534b..67ccc8b 100644 --- a/hask-irc-core/Network/IRC/Bot.hs +++ b/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 diff --git a/hask-irc-core/Network/IRC/Internal/Types.hs b/hask-irc-core/Network/IRC/Internal/Types.hs index 2de9643..d8c3275 100644 --- a/hask-irc-core/Network/IRC/Internal/Types.hs +++ b/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 diff --git a/hask-irc-core/Network/IRC/Message/Types.hs b/hask-irc-core/Network/IRC/Message/Types.hs index 10a3ed6..f2a9430 100644 --- a/hask-irc-core/Network/IRC/Message/Types.hs +++ b/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 diff --git a/hask-irc-core/Network/IRC/MessageBus.hs b/hask-irc-core/Network/IRC/MessageBus.hs index afa641c..8c747cf 100644 --- a/hask-irc-core/Network/IRC/MessageBus.hs +++ b/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) diff --git a/hask-irc-core/Network/IRC/Protocol.hs b/hask-irc-core/Network/IRC/Protocol.hs index 031bd7b..1816979 100644 --- a/hask-irc-core/Network/IRC/Protocol.hs +++ b/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 { .. }