module Data.Parser.JSONPath
  ( encodeJSONPath,
    parseJSONPath,
  )
where

import Control.Applicative
import Data.Aeson (Key)
import Data.Aeson qualified as Aeson
import Data.Aeson.Internal (JSONPath, JSONPathElement (..))
import Data.Aeson.Key qualified as K
import Data.Attoparsec.Text
import Data.Bifunctor qualified as Bifunctor
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.Encoding qualified as TL
import Hasura.Prelude

-- | Encodes a JSON path as text that looks like code you would write
-- in order to traverse that path in JavaScript.
encodeJSONPath :: JSONPath -> Text
encodeJSONPath :: JSONPath -> Text
encodeJSONPath JSONPath
path = Text
"$" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (JSONPathElement -> Text) -> JSONPath -> Text
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap JSONPathElement -> Text
formatPart JSONPath
path
  where
    formatPart :: JSONPathElement -> Text
formatPart (Index Int
idx) = Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tshow Int
idx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
    formatPart (Key Key
key)
      | [Char] -> Bool
specialChars [Char]
stringKey = Text -> Text
TL.toStrict (Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
TL.decodeUtf8 (Value -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode (Text -> Value
Aeson.String Text
textKey)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]")
      | Bool
otherwise = Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
textKey
      where
        textKey :: Text
textKey = Key -> Text
K.toText Key
key
        stringKey :: [Char]
stringKey = Text -> [Char]
T.unpack Text
textKey
        specialChars :: [Char] -> Bool
specialChars [] = Bool
True
        -- first char must not be number
        specialChars (Char
c : [Char]
xs) =
          Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem Char
c ([Char]
alphabet [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_")
            Bool -> Bool -> Bool
|| (Char -> Bool) -> [Char] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ([Char]
alphaNumerics [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_-")) [Char]
xs

parseJSONPath :: Text -> Either Text JSONPath
parseJSONPath :: Text -> Either Text JSONPath
parseJSONPath Text
"$" = JSONPath -> Either Text JSONPath
forall a b. b -> Either a b
Right []
parseJSONPath Text
txt =
  ([Char] -> Text) -> Either [Char] JSONPath -> Either Text JSONPath
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
Bifunctor.first (Text -> [Char] -> Text
forall a b. a -> b -> a
const Text
invalidMessage) (Either [Char] JSONPath -> Either Text JSONPath)
-> Either [Char] JSONPath -> Either Text JSONPath
forall a b. (a -> b) -> a -> b
$
    Parser JSONPath -> Text -> Either [Char] JSONPath
forall a. Parser a -> Text -> Either [Char] a
parseOnly (Parser Text Char -> Parser Text (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Char -> Parser Text Char
char Char
'$') Parser Text (Maybe Char) -> Parser JSONPath -> Parser JSONPath
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text JSONPathElement -> Parser JSONPath
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many1' Parser Text JSONPathElement
element Parser JSONPath -> Parser Text () -> Parser JSONPath
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Text ()
forall t. Chunk t => Parser t ()
endOfInput) Text
txt
  where
    invalidMessage :: Text
invalidMessage =
      Text
txt
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Accept letters, digits, underscore (_) or hyphen (-) only"
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
". Use quotes enclosed in bracket ([\"...\"]) if there is any special character"

element :: Parser JSONPathElement
element :: Parser Text JSONPathElement
element =
  Key -> JSONPathElement
Key (Key -> JSONPathElement)
-> Parser Text Key -> Parser Text JSONPathElement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser Text Char -> Parser Text (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Char -> Parser Text Char
char Char
'.') Parser Text (Maybe Char) -> Parser Text Key -> Parser Text Key
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Key
name) -- field or .field
    Parser Text JSONPathElement
-> Parser Text JSONPathElement -> Parser Text JSONPathElement
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text JSONPathElement
bracketElement -- [42], ["field"], or ['field']

name :: Parser Key
name :: Parser Text Key
name = Parser Text Key
go Parser Text Key -> [Char] -> Parser Text Key
forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"property name"
  where
    go :: Parser Text Key
go = do
      Char
firstChar <-
        Parser Text Char
letter
          Parser Text Char -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Text Char
char Char
'_'
          Parser Text Char -> [Char] -> Parser Text Char
forall i a. Parser i a -> [Char] -> Parser i a
<?> [Char]
"first character of property name must be a letter or underscore"
      [Char]
otherChars <- Parser Text Char -> Parser Text [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' (Parser Text Char
letter Parser Text Char -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Char
digit Parser Text Char -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Bool) -> Parser Text Char
satisfy ([Char] -> Char -> Bool
inClass [Char]
"-_"))
      Key -> Parser Text Key
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key -> Parser Text Key) -> Key -> Parser Text Key
forall a b. (a -> b) -> a -> b
$ Text -> Key
K.fromText (Text -> Key) -> Text -> Key
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack (Char
firstChar Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
otherChars)

-- | Parses a JSON property key or index in square bracket format, e.g.
-- > [42]
-- > ["hello"]
-- > ['你好']
bracketElement :: Parser JSONPathElement
bracketElement :: Parser Text JSONPathElement
bracketElement = do
  Parser Text Char -> Parser Text ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text Char -> Parser Text ())
-> Parser Text Char -> Parser Text ()
forall a b. (a -> b) -> a -> b
$ Parser Text Char -> Parser Text (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Char -> Parser Text Char
char Char
'.') Parser Text (Maybe Char) -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Char -> Parser Text Char
char Char
'['
  JSONPathElement
result <-
    Int -> JSONPathElement
Index (Int -> JSONPathElement)
-> Parser Text Int -> Parser Text JSONPathElement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Int
forall a. Integral a => Parser a
decimal
      Parser Text JSONPathElement
-> Parser Text JSONPathElement -> Parser Text JSONPathElement
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Key -> JSONPathElement
Key (Key -> JSONPathElement)
-> Parser Text Key -> Parser Text JSONPathElement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Key
doubleQuotedString
      Parser Text JSONPathElement
-> Parser Text JSONPathElement -> Parser Text JSONPathElement
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Key -> JSONPathElement
Key (Key -> JSONPathElement)
-> Parser Text Key -> Parser Text JSONPathElement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Key
singleQuotedString
  Parser Text Char -> Parser Text ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text Char -> Parser Text ())
