{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Irc.RawIrcMsg
(
RawIrcMsg(..)
, TagEntry(..)
, rawIrcMsg
, msgTags
, msgPrefix
, msgCommand
, msgParams
, parseRawIrcMsg
, renderRawIrcMsg
, prefixParser
, simpleTokenParser
, asUtf8
) where
import Control.Applicative
import Data.Attoparsec.Text as P
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder as Builder
import Data.List
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import Irc.UserInfo
import View
data RawIrcMsg = RawIrcMsg
{ RawIrcMsg -> [TagEntry]
_msgTags :: [TagEntry]
, RawIrcMsg -> Maybe UserInfo
_msgPrefix :: Maybe UserInfo
, RawIrcMsg -> Text
_msgCommand :: !Text
, RawIrcMsg -> [Text]
_msgParams :: [Text]
}
deriving (RawIrcMsg -> RawIrcMsg -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RawIrcMsg -> RawIrcMsg -> Bool
$c/= :: RawIrcMsg -> RawIrcMsg -> Bool
== :: RawIrcMsg -> RawIrcMsg -> Bool
$c== :: RawIrcMsg -> RawIrcMsg -> Bool
Eq, ReadPrec [RawIrcMsg]
ReadPrec RawIrcMsg
Int -> ReadS RawIrcMsg
ReadS [RawIrcMsg]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RawIrcMsg]
$creadListPrec :: ReadPrec [RawIrcMsg]
readPrec :: ReadPrec RawIrcMsg
$creadPrec :: ReadPrec RawIrcMsg
readList :: ReadS [RawIrcMsg]
$creadList :: ReadS [RawIrcMsg]
readsPrec :: Int -> ReadS RawIrcMsg
$creadsPrec :: Int -> ReadS RawIrcMsg
Read, Int -> RawIrcMsg -> ShowS
[RawIrcMsg] -> ShowS
RawIrcMsg -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RawIrcMsg] -> ShowS
$cshowList :: [RawIrcMsg] -> ShowS
show :: RawIrcMsg -> [Char]
$cshow :: RawIrcMsg -> [Char]
showsPrec :: Int -> RawIrcMsg -> ShowS
$cshowsPrec :: Int -> RawIrcMsg -> ShowS
Show)
data TagEntry = TagEntry {-# UNPACK #-} !Text {-# UNPACK #-} !Text
deriving (TagEntry -> TagEntry -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TagEntry -> TagEntry -> Bool
$c/= :: TagEntry -> TagEntry -> Bool
== :: TagEntry -> TagEntry -> Bool
$c== :: TagEntry -> TagEntry -> Bool
Eq, ReadPrec [TagEntry]
ReadPrec TagEntry
Int -> ReadS TagEntry
ReadS [TagEntry]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [TagEntry]
$creadListPrec :: ReadPrec [TagEntry]
readPrec :: ReadPrec TagEntry
$creadPrec :: ReadPrec TagEntry
readList :: ReadS [TagEntry]
$creadList :: ReadS [TagEntry]
readsPrec :: Int -> ReadS TagEntry
$creadsPrec :: Int -> ReadS TagEntry
Read, Int -> TagEntry -> ShowS
[TagEntry] -> ShowS
TagEntry -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TagEntry] -> ShowS
$cshowList :: [TagEntry] -> ShowS
show :: TagEntry -> [Char]
$cshow :: TagEntry -> [Char]
showsPrec :: Int -> TagEntry -> ShowS
$cshowsPrec :: Int -> TagEntry -> ShowS
Show)
msgTags :: Functor f => ([TagEntry] -> f [TagEntry]) -> RawIrcMsg -> f RawIrcMsg
msgTags :: forall (f :: * -> *).
Functor f =>
([TagEntry] -> f [TagEntry]) -> RawIrcMsg -> f RawIrcMsg
msgTags [TagEntry] -> f [TagEntry]
f RawIrcMsg
m = (\[TagEntry]
x -> RawIrcMsg
m { _msgTags :: [TagEntry]
_msgTags = [TagEntry]
x }) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TagEntry] -> f [TagEntry]
f (RawIrcMsg -> [TagEntry]
_msgTags RawIrcMsg
m)
msgPrefix :: Functor f => (Maybe UserInfo -> f (Maybe UserInfo)) -> RawIrcMsg -> f RawIrcMsg
msgPrefix :: forall (f :: * -> *).
Functor f =>
(Maybe UserInfo -> f (Maybe UserInfo)) -> RawIrcMsg -> f RawIrcMsg
msgPrefix Maybe UserInfo -> f (Maybe UserInfo)
f RawIrcMsg
m = (\Maybe UserInfo
x -> RawIrcMsg
m { _msgPrefix :: Maybe UserInfo
_msgPrefix = Maybe UserInfo
x }) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UserInfo -> f (Maybe UserInfo)
f (RawIrcMsg -> Maybe UserInfo
_msgPrefix RawIrcMsg
m)
msgCommand :: Functor f => (Text -> f Text) -> RawIrcMsg -> f RawIrcMsg
msgCommand :: forall (f :: * -> *).
Functor f =>
(Text -> f Text) -> RawIrcMsg -> f RawIrcMsg
msgCommand Text -> f Text
f RawIrcMsg
m = (\Text
x -> RawIrcMsg
m { _msgCommand :: Text
_msgCommand = Text
x }) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> f Text
f (RawIrcMsg -> Text
_msgCommand RawIrcMsg
m)
msgParams :: Functor f => ([Text] -> f [Text]) -> RawIrcMsg -> f RawIrcMsg
msgParams :: forall (f :: * -> *).
Functor f =>
([Text] -> f [Text]) -> RawIrcMsg -> f RawIrcMsg
msgParams [Text] -> f [Text]
f RawIrcMsg
m = (\[Text]
x -> RawIrcMsg
m { _msgParams :: [Text]
_msgParams = [Text]
x }) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text] -> f [Text]
f (RawIrcMsg -> [Text]
_msgParams RawIrcMsg
m)
parseRawIrcMsg :: Text -> Maybe RawIrcMsg
parseRawIrcMsg :: Text -> Maybe RawIrcMsg
parseRawIrcMsg Text
x =
case forall a. Parser a -> Text -> Either [Char] a
parseOnly Parser RawIrcMsg
rawIrcMsgParser Text
x of
Left{} -> forall a. Maybe a
Nothing
Right RawIrcMsg
r -> forall a. a -> Maybe a
Just RawIrcMsg
r
maxMiddleParams :: Int
maxMiddleParams :: Int
maxMiddleParams = Int
14
rawIrcMsgParser :: Parser RawIrcMsg
rawIrcMsgParser :: Parser RawIrcMsg
rawIrcMsgParser =
do [TagEntry]
tags <- forall a. a -> Maybe a -> a
fromMaybe [] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b. Char -> Parser b -> Parser (Maybe b)
guarded Char
'@' Parser Text [TagEntry]
tagsParser
Maybe UserInfo
prefix <- forall b. Char -> Parser b -> Parser (Maybe b)
guarded Char
':' Parser UserInfo
prefixParser
Text
cmd <- Parser Text
simpleTokenParser
[Text]
params <- Int -> Parser [Text]
paramsParser Int
maxMiddleParams
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! RawIrcMsg
{ _msgTags :: [TagEntry]
_msgTags = [TagEntry]
tags
, _msgPrefix :: Maybe UserInfo
_msgPrefix = Maybe UserInfo
prefix
, _msgCommand :: Text
_msgCommand = Text
cmd
, _msgParams :: [Text]
_msgParams = [Text]
params
}
paramsParser ::
Int -> Parser [Text]
paramsParser :: Int -> Parser [Text]
paramsParser !Int
n =
do Bool
end <- forall t. Chunk t => Parser t Bool
P.atEnd
if Bool
end
then forall (m :: * -> *) a. Monad m => a -> m a
return []
else do Bool
isColon <- Char -> Parser Bool
optionalChar Char
':'
if Bool
isColon Bool -> Bool -> Bool
|| Int
n forall a. Eq a => a -> a -> Bool
== Int
0
then Parser [Text]
finalParam
else Parser [Text]
middleParam
where
finalParam :: Parser [Text]
finalParam =
do Text
x <- Parser Text
takeText
let !x' :: Text
x' = Text -> Text
Text.copy Text
x
forall (m :: * -> *) a. Monad m => a -> m a
return [Text
x']
middleParam :: Parser [Text]
middleParam =
do Text
x <- Parser Text
simpleTokenParser
[Text]
xs <- Int -> Parser [Text]
paramsParser (Int
nforall a. Num a => a -> a -> a
-Int
1)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
xforall a. a -> [a] -> [a]
:[Text]
xs)
tagsParser :: Parser [TagEntry]
tagsParser :: Parser Text [TagEntry]
tagsParser = Parser TagEntry
tagParser forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy1` Char -> Parser Char
char Char
';' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
spaces
tagParser :: Parser TagEntry
tagParser :: Parser TagEntry
tagParser =
do Text
key <- (Char -> Bool) -> Parser Text
P.takeWhile ([Char] -> Char -> Bool
notInClass [Char]
"=; ")
Maybe Char
_ <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Char -> Parser Char
char Char
'=')
Text
val <- (Char -> Bool) -> Parser Text
P.takeWhile ([Char] -> Char -> Bool
notInClass [Char]
"; ")
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Text -> Text -> TagEntry
TagEntry Text
key (Text -> Text
unescapeTagVal Text
val)
unescapeTagVal :: Text -> Text
unescapeTagVal :: Text -> Text
unescapeTagVal = [Char] -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
aux forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
Text.unpack
where
aux :: ShowS
aux (Char
'\\':Char
':':[Char]
xs) = Char
';'forall a. a -> [a] -> [a]
:ShowS
aux [Char]
xs
aux (Char
'\\':Char
's':[Char]
xs) = Char
' 'forall a. a -> [a] -> [a]
:ShowS
aux [Char]
xs
aux (Char
'\\':Char
'\\':[Char]
xs) = Char
'\\'forall a. a -> [a] -> [a]
:ShowS
aux [Char]
xs
aux (Char
'\\':Char
'r':[Char]
xs) = Char
'\r'forall a. a -> [a] -> [a]
:ShowS
aux [Char]
xs
aux (Char
'\\':Char
'n':[Char]
xs) = Char
'\n'forall a. a -> [a] -> [a]
:ShowS
aux [Char]
xs
aux (Char
x:[Char]
xs) = Char
x forall a. a -> [a] -> [a]
: ShowS
aux [Char]
xs
aux [Char]
"" = [Char]
""
escapeTagVal :: Text -> Text
escapeTagVal :: Text -> Text
escapeTagVal = (Char -> Text) -> Text -> Text
Text.concatMap Char -> Text
aux
where
aux :: Char -> Text
aux Char
';' = Text
"\\:"
aux Char
' ' = Text
"\\s"
aux Char
'\\' = Text
"\\\\"
aux Char
'\r' = Text
"\\r"
aux Char
'\n' = Text
"\\n"
aux Char
x = Char -> Text
Text.singleton Char
x
prefixParser :: Parser UserInfo
prefixParser :: Parser UserInfo
prefixParser =
do Text
tok <- Parser Text
simpleTokenParser
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Text -> UserInfo
parseUserInfo Text
tok
simpleTokenParser :: Parser Text
simpleTokenParser :: Parser Text
simpleTokenParser =
do Text
xs <- (Char -> Bool) -> Parser Text
P.takeWhile1 (forall a. Eq a => a -> a -> Bool
/= Char
' ')
Parser ()
spaces
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Text -> Text
Text.copy Text
xs
spaces :: Parser ()
spaces :: Parser ()
spaces = (Char -> Bool) -> Parser ()
P.skipWhile (forall a. Eq a => a -> a -> Bool
== Char
' ')
renderRawIrcMsg :: RawIrcMsg -> ByteString
renderRawIrcMsg :: RawIrcMsg -> ByteString
renderRawIrcMsg !RawIrcMsg
m
= ByteString -> ByteString
L.toStrict
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
Builder.toLazyByteString
forall a b. (a -> b) -> a -> b
$ [TagEntry] -> Builder
renderTags (forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view forall (f :: * -> *).
Functor f =>
([TagEntry] -> f [TagEntry]) -> RawIrcMsg -> f RawIrcMsg
msgTags RawIrcMsg
m)
forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty UserInfo -> Builder
renderPrefix (forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view forall (f :: * -> *).
Functor f =>
(Maybe UserInfo -> f (Maybe UserInfo)) -> RawIrcMsg -> f RawIrcMsg
msgPrefix RawIrcMsg
m)
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.encodeUtf8Builder (forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view forall (f :: * -> *).
Functor f =>
(Text -> f Text) -> RawIrcMsg -> f RawIrcMsg
msgCommand RawIrcMsg
m)
forall a. Semigroup a => a -> a -> a
<> [Text] -> Builder
buildParams (forall a s. ((a -> Const a a) -> s -> Const a s) -> s -> a
view forall (f :: * -> *).
Functor f =>
([Text] -> f [Text]) -> RawIrcMsg -> f RawIrcMsg
msgParams RawIrcMsg
m)
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.char8 Char
'\r'
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.char8 Char
'\n'
rawIrcMsg ::
Text ->
[Text] -> RawIrcMsg
rawIrcMsg :: Text -> [Text] -> RawIrcMsg
rawIrcMsg = [TagEntry] -> Maybe UserInfo -> Text -> [Text] -> RawIrcMsg
RawIrcMsg [] forall a. Maybe a
Nothing
renderTags :: [TagEntry] -> Builder
renderTags :: [TagEntry] -> Builder
renderTags [] = forall a. Monoid a => a
mempty
renderTags [TagEntry]
xs
= Char -> Builder
Builder.char8 Char
'@'
forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
intersperse (Char -> Builder
Builder.char8 Char
';') (forall a b. (a -> b) -> [a] -> [b]
map TagEntry -> Builder
renderTag [TagEntry]
xs))
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.char8 Char
' '
renderTag :: TagEntry -> Builder
renderTag :: TagEntry -> Builder
renderTag (TagEntry Text
key Text
val)
| Text -> Bool
Text.null Text
val = Text -> Builder
Text.encodeUtf8Builder Text
key
| Bool
otherwise = Text -> Builder
Text.encodeUtf8Builder Text
key
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.char8 Char
'='
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.encodeUtf8Builder (Text -> Text
escapeTagVal Text
val)
renderPrefix :: UserInfo -> Builder
renderPrefix :: UserInfo -> Builder
renderPrefix UserInfo
u
= Char -> Builder
Builder.char8 Char
':'
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.encodeUtf8Builder (UserInfo -> Text
renderUserInfo UserInfo
u)
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.char8 Char
' '
buildParams :: [Text] -> Builder
buildParams :: [Text] -> Builder
buildParams [Text
x]
| Text
" " Text -> Text -> Bool
`Text.isInfixOf` Text
x Bool -> Bool -> Bool
|| Text
":" Text -> Text -> Bool
`Text.isPrefixOf` Text
x Bool -> Bool -> Bool
|| Text -> Bool
Text.null Text
x
= Char -> Builder
Builder.char8 Char
' ' forall a. Semigroup a => a -> a -> a
<> Char -> Builder
Builder.char8 Char
':' forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.encodeUtf8Builder Text
x
buildParams (Text
x:[Text]
xs)
| Text -> Bool
Text.null Text
x = Char -> Builder
Builder.char8 Char
' ' forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.encodeUtf8Builder Text
"*" forall a. Semigroup a => a -> a -> a
<> [Text] -> Builder
buildParams [Text]
xs
| Bool
otherwise = Char -> Builder
Builder.char8 Char
' ' forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.encodeUtf8Builder Text
x forall a. Semigroup a => a -> a -> a
<> [Text] -> Builder
buildParams [Text]
xs
buildParams [] = forall a. Monoid a => a
mempty
guarded :: Char -> Parser b -> Parser (Maybe b)
guarded :: forall b. Char -> Parser b -> Parser (Maybe b)
guarded Char
c Parser b
p =
do Bool
success <- Char -> Parser Bool
optionalChar Char
c
if Bool
success then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser b
p else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
optionalChar :: Char -> Parser Bool
optionalChar :: Char -> Parser Bool
optionalChar Char
c = Bool
True forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> Parser Char
char Char
c forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
asUtf8 :: ByteString -> Text
asUtf8 :: ByteString -> Text
asUtf8 ByteString
x = case ByteString -> Either UnicodeException Text
Text.decodeUtf8' ByteString
x of
Right Text
txt -> Text
txt
Left{} -> ByteString -> Text
decodeCP1252 ByteString
x
decodeCP1252 :: ByteString -> Text
decodeCP1252 :: ByteString -> Text
decodeCP1252 ByteString
bs = [Char] -> Text
Text.pack [ Vector Char
cp1252 forall a. Vector a -> Int -> a
Vector.! forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x | Word8
x <- ByteString -> [Word8]
B.unpack ByteString
bs ]
cp1252 :: Vector Char
cp1252 :: Vector Char
cp1252 = forall a. [a] -> Vector a
Vector.fromList
forall a b. (a -> b) -> a -> b
$ [Char
'\x00'..Char
'\x7f']
forall a. [a] -> [a] -> [a]
++ [Char]
"€\x81‚ƒ„…†‡ˆ‰Š‹Œ\x8dŽ\x8f\x90‘’“”•–—˜™š›œ\x9džŸ"
forall a. [a] -> [a] -> [a]
++ [Char
'\xa0'..Char
'\xff']