{-# LANGUAGE BangPatterns #-}

-- | Unescaping of JSON string literals.
--
-- The input is the raw slice between the quotes, escapes intact. Output is
-- decoded 'Text'. The pure-Haskell equivalent of aeson's @unescapeText@,
-- minus the C fast path: no escapes means one 'decodeUtf8'' and done.
module Circuit.Parser.Json.Unescape
  ( unescape,
  )
where

import Data.Bits (shiftL, (.|.))
import Data.ByteString (ByteString)
import Data.ByteString qualified as B
import Data.Char (chr, isDigit, isHexDigit, ord)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Encoding (decodeUtf8')
import Data.Word (Word8)

-- $setup
-- >>> import Data.ByteString.Char8 qualified as C

-- | Unescape a raw JSON string slice (the bytes between the quotes) to
-- 'Text'.
--
-- >>> unescape (C.pack "hello")
-- Right "hello"
--
-- >>> unescape (C.pack "a\\nb")
-- Right "a\nb"
--
-- >>> unescape (C.pack "\\u0041\\u00e9")
-- Right "A\233"
--
-- >>> unescape (C.pack "\\uD834\\uDD1E")
-- Right "\119070"
--
-- >>> unescape (C.pack "bad\\x")
-- Left "invalid escape: \\x"
unescape :: ByteString -> Either String Text
unescape :: ByteString -> Either String Text
unescape ByteString
bs = case Word8 -> ByteString -> Maybe Int
B.elemIndex Word8
backslash ByteString
bs of
  Maybe Int
Nothing
    | (Word8 -> Bool) -> ByteString -> Bool
B.any (Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0x20) ByteString
bs -> String -> Either String Text
forall a b. a -> Either a b
Left String
"unescaped control character"
    | Bool
otherwise -> (UnicodeException -> Either String Text)
-> (Text -> Either String Text)
-> Either UnicodeException Text
-> Either String Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Either String Text
forall a b. a -> Either a b
Left (String -> Either String Text)
-> (UnicodeException -> String)
-> UnicodeException
-> Either String Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnicodeException -> String
forall a. Show a => a -> String
show) Text -> Either String Text
forall a b. b -> Either a b
Right (ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
bs)
  Just Int
_ -> Int -> [Text] -> Either String Text
go Int
0 []
  where
    !len :: Int
len = ByteString -> Int
B.length ByteString
bs
    go :: Int -> [Text] -> Either String Text
go !Int
i [Text]
acc
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len =
          Text -> Either String Text
forall a b. b -> Either a b
Right ([Text] -> Text
T.concat ([Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
acc))
      | Bool
otherwise =
          case Word8 -> Int -> ByteString -> Maybe Int
elemIndexFrom Word8
backslash Int
i ByteString
bs of
            Maybe Int
Nothing ->
              -- tail chunk, no more escapes
              let chunk :: ByteString
chunk = Int -> ByteString -> ByteString
B.drop Int
i ByteString
bs
               in if (Word8 -> Bool) -> ByteString -> Bool
B.any (Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0x20) ByteString
chunk
                    then String -> Either String Text
forall a b. a -> Either a b
Left String
"unescaped control character"
                    else case ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
chunk of
                      Left UnicodeException
e -> String -> Either String Text
forall a b. a -> Either a b
Left (UnicodeException -> String
forall a. Show a => a -> String
show UnicodeException
e)
                      Right Text
t -> Text -> Either String Text
forall a b. b -> Either a b
Right ([Text] -> Text
T.concat ([Text] -> [Text]
forall a. [a] -> [a]
reverse (Text
t Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc)))
            Just Int
j ->
              -- chunk [i, j) is escape-free raw UTF-8
              let chunk :: ByteString
chunk = Int -> ByteString -> ByteString
B.take (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i) (Int -> ByteString -> ByteString
B.drop Int
i ByteString
bs)
               in if (Word8 -> Bool) -> ByteString -> Bool
B.any (Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
0x20) ByteString
chunk
                    then String -> Either String Text
forall a b. a -> Either a b
Left String
"unescaped control character"
                    else case ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
chunk of
                      Left UnicodeException
e -> String -> Either String Text
forall a b. a -> Either a b
Left (UnicodeException -> String
forall a. Show a => a -> String
show UnicodeException
e)
                      Right Text
t -> Int -> [Text] -> Either String Text
escapeAt (Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Text
t Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc)
    -- i points just past the backslash
    escapeAt :: Int -> [Text] -> Either String Text
escapeAt !Int
i [Text]
acc
      | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
len = String -> Either String Text
forall a b. a -> Either a b
Left String
"trailing backslash"
      | Bool
otherwise = case HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
B.index ByteString
bs Int
i of
          Word8
0x22 -> Int -> [Text] -> Either String Text
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Char -> Text
T.singleton Char
'"' Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc)
          Word8
0x5C -> Int -> [Text] -> Either String Text
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Char -> Text
T.singleton Char
'\\' Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc)
          Word8
0x2F -> Int -> [Text] -> Either String Text
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Char -> Text
T.singleton Char
'/' Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc)
          Word8
0x62 -> Int -> [Text] -> Either String Text
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Char -> Text
T.singleton Char
'\b' Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc)
          Word8