-> Parser Text Char -> Parser Text ()
forall a b. (a -> b) -> a -> b
$ Char -> Parser Text Char
char Char
']'
  JSONPathElement -> Parser Text JSONPathElement
forall (f :: * -> *) a. Applicative f => a -> f a
pure JSONPathElement
result
  where
    parseJSONString :: Text -> m Key
parseJSONString Text
inQuotes =
      m Key -> (Text -> m Key) -> Maybe Text -> m Key
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> m Key
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Invalid JSON string") (Key -> m Key
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Key -> m Key) -> (Text -> Key) -> Text -> m Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Key
K.fromText) (Maybe Text -> m Key) -> (Text -> Maybe Text) -> Text -> m Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe Text
forall a. FromJSON a => ByteString -> Maybe a
Aeson.decode (ByteString -> Maybe Text)
-> (Text -> ByteString) -> Text -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
TL.encodeUtf8 (Text -> m Key) -> Text -> m Key
forall a b. (a -> b) -> a -> b
$
        Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
inQuotes Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\""

    doubleQuotedString :: Parser Text Key
doubleQuotedString = do
      Parser Text Char -> Parser Text ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text Char -> Parser Text ())
-> Parser Text Char -> Parser Text ()
forall a b. (a -> b) -> a -> b
$ Char -> Parser Text Char
char Char
'"'
      Text
inQuotes <- [Text] -> Text
TL.concat ([Text] -> Text) -> Parser Text [Text] -> Parser Text Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Text -> Parser Text [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser Text Text
doubleQuotedChar
      Parser Text Char -> Parser Text ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text Char -> Parser Text ())
-> Parser Text Char -> Parser Text ()
forall a b. (a -> b) -> a -> b
$ Char -> Parser Text Char
char Char
'"'
      Text -> Parser Text Key
forall (m :: * -> *). MonadFail m => Text -> m Key
parseJSONString Text
inQuotes

    doubleQuotedChar :: Parser Text Text
doubleQuotedChar = Char -> Parser Text Text
jsonChar Char
'"'

    -- Converts `'foo'` to `"foo"` and then parses it.
    singleQuotedString :: Parser Text Key
singleQuotedString = do
      Parser Text Char -> Parser Text ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text Char -> Parser Text ())
-> Parser Text Char -> Parser Text ()
forall a b. (a -> b) -> a -> b
$ Char -> Parser Text Char
char Char
'\''
      Text
inQuotes <- [Text] -> Text
TL.concat ([Text] -> Text) -> Parser Text [Text] -> Parser Text Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Text -> Parser Text [Text]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser Text Text
singleQuotedChar
      Parser Text Char -> Parser Text ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Parser Text Char -> Parser Text ())
-> Parser Text Char -> Parser Text ()
forall a b. (a -> b) -> a -> b
$ Char -> Parser Text Char
char Char
'\''
      Text -> Parser Text Key
forall (m :: * -> *). MonadFail m => Text -> m Key
parseJSONString Text
inQuotes

    -- Un-escapes single quotes, and escapes double quotes.
    singleQuotedChar :: Parser Text Text
singleQuotedChar =
      (Text -> Parser Text
string Text
"\\'" Parser Text -> Parser Text Text -> Parser Text Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"'")
        Parser Text Text -> Parser Text Text -> Parser Text Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Text -> Parser Text
string Text
"\"" Parser Text -> Parser Text Text -> Parser Text Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Text -> Parser Text Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"\\\"")
        Parser Text Text -> Parser Text Text -> Parser Text Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Char -> Parser Text Text
jsonChar Char
'\''

    jsonChar :: Char -> Parser Text Text
jsonChar Char
delimiter =
      ((Text
"\\" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (Char -> Text) -> Char -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
TL.singleton (Char -> Text) -> Parser Text Char -> Parser Text Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Char -> Parser Text Char
char Char
'\\' Parser Text Char -> Parser Text Char -> Parser Text Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Text Char
anyChar))
        Parser Text Text -> Parser Text Text -> Parser Text Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Text
TL.singleton (Char -> Text) -> Parser Text Char -> Parser Text Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Parser Text Char
notChar Char
delimiter)