module DoubleXEncoding where
import Data.Function ((&))
import qualified Data.Text as T
import Data.Text (replace, Text)
import Data.Functor ((<&>))
import Distribution.Utils.Generic (isAsciiAlphaNum)
import Numeric (showHex, readHex)
import Data.Char (ord, isDigit, chr)
import Control.Monad (join)
charEncode :: Char -> Char
charEncode :: Char -> Char
charEncode = \case
Char
' ' -> Char
'0'
Char
'!' -> Char
'1'
Char
'"' -> Char
'2'
Char
'#' -> Char
'3'
Char
'$' -> Char
'4'
Char
'%' -> Char
'5'
Char
'&' -> Char
'6'
Char
'\'' -> Char
'7'
Char
'(' -> Char
'8'
Char
')' -> Char
'9'
Char
'*' -> Char
'A'
Char
'+' -> Char
'B'
Char
',' -> Char
'C'
Char
'-' -> Char
'D'
Char
'.' -> Char
'E'
Char
'/' -> Char
'F'
Char
':' -> Char
'G'
Char
';' -> Char
'H'
Char
'<' -> Char
'I'
Char
'=' -> Char
'J'
Char
'>' -> Char
'K'
Char
'?' -> Char
'L'
Char
'@' -> Char
'M'
Char
'[' -> Char
'N'
Char
'\\' -> Char
'O'
Char
']' -> Char
'P'
Char
'^' -> Char
'Q'
Char
'_' -> Char
'R'
Char
'`' -> Char
'S'
Char
'{' -> Char
'T'
Char
'|' -> Char
'U'
Char
'}' -> Char
'V'
Char
'~' -> Char
'W'
Char
'X' -> Char
'x'
Char
_ -> Char
'\0'
charDecode :: Char -> Char
charDecode :: Char -> Char
charDecode = \case
Char
'0' -> Char
' '
Char
'1' -> Char
'!'
Char
'2' -> Char
'"'
Char
'3' -> Char
'#'
Char
'4' -> Char
'$'
Char
'5' -> Char
'%'
Char
'6' -> Char
'&'
Char
'7' -> Char
'\''
Char
'8' -> Char
'('
Char
'9' -> Char
')'
Char
'A' -> Char
'*'
Char
'B' -> Char
'+'
Char
'C' -> Char
','
Char
'D' -> Char
'-'
Char
'E' -> Char
'.'
Char
'F' -> Char
'/'
Char
'G' -> Char
':'
Char
'H' -> Char
';'
Char
'I' -> Char
'<'
Char
'J' -> Char
'='
Char
'K' -> Char
'>'
Char
'L' -> Char
'?'
Char
'M' -> Char
'@'
Char
'N' -> Char
'['
Char
'O' -> Char
'\\'
Char
'P' -> Char
']'
Char
'Q' -> Char
'^'
Char
'R' -> Char
'_'
Char
'S' -> Char
'`'
Char
'T' -> Char
'{'
Char
'U' -> Char
'|'
Char
'V' -> Char
'}'
Char
'W' -> Char
'~'
Char
'x' -> Char
'X'
Char
_ -> Char
'\0'
hexShiftEncode :: Char -> Char
hexShiftEncode :: Char -> Char
hexShiftEncode = \case
Char
'0' -> Char
'a'
Char
'1' -> Char
'b'
Char
'2' -> Char
'c'
Char
'3' -> Char
'd'
Char
'4' -> Char
'e'
Char
'5' -> Char
'f'
Char
'6' -> Char
'g'
Char
'7' -> Char
'h'
Char
'8' -> Char
'i'
Char
'9' -> Char
'j'
Char
'a' -> Char
'k'
Char
'b' -> Char
'l'
Char
'c' -> Char
'm'
Char
'd' -> Char
'n'
Char
'e' -> Char
'o'
Char
'f' -> Char
'p'
Char
_ -> Char
'\0'
hexShiftDecode :: Char -> Char
hexShiftDecode :: Char -> Char
hexShiftDecode = \case
Char
'a' -> Char
'0'
Char
'b' -> Char
'1'
Char
'c' -> Char
'2'
Char
'd' -> Char
'3'
Char
'e' -> Char
'4'
Char
'f' -> Char
'5'
Char
'g' -> Char
'6'
Char
'h' -> Char
'7'
Char
'i' -> Char
'8'
Char
'j' -> Char
'9'
Char
'k' -> Char
'a'
Char
'l' -> Char
'b'
Char
'm' -> Char
'c'
Char
'n' -> Char
'd'
Char
'o' -> Char
'e'
Char
'p' -> Char
'f'
Char
_ -> Char
'\0'
data EncodeOptions = EncodeOptions
{ EncodeOptions -> Bool
encodeLeadingDigit :: Bool
, EncodeOptions -> Bool
encodeDoubleUnderscore :: Bool
}
doubleXEncodeWithOptions :: EncodeOptions -> Text -> Text
doubleXEncodeWithOptions :: EncodeOptions -> Text -> Text
doubleXEncodeWithOptions EncodeOptions
encodeOptions Text
text =
let
encodeStandard :: Text -> Text
encodeStandard Text
text = Text
text
Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
replace Text
"XX" Text
"XXXXXX"
Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& (\Text
txt ->
if EncodeOptions
encodeOptionsEncodeOptions -> (EncodeOptions -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
&EncodeOptions -> Bool
encodeDoubleUnderscore
then Text
txt Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
replace Text
"__" Text
"XXRXXR"
else Text
txt
)
Text -> (Text -> String) -> String
forall a b. a -> (a -> b) -> b
& Text -> String
T.unpack
String -> (Char -> String) -> [String]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\Char
char ->
if Char -> Bool
isAsciiAlphaNum Char
char Bool -> Bool -> Bool
|| Char
char Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'
then [Char
char]
else
if Char -> Char
charEncode Char
char Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\0'
then [Char
'X', Char
'X', Char -> Char
charEncode Char
char]
else
let
charHex :: String
charHex = Int -> ShowS
forall a. Integral a => a -> ShowS
showHex (Char -> Int
ord Char
char) String
""
charHexEncoded :: String
charHexEncoded = String
charHex String -> (Char -> Char) -> String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Char -> Char
hexShiftEncode
padStart :: Int -> ShowS
padStart Int
n String
txt = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
txt) Char
'a' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
txt
in
if
| String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
charHex Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
5 ->
String
"XX" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> ShowS
padStart Int
5 String
charHexEncoded
| String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
charHex Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
6 ->
String
"XXY" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> ShowS
padStart Int
6 String
charHexEncoded
| Bool
otherwise ->
ShowS
forall a. HasCallStack => String -> a
error String
"ERROR: Hex encoding is too long"
)
[String] -> ([String] -> String) -> String
forall a b. a -> (a -> b) -> b
& [String] -> String
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join
String -> (String -> Text) -> Text
forall a b. a -> (a -> b) -> b
& String -> Text
T.pack
encodeDigit :: Char -> Text
encodeDigit Char
digit =
String -> Text
T.pack [Char
'X', Char
'X', Char
'Z', Char
digit]
in
if EncodeOptions
encodeOptionsEncodeOptions -> (EncodeOptions -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
&EncodeOptions -> Bool
encodeLeadingDigit
then
case Text -> String
T.unpack Text
text of
[] -> Text
""
Char
leadingChar : String
rest ->
if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Char -> Bool
isDigit Char
leadingChar
then Text -> Text
encodeStandard Text
text
else
if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
rest
then Char -> Text
encodeDigit Char
leadingChar
else
Char -> Text
encodeDigit Char
leadingChar
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EncodeOptions -> Text -> Text
doubleXEncodeWithOptions
EncodeOptions
encodeOptions { encodeLeadingDigit = False }
(String -> Text
T.pack String
rest)
else
Text -> Text
encodeStandard Text
text
defaultOptions :: EncodeOptions
defaultOptions :: EncodeOptions
defaultOptions = EncodeOptions
{ encodeLeadingDigit :: Bool
encodeLeadingDigit = Bool
False
, encodeDoubleUnderscore :: Bool
encodeDoubleUnderscore = Bool
False
}
doubleXEncode :: Text -> Text
doubleXEncode :: Text -> Text
doubleXEncode =
EncodeOptions -> Text -> Text
doubleXEncodeWithOptions EncodeOptions
defaultOptions
gqlOptions :: EncodeOptions
gqlOptions :: EncodeOptions
gqlOptions = EncodeOptions
{ encodeLeadingDigit :: Bool
encodeLeadingDigit = Bool
True
, encodeDoubleUnderscore :: Bool
encodeDoubleUnderscore = Bool
True
}
doubleXEncodeGql :: Text -> Text
doubleXEncodeGql :: Text -> Text
doubleXEncodeGql =
EncodeOptions -> Text -> Text
doubleXEncodeWithOptions EncodeOptions
gqlOptions
parseHex :: Text -> Int
parseHex :: Text -> Int
parseHex Text
text =
case ReadS Int
forall a. (Eq a, Num a) => ReadS a
readHex (Text -> String
T.unpack Text
text) of
[(Int
int, String
"")] -> Int
int
[(Int, String)]
_ -> Int
0
doubleXDecode :: Text -> Text
doubleXDecode :: Text -> Text
doubleXDecode Text
text =
let
decodeWord :: Text -> (Text, Text)
decodeWord :: Text -> (Text, Text)
decodeWord Text
word =
let
noXX :: Text
noXX = Int -> Text -> Text
T.drop Int
2 Text
word
first :: Text
first = Int -> Text -> Text
T.take Int
1 Text
noXX
in
if | Text
first Text -> Text -> Bool
forall a. Ord a => a -> a -> Bool
>= Text
"a" Bool -> Bool -> Bool
&& Text
first Text -> Text -> Bool
forall a. Ord a => a -> a -> Bool
<= Text
"p" ->
(String -> Text
T.pack [
Text
noXX
Text -> (Text -> String) -> String
forall a b. a -> (a -> b) -> b
& Text -> String
T.unpack
String -> ShowS -> String
forall a b. a -> (a -> b) -> b
& Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
5
String -> (Char -> Char) -> String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Char -> Char
hexShiftDecode
String -> (String -> Text) -> Text
forall a b. a -> (a -> b) -> b
& String -> Text
T.pack
Text -> (Text -> Int) -> Int
forall a b. a -> (a -> b) -> b
& Text -> Int
parseHex
Int -> (Int -> Char) -> Char
forall a b. a -> (a -> b) -> b
& Int -> Char
chr
]
, Int -> Text -> Text
T.drop Int
5 Text
noXX
)
| Text
first Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"X" ->
if Text
"XXXX" Text -> Text -> Bool
`T.isPrefixOf` Text
noXX
then (Text
"XX", Int -> Text -> Text
T.drop Int
4 Text
noXX)
else (Text
"X", Int -> Text -> Text
T.drop Int
1 Text
word)
| Text
first Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Y" ->
(String -> Text
T.pack [
Text
noXX
Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Int -> Text -> Text
T.drop Int
1
Text -> (Text -> String) -> String
forall a b. a -> (a -> b) -> b
& Text -> String
T.unpack
String -> ShowS -> String
forall a b. a -> (a -> b) -> b
& Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
6
String -> (Char -> Char) -> String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Char -> Char
hexShiftDecode
String -> (String -> Text) -> Text
forall a b. a -> (a -> b) -> b
& String -> Text
T.pack
Text -> (Text -> Int) -> Int
forall a b. a -> (a -> b) -> b
& Text -> Int
parseHex
Int -> (Int -> Char) -> Char
forall a b. a -> (a -> b) -> b
& Int -> Char
chr
]
, Int -> Text -> Text
T.drop Int
7 Text
noXX
)
| Text
first Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"Z" ->
(Text
noXX
Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Int -> Text -> Text
T.drop Int
1
Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Int -> Text -> Text
T.take Int
1
, Int -> Text -> Text
T.drop Int
2 Text
noXX
)
| Bool
otherwise ->
(Text
noXX
Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
& Int -> Text -> Text
T.take Int
1
Text -> (Text -> String) -> String
forall a b. a -> (a -> b) -> b
& Text -> String
T.unpack
String -> (Char -> Char) -> String
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Char -> Char
charDecode
String -> (String -> Text) -> Text
forall a b. a -> (a -> b) -> b
& String -> Text
T.pack
, Int -> Text -> Text
T.drop Int
1 Text
noXX
)
in
Text
text
Text -> (Text -> (Text, Text)) -> (Text, Text)
forall a b. a -> (a -> b) -> b
& HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"XX"
(Text, Text) -> ((Text, Text) -> Text) -> Text
forall a b. a -> (a -> b) -> b
& \case
(Text
"", Text
end) -> case Text -> (Text, Text)
decodeWord Text
end of
(Text
decoded, Text
"") -> Text
decoded
(Text
decoded, Text
rest) -> Text
decoded Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
doubleXDecode Text
rest
(Text
start, Text
"") -> Text
start
(Text
start, Text
end) -> Text
start Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
doubleXDecode Text
end