184 lines
5.0 KiB
Haskell
184 lines
5.0 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Pipes.IRC.Message.Parse where
|
|
|
|
import Control.Applicative
|
|
import Data.Attoparsec.ByteString.Char8 as P
|
|
import qualified Data.ByteString as BS
|
|
import Data.ByteString.Char8 as C8
|
|
import Data.Char as C
|
|
import Pipes.IRC.Message.Types
|
|
|
|
--
|
|
-- Parsers
|
|
--
|
|
|
|
parseMsgOrLine :: Parser (Either ByteString IrcMessage)
|
|
parseMsgOrLine =
|
|
Right <$> parseIrcMessage <|>
|
|
Left <$> parseToEOL
|
|
|
|
parseToEOL :: Parser ByteString
|
|
parseToEOL = C8.append <$> P.takeWhile (not . isCRLFChar)
|
|
<*> P.takeWhile isCRLFChar
|
|
|
|
parseIrcMessage :: Parser IrcMessage
|
|
parseIrcMessage =
|
|
IrcMessage <$> option Nothing (Just <$> parseMsgPrefix )
|
|
<*> parseCommand
|
|
<*> parseParams
|
|
<* parseLineEnd
|
|
<?> "parseIrcMessage"
|
|
|
|
parseMsgPrefix :: Parser MsgPrefix
|
|
parseMsgPrefix =
|
|
Right <$ char ':' <*> parseNickName <* takeWhile1 (== ' ') <|>
|
|
Left <$ char ':' <*> parseServerName <* takeWhile1 (== ' ')
|
|
<?> "parseMsgPrefix"
|
|
|
|
parseServerName :: Parser ServerName
|
|
parseServerName = C8.intercalate "." <$> parseName `sepBy1` char '.'
|
|
<?> "parseServerName"
|
|
|
|
parseName :: Parser ByteString
|
|
parseName = C8.cons
|
|
<$> satisfy isLetOrDig
|
|
<*> parseHyphenated
|
|
<?> "parseName"
|
|
|
|
parseHyphenated :: Parser ByteString
|
|
parseHyphenated =
|
|
C8.intercalate "-" <$> P.takeWhile1 isLetOrDig `sepBy` char '-'
|
|
<?> "parseHyphenated"
|
|
|
|
parseNickName :: Parser NickName
|
|
parseNickName =
|
|
NickName <$> parseNick
|
|
<*> parseUser
|
|
<*> parseHost
|
|
<?> "parseNickName"
|
|
|
|
parseNick :: Parser ByteString
|
|
parseNick = takeWhile1 isNickChar <?> "parseNick"
|
|
|
|
parseUser :: Parser (Maybe ByteString)
|
|
parseUser = option Nothing
|
|
(Just <$ char '!' <*> takeWhile1 isUserChar
|
|
<?> "parseUser")
|
|
|
|
parseHost :: Parser (Maybe ByteString)
|
|
parseHost = option Nothing
|
|
(Just <$ char '@' <*> parseServerName
|
|
<?> "parseHost")
|
|
|
|
parseCommand :: Parser MsgCommand
|
|
parseCommand =
|
|
Right <$> parseIrcReply <|>
|
|
Left <$> parseIrcCommand
|
|
<?> "parseCommand"
|
|
|
|
parseIrcCommand :: Parser IrcCommand
|
|
parseIrcCommand = (toCmd . C8.map toUpper) <$> takeWhile1 isAlpha_ascii
|
|
<?> "parseIrcCommand"
|
|
where
|
|
toCmd cmd = case cmd of
|
|
"PASS" -> PASS
|
|
"NICK" -> NICK
|
|
"USER" -> USER
|
|
"SERVER" -> SERVER
|
|
"OPER" -> OPER
|
|
"QUIT" -> QUIT
|
|
"SQUIT" -> SQUIT
|
|
"JOIN" -> JOIN
|
|
"PART" -> PART
|
|
"MODE" -> MODE
|
|
"TOPIC" -> TOPIC
|
|
"NAMES" -> NAMES
|
|
"LIST" -> LIST
|
|
"INVITE" -> INVITE
|
|
"KICK" -> KICK
|
|
"VERSION" -> VERSION
|
|
"STATS" -> STATS
|
|
"LINKS" -> LINKS
|
|
"TIME" -> TIME
|
|
"CONNECT" -> CONNECT
|
|
"TRACE" -> TRACE
|
|
"ADMIN" -> ADMIN
|
|
"INFO" -> INFO
|
|
"PRIVMSG" -> PRIVMSG
|
|
"NOTICE" -> NOTICE
|
|
"WHO" -> WHO
|
|
"WHOIS" -> WHOIS
|
|
"WHOWAS" -> WHOWAS
|
|
"KILL" -> KILL
|
|
"PING" -> PING
|
|
"PONG" -> PONG
|
|
"ERROR" -> ERROR
|
|
"AWAY" -> AWAY
|
|
"REHASH" -> REHASH
|
|
"RESTART" -> RESTART
|
|
"SUMMON" -> SUMMON
|
|
"USERS" -> USERS
|
|
"WALLOPS" -> WALLOPS
|
|
"USERHOST" -> USERHOST
|
|
"ISON" -> ISON
|
|
_ -> Unknown cmd
|
|
|
|
parseIrcReply :: Parser IrcReply
|
|
parseIrcReply = toReply <$> digit <*> digit <*> digit
|
|
<?> "ParseIrcReply"
|
|
where
|
|
toReply a b c = toEnum $
|
|
100 * digitToInt a + 10 * digitToInt b + digitToInt c
|
|
|
|
parseParams :: Parser [IrcParam]
|
|
parseParams = takeWhile1 (== ' ') *>
|
|
option [] ( parseTrail <|> parseMiddle )
|
|
<|> pure []
|
|
where
|
|
parseTrail = (:[]) <$> parseTrailParam
|
|
parseMiddle = (:) <$> parseMiddleParam <*> parseParams
|
|
|
|
parseTrailParam :: Parser IrcParam
|
|
parseTrailParam = C8.cons <$> satisfy (== ':') *> P.takeWhile isTrailingChar
|
|
|
|
parseMiddleParam :: Parser IrcParam
|
|
parseMiddleParam = C8.cons <$> satisfy (\c -> c /= ':' && isNonWhite c)
|
|
<*> P.takeWhile isNonWhite
|
|
<?> "parseMiddleParam"
|
|
|
|
parseLineEnd :: Parser ()
|
|
parseLineEnd = const () <$> ("\r\n" <|> "\n" <|> "\r")
|
|
<?> "parseLineEnd"
|
|
|
|
--
|
|
-- Character Predicates
|
|
--
|
|
|
|
isLetOrDig :: Char -> Bool
|
|
isLetOrDig c = P.isDigit c || isAlpha_ascii c
|
|
|
|
isLetOrDigOrHyph :: Char -> Bool
|
|
isLetOrDigOrHyph c = isLetOrDig c || c == '-'
|
|
|
|
isSpecial :: Char -> Bool
|
|
isSpecial c = c `C8.elem` "-[]\\`^{}"
|
|
|
|
isNonWhite :: Char -> Bool
|
|
isNonWhite c = not $ c `C8.elem` BS.pack [0x00, 0x20, 0x0d, 0x0a]
|
|
|
|
isTrailingChar :: Char -> Bool
|
|
isTrailingChar c = not $ c `C8.elem` BS.pack [0x00, 0x0d, 0x0a]
|
|
|
|
isCRLFChar :: Char -> Bool
|
|
isCRLFChar c = c `C8.elem` BS.pack [0x0d, 0x0a]
|
|
|
|
isNickChar :: Char -> Bool
|
|
isNickChar c = isLetOrDig c || isSpecial c
|
|
|
|
isNickNameSep :: Char -> Bool
|
|
isNickNameSep c = c == '!' || c == '@'
|
|
|
|
isUserChar :: Char -> Bool
|
|
isUserChar c = isNonWhite c && not (isNickNameSep c)
|