119 lines
5.5 KiB
Haskell
119 lines
5.5 KiB
Haskell
module Network.IRC.Protocol (parseLine, formatCommand) where
|
|
|
|
import ClassyPrelude
|
|
import Data.Foldable (msum)
|
|
import Data.List ((!!))
|
|
import Data.Text (strip)
|
|
|
|
import Network.IRC.Types
|
|
|
|
parseLine :: BotConfig -> UTCTime -> Text -> Map MessageParserId [MessagePart]
|
|
-> ([Message], Map MessageParserId [MessagePart])
|
|
parseLine botConfig@BotConfig { .. } time line msgParts =
|
|
mconcat . flip map parsers $ \MessageParser { .. } ->
|
|
let parserMsgParts = concat . maybeToList $ lookup msgParserId msgParts
|
|
in case msgParser botConfig time line parserMsgParts of
|
|
Reject -> ([], (singletonMap msgParserId parserMsgParts))
|
|
Partial msgParts' -> ([], (singletonMap msgParserId msgParts'))
|
|
Done message msgParts' -> ([message], (singletonMap msgParserId msgParts'))
|
|
where
|
|
parsers = [pingParser, namesParser, lineParser] ++ msgParsers ++ [defaultParser]
|
|
|
|
pingParser :: MessageParser
|
|
pingParser = MessageParser "ping" go
|
|
where
|
|
go _ time line _
|
|
| "PING :" `isPrefixOf` line = Done (Message time line . toMessage . PingMsg . drop 6 $ line) []
|
|
| otherwise = Reject
|
|
|
|
parseMsgLine :: Text -> ([Text], Text, Text, Text, Text)
|
|
parseMsgLine line = (splits, command, source, target, message)
|
|
where
|
|
splits = words line
|
|
command = splits !! 1
|
|
source = drop 1 $ splits !! 0
|
|
target = splits !! 2
|
|
message = strip . drop 1 . unwords . drop 3 $ splits
|
|
|
|
lineParser :: MessageParser
|
|
lineParser = MessageParser "line" go
|
|
where
|
|
go BotConfig { .. } time line _
|
|
| "PING :" `isPrefixOf` line = Reject
|
|
| 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
|
|
"PRIVMSG" | target /= botChannel -> done $ toMessage $ PrivMsg user message
|
|
| isActionMsg -> done $ toMessage $ ActionMsg user (initDef . drop 8 $ message)
|
|
| otherwise -> done $ toMessage $ ChannelMsg user message
|
|
_ -> Reject
|
|
where
|
|
done = flip Done [] . Message time line
|
|
|
|
(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
|
|
go _ time line _
|
|
| "PING :" `isPrefixOf` line = Reject
|
|
| otherwise =
|
|
flip Done [] . Message time line $ toMessage $ OtherMsg source command target message
|
|
where
|
|
(_, command, source, target, message) = parseMsgLine line
|
|
|
|
namesParser :: MessageParser
|
|
namesParser = MessageParser "names" go
|
|
where
|
|
go BotConfig { .. } time line msgParts
|
|
| "PING :" `isPrefixOf` line = Reject
|
|
| otherwise = case command of
|
|
"353" -> Partial $ MessagePart target time line : msgParts
|
|
"366" -> let
|
|
(myMsgParts, otherMsgParts) = partition ((target ==) . msgPartTarget) msgParts
|
|
(nicks, allLines) = concat *** intercalate "\r\n" . (++ [line])
|
|
$ unzip $ map (\MessagePart { .. } -> (namesNicks msgPartLine, msgPartLine)) myMsgParts
|
|
in Done (Message time allLines . toMessage $ NamesMsg nicks) otherMsgParts
|
|
_ -> Reject
|
|
where
|
|
(_ : command : target : _) = words line
|
|
stripNickPrefix = pack . dropWhile (`elem` ("~&@%+" :: String)) . unpack
|
|
namesNicks line' =
|
|
map (Nick . stripNickPrefix) . words . drop 1 . unwords . drop 5 . words $ line'
|
|
|
|
formatCommand :: CommandFormatter
|
|
formatCommand botConfig@BotConfig { .. } message =
|
|
msum . map (\formatter -> formatter botConfig message) $ defaultCommandFormatter : cmdFormatters
|
|
|
|
defaultCommandFormatter :: CommandFormatter
|
|
defaultCommandFormatter BotConfig { .. } Message { .. }
|
|
| 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 (ChannelMsgReply msg) <- fromMessage message =
|
|
Just $ "PRIVMSG " ++ botChannel ++ " :" ++ msg
|
|
| Just (PrivMsgReply (User { .. }) msg) <- fromMessage message =
|
|
Just $ "PRIVMSG " ++ nickToText userNick ++ " :" ++ msg
|
|
| otherwise = Nothing
|
|
where
|
|
botNick' = nickToText botNick
|