{-|
Module: IHP.GraphQL.Parser
Description: Parser for GraphQL requests
Copyright: (c) digitally induced GmbH, 2022
-}
module IHP.GraphQL.Parser where

import IHP.Prelude
import IHP.GraphQL.Types
import qualified Data.Text as Text
import Data.Attoparsec.Text
import qualified Data.HashMap.Strict as HashMap

parseDocument :: Parser Document
parseDocument :: Parser Document
parseDocument = [Definition] -> Document
Document ([Definition] -> Document)
-> Parser Text [Definition] -> Parser Document
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Definition -> Parser Text [Definition]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many1 Parser Text Definition
parseDefinition

parseDefinition :: Parser Definition
parseDefinition :: Parser Text Definition
parseDefinition = Parser ()
skipSpace Parser () -> Parser Text Definition -> Parser Text Definition
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Parser Text Definition
executableDefinition Parser Text Definition
-> Parser Text Definition -> Parser Text Definition
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Definition
parseFragmentDefinition)

executableDefinition :: Parser Definition
executableDefinition :: Parser Text Definition
executableDefinition = do
    let query :: Parser Text OperationType
query = Text -> Parser Text
string Text
"query" Parser Text
-> Parser Text OperationType -> Parser Text OperationType
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> OperationType -> Parser Text OperationType
forall (f :: * -> *) a. Applicative f => a -> f a
pure OperationType
Query
    let mutation :: Parser Text OperationType
mutation = Text -> Parser Text
string Text
"mutation" Parser Text
-> Parser Text OperationType -> Parser Text OperationType
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> OperationType -> Parser Text OperationType
forall (f :: * -> *) a. Applicative f => a -> f a
pure OperationType
Mutation
    let subscription :: Parser Text OperationType
subscription = Text -> Parser Text
string Text
"subscription" Parser Text
-> Parser Text OperationType -> Parser Text OperationType
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> OperationType -> Parser Text OperationType
forall (f :: * -> *) a. Applicative f => a -> f a
pure OperationType
Subscription

    (OperationType
operationType,  Maybe Text
name, [VariableDefinition]
variableDefinitions) <- (OperationType, Maybe Text, [VariableDefinition])
-> Parser Text (OperationType, Maybe Text, [VariableDefinition])
-> Parser Text (OperationType, Maybe Text, [VariableDefinition])
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option (OperationType
Query, Maybe Text
forall a. Maybe a
Nothing, []) do
        OperationType
operationType <- (Parser Text OperationType
query Parser Text OperationType
-> Parser Text OperationType -> Parser Text OperationType
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text OperationType
mutation Parser Text OperationType
-> Parser Text OperationType -> Parser Text OperationType
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text OperationType
subscription) Parser Text OperationType -> String -> Parser Text OperationType
forall i a. Parser i a -> String -> Parser i a
<?> String
"OperationType"
        Parser ()
skipSpace
        Maybe Text
name <- Maybe Text -> Parser Text (Maybe Text) -> Parser Text (Maybe Text)
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Maybe Text
forall a. Maybe a
Nothing (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Parser Text -> Parser Text (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
parseName)
        Parser ()
skipSpace
        [VariableDefinition]
variableDefinitions <- [VariableDefinition]
-> Parser Text [VariableDefinition]
-> Parser Text [VariableDefinition]
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option [] Parser Text [VariableDefinition]
parseVariableDefinitions
        (OperationType, Maybe Text, [VariableDefinition])
-> Parser Text (OperationType, Maybe Text, [VariableDefinition])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OperationType
operationType, Maybe Text
name, [VariableDefinition]
variableDefinitions)

    [Selection]
selectionSet <- Parser [Selection]
parseSelectionSet
    Definition -> Parser Text Definition
