A simple IRC bot written in Haskell
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

Protocol.hs 6.7KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148
  1. module Network.IRC.Protocol
  2. ( defaultParsers
  3. , defaultCommandFormatter
  4. ) where
  5. import ClassyPrelude
  6. import Data.Maybe (fromJust)
  7. import Data.List ((!!))
  8. import Data.Text (strip)
  9. import Network.IRC.Types
  10. pingParser :: MessageParser
  11. pingParser = MessageParser "ping" go
  12. where
  13. go _ time line _
  14. | "PING :" `isPrefixOf` line =
  15. flip ParseDone [] . Message time line . toMessage . PingMsg . drop 6 $ line
  16. | otherwise = ParseReject
  17. parseMsgLine :: Text -> ([Text], Text, Text, Text, Text)
  18. parseMsgLine line = (splits, command, source, target, message)
  19. where
  20. splits = words line
  21. command = splits !! 1
  22. source = drop 1 $ splits !! 0
  23. target = splits !! 2
  24. message = strip . drop 1 . unwords . drop 3 $ splits
  25. lineParser :: MessageParser
  26. lineParser = MessageParser "line" go
  27. where
  28. go BotConfig { .. } time line _
  29. | "PING :" `isPrefixOf` line = ParseReject
  30. | otherwise = case command of
  31. "PONG" -> done $ toMessage $ PongMsg message
  32. "JOIN" -> done $ toMessage $ JoinMsg user
  33. "QUIT" -> done $ toMessage $ QuitMsg user quitMessage
  34. "PART" -> done $ toMessage $ PartMsg user message
  35. "KICK" -> done $ toMessage $ KickMsg user (Nick kicked) kickReason
  36. "MODE" -> done $ toMessage $ if Nick target == botNick
  37. then ModeMsg Self target message []
  38. else ModeMsg user target mode modeArgs
  39. "NICK" -> done $ toMessage $ NickMsg user $ Nick (drop 1 target)
  40. "433" -> done $ toMessage NickInUseMsg
  41. "PRIVMSG"
  42. | target /= botChannel -> done $ toMessage $ PrivMsg user message
  43. | isActionMsg -> done $ toMessage $ ActionMsg user (initDef . drop 8 $ message)
  44. | otherwise -> done $ toMessage $ ChannelMsg user message
  45. _ -> ParseReject
  46. where
  47. done = flip ParseDone [] . Message time line
  48. (splits, command, source, target, message) = parseMsgLine line
  49. quitMessage = strip . drop 1 . unwords . drop 2 $ splits
  50. user = uncurry User . (Nick *** drop 1) . break (== '!') $ source
  51. mode = splits !! 3
  52. modeArgs = drop 4 splits
  53. kicked = splits !! 3
  54. kickReason = drop 1 . unwords . drop 4 $ splits
  55. isActionMsg = "\SOH" `isPrefixOf` message && "ACTION" `isPrefixOf` drop 1 message
  56. defaultParser :: MessageParser
  57. defaultParser = MessageParser "default" go
  58. where
  59. go _ time line _
  60. | "PING :" `isPrefixOf` line = ParseReject
  61. | otherwise =
  62. flip ParseDone [] . Message time line . toMessage . OtherMsg source command target $ message
  63. where
  64. (_, command, source, target, message) = parseMsgLine line
  65. namesParser :: MessageParser
  66. namesParser = MessageParser "names" go
  67. where
  68. go BotConfig { .. } time line msgParts
  69. | "PING :" `isPrefixOf` line = ParseReject
  70. | otherwise = case command of
  71. "353" -> ParsePartial $ MessagePart target time line : msgParts
  72. "366" -> let
  73. (myMsgParts, otherMsgParts) = partition ((target ==) . msgPartTarget) msgParts
  74. (nicks, allLines) = concat *** intercalate "\r\n" . (++ [line])
  75. $ unzip $ map (\MessagePart { .. } -> (namesNicks msgPartLine, msgPartLine)) myMsgParts
  76. in ParseDone (Message time allLines . toMessage $ NamesMsg nicks) otherMsgParts
  77. _ -> ParseReject
  78. where
  79. (_, command, _ , target, _) = parseMsgLine line
  80. stripNickPrefix = pack . dropWhile (`elem` ("~&@%+" :: String)) . unpack
  81. namesNicks line' =
  82. map (Nick . stripNickPrefix) . words . drop 1 . unwords . drop 5 . words $ line'
  83. whoisParser :: MessageParser
  84. whoisParser = MessageParser "whois" go
  85. where
  86. go BotConfig { .. } time line msgParts
  87. | "PING :" `isPrefixOf` line = ParseReject
  88. | command `elem` ["401", "311", "319", "312", "317"] =
  89. ParsePartial $ MessagePart target time line : msgParts
  90. | command == "318" = let
  91. (myMsgParts, otherMsgParts) = partition ((target ==) . msgPartTarget) msgParts
  92. allLines = intercalate "\r\n" . reverse . (line :) . map msgPartLine $ myMsgParts
  93. in ParseDone (Message time allLines . toMessage $ parse myMsgParts) otherMsgParts
  94. | otherwise = ParseReject
  95. where
  96. (_, command, _, target, _) = parseMsgLine line
  97. parse :: [MessagePart] -> WhoisReplyMsg
  98. parse myMsgParts =
  99. let partMap = asMap $ flip (`foldl'` mempty) myMsgParts $ \m MessagePart { .. } ->
  100. insertMap (words msgPartLine !! 1) msgPartLine m
  101. in case lookup "401" partMap of
  102. Just line -> WhoisNoSuchNickMsg . Nick $ words line !! 3
  103. Nothing -> let
  104. splits311 = words . fromJust . lookup "311" $ partMap
  105. nick = Nick (splits311 !! 3)
  106. user = splits311 !! 4
  107. host = splits311 !! 5
  108. realName = drop 1 $ splits311 !! 7
  109. channels = mconcat
  110. . maybeToList
  111. . map (words . drop 1 . unwords . drop 4 . words)
  112. . lookup "319"
  113. $ partMap
  114. splits312 = words . fromJust . lookup "312" $ partMap
  115. server = splits312 !! 4
  116. serverInfo = drop 1 . unwords . drop 5 $ splits312
  117. in WhoisNickInfoMsg nick user host realName channels server serverInfo
  118. defaultParsers :: [MessageParser]
  119. defaultParsers = [pingParser, namesParser, whoisParser, lineParser, defaultParser]
  120. defaultCommandFormatter :: CommandFormatter
  121. defaultCommandFormatter BotConfig { .. } Message { .. }
  122. | Just (PongCmd msg) <- fromMessage message = Just $ "PONG :" ++ msg
  123. | Just (PingCmd msg) <- fromMessage message = Just $ "PING :" ++ msg
  124. | Just NickCmd <- fromMessage message = Just $ "NICK " ++ botNick'
  125. | Just UserCmd <- fromMessage message = Just $ "USER " ++ botNick' ++ " 0 * :" ++ botNick'
  126. | Just JoinCmd <- fromMessage message = Just $ "JOIN " ++ botChannel
  127. | Just QuitCmd <- fromMessage message = Just "QUIT"
  128. | Just NamesCmd <- fromMessage message = Just $ "NAMES " ++ botChannel
  129. | Just (WhoisCmd nick) <- fromMessage message = Just $ "WHOIS " ++ nick
  130. | Just (ChannelMsgReply msg) <- fromMessage message =
  131. Just $ "PRIVMSG " ++ botChannel ++ " :" ++ msg
  132. | Just (PrivMsgReply (User { .. }) msg) <- fromMessage message =
  133. Just $ "PRIVMSG " ++ nickToText userNick ++ " :" ++ msg
  134. | otherwise = Nothing
  135. where
  136. botNick' = nickToText botNick