Added support for parsing multipart messages
This commit is contained in:
parent
816d14109a
commit
7c5ee230e4
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
|
||||||
module Network.IRC.Bot
|
module Network.IRC.Bot
|
||||||
( Line (..)
|
( Line
|
||||||
, sendCommand
|
, sendCommand
|
||||||
, sendMessage
|
, sendMessage
|
||||||
, sendEvent
|
, sendEvent
|
||||||
|
@ -20,6 +20,7 @@ import Control.Concurrent.Lifted (fork, Chan, readChan, writeChan, threadDelay)
|
||||||
import Control.Exception.Lifted (mask_)
|
import Control.Exception.Lifted (mask_)
|
||||||
import Control.Monad.Reader (ask)
|
import Control.Monad.Reader (ask)
|
||||||
import Control.Monad.State (get, put)
|
import Control.Monad.State (get, put)
|
||||||
|
import Data.Time (addUTCTime)
|
||||||
import System.IO (hIsEOF)
|
import System.IO (hIsEOF)
|
||||||
import System.Timeout (timeout)
|
import System.Timeout (timeout)
|
||||||
import System.Log.Logger.TH (deriveLoggers)
|
import System.Log.Logger.TH (deriveLoggers)
|
||||||
|
@ -30,13 +31,13 @@ import Network.IRC.Util
|
||||||
|
|
||||||
$(deriveLoggers "HSL" [HSL.DEBUG, HSL.INFO, HSL.ERROR])
|
$(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 :: Chan Command -> Command -> IO ()
|
||||||
sendCommand = writeChan
|
sendCommand = writeChan
|
||||||
|
|
||||||
sendMessage :: Chan Line -> Message -> IO ()
|
sendMessage :: Chan Line -> Message -> IO ()
|
||||||
sendMessage = (. Line) . writeChan
|
sendMessage = (. Msg) . writeChan
|
||||||
|
|
||||||
sendEvent :: Chan SomeEvent -> SomeEvent -> IO ()
|
sendEvent :: Chan SomeEvent -> SomeEvent -> IO ()
|
||||||
sendEvent = writeChan
|
sendEvent = writeChan
|
||||||
|
@ -58,19 +59,33 @@ sendCommandLoop (commandChan, latch) bot@Bot { .. } = do
|
||||||
_ -> sendCommandLoop (commandChan, latch) bot
|
_ -> sendCommandLoop (commandChan, latch) bot
|
||||||
|
|
||||||
readLineLoop :: MVar BotStatus -> Channel Line -> Bot -> Int -> IO ()
|
readLineLoop :: MVar BotStatus -> Channel Line -> Bot -> Int -> IO ()
|
||||||
readLineLoop mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do
|
readLineLoop = readLineLoop' []
|
||||||
botStatus <- readMVar mvBotStatus
|
where
|
||||||
case botStatus of
|
msgPartTimeout = 10
|
||||||
Disconnected -> latchIt latch
|
|
||||||
_ -> do
|
readLineLoop' !msgParts mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do
|
||||||
mLine <- try $ timeout timeoutDelay readLine'
|
botStatus <- readMVar mvBotStatus
|
||||||
case mLine of
|
case botStatus of
|
||||||
Left (e :: SomeException) -> do
|
Disconnected -> latchIt latch
|
||||||
errorM $ "Error while reading from connection: " ++ show e
|
_ -> do
|
||||||
writeChan lineChan EOF
|
mLine <- try $ timeout timeoutDelay readLine'
|
||||||
Right Nothing -> writeChan lineChan Timeout
|
msgParts' <- case mLine of
|
||||||
Right (Just line) -> writeChan lineChan line
|
Left (e :: SomeException) -> do
|
||||||
readLineLoop mvBotStatus (lineChan, latch) bot timeoutDelay
|
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
|
where
|
||||||
readLine' = do
|
readLine' = do
|
||||||
eof <- hIsEOF socket
|
eof <- hIsEOF socket
|
||||||
|
@ -80,53 +95,56 @@ readLineLoop mvBotStatus (lineChan, latch) bot@Bot { .. } timeoutDelay = do
|
||||||
line <- map initEx $ hGetLine socket
|
line <- map initEx $ hGetLine socket
|
||||||
infoM . unpack $ "< " ++ line
|
infoM . unpack $ "< " ++ line
|
||||||
now <- getCurrentTime
|
now <- getCurrentTime
|
||||||
return . Line $ msgFromLine botConfig now line
|
return $ Line 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
|
|
||||||
|
|
||||||
|
messageProcessLoop :: Chan Line -> Chan Command -> IRC ()
|
||||||
|
messageProcessLoop = messageProcessLoop' 0
|
||||||
where
|
where
|
||||||
dispatchHandlers Bot { .. } message =
|
messageProcessLoop' !idleFor lineChan commandChan = do
|
||||||
forM_ (mapValues msgHandlers) $ \msgHandler -> void . fork $
|
status <- get
|
||||||
handle (\(e :: SomeException) ->
|
bot@Bot { .. } <- ask
|
||||||
errorM $ "Exception while processing message: " ++ show e) $ do
|
let nick = botNick botConfig
|
||||||
mCmd <- handleMessage msgHandler botConfig message
|
|
||||||
whenJust mCmd (sendCommand commandChan)
|
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 :: Channel SomeEvent -> Chan Line -> Chan Command -> Bot -> IO ()
|
||||||
eventProcessLoop (eventChan, latch) lineChan commandChan bot@Bot {.. } = do
|
eventProcessLoop (eventChan, latch) lineChan commandChan bot@Bot {.. } = do
|
||||||
|
|
|
@ -104,4 +104,4 @@ runBot botConfig' = withSocketsDo $ do
|
||||||
fork $ sendCommandLoop (commandChan, sendLatch) bot
|
fork $ sendCommandLoop (commandChan, sendLatch) bot
|
||||||
fork $ readLineLoop mvBotStatus (lineChan, readLatch) bot oneSec
|
fork $ readLineLoop mvBotStatus (lineChan, readLatch) bot oneSec
|
||||||
fork $ eventProcessLoop eventChannel lineChan commandChan bot
|
fork $ eventProcessLoop eventChannel lineChan commandChan bot
|
||||||
runIRC bot Connected (messageProcessLoop lineChan commandChan 0)
|
runIRC bot Connected (messageProcessLoop lineChan commandChan)
|
||||||
|
|
|
@ -35,9 +35,9 @@ mkMsgHandler botConfig eventChan name =
|
||||||
flip (`foldM` Nothing) [ Logger.mkMsgHandler
|
flip (`foldM` Nothing) [ Logger.mkMsgHandler
|
||||||
, SongSearch.mkMsgHandler
|
, SongSearch.mkMsgHandler
|
||||||
, Auth.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
|
Nothing -> handler botConfig eventChan name
|
||||||
|
|
||||||
pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m (Maybe Command)
|
pingPong :: MonadMsgHandler m => IORef UTCTime -> Message -> m (Maybe Command)
|
||||||
|
|
|
@ -1,17 +1,51 @@
|
||||||
module Network.IRC.Protocol (MessageParser, msgFromLine, lineFromCommand) where
|
module Network.IRC.Protocol
|
||||||
|
( MessagePart (..)
|
||||||
|
, parseLine
|
||||||
|
, lineFromCommand) where
|
||||||
|
|
||||||
import ClassyPrelude
|
import ClassyPrelude
|
||||||
import Data.List ((!!))
|
import Data.List ((!!))
|
||||||
import Data.Text (split, strip)
|
import Data.Text (strip)
|
||||||
|
|
||||||
import Network.IRC.Types
|
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
|
"PONG" -> Message time line $ PongMsg message
|
||||||
"JOIN" -> Message time line $ JoinMsg user
|
"JOIN" -> Message time line $ JoinMsg user
|
||||||
"QUIT" -> Message time line $ QuitMsg user quitMessage
|
"QUIT" -> Message time line $ QuitMsg user quitMessage
|
||||||
|
@ -21,33 +55,44 @@ msgFromLine (BotConfig { .. }) time line
|
||||||
then Message time line $ ModeMsg Self target message []
|
then Message time line $ ModeMsg Self target message []
|
||||||
else Message time line $ ModeMsg user target mode modeArgs
|
else Message time line $ ModeMsg user target mode modeArgs
|
||||||
"NICK" -> Message time line $ NickMsg user (drop 1 target)
|
"NICK" -> Message time line $ NickMsg user (drop 1 target)
|
||||||
"353" -> Message time line $ NamesMsg namesNicks
|
|
||||||
"433" -> Message time line NickInUseMsg
|
"433" -> Message time line NickInUseMsg
|
||||||
"PRIVMSG" | target /= channel -> Message time line $ PrivMsg user message
|
"PRIVMSG" | target /= channel -> Message time line $ PrivMsg user message
|
||||||
| isActionMsg -> Message time line $ ActionMsg user (initDef . drop 8 $ message)
|
| isActionMsg -> Message time line $ ActionMsg user (initDef . drop 8 $ message)
|
||||||
| otherwise -> Message time line $ ChannelMsg user message
|
| otherwise -> Message time line $ ChannelMsg user message
|
||||||
_ -> Message time line $ OtherMsg source command target message
|
_ -> Message time line $ OtherMsg source command target message
|
||||||
where
|
where
|
||||||
isSpc = (== ' ')
|
splits = words line
|
||||||
isNotSpc = not . isSpc
|
|
||||||
splits = split isSpc line
|
|
||||||
source = drop 1 . takeWhile isNotSpc $ line
|
|
||||||
target = splits !! 2
|
|
||||||
command = splits !! 1
|
command = splits !! 1
|
||||||
|
source = drop 1 $ splits !! 0
|
||||||
|
target = splits !! 2
|
||||||
message = strip . drop 1 . unwords . drop 3 $ splits
|
message = strip . drop 1 . unwords . drop 3 $ splits
|
||||||
quitMessage = strip . drop 1 . unwords . drop 2 $ 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
|
mode = splits !! 3
|
||||||
modeArgs = drop 4 splits
|
modeArgs = drop 4 splits
|
||||||
kicked = splits !! 3
|
kicked = splits !! 3
|
||||||
kickReason = drop 1 . unwords . drop 4 $ splits
|
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
|
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 -> Maybe Text
|
||||||
lineFromCommand BotConfig { .. } command = case command of
|
lineFromCommand BotConfig { .. } command = case command of
|
||||||
PongCmd { .. } -> Just $ "PONG :" ++ rmsg
|
PongCmd { .. } -> Just $ "PONG :" ++ rmsg
|
||||||
|
|
Loading…
Reference in New Issue