forall (f :: * -> *) a. Applicative f => a -> f a
pure ExecutableDefinition :: OperationDefinition -> Definition
ExecutableDefinition { $sel:operation:ExecutableDefinition :: OperationDefinition
operation = OperationDefinition :: OperationType
-> Maybe Text
-> [Selection]
-> [VariableDefinition]
-> OperationDefinition
OperationDefinition { OperationType
$sel:operationType:OperationDefinition :: OperationType
operationType :: OperationType
operationType, Maybe Text
$sel:name:OperationDefinition :: Maybe Text
name :: Maybe Text
name, [Selection]
$sel:selectionSet:OperationDefinition :: [Selection]
selectionSet :: [Selection]
selectionSet, [VariableDefinition]
$sel:variableDefinitions:OperationDefinition :: [VariableDefinition]
variableDefinitions :: [VariableDefinition]
variableDefinitions } }

parseFragmentDefinition :: Parser Definition
parseFragmentDefinition :: Parser Text Definition
parseFragmentDefinition = do
    Text -> Parser Text
string Text
"fragment"
    Parser ()
skipSpace
    Text
name <- Parser Text
parseName
    Parser ()
skipSpace
    [Selection]
selectionSet <- Parser [Selection]
parseSelectionSet
    Definition -> Parser Text Definition
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Fragment -> Definition
FragmentDefinition Fragment :: Text -> [Selection] -> Fragment
Fragment { Text
$sel:name:Fragment :: Text
name :: Text
name, [Selection]
$sel:selectionSet:Fragment :: [Selection]
selectionSet :: [Selection]
selectionSet })


parseVariableDefinitions :: Parser [VariableDefinition]
parseVariableDefinitions :: Parser Text [VariableDefinition]
parseVariableDefinitions = do
    Char -> Parser Char
char Char
'('
    Parser ()
skipSpace
    [VariableDefinition]
