From 7c5ee230e42ba6e835f2b8f9be782444fd9120d0 Mon Sep 17 00:00:00 2001 From: Abhinav Sarkar Date: Sun, 25 May 2014 05:30:49 +0530 Subject: [PATCH] Added support for parsing multipart messages --- Network/IRC/Bot.hs | 140 +++++++++++++++++++++++----------------- Network/IRC/Client.hs | 2 +- Network/IRC/Handlers.hs | 6 +- Network/IRC/Protocol.hs | 83 ++++++++++++++++++------ 4 files changed, 147 insertions(+), 84 deletions(-) diff --git a/Network/IRC/Bot.hs b/Network/IRC/Bot.hs index f8a13fa..f92839e 100644 --- a/Network/IRC/Bot.hs +++ b/Network/IRC/Bot.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} module Network.IRC.Bot - ( Line (..) + ( Line , sendCommand , sendMessage , sendEvent @@ -20,6 +20,7 @@ import Control.Concurrent.Lifted (fork, Chan, readChan, writeChan, threadDelay) import Control.Exception.Lifted (mask_) import Control.Monad.Reader (ask) import Control.Monad.State (get, put) +import Data.Time (addUTCTime) import System.IO (hIsEOF) import System.Timeout (timeout) import System.Log.Logger.TH (deriveLoggers) @@ -30,13 +31,13 @@ import Network.IRC.Util $(deriveLoggers "HSL" [HSL.DEBUG, HSL.INFO, HSL.ERROR]) -data Line = Timeout | EOF | Line !Message deriving (Show, Eq) +data Line = Timeout | EOF | Line !UTCTime !Text | Msg Message deriving (Show, Eq) sendCommand :: Chan Command -> Command -> IO () sendCommand = writeChan sendMessage :: Chan Line -> Message -> IO () -sendMessage = (. Line) . writeChan +sendMessage = (. Msg) . writeChan sendEvent :: Chan SomeEvent -> SomeEvent -> IO () sendEvent = writeChan @@ -58,19 +59,33 @@ sendCommandLoop (commandChan, latch) bot@Bot { .. } = do _ -> sendCommandLoop (commandChan, latch) bot readLineLoop :: MVar BotStatus -> Channel Line -> Bot -> Int -> IO () -readLineLoop mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do - botStatus <- readMVar mvBotStatus - case botStatus of - Disconnected -> latchIt latch - _ -> do - mLine <- try $ timeout timeoutDelay readLine' - case mLine of - Left (e :: SomeException) -> do - errorM $ "Error while reading from connection: " ++ show e - writeChan lineChan EOF - Right Nothing -> writeChan lineChan Timeout - Right (Just line) -> writeChan lineChan line - readLineLoop mvBotStatus (lineChan, latch) bot timeoutDelay +readLineLoop = readLineLoop' [] + where + msgPartTimeout = 10 + + readLineLoop' !msgParts mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do + botStatus <- readMVar mvBotStatus + case botStatus of + Disconnected -> latchIt latch + _ -> do + mLine <- try $ timeout timeoutDelay readLine' + msgParts' <- case mLine of + Left (e :: SomeException) -> do + errorM $ "Error while reading from connection: " ++ show e + writeChan lineChan EOF >> return msgParts + Right Nothing -> writeChan lineChan Timeout >> return msgParts + Right (Just (Line time line)) -> do + let (mmsg, msgParts') = parseLine botConfig time line msgParts + case mmsg of + Nothing -> return msgParts' + Just msg -> writeChan lineChan (Msg msg) >> return msgParts' + Right (Just l) -> writeChan lineChan l >> return msgParts + + limit <- map (addUTCTime (- msgPartTimeout)) getCurrentTime + let msgParts'' = concat + . filter ((> limit) . msgPartTime . headEx . sortBy (flip $ comparing msgPartTime)) + . groupAllOn (msgParserType &&& msgPartTarget) $ msgParts' + readLineLoop' msgParts'' mvBotStatus (lineChan, latch) bot timeoutDelay where readLine' = do eof <- hIsEOF socket @@ -80,53 +95,56 @@ readLineLoop mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do line <- map initEx $ hGetLine socket infoM . unpack $ "< " ++ line now <- getCurrentTime - return . Line $ msgFromLine botConfig now line - -messageProcessLoop :: Chan Line -> Chan Command -> Int -> IRC () -messageProcessLoop lineChan commandChan !idleFor = do - status <- get - bot@Bot { .. } <- ask - let nick = botNick botConfig - - nStatus <- io . mask_ $ - if idleFor >= (oneSec * botTimeout botConfig) - then infoM "Timeout" >> return Disconnected - else do - when (status == Kicked) $ - threadDelay (5 * oneSec) >> sendCommand commandChan JoinCmd - - mLine <- readLine lineChan - case mLine of - Timeout -> - getCurrentTime >>= \t -> dispatchHandlers bot (Message t "" IdleMsg) >> return Idle - EOF -> infoM "Connection closed" >> return Disconnected - Line (message@Message { .. }) -> do - nStatus <- case msgDetails of - JoinMsg { .. } | userNick user == nick -> infoM "Joined" >> return Joined - KickMsg { .. } | kickedNick == nick -> infoM "Kicked" >> return Kicked - NickInUseMsg { .. } -> - infoM "Nick already in use" >> return NickNotAvailable - ModeMsg { user = Self, .. } -> - sendCommand commandChan JoinCmd >> return Connected - _ -> return Connected - - dispatchHandlers bot message - return nStatus - - put nStatus - case nStatus of - Idle -> messageProcessLoop lineChan commandChan (idleFor + oneSec) - Disconnected -> return () - NickNotAvailable -> return () - _ -> messageProcessLoop lineChan commandChan 0 + return $ Line now line +messageProcessLoop :: Chan Line -> Chan Command -> IRC () +messageProcessLoop = messageProcessLoop' 0 where - dispatchHandlers Bot { .. } message = - forM_ (mapValues msgHandlers) $ \msgHandler -> void . fork $ - handle (\(e :: SomeException) -> - errorM $ "Exception while processing message: " ++ show e) $ do - mCmd <- handleMessage msgHandler botConfig message - whenJust mCmd (sendCommand commandChan) + messageProcessLoop' !idleFor lineChan commandChan = do + status <- get + bot@Bot { .. } <- ask + let nick = botNick botConfig + + nStatus <- io . mask_ $ + if idleFor >= (oneSec * botTimeout botConfig) + then infoM "Timeout" >> return Disconnected + else do + when (status == Kicked) $ + threadDelay (5 * oneSec) >> sendCommand commandChan JoinCmd + + mLine <- readLine lineChan + case mLine of + Timeout -> + getCurrentTime >>= \t -> dispatchHandlers bot (Message t "" IdleMsg) >> return Idle + EOF -> infoM "Connection closed" >> return Disconnected + Line _ _ -> error "This should never happen" + Msg (message@Message { .. }) -> do + nStatus <- case msgDetails of + JoinMsg { .. } | userNick user == nick -> infoM "Joined" >> return Joined + KickMsg { .. } | kickedNick == nick -> infoM "Kicked" >> return Kicked + NickInUseMsg { .. } -> + infoM "Nick already in use" >> return NickNotAvailable + ModeMsg { user = Self, .. } -> + sendCommand commandChan JoinCmd >> return Connected + _ -> return Connected + + dispatchHandlers bot message + return nStatus + + put nStatus + case nStatus of + Idle -> messageProcessLoop' (idleFor + oneSec) lineChan commandChan + Disconnected -> return () + NickNotAvailable -> return () + _ -> messageProcessLoop' 0 lineChan commandChan + + where + dispatchHandlers Bot { .. } message = + forM_ (mapValues msgHandlers) $ \msgHandler -> void . fork $ + handle (\(e :: SomeException) -> + errorM $ "Exception while processing message: " ++ show e) $ do + mCmd <- handleMessage msgHandler botConfig message + whenJust mCmd (sendCommand commandChan) eventProcessLoop :: Channel SomeEvent -> Chan Line -> Chan Command -> Bot -> IO () eventProcessLoop (eventChan, latch) lineChan commandChan bot@Bot {.. } = do diff --git a/Network/IRC/Client.hs b/Network/IRC/Client.hs index e5d446a..a652398 100644 --- a/Network/IRC/Client.hs +++ b/Network/IRC/Client.hs @@ -104,4 +104,4 @@ runBot botConfig' = withSocketsDo $ do fork $ sendCommandLoop (commandChan, sendLatch) bot fork $ readLineLoop mvBotStatus (lineChan, readLatch) bot oneSec fork $ eventProcessLoop eventChannel lineChan commandChan bot - runIRC bot Connected (messageProcessLoop lineChan commandChan 0) + runIRC bot Connected (messageProcessLoop lineChan commandChan) diff --git a/Network/IRC/Handlers.hs b/Network/IRC/Handlers.hs index a1fe922..982e1ac 100644 --- a/Network/IRC/Handlers.hs +++ b/Network/IRC/Handlers.hs @@ -35,9 +35,9 @@ mkMsgHandler botConfig eventChan name = flip (`foldM` Nothing) [ Logger.mkMsgHandler , SongSearch.mkMsgHandler , Auth.mkMsgHandler - , NickTracker.mkMsgHandler ] $ \handlers handler -> - case handlers of - Just _ -> return handlers + , NickTracker.mkMsgHandler ] $ \finalHandler handler -> + case finalHandler of + Just _ -> return finalHandler Nothing -> handler botConfig eventChan name pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m (Maybe Command) diff --git a/Network/IRC/Protocol.hs b/Network/IRC/Protocol.hs index 8c087bb..6109db2 100644 --- a/Network/IRC/Protocol.hs +++ b/Network/IRC/Protocol.hs @@ -1,17 +1,51 @@ -module Network.IRC.Protocol (MessageParser, msgFromLine, lineFromCommand) where +module Network.IRC.Protocol + ( MessagePart (..) + , parseLine + , lineFromCommand) where import ClassyPrelude import Data.List ((!!)) -import Data.Text (split, strip) +import Data.Text (strip) import Network.IRC.Types -type MessageParser = BotConfig -> UTCTime -> Text -> Message +data MessageParseType = Names + | Whois + deriving (Show, Eq) -msgFromLine :: MessageParser -msgFromLine (BotConfig { .. }) time line - | "PING :" `isPrefixOf` line = Message time line $ PingMsg (drop 6 line) - | otherwise = case command of +data MessagePart = MessagePart { msgParserType :: MessageParseType + , msgPartTarget :: Text + , msgPartTime :: UTCTime + , msgPartLine :: Text } + deriving (Show, Eq) + +data MessageParseResult = Done Message [MessagePart] + | Partial [MessagePart] + | Reject + deriving (Show, Eq) + +type MessageParser = BotConfig -> UTCTime -> Text -> [MessagePart] -> MessageParseResult + +parseLine :: BotConfig -> UTCTime -> Text -> [MessagePart] -> (Maybe Message, [MessagePart]) +parseLine botConfig time line msgParts = + case lineParser botConfig time line msgParts of + Done message@(Message { msgDetails = OtherMsg { .. }, .. }) _ -> + fromMaybe (Just message, msgParts) . flip (`foldl'` Nothing) parsers $ \parseResult parser -> + case parseResult of + Just _ -> parseResult + Nothing -> case parser botConfig time line msgParts of + Reject -> Nothing + Partial msgParts' -> Just (Nothing, msgParts') + Done message' msgParts' -> Just (Just message', msgParts') + Done message _ -> (Just message, msgParts) + _ -> error "This should never happen" + where + parsers = [namesParser] + +lineParser :: MessageParser +lineParser BotConfig { .. } time line msgParts + | "PING :" `isPrefixOf` line = flip Done msgParts $ Message time line $ PingMsg (drop 6 line) + | otherwise = flip Done msgParts $ case command of "PONG" -> Message time line $ PongMsg message "JOIN" -> Message time line $ JoinMsg user "QUIT" -> Message time line $ QuitMsg user quitMessage @@ -21,33 +55,44 @@ msgFromLine (BotConfig { .. }) time line then Message time line $ ModeMsg Self target message [] else Message time line $ ModeMsg user target mode modeArgs "NICK" -> Message time line $ NickMsg user (drop 1 target) - "353" -> Message time line $ NamesMsg namesNicks "433" -> Message time line NickInUseMsg "PRIVMSG" | target /= channel -> Message time line $ PrivMsg user message | isActionMsg -> Message time line $ ActionMsg user (initDef . drop 8 $ message) | otherwise -> Message time line $ ChannelMsg user message _ -> Message time line $ OtherMsg source command target message where - isSpc = (== ' ') - isNotSpc = not . isSpc - splits = split isSpc line - source = drop 1 . takeWhile isNotSpc $ line - target = splits !! 2 + splits = words line command = splits !! 1 + source = drop 1 $ splits !! 0 + target = splits !! 2 message = strip . drop 1 . unwords . drop 3 $ splits quitMessage = strip . drop 1 . unwords . drop 2 $ splits - user = uncurry User . break (== '!') $ source + user = uncurry User . second (drop 1) . break (== '!') $ source mode = splits !! 3 modeArgs = drop 4 splits kicked = splits !! 3 kickReason = drop 1 . unwords . drop 4 $ splits - - nickPrefixes = "~&@%+" :: String - namesNicks = map stripNickPrefix . words . drop 1 . unwords . drop 5 $ splits - stripNickPrefix = pack . dropWhile (`elem` nickPrefixes) . unpack - isActionMsg = "\SOH" `isPrefixOf` message && "ACTION" `isPrefixOf` drop 1 message +partitionMsgParts :: MessageParseType -> Text -> [MessagePart] -> ([MessagePart], [MessagePart]) +partitionMsgParts parserType target = + partition (\MessagePart { .. } -> msgParserType == parserType && msgPartTarget == target) + +namesParser :: MessageParser +namesParser BotConfig { .. } time line msgParts = case command of + "353" -> Partial $ MessagePart Names target time line : msgParts + "366" -> let + (myMsgParts, otherMsgParts) = partitionMsgParts Names target msgParts + (nicks, allLines) = concat *** intercalate "\r\n" . (++ [line]) + $ unzip $ map (\MessagePart { .. } -> (namesNicks msgPartLine, msgPartLine)) myMsgParts + in Done (Message time allLines $ NamesMsg nicks) otherMsgParts + _ -> Reject + where + (_ : command : target : _) = words line + stripNickPrefix = pack . dropWhile (`elem` ("~&@%+" :: String)) . unpack + namesNicks line' = map stripNickPrefix . words . drop 1 . unwords . drop 5 . words $ line' + + lineFromCommand :: BotConfig -> Command -> Maybe Text lineFromCommand BotConfig { .. } command = case command of PongCmd { .. } -> Just $ "PONG :" ++ rmsg