aboutsummaryrefslogtreecommitdiff
path: root/src/Language
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language')
-rw-r--r--src/Language/GraphQL.hs45
-rw-r--r--src/Language/GraphQL/AST/Document.hs8
-rw-r--r--src/Language/GraphQL/AST/Parser.hs4
-rw-r--r--src/Language/GraphQL/Execute.hs51
4 files changed, 83 insertions, 25 deletions
diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs
index 20bb123..b64cf42 100644
--- a/src/Language/GraphQL.hs
+++ b/src/Language/GraphQL.hs
@@ -1,9 +1,8 @@
{-# LANGUAGE CPP #-}
-
-#ifdef WITH_JSON
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
+#ifdef WITH_JSON
-- | This module provides the functions to parse and execute @GraphQL@ queries.
module Language.GraphQL
( graphql
@@ -79,6 +78,46 @@ graphqlSubs schema operationName variableValues document' =
#else
-- | This module provides the functions to parse and execute @GraphQL@ queries.
module Language.GraphQL
- (
+ ( graphql
) where
+
+import Control.Monad.Catch (MonadCatch)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.Sequence as Seq
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Language.GraphQL.AST as Full
+import Language.GraphQL.Error
+import Language.GraphQL.Execute
+import qualified Language.GraphQL.Validate as Validate
+import Language.GraphQL.Type.Schema (Schema)
+import Prelude hiding (null)
+import Text.Megaparsec (parse)
+
+-- | If the text parses correctly as a @GraphQL@ query the query is
+-- executed using the given 'Schema'.
+--
+-- An operation name can be given if the document contains multiple operations.
+graphql :: (MonadCatch m, VariableValue a, Serialize b)
+ => Schema m -- ^ Resolvers.
+ -> Maybe Text -- ^ Operation name.
+ -> HashMap Full.Name a -- ^ Variable substitution function.
+ -> Text -- ^ Text representing a @GraphQL@ request document.
+ -> m (Either (ResponseEventStream m b) (Response b)) -- ^ Response.
+graphql schema operationName variableValues document' =
+ case parse Full.document "" document' of
+ Left errorBundle -> pure <$> parseError errorBundle
+ Right parsed ->
+ case validate parsed of
+ Seq.Empty -> execute schema operationName variableValues parsed
+ errors -> pure $ pure
+ $ Response null
+ $ fromValidationError <$> errors
+ where
+ validate = Validate.document schema Validate.specifiedRules
+ fromValidationError Validate.Error{..} = Error
+ { message = Text.pack message
+ , locations = locations
+ , path = []
+ }
#endif
diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs
index a698d2e..ea640df 100644
--- a/src/Language/GraphQL/AST/Document.hs
+++ b/src/Language/GraphQL/AST/Document.hs
@@ -49,6 +49,8 @@ module Language.GraphQL.AST.Document
, Value(..)
, VariableDefinition(..)
, escape
+ , showVariableName
+ , showVariable
) where
import Data.Char (ord)
@@ -339,6 +341,12 @@ data VariableDefinition =
VariableDefinition Name Type (Maybe (Node ConstValue)) Location
deriving (Eq, Show)
+showVariableName :: VariableDefinition -> String
+showVariableName (VariableDefinition name _ _ _) = "$" <> Text.unpack name
+
+showVariable :: VariableDefinition -> String
+showVariable var@(VariableDefinition _ type' _ _) = showVariableName var <> ":" <> " " <> show type'
+
-- ** Type References
-- | Type representation.
diff --git a/src/Language/GraphQL/AST/Parser.hs b/src/Language/GraphQL/AST/Parser.hs
index 19251ab..e19823c 100644
--- a/src/Language/GraphQL/AST/Parser.hs
+++ b/src/Language/GraphQL/AST/Parser.hs
@@ -450,8 +450,8 @@ value = Full.Variable <$> variable
<|> Full.Null <$ nullValue
<|> Full.String <$> stringValue
<|> Full.Enum <$> try enumValue
- <|> Full.List <$> brackets (some $ valueNode value)
- <|> Full.Object <$> braces (some $ objectField $ valueNode value)
+ <|> Full.List <$> brackets (many $ valueNode value)
+ <|> Full.Object <$> braces (many $ objectField $ valueNode value)
<?> "Value"
constValue :: Parser Full.ConstValue
diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs
index 476cc50..5ceb616 100644
--- a/src/Language/GraphQL/Execute.hs
+++ b/src/Language/GraphQL/Execute.hs
@@ -61,6 +61,7 @@ import Language.GraphQL.Error
, ResponseEventStream
)
import Prelude hiding (null)
+import Language.GraphQL.AST.Document (showVariableName)
newtype ExecutorT m a = ExecutorT
{ runExecutorT :: ReaderT (HashMap Full.Name (Type m)) (WriterT (Seq Error) m) a
@@ -190,32 +191,42 @@ data QueryError
tell :: Monad m => Seq Error -> ExecutorT m ()
tell = ExecutorT . lift . Writer.tell
+operationNameErrorText :: Text
+operationNameErrorText = Text.unlines
+ [ "Named operations must be provided with the name of the desired operation."
+ , "See https://spec.graphql.org/June2018/#sec-Language.Document description."
+ ]
+
queryError :: QueryError -> Error
queryError OperationNameRequired =
- Error{ message = "Operation name is required.", locations = [], path = [] }
+ let queryErrorMessage = "Operation name is required. " <> operationNameErrorText
+ in Error{ message = queryErrorMessage, locations = [], path = [] }
queryError (OperationNotFound operationName) =
- let queryErrorMessage = Text.concat
- [ "Operation \""
- , Text.pack operationName
- , "\" not found."
+ let queryErrorMessage = Text.unlines
+ [ Text.concat
+ [ "Operation \""
+ , Text.pack operationName
+ , "\" is not found in the named operations you've provided. "
+ ]
+ , operationNameErrorText
]
in Error{ message = queryErrorMessage, locations = [], path = [] }
queryError (CoercionError variableDefinition) =
- let Full.VariableDefinition variableName _ _ location = variableDefinition
+ let (Full.VariableDefinition _ _ _ location) = variableDefinition
queryErrorMessage = Text.concat
- [ "Failed to coerce the variable \""
- , variableName
- , "\"."
+ [ "Failed to coerce the variable "
+ , Text.pack $ Full.showVariable variableDefinition
+ , "."
]
in Error{ message = queryErrorMessage, locations = [location], path = [] }
queryError (UnknownInputType variableDefinition) =
- let Full.VariableDefinition variableName variableTypeName _ location = variableDefinition
+ let Full.VariableDefinition _ variableTypeName _ location = variableDefinition
queryErrorMessage = Text.concat
- [ "Variable \""
- , variableName
- , "\" has unknown type \""
+ [ "Variable "
+ , Text.pack $ showVariableName variableDefinition
+ , " has unknown type "
, Text.pack $ show variableTypeName
- , "\"."
+ , "."
]
in Error{ message = queryErrorMessage, locations = [location], path = [] }
@@ -375,6 +386,7 @@ executeField objectValue fields (viewResolver -> resolverPair) errorPath =
, Handler (resolverHandler fieldLocation)
]
where
+ fieldErrorPath = fieldsSegment fields : errorPath
inputCoercionHandler :: (MonadCatch m, Serialize a)
=> Full.Location
-> InputCoercionException
@@ -402,17 +414,16 @@ executeField objectValue fields (viewResolver -> resolverPair) errorPath =
then throwM e
else returnError newError
exceptionHandler errorLocation e =
- let newPath = fieldsSegment fields : errorPath
- newError = constructError e errorLocation newPath
+ let newError = constructError e errorLocation fieldErrorPath
in if Out.isNonNullType fieldType
- then throwM $ FieldException errorLocation newPath e
+ then throwM $ FieldException errorLocation fieldErrorPath e
else returnError newError
returnError newError = tell (Seq.singleton newError) >> pure null
go fieldName inputArguments = do
argumentValues <- coerceArgumentValues argumentTypes inputArguments
resolvedValue <-
resolveFieldValue resolveFunction objectValue fieldName argumentValues
- completeValue fieldType fields errorPath resolvedValue
+ completeValue fieldType fields fieldErrorPath resolvedValue
(resolverField, resolveFunction) = resolverPair
Out.Field _ fieldType argumentTypes = resolverField
@@ -445,6 +456,7 @@ resolveAbstractType abstractType values'
_ -> pure Nothing
| otherwise = pure Nothing
+-- https://spec.graphql.org/October2021/#sec-Value-Completion
completeValue :: (MonadCatch m, Serialize a)
=> Out.Type m
-> NonEmpty (Transform.Field m)
@@ -476,8 +488,7 @@ completeValue outputType@(Out.EnumBaseType enumType) _ _ (Type.Enum enum) =
$ ValueCompletionException (show outputType)
$ Type.Enum enum
completeValue (Out.ObjectBaseType objectType) fields errorPath result
- = executeSelectionSet (mergeSelectionSets fields) objectType result
- $ fieldsSegment fields : errorPath
+ = executeSelectionSet (mergeSelectionSets fields) objectType result errorPath
completeValue outputType@(Out.InterfaceBaseType interfaceType) fields errorPath result
| Type.Object objectMap <- result = do
let abstractType = Type.Internal.AbstractInterfaceType interfaceType
generated by cgit v1.2.3 (git 2.26.2) at 2026-10-02 08:51:57 +0000