variableDefinitions <- Parser VariableDefinition
parseVariableDefinition Parser VariableDefinition
-> Parser () -> Parser Text [VariableDefinition]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` (Char -> Parser Char
char Char
',' Parser Char -> Parser () -> Parser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
skipSpace)
    Parser ()
skipSpace
    Char -> Parser Char
char Char
')'
    Parser ()
skipSpace
    [VariableDefinition] -> Parser Text [VariableDefinition]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [VariableDefinition]
variableDefinitions

parseVariableDefinition :: Parser VariableDefinition
parseVariableDefinition :: Parser VariableDefinition
parseVariableDefinition = do
    Text
variableName <- Parser Text
parseVariableName
    Parser ()
skipSpace
    Char -> Parser Char
char Char
':'
    Parser ()
skipSpace
    Type
variableType <- Parser Type
parseType
    VariableDefinition -> Parser VariableDefinition
forall (f :: * -> *) a. Applicative f => a -> f a
pure VariableDefinition :: Text -> Type -> VariableDefinition
VariableDefinition { Text
$sel:variableName:VariableDefinition :: Text
variableName :: Text
variableName, Type
$sel:variableType:VariableDefinition :: Type
variableType :: Type
variableType }

parseSelectionSet :: Parser [Selection]
parseSelectionSet :: Parser [Selection]
parseSelectionSet = (do
    Char -> Parser Char
char Char
'{'
    Parser ()
skipSpace
    [Selection]
selectionSet <- Parser Text Selection -> Parser [Selection]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many1 Parser Text Selection
parseSelection
    Parser ()
skipSpace
    Char -> Parser Char
char Char
'}'
    Parser ()
skipSpace
    [Selection] -> Parser [Selection]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Selection]
selectionSet) Parser [Selection] -> String -> Parser [Selection]
forall i a. Parser i a -> String -> Parser i a
<?> String
"selectionSet"

parseSelection :: Parser Selection
parseSelection :: Parser Text Selection
parseSelection = Parser Text Selection
parseField Parser Text Selection
-> Parser Text Selection -> Parser Text Selection
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser Text Selection
parseFragmentSpread

parseField :: Parser Selection
parseField :: Parser Text Selection
parseField = (do
    Text
nameOrAlias <- Parser Text
parseName
    Parser ()
skipSpace
    Maybe Text
name' <- Maybe Text -> Parser Text (Maybe Text) -> Parser Text (Maybe Text)
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Maybe Text
forall a. Maybe a
Nothing do
        Char -> Parser Char
char Char
':'
        Parser ()
skipSpace
        Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Parser Text -> Parser Text (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
parseName

    let alias :: Maybe Text
alias = case Maybe Text
name' of
            Just Text
_ -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
nameOrAlias
            Maybe Text
Nothing -> Maybe Text
forall a. Maybe a
Nothing
    let name :: Text
name = case Maybe Text
name' of
            Just Text
name -> Text
name
            Maybe Text
Nothing -> Text
nameOrAlias

    Parser ()
skipSpace

    [Argument]
arguments <- [Argument] -> Parser Text [Argument] -> Parser Text [Argument]
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option [] Parser Text [Argument]
parseArguments

    [Selection]
selectionSet <- [Selection] -> Parser [Selection] -> Parser [Selection]
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option [] Parser [Selection]
parseSelectionSet
    Selection -> Parser Text Selection
forall (f :: * -> *) a. Applicative f => a -> f a
pure Field :: Maybe Text
-> Text -> [Argument] -> Directives -> [Selection] -> Selection
Field { Maybe Text
$sel:alias:Field :: Maybe Text
alias :: Maybe Text
alias, Text
$sel:name:Field :: Text
name :: Text
name, [Argument]
$sel:arguments:Field :: [Argument]
arguments :: [Argument]
arguments, $sel:directives:Field :: Directives
directives = [], [Selection]
$sel:selectionSet:Field :: [Selection]
selectionSet :: [Selection]
selectionSet }
    ) Parser Text Selection -> String -> Parser Text Selection
forall i a. Parser i a -> String -> Parser i a
<?> String
"field"

parseFragmentSpread :: Parser Selection
parseFragmentSpread :: Parser Text Selection
parseFragmentSpread = (do
    Text -> Parser Text
string Text
"..."
    Text
fragmentName <- Parser Text
parseName
    Parser ()
skipSpace
    Selection -> Parser Text Selection
forall (f :: * -> *) a. Applicative f => a -> f a
pure FragmentSpread :: Text -> Selection
FragmentSpread { Text
$sel:fragmentName:Field :: Text
fragmentName :: Text
fragmentName }
    ) Parser Text Selection -> String -> Parser Text Selection
forall i a. Parser i a -> String -> Parser i a
<?> String
"FragmentSpread"

parseArguments :: Parser [Argument]
parseArguments :: Parser Text [Argument]
parseArguments = do
    Char -> Parser Char
char Char
'('
    Parser ()
skipSpace
    [Argument]
arguments <- Parser Argument
parseArgument Parser Argument -> Parser () -> Parser Text [Argument]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` (Char -> Parser Char
char Char
',' Parser Char -> Parser () -> Parser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
skipSpace)
    Parser ()
skipSpace
    Char -> Parser Char
char Char
')'
    Parser ()
skipSpace
    [Argument] -> Parser Text [Argument]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Argument]
arguments

parseArgument :: Parser Argument
parseArgument :: Parser Argument
parseArgument = do
    Text
argumentName <- Parser Text
parseName
    Parser ()
skipSpace
    Char -> Parser Char
char Char
':'
    Parser ()
skipSpace
    Value
argumentValue <- Parser Value
parseValue
    Argument -> Parser Argument
forall (f :: * -> *) a. Applicative f => a -> f a
pure Argument :: Text -> Value -> Argument
Argument { Text
$sel:argumentName:Argument :: Text
argumentName :: Text
argumentName, Value
$sel:argumentValue:Argument :: Value
argumentValue :: Value
argumentValue }

parseValue :: Parser Value
parseValue :: Parser Value
parseValue = do
    let variable :: Parser Value
variable = Text -> Value
Variable (Text -> Value) -> Parser Text -> Parser Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
parseVariableName
    let object :: Parser Value
object = do
            Char -> Parser Char
char Char
'{'
            Parser ()
skipSpace
            [Argument]
values <- Parser Argument
parseArgument Parser Argument -> Parser () -> Parser Text [Argument]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` (Char -> Parser Char
char Char
',' Parser Char -> Parser () -> Parser ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ()
skipSpace)
            Parser ()
skipSpace
            Char -> Parser Char
char Char
'}'
            Parser ()
skipSpace

            let HashMap Text Value
hashMap :: HashMap.HashMap Text Value = [Argument]
values
                    [Argument] -> ([Argument] -> [(Text, Value)]) -> [(Text, Value)]
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> (Argument -> (Text, Value)) -> [Argument] -> [(Text, Value)]
forall a b. (a -> b) -> [a] -> [b]
map (\Argument { Text
argumentName :: Text
$sel:argumentName:Argument :: Argument -> Text
argumentName, Value
argumentValue :: Value
$sel:argumentValue:Argument :: Argument -> Value
argumentValue } -> (Text
argumentName, Value
argumentValue))
                    [(Text, Value)]
-> ([(Text, Value)] -> HashMap Text Value) -> HashMap Text Value
forall t1 t2. t1 -> (t1 -> t2) -> t2
|> [(Text, Value)] -> HashMap Text Value
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList
            Value -> Parser Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap Text Value -> Value
ObjectValue HashMap Text Value
hashMap)
    let string :: Parser Value
string = do
            Char -> Parser Char
char Char
'"'
            Text
body <- (Char -> Bool) -> Parser Text
takeTill (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\"')
            Char -> Parser Char
char Char
'"'
            Parser ()
skipSpace
            Value -> Parser Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Value
StringValue Text
body)
    (Parser Value
variable Parser Value -> String -> Parser Value
forall i a. Parser i a -> String -> Parser i a
<?> String
"Variable") Parser Value -> Parser Value -> Parser Value
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser Value
object Parser Value -> String -> Parser Value
forall i a. Parser i a -> String -> Parser i a
<?> String
"Object") Parser Value -> Parser Value -> Parser Value
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Parser Value
string Parser Value -> String -> Parser Value
forall i a. Parser i a -> String -> Parser i a
<?> String
"String")

parseName :: Parser Text
parseName :: Parser Text
parseName = (Char -> Bool) -> Parser Text
takeWhile1 Char -> Bool
isNameChar Parser Text -> String -> Parser Text
forall i a. Parser i a -> String -> Parser i a
<?> String
"Name"
    where
        isNameChar :: Char -> Bool
        isNameChar :: Char -> Bool
isNameChar !Char
char = (Char
char Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'A' Bool -> Bool -> Bool
&& Char
char Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'Z') Bool -> Bool -> Bool
|| (Char
char Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'a' Bool -> Bool -> Bool
&& Char
char Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z') Bool -> Bool -> Bool
|| (Char
char Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_') Bool -> Bool -> Bool
|| (Char
char Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
>= Char
'0' Bool -> Bool -> Bool
&& Char
char Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9')

parseVariableName :: Parser Text
parseVariableName :: Parser Text
parseVariableName = (Char -> Parser Char
char Char
'$' Parser Char -> Parser Text -> Parser Text
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser Text
parseName) Parser Text -> String -> Parser Text
forall i a. Parser i a -> String -> Parser i a
<?> String
"Variable"

parseType :: Parser Type
parseType :: Parser Type
parseType = do
    Type
inner <- Parser Type
parseNamedType
    Type -> Parser Type -> Parser Type
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Type
inner do
        Text -> Parser Text
string Text
"!"
        Type -> Parser Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Type
NonNullType Type
inner)

parseNamedType :: Parser Type
parseNamedType :: Parser Type
parseNamedType = Text -> Type
NamedType (Text -> Type) -> Parser Text -> Parser Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
parseName