Added support for parsing multipart messages

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
+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'
-      case mLine of
+          msgParts' <- case mLine of
             Left (e :: SomeException)     -> do
               errorM $ "Error while reading from connection: " ++ show e
-          writeChan lineChan EOF
+              writeChan lineChan EOF >> return msgParts
-        Right Nothing     -> writeChan lineChan Timeout
+            Right Nothing                 -> writeChan lineChan Timeout >> return msgParts
-        Right (Just line) -> writeChan lineChan line
+            Right (Just (Line time line)) -> do
-      readLineLoop mvBotStatus (lineChan, latch) bot timeoutDelay
+              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,10 +95,12 @@ readLineLoop mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do
               line <- map initEx $ hGetLine socket
               infoM . unpack $ "< " ++ line
               now <- getCurrentTime
-              return . Line $ msgFromLine botConfig now line
+              return $ Line now line
 
-messageProcessLoop :: Chan Line -> Chan Command -> Int -> IRC ()
+messageProcessLoop :: Chan Line -> Chan Command -> IRC ()
-messageProcessLoop lineChan commandChan !idleFor = do
+messageProcessLoop = messageProcessLoop' 0
+  where
+    messageProcessLoop' !idleFor lineChan commandChan = do
       status         <- get
       bot@Bot { .. } <- ask
       let nick       = botNick botConfig
@@ -100,7 +117,8 @@ messageProcessLoop lineChan commandChan !idleFor = do
               Timeout      ->
                 getCurrentTime >>= \t -> dispatchHandlers bot (Message t "" IdleMsg)  >> return Idle
               EOF          -> infoM "Connection closed" >> return Disconnected
-          Line (message@Message { .. }) -> do
+              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
@@ -115,10 +133,10 @@ messageProcessLoop lineChan commandChan !idleFor = do
 
       put nStatus
       case nStatus of
-    Idle             -> messageProcessLoop lineChan commandChan (idleFor + oneSec)
+        Idle             -> messageProcessLoop' (idleFor + oneSec) lineChan commandChan
         Disconnected     -> return ()
         NickNotAvailable -> return ()
-    _                -> messageProcessLoop lineChan commandChan 0
+        _                -> messageProcessLoop' 0 lineChan commandChan
 
       where
         dispatchHandlers Bot { .. } message =

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)

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 ->
+                         , NickTracker.mkMsgHandler ] $ \finalHandler handler ->
-    case handlers of
+    case finalHandler of
-      Just _  -> return handlers
+      Just _  -> return finalHandler
       Nothing -> handler botConfig eventChan name
 
 pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m (Maybe Command)

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
+data MessagePart = MessagePart { msgParserType :: MessageParseType
-msgFromLine (BotConfig { .. }) time line
+                               , msgPartTarget :: Text
-  | "PING :" `isPrefixOf` line = Message time line $ PingMsg (drop 6 line)
+                               , msgPartTime   :: UTCTime
-  | otherwise = case command of
+                               , 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           = (== ' ')
+    splits          = words line
-    isNotSpc        = not . isSpc
-    splits          = split isSpc line
-    source          = drop 1 . takeWhile isNotSpc $ line
-    target          = splits !! 2
     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