0x66 -> Int -> [Text] -> Either String Text
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Char -> Text
T.singleton Char
'\f' Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc)
          Word8
0x6E -> Int -> [Text] -> Either String Text
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Char -> Text
T.singleton Char
'\n' Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc)
          Word8
0x72 -> Int -> [Text] -> Either String Text
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Char -> Text
T.singleton Char
'\r' Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc)
          Word8
0x74 -> Int -> [Text] -> Either String Text
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Char -> Text
T.singleton Char
'\t' Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc)
          Word8
0x75 -> Int -> [Text] -> Either String Text
hexAt (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Text]
acc
          Word8
w -> String -> Either String Text
forall a b. a -> Either a b
Left (String
"invalid escape: \\" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Word8 -> Char
w2c Word8
w])
    -- i points at the first of 4 hex digits
    hexAt :: Int -> [Text] -> Either String Text
hexAt !Int
i [Text]
acc
      | Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
len = String -> Either String Text
forall a b. a -> Either a b
Left String
"truncated \\u escape"
      | Bool
otherwise =
          let h :: ByteString
h = Int -> ByteString -> ByteString
B.take Int
4 (Int -> ByteString -> ByteString
B.drop Int
i ByteString
bs)
           in if (Word8 -> Bool) -> ByteString -> Bool
B.all (Char -> Bool
isHexDigit (Char -> Bool) -> (Word8 -> Char) -> Word8 -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Char
w2c) ByteString
h
                then
                  let !n :: Int
n = ByteString -> Int
hexVal ByteString
h
                   in if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0xD800 Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0xDBFF
                        then Int -> Int -> [Text] -> Either String Text
lowSurrogate (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4) Int
n [Text]
acc
                        else
                          if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0xDC00 Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0xDFFF
                            then String -> Either String Text
forall a b. a -> Either a b
Left String
"lone low surrogate"
                            else Int -> [Text] -> Either String Text
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4) (Char -> Text
T.singleton (Int -> Char
chr Int
n) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc)
                else String -> Either String Text
forall a b. a -> Either a b
Left String
"invalid hex in \\u escape"
    -- i points just past a high surrogate; expect \uDC00-\uDFFF
    lowSurrogate :: Int -> Int -> [Text] -> Either String Text
lowSurrogate !Int
i !Int
hi [Text]
acc
      | Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
6 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
len = String -> Either String Text
forall a b. a -> Either a b
Left String
"truncated surrogate pair"
      | HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
B.index ByteString
bs Int
i Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
backslash Bool -> Bool -> Bool
|| HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
B.index ByteString
bs (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0x75 =
          String -> Either String Text
forall a b. a -> Either a b
Left String
"lone high surrogate"
      | Bool
otherwise =
          let h :: ByteString
h = Int -> ByteString -> ByteString
B.take Int
4 (Int -> ByteString -> ByteString
B.drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) ByteString
bs)
           in if (Word8 -> Bool) -> ByteString -> Bool
B.all (Char -> Bool
isHexDigit (Char -> Bool) -> (Word8 -> Char) -> Word8 -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Char
w2c) ByteString
h
                then
                  let !lo :: Int
lo = ByteString -> Int
hexVal ByteString
h
                   in if Int
lo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0xDC00 Bool -> Bool -> Bool
&& Int
lo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0xDFFF
                        then
                          let !n :: Int
n = Int
0x10000 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ((Int
hi Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0xD800) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
10) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. (Int
lo Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0xDC00)
                           in Int -> [Text] -> Either String Text
go (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
6) (Char -> Text
T.singleton (Int -> Char
chr Int
n) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
acc)
                        else String -> Either String Text
forall a b. a -> Either a b
Left String
"lone high surrogate"
                else String -> Either String Text
forall a b. a -> Either a b
Left String
"invalid hex in \\u escape"

backslash :: Word8
backslash :: Word8
backslash = Word8
0x5C

w2c :: Word8 -> Char
w2c :: Word8 -> Char
w2c = Int -> Char
chr (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral

-- | elemIndexFrom is not exported by bytestring; search from an offset.
elemIndexFrom :: Word8 -> Int -> ByteString -> Maybe Int
elemIndexFrom :: Word8 -> Int -> ByteString -> Maybe Int
elemIndexFrom Word8
w Int
i ByteString
bs = (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+) (Int -> Int) -> Maybe Int -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word8 -> ByteString -> Maybe Int
B.elemIndex Word8
w (Int -> ByteString -> ByteString
B.drop Int
i ByteString
bs)

hexVal :: ByteString -> Int
hexVal :: ByteString -> Int
hexVal = (Int -> Word8 -> Int) -> Int -> ByteString -> Int
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
B.foldl' Int -> Word8 -> Int
step Int
0
  where
    step :: Int -> Word8 -> Int
step !Int
acc Word8
w = Int
acc Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
dig (Word8 -> Char
w2c Word8
w)
    dig :: Char -> Int
dig Char
c
      | Char -> Bool
isDigit Char
c = Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'0'
      | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'f' = Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'a' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10
      | Bool
otherwise = Char -> Int
ord Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
ord Char
'A' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
10