abhin4v/hask-irc
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Added support for parsing multipart messages

Browse Source
This commit is contained in:
Abhinav Sarkar 2014-05-25 05:30:49 +05:30
parent 816d14109a
commit 7c5ee230e4
4 changed files with 147 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

140
Network/IRC/Bot.hs
View File

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

2
Network/IRC/Client.hs
View File

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

6
Network/IRC/Handlers.hs
View File

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

83
Network/IRC/Protocol.hs
View File

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