{-# LANGUAGE OverloadedStrings #-}
module Testing.CurlRunnings.Internal.Parser
(
parseQuery
) where
import Data.Bifunctor (Bifunctor (..))
import Data.Char (isAscii)
import Data.List
import qualified Data.Text as T
import Data.Void
import Testing.CurlRunnings.Types
import Text.Megaparsec
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
parseQuery :: FullQueryText -> Either QueryError [InterpolatedQuery]
parseQuery q =
let trimmed = T.strip q
in case Text.Megaparsec.parse parseFullTextWithQuery "" trimmed of
Right a -> Right a >>= validateQuery
Left a -> Left $ QueryParseError (T.pack $ errorBundlePretty a) q
validateQuery :: [InterpolatedQuery] -> Either QueryError [InterpolatedQuery]
validateQuery q@(InterpolatedQuery _ (Query (CaseResultIndex _:_)):_) = Right q
validateQuery q@(NonInterpolatedQuery (Query (CaseResultIndex _:_)):_) = Right q
validateQuery (InterpolatedQuery _ (Query _):_) = Left $ QueryValidationError "JSON interpolation must begin by indexing into RESPONSES"
validateQuery (NonInterpolatedQuery (Query _):_) = Left $ QueryValidationError "JSON interpolation must begin by indexing into RESPONSES"
validateQuery q = Right q
type Parser = Parsec Void T.Text
parseSuiteIndex' :: Parser Index
parseSuiteIndex' = do
notFollowedBy gtlt
_ <- string "RESPONSES" <|> string "SUITE"
(ArrayIndex i) <- arrayIndexParser
return $ CaseResultIndex i
spaceOrDot :: Parser ()
spaceOrDot = (try $ char '.' >> space) <|> space
lexeme :: Parser a -> Parser a
lexeme = L.lexeme spaceOrDot
symbol :: T.Text -> Parser T.Text
symbol = L.symbol spaceOrDot
inGTLT :: Parser a -> Parser a
inGTLT = between (symbol "$<") (string ">")
gtlt :: Parser T.Text
gtlt = symbol "<" <|> symbol ">"
brackets :: Parser a -> Parser a
brackets = between (symbol "[") (symbol "]")
bracket :: Parser T.Text
bracket = symbol "[" <|> symbol "]"
braces :: Parser a -> Parser a
braces = between (symbol "${") (string "}")
brace :: Parser T.Text
brace = symbol "{" <|> symbol "}"
integer :: Parser Integer
integer = lexeme $ L.signed spaceOrDot L.decimal
dot :: Parser T.Text
dot = symbol "."
arrayIndexParser :: Parser Index
arrayIndexParser = notFollowedBy gtlt >> ArrayIndex <$> brackets integer
environmentVariableParser :: Parser Query
environmentVariableParser = do
notFollowedBy endingChars
(EnvironmentVariable . T.pack) <$> braces (lexeme $ many (noneOf ['[', ']', '<', '>', ' ', '{', '}']))
endingChars :: Parser T.Text
endingChars = dot <|> eol <|> bracket <|> gtlt <|> brace
keyIndexParser :: Parser Index
keyIndexParser = do
notFollowedBy endingChars
(lexeme . try) ((KeyIndex . T.pack) <$> p)
where
p = (:) <$> (letterChar <|> (char '_')) <*> many (noneOf ['.', '[', ']', '<', '>', ' ', '{', '}'])
jsonIndexParser :: Parser Query
jsonIndexParser =
leadingText >>
(inGTLT $ some (parseSuiteIndex' <|> keyIndexParser <|> arrayIndexParser)) >>=
return . Query
interpolatedQueryParser :: Parser InterpolatedQuery
interpolatedQueryParser = do
text <- leadingText
q <- environmentVariableParser <|> jsonIndexParser
if null text then return $ NonInterpolatedQuery q
else return $ InterpolatedQuery (T.pack text) q
leadingText :: Parser String
leadingText = manyTill anySingle $ lookAhead (symbol "$<" <|> "${")
noQueryText :: Parser InterpolatedQuery
noQueryText = do
str <- some anySingle
eof
if "$<" `isInfixOf` str
then fail "invalid `$<` found"
else if "${" `isInfixOf` str
then fail "invalid `${` found"
else return $ LiteralText $ T.pack str
parseFullTextWithQuery :: Parser [InterpolatedQuery]
parseFullTextWithQuery = many ((try interpolatedQueryParser) <|> noQueryText)