2015-06-21 18:18:59 +05:30
|
|
|
module Network.IRC.Protocol
|
|
|
|
( defaultParsers
|
|
|
|
, defaultCommandFormatter
|
|
|
|
) where
|
2014-05-04 02:57:43 +05:30
|
|
|
|
2014-05-10 21:45:16 +05:30
|
|
|
import ClassyPrelude
|
2015-06-21 18:18:59 +05:30
|
|
|
import Data.Maybe (fromJust)
|
|
|
|
import Data.List ((!!))
|
|
|
|
import Data.Text (strip)
|
2014-05-04 02:57:43 +05:30
|
|
|
|
|
|
|
import Network.IRC.Types
|
|
|
|
|
2014-05-25 14:51:33 +05:30
|
|
|
pingParser :: MessageParser
|
2014-06-08 04:26:50 +05:30
|
|
|
pingParser = MessageParser "ping" go
|
|
|
|
where
|
|
|
|
go _ time line _
|
2015-06-26 10:45:02 +05:30
|
|
|
| "PING :" `isPrefixOf` line =
|
|
|
|
flip ParseDone [] . Message time line . toMessage . PingMsg . drop 6 $ line
|
2015-06-21 18:18:59 +05:30
|
|
|
| otherwise = ParseReject
|
2014-05-25 05:30:49 +05:30
|
|
|
|
2014-06-08 04:26:50 +05:30
|
|
|
parseMsgLine :: Text -> ([Text], Text, Text, Text, Text)
|
|
|
|
parseMsgLine line = (splits, command, source, target, message)
|
2014-05-04 02:57:43 +05:30
|
|
|
where
|
2014-06-08 07:12:33 +05:30
|
|
|
splits = words line
|
|
|
|
command = splits !! 1
|
|
|
|
source = drop 1 $ splits !! 0
|
|
|
|
target = splits !! 2
|
|
|
|
message = strip . drop 1 . unwords . drop 3 $ splits
|
2014-05-20 00:05:06 +05:30
|
|
|
|
2014-06-08 04:26:50 +05:30
|
|
|
lineParser :: MessageParser
|
|
|
|
lineParser = MessageParser "line" go
|
|
|
|
where
|
2014-10-13 11:21:08 +05:30
|
|
|
go BotConfig { .. } time line _
|
2015-06-21 18:18:59 +05:30
|
|
|
| "PING :" `isPrefixOf` line = ParseReject
|
2014-10-13 11:21:08 +05:30
|
|
|
| otherwise = case command of
|
|
|
|
"PONG" -> done $ toMessage $ PongMsg message
|
|
|
|
"JOIN" -> done $ toMessage $ JoinMsg user
|
|
|
|
"QUIT" -> done $ toMessage $ QuitMsg user quitMessage
|
|
|
|
"PART" -> done $ toMessage $ PartMsg user message
|
|
|
|
"KICK" -> done $ toMessage $ KickMsg user (Nick kicked) kickReason
|
|
|
|
"MODE" -> done $ toMessage $ if Nick target == botNick
|
|
|
|
then ModeMsg Self target message []
|
|
|
|
else ModeMsg user target mode modeArgs
|
|
|
|
"NICK" -> done $ toMessage $ NickMsg user $ Nick (drop 1 target)
|
|
|
|
"433" -> done $ toMessage NickInUseMsg
|
2015-06-21 18:18:59 +05:30
|
|
|
"PRIVMSG"
|
|
|
|
| target /= botChannel -> done $ toMessage $ PrivMsg user message
|
|
|
|
| isActionMsg -> done $ toMessage $ ActionMsg user (initDef . drop 8 $ message)
|
|
|
|
| otherwise -> done $ toMessage $ ChannelMsg user message
|
|
|
|
_ -> ParseReject
|
2014-06-08 04:26:50 +05:30
|
|
|
where
|
2015-06-21 18:18:59 +05:30
|
|
|
done = flip ParseDone [] . Message time line
|
2014-06-08 04:26:50 +05:30
|
|
|
|
|
|
|
(splits, command, source, target, message) = parseMsgLine line
|
|
|
|
quitMessage = strip . drop 1 . unwords . drop 2 $ splits
|
|
|
|
user = uncurry User . (Nick *** drop 1) . break (== '!') $ source
|
|
|
|
mode = splits !! 3
|
|
|
|
modeArgs = drop 4 splits
|
|
|
|
kicked = splits !! 3
|
|
|
|
kickReason = drop 1 . unwords . drop 4 $ splits
|
|
|
|
isActionMsg = "\SOH" `isPrefixOf` message && "ACTION" `isPrefixOf` drop 1 message
|
|
|
|
|
|
|
|
defaultParser :: MessageParser
|
|
|
|
defaultParser = MessageParser "default" go
|
|
|
|
where
|
2014-10-13 11:21:08 +05:30
|
|
|
go _ time line _
|
2015-06-21 18:18:59 +05:30
|
|
|
| "PING :" `isPrefixOf` line = ParseReject
|
2014-10-13 11:21:08 +05:30
|
|
|
| otherwise =
|
2015-06-26 10:45:02 +05:30
|
|
|
flip ParseDone [] . Message time line . toMessage . OtherMsg source command target $ message
|
2014-06-08 04:26:50 +05:30
|
|
|
where
|
|
|
|
(_, command, source, target, message) = parseMsgLine line
|
2014-05-25 05:30:49 +05:30
|
|
|
|
|
|
|
namesParser :: MessageParser
|
2014-06-08 04:26:50 +05:30
|
|
|
namesParser = MessageParser "names" go
|
2014-05-25 05:30:49 +05:30
|
|
|
where
|
2014-10-13 11:21:08 +05:30
|
|
|
go BotConfig { .. } time line msgParts
|
2015-06-21 18:18:59 +05:30
|
|
|
| "PING :" `isPrefixOf` line = ParseReject
|
2014-10-13 11:21:08 +05:30
|
|
|
| otherwise = case command of
|
2015-06-21 18:18:59 +05:30
|
|
|
"353" -> ParsePartial $ MessagePart target time line : msgParts
|
2014-10-13 11:21:08 +05:30
|
|
|
"366" -> let
|
|
|
|
(myMsgParts, otherMsgParts) = partition ((target ==) . msgPartTarget) msgParts
|
2015-06-21 18:18:59 +05:30
|
|
|
(nicks, allLines) = concat *** intercalate "\r\n" . (++ [line])
|
2014-10-13 11:21:08 +05:30
|
|
|
$ unzip $ map (\MessagePart { .. } -> (namesNicks msgPartLine, msgPartLine)) myMsgParts
|
2015-06-21 18:18:59 +05:30
|
|
|
in ParseDone (Message time allLines . toMessage $ NamesMsg nicks) otherMsgParts
|
|
|
|
_ -> ParseReject
|
2014-06-08 04:26:50 +05:30
|
|
|
where
|
2015-06-21 15:14:32 +05:30
|
|
|
(_, command, _ , target, _) = parseMsgLine line
|
2014-06-08 04:26:50 +05:30
|
|
|
stripNickPrefix = pack . dropWhile (`elem` ("~&@%+" :: String)) . unpack
|
|
|
|
namesNicks line' =
|
|
|
|
map (Nick . stripNickPrefix) . words . drop 1 . unwords . drop 5 . words $ line'
|
2014-05-04 02:57:43 +05:30
|
|
|
|
2015-06-21 15:14:32 +05:30
|
|
|
whoisParser :: MessageParser
|
|
|
|
whoisParser = MessageParser "whois" go
|
|
|
|
where
|
|
|
|
go BotConfig { .. } time line msgParts
|
2015-06-21 18:18:59 +05:30
|
|
|
| "PING :" `isPrefixOf` line = ParseReject
|
2015-06-21 15:14:32 +05:30
|
|
|
| command `elem` ["401", "311", "319", "312", "317"] =
|
2015-06-21 18:18:59 +05:30
|
|
|
ParsePartial $ MessagePart target time line : msgParts
|
2015-06-21 15:14:32 +05:30
|
|
|
| command == "318" = let
|
|
|
|
(myMsgParts, otherMsgParts) = partition ((target ==) . msgPartTarget) msgParts
|
|
|
|
allLines = intercalate "\r\n" . reverse . (line :) . map msgPartLine $ myMsgParts
|
2015-06-21 18:18:59 +05:30
|
|
|
in ParseDone (Message time allLines . toMessage $ parse myMsgParts) otherMsgParts
|
|
|
|
| otherwise = ParseReject
|
2015-06-21 15:14:32 +05:30
|
|
|
where
|
|
|
|
(_, command, _, target, _) = parseMsgLine line
|
|
|
|
|
|
|
|
parse :: [MessagePart] -> WhoisReplyMsg
|
|
|
|
parse myMsgParts =
|
2015-06-26 10:45:02 +05:30
|
|
|
let partMap = asMap $ flip (`foldl'` mempty) myMsgParts $ \m MessagePart { .. } ->
|
|
|
|
insertMap (words msgPartLine !! 1) msgPartLine m
|
2015-06-21 15:14:32 +05:30
|
|
|
in case lookup "401" partMap of
|
2015-06-26 10:45:02 +05:30
|
|
|
Just line -> WhoisNoSuchNickMsg . Nick $ words line !! 3
|
2015-06-21 15:14:32 +05:30
|
|
|
Nothing -> let
|
|
|
|
splits311 = words . fromJust . lookup "311" $ partMap
|
|
|
|
nick = Nick (splits311 !! 3)
|
|
|
|
user = splits311 !! 4
|
|
|
|
host = splits311 !! 5
|
|
|
|
realName = drop 1 $ splits311 !! 7
|
2015-06-21 18:18:59 +05:30
|
|
|
channels = mconcat
|
|
|
|
. maybeToList
|
|
|
|
. map (words . drop 1 . unwords . drop 4 . words)
|
|
|
|
. lookup "319"
|
|
|
|
$ partMap
|
2015-06-21 15:14:32 +05:30
|
|
|
splits312 = words . fromJust . lookup "312" $ partMap
|
|
|
|
server = splits312 !! 4
|
2015-06-21 19:44:39 +05:30
|
|
|
serverInfo = drop 1 . unwords . drop 5 $ splits312
|
2015-06-26 10:45:02 +05:30
|
|
|
in WhoisNickInfoMsg nick user host realName channels server serverInfo
|
2015-06-21 15:14:32 +05:30
|
|
|
|
2015-06-21 18:18:59 +05:30
|
|
|
defaultParsers :: [MessageParser]
|
|
|
|
defaultParsers = [pingParser, namesParser, whoisParser, lineParser, defaultParser]
|
2014-06-08 05:33:03 +05:30
|
|
|
|
|
|
|
defaultCommandFormatter :: CommandFormatter
|
2014-10-04 21:22:24 +05:30
|
|
|
defaultCommandFormatter BotConfig { .. } Message { .. }
|
2015-06-21 15:14:32 +05:30
|
|
|
| Just (PongCmd msg) <- fromMessage message = Just $ "PONG :" ++ msg
|
|
|
|
| Just (PingCmd msg) <- fromMessage message = Just $ "PING :" ++ msg
|
|
|
|
| Just NickCmd <- fromMessage message = Just $ "NICK " ++ botNick'
|
|
|
|
| Just UserCmd <- fromMessage message = Just $ "USER " ++ botNick' ++ " 0 * :" ++ botNick'
|
|
|
|
| Just JoinCmd <- fromMessage message = Just $ "JOIN " ++ botChannel
|
|
|
|
| Just QuitCmd <- fromMessage message = Just "QUIT"
|
|
|
|
| Just NamesCmd <- fromMessage message = Just $ "NAMES " ++ botChannel
|
|
|
|
| Just (WhoisCmd nick) <- fromMessage message = Just $ "WHOIS " ++ nick
|
2014-10-05 13:12:49 +05:30
|
|
|
| Just (ChannelMsgReply msg) <- fromMessage message =
|
2014-10-04 21:22:24 +05:30
|
|
|
Just $ "PRIVMSG " ++ botChannel ++ " :" ++ msg
|
|
|
|
| Just (PrivMsgReply (User { .. }) msg) <- fromMessage message =
|
2014-06-08 04:26:50 +05:30
|
|
|
Just $ "PRIVMSG " ++ nickToText userNick ++ " :" ++ msg
|
2014-06-08 07:12:33 +05:30
|
|
|
| otherwise = Nothing
|
2014-06-01 23:14:19 +05:30
|
|
|
where
|
|
|
|
botNick' = nickToText botNick
|