From 7c0b0ace4dacbb581669f88b83b9643a83fc797a Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Wed, 7 Oct 2020 05:24:51 +0200 Subject: [PATCH] Collect types once the schema is created --- CHANGELOG.md | 6 +- README.md | 2 +- docs/tutorial/tutorial.lhs | 6 +- src/Language/GraphQL/AST/Encoder.hs | 10 +- src/Language/GraphQL/Error.hs | 10 +- src/Language/GraphQL/Execute/Execution.hs | 15 +- src/Language/GraphQL/Execute/Transform.hs | 15 +- src/Language/GraphQL/Type.hs | 2 +- src/Language/GraphQL/Type/Internal.hs | 169 ++++++----- src/Language/GraphQL/Type/Schema.hs | 183 +++++++++--- src/Language/GraphQL/Validate.hs | 64 +---- src/Language/GraphQL/Validate/Rules.hs | 303 ++++++++++---------- src/Language/GraphQL/Validate/Validation.hs | 4 - stack.yaml | 2 +- tests/Language/GraphQL/ExecuteSpec.hs | 7 +- tests/Language/GraphQL/ValidateSpec.hs | 7 +- tests/Test/DirectiveSpec.hs | 2 +- tests/Test/FragmentSpec.hs | 2 +- tests/Test/RootOperationSpec.hs | 9 +- tests/Test/StarWars/Schema.hs | 2 +- 20 files changed, 427 insertions(+), 393 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index a7e9c41..4fc2753 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -23,7 +23,9 @@ and this project adheres to the path without executing the query. - `Error.Error`: `path` added. It is currently always empty. - `Validate.Validation.Path` was moved to `Error`. -- `Type.Schema.Schema` gets an additional field, `Schema.directives`. +- `Type.Schema.Schema`: data constructor is hidden, fields are accessible with + freestanding functions: `query`, `mutation`, `subscription`, `directives` and + `types`. ### Added - `Validate.Validation.Rule` constructors: @@ -62,7 +64,7 @@ and this project adheres to - `Type.In.Arguments`: Type alias for an argument map. - `Type.Schema.Directive` and `Type.Schema.Directives` are directive definition representation. -- `Type.Schema.schema`: Shortcut for creating a schema. +- `Type.Schema.schema`: Schema constructor. ### Fixed - Collecting existing types from the schema considers subscriptions. diff --git a/README.md b/README.md index 32c55ce..8643f46 100644 --- a/README.md +++ b/README.md @@ -75,7 +75,7 @@ import qualified Language.GraphQL.Type.Out as Out -- GraphQL supports 3 kinds of operations: queries, mutations and subscriptions. -- Our first schema supports only queries. citeSchema :: Schema IO -citeSchema = schema queryType +citeSchema = schema queryType Nothing Nothing mempty -- GraphQL distinguishes between input and output types. Input types are field -- argument types and they are defined in Language.GraphQL.Type.In. Output types diff --git a/docs/tutorial/tutorial.lhs b/docs/tutorial/tutorial.lhs index 6a68e35..1024251 100644 --- a/docs/tutorial/tutorial.lhs +++ b/docs/tutorial/tutorial.lhs @@ -39,7 +39,7 @@ Now, as our first example, we are going to look at the example from First we build a GraphQL schema. > schema1 :: Schema IO -> schema1 = schema queryType +> schema1 = schema queryType Nothing Nothing mempty > > queryType :: ObjectType IO > queryType = ObjectType "Query" Nothing [] @@ -76,7 +76,7 @@ This runs the query by fetching the one field defined, returning For this example, we're going to be using time. > schema2 :: Schema IO -> schema2 = schema queryType2 +> schema2 = schema queryType2 Nothing Nothing mempty > > queryType2 :: ObjectType IO > queryType2 = ObjectType "Query" Nothing [] @@ -113,7 +113,7 @@ This runs the query, returning the current time Now that we have two resolvers, we can define a schema which uses them both. > schema3 :: Schema IO -> schema3 = schema queryType3 +> schema3 = schema queryType3 Nothing Nothing mempty > > queryType3 :: ObjectType IO > queryType3 = ObjectType "Query" Nothing [] $ HashMap.fromList diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs index 9b3eea3..9ba51b8 100644 --- a/src/Language/GraphQL/AST/Encoder.hs +++ b/src/Language/GraphQL/AST/Encoder.hs @@ -56,7 +56,7 @@ document formatter defs definition formatter executableDefinition' : acc executableDefinition _ acc = acc --- | Converts a t'ExecutableDefinition' into a string. +-- | Converts a t'Full.ExecutableDefinition' into a string. definition :: Formatter -> Full.ExecutableDefinition -> Lazy.Text definition formatter x | Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n' @@ -67,7 +67,7 @@ definition formatter x encodeDefinition (Full.DefinitionFragment fragment) = fragmentDefinition formatter fragment --- | Converts a 'OperationDefinition into a string. +-- | Converts a 'Full.OperationDefinition into a string. operationDefinition :: Formatter -> Full.OperationDefinition -> Lazy.Text operationDefinition formatter = \case Full.SelectionSet sels _ -> selectionSet formatter sels @@ -192,7 +192,7 @@ fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels _) -- * Miscellaneous --- | Converts a 'Directive' into a string. +-- | Converts a 'Full.Directive' into a string. directive :: Formatter -> Full.Directive -> Lazy.Text directive formatter (Full.Directive name args _) = "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) args @@ -201,7 +201,7 @@ directives :: Formatter -> [Full.Directive] -> Lazy.Text directives Minified = spaces (directive Minified) directives formatter = Lazy.Text.cons ' ' . spaces (directive formatter) --- | Converts a 'Value' into a string. +-- | Converts a 'Full.Value' into a string. value :: Formatter -> Full.Value -> Lazy.Text value _ (Full.Variable x) = variable x value _ (Full.Int x) = Builder.toLazyText $ decimal x @@ -296,7 +296,7 @@ objectField :: Formatter -> Full.ObjectField Full.Value -> Lazy.Text objectField formatter (Full.ObjectField name (Full.Node value' _) _) = Lazy.Text.fromStrict name <> colon formatter <> value formatter value' --- | Converts a 'Type' a type into a string. +-- | Converts a 'Full.Type' a type into a string. type' :: Full.Type -> Lazy.Text type' (Full.TypeNamed x) = Lazy.Text.fromStrict x type' (Full.TypeList x) = listType x diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs index 4992169..b084c78 100644 --- a/src/Language/GraphQL/Error.hs +++ b/src/Language/GraphQL/Error.hs @@ -5,8 +5,7 @@ -- | Error handling. module Language.GraphQL.Error - ( parseError - , CollectErrsT + ( CollectErrsT , Error(..) , Path(..) , Resolution(..) @@ -15,6 +14,7 @@ module Language.GraphQL.Error , ResponseEventStream , addErr , addErrMsg + , parseError , runCollectErrs , singleError ) where @@ -29,7 +29,7 @@ import Data.Text (Text) import qualified Data.Text as Text import Language.GraphQL.AST (Location(..), Name) import Language.GraphQL.Execute.Coerce -import Language.GraphQL.Type.Schema +import qualified Language.GraphQL.Type.Schema as Schema import Prelude hiding (null) import Text.Megaparsec ( ParseErrorBundle(..) @@ -44,7 +44,7 @@ import Text.Megaparsec -- | Executor context. data Resolution m = Resolution { errors :: Seq Error - , types :: HashMap Name (Type m) + , types :: HashMap Name (Schema.Type m) } -- | Wraps a parse error into a list of errors. @@ -129,7 +129,7 @@ instance Exception ResolverException -- | Runs the given query computation, but collects the errors into an error -- list, which is then sent back with the data. runCollectErrs :: (Monad m, Serialize a) - => HashMap Name (Type m) + => HashMap Name (Schema.Type m) -> CollectErrsT m a -> m (Response a) runCollectErrs types' res = do diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs index 3caa7f0..9d588ca 100644 --- a/src/Language/GraphQL/Execute/Execution.hs +++ b/src/Language/GraphQL/Execute/Execution.hs @@ -27,8 +27,7 @@ import qualified Language.GraphQL.Execute.Transform as Transform import qualified Language.GraphQL.Type as Type import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out -import Language.GraphQL.Type.Internal -import Language.GraphQL.Type.Schema +import qualified Language.GraphQL.Type.Internal as Internal import Prelude hiding (null) resolveFieldValue :: MonadCatch m @@ -60,7 +59,7 @@ collectFields objectType = foldl forEach Map.empty in Map.insertWith (<>) responseKey (field :| []) groupedFields forEach groupedFields (Transform.SelectionFragment selectionFragment) | Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment - , doesFragmentTypeApply fragmentType objectType = + , Internal.doesFragmentTypeApply fragmentType objectType = let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet | otherwise = groupedFields @@ -69,15 +68,15 @@ aliasOrName :: forall m. Transform.Field m -> Name aliasOrName (Transform.Field alias name _ _) = fromMaybe name alias resolveAbstractType :: Monad m - => AbstractType m + => Internal.AbstractType m -> Type.Subs -> CollectErrsT m (Maybe (Out.ObjectType m)) resolveAbstractType abstractType values' | Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do types' <- gets types case HashMap.lookup typeName types' of - Just (ObjectType objectType) -> - if instanceOf objectType abstractType + Just (Internal.ObjectType objectType) -> + if Internal.instanceOf objectType abstractType then pure $ Just objectType else pure Nothing _ -> pure Nothing @@ -129,7 +128,7 @@ completeValue (Out.ObjectBaseType objectType) fields result = executeSelectionSet result objectType $ mergeSelectionSets fields completeValue (Out.InterfaceBaseType interfaceType) fields result | Type.Object objectMap <- result = do - let abstractType = AbstractInterfaceType interfaceType + let abstractType = Internal.AbstractInterfaceType interfaceType concreteType <- resolveAbstractType abstractType objectMap case concreteType of Just objectType -> executeSelectionSet result objectType @@ -137,7 +136,7 @@ completeValue (Out.InterfaceBaseType interfaceType) fields result Nothing -> addErrMsg "Interface value completion failed." completeValue (Out.UnionBaseType unionType) fields result | Type.Object objectMap <- result = do - let abstractType = AbstractUnionType unionType + let abstractType = Internal.AbstractUnionType unionType concreteType <- resolveAbstractType abstractType objectMap case concreteType of Just objectType -> executeSelectionSet result objectType diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index a8a2ae2..010899b 100644 --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -47,9 +47,8 @@ import Language.GraphQL.AST (Name) import qualified Language.GraphQL.Execute.Coerce as Coerce import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type as Type -import Language.GraphQL.Type.Internal +import qualified Language.GraphQL.Type.Internal as Type import qualified Language.GraphQL.Type.Out as Out -import Language.GraphQL.Type.Schema (Schema) import qualified Language.GraphQL.Type.Schema as Schema -- | Associates a fragment name with a list of 'Field's. @@ -64,7 +63,7 @@ type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition -- | Represents fragments and inline fragments. data Fragment m - = Fragment (CompositeType m) (Seq (Selection m)) + = Fragment (Type.CompositeType m) (Seq (Selection m)) -- | Single selection element. data Selection m @@ -154,7 +153,7 @@ coerceVariableValues types operationDefinition variableValues = let Full.VariableDefinition variableName variableTypeName defaultValue _ = variableDefinition let defaultValue' = constValue . Full.node <$> defaultValue - variableType <- lookupInputType variableTypeName types + variableType <- Type.lookupInputType variableTypeName types Coerce.matchFieldValues coerceVariableValue' @@ -185,13 +184,13 @@ constValue (Full.ConstObject o) = -- for query execution. document :: Coerce.VariableValue a => forall m - . Schema m + . Type.Schema m -> Maybe Full.Name -> HashMap Full.Name a -> Full.Document -> Either QueryError (Document m) document schema operationName subs ast = do - let referencedTypes = collectReferencedTypes schema + let referencedTypes = Schema.types schema (operations, fragmentTable) <- defragment ast chosenOperation <- getOperation operationName operations @@ -311,7 +310,7 @@ inlineFragment (Full.InlineFragment type' directives' selections _) = do Nothing -> pure $ Left fragmentSelectionSet Just typeName -> do types' <- gets types - case lookupTypeCondition typeName types' of + case Type.lookupTypeCondition typeName types' of Just typeCondition -> pure $ selectionFragment typeCondition fragmentSelectionSet Nothing -> pure $ Left mempty @@ -358,7 +357,7 @@ fragmentDefinition (Full.FragmentDefinition name type' _ selections _) = do fragmentSelection <- appendSelection selections types' <- gets types - case lookupTypeCondition type' types' of + case Type.lookupTypeCondition type' types' of Just compositeType -> do let newValue = Fragment compositeType fragmentSelection modify $ insertFragment newValue diff --git a/src/Language/GraphQL/Type.hs b/src/Language/GraphQL/Type.hs index fc4f0fc..3ed8bb9 100644 --- a/src/Language/GraphQL/Type.hs +++ b/src/Language/GraphQL/Type.hs @@ -21,6 +21,6 @@ module Language.GraphQL.Type ) where import Language.GraphQL.Type.Definition -import Language.GraphQL.Type.Schema (Schema(..), schema) +import Language.GraphQL.Type.Schema (Schema, schema) import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out diff --git a/src/Language/GraphQL/Type/Internal.hs b/src/Language/GraphQL/Type/Internal.hs index 2aea996..eb8489c 100644 --- a/src/Language/GraphQL/Type/Internal.hs +++ b/src/Language/GraphQL/Type/Internal.hs @@ -8,22 +8,80 @@ module Language.GraphQL.Type.Internal ( AbstractType(..) , CompositeType(..) - , collectReferencedTypes + , Directive(..) + , Directives + , Schema(..) + , Type(..) + , directives , doesFragmentTypeApply , instanceOf , lookupInputType , lookupTypeCondition , lookupTypeField + , mutation + , subscription + , query + , types ) where import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import Data.Text (Text) import qualified Language.GraphQL.AST as Full +import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation) import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out -import Language.GraphQL.Type.Schema (Schema) -import qualified Language.GraphQL.Type.Schema as Schema + +-- | These are all of the possible kinds of types. +data Type m + = ScalarType Definition.ScalarType + | EnumType Definition.EnumType + | ObjectType (Out.ObjectType m) + | InputObjectType In.InputObjectType + | InterfaceType (Out.InterfaceType m) + | UnionType (Out.UnionType m) + deriving Eq + +-- | Directive definition. +data Directive = Directive (Maybe Text) [DirectiveLocation] In.Arguments + +-- | Directive definitions. +type Directives = HashMap Full.Name Directive + +-- | A Schema is created by supplying the root types of each type of operation, +-- query and mutation (optional). A schema definition is then supplied to the +-- validator and executor. +-- +-- __Note:__ When the schema is constructed, by default only the types that +-- are reachable by traversing the root types are included, other types must +-- be explicitly referenced. +data Schema m = Schema + (Out.ObjectType m) + (Maybe (Out.ObjectType m)) + (Maybe (Out.ObjectType m)) + Directives + (HashMap Full.Name (Type m)) + +-- | Schema query type. +query :: forall m. Schema m -> Out.ObjectType m +query (Schema query' _ _ _ _) = query' + +-- | Schema mutation type. +mutation :: forall m. Schema m -> Maybe (Out.ObjectType m) +mutation (Schema _ mutation' _ _ _) = mutation' + +-- | Schema subscription type. +subscription :: forall m. Schema m -> Maybe (Out.ObjectType m) +subscription (Schema _ _ subscription' _ _) = subscription' + +-- | Schema directive definitions. +directives :: forall m. Schema m -> Directives +directives (Schema _ _ _ directives' _) = directives' + +-- | Types referenced by the schema. +types :: forall m. Schema m -> HashMap Full.Name (Type m) +types (Schema _ _ _ _ types') = types' -- | These types may describe the parent context of a selection set. data CompositeType m @@ -38,70 +96,6 @@ data AbstractType m | AbstractInterfaceType (Out.InterfaceType m) deriving Eq --- | Traverses the schema and finds all referenced types. -collectReferencedTypes :: forall m - . Schema m - -> HashMap Full.Name (Schema.Type m) -collectReferencedTypes schema = - let queryTypes = traverseObjectType (Schema.query schema) HashMap.empty - mutationTypes = maybe queryTypes (`traverseObjectType` queryTypes) - $ Schema.mutation schema - in maybe mutationTypes (`traverseObjectType` queryTypes) - $ Schema.subscription schema - where - collect traverser typeName element foundTypes - | HashMap.member typeName foundTypes = foundTypes - | otherwise = traverser $ HashMap.insert typeName element foundTypes - visitFields (Out.Field _ outputType arguments) foundTypes - = traverseOutputType outputType - $ foldr visitArguments foundTypes arguments - visitArguments (In.Argument _ inputType _) = traverseInputType inputType - visitInputFields (In.InputField _ inputType _) = traverseInputType inputType - getField (Out.ValueResolver field _) = field - getField (Out.EventStreamResolver field _ _) = field - traverseInputType (In.InputObjectBaseType objectType) = - let In.InputObjectType typeName _ inputFields = objectType - element = Schema.InputObjectType objectType - traverser = flip (foldr visitInputFields) inputFields - in collect traverser typeName element - traverseInputType (In.ListBaseType listType) = - traverseInputType listType - traverseInputType (In.ScalarBaseType scalarType) = - let Definition.ScalarType typeName _ = scalarType - in collect Prelude.id typeName (Schema.ScalarType scalarType) - traverseInputType (In.EnumBaseType enumType) = - let Definition.EnumType typeName _ _ = enumType - in collect Prelude.id typeName (Schema.EnumType enumType) - traverseOutputType (Out.ObjectBaseType objectType) = - traverseObjectType objectType - traverseOutputType (Out.InterfaceBaseType interfaceType) = - traverseInterfaceType interfaceType - traverseOutputType (Out.UnionBaseType unionType) = - let Out.UnionType typeName _ types = unionType - traverser = flip (foldr traverseObjectType) types - in collect traverser typeName (Schema.UnionType unionType) - traverseOutputType (Out.ListBaseType listType) = - traverseOutputType listType - traverseOutputType (Out.ScalarBaseType scalarType) = - let Definition.ScalarType typeName _ = scalarType - in collect Prelude.id typeName (Schema.ScalarType scalarType) - traverseOutputType (Out.EnumBaseType enumType) = - let Definition.EnumType typeName _ _ = enumType - in collect Prelude.id typeName (Schema.EnumType enumType) - traverseObjectType objectType foundTypes = - let Out.ObjectType typeName _ interfaces fields = objectType - element = Schema.ObjectType objectType - traverser = polymorphicTraverser interfaces (getField <$> fields) - in collect traverser typeName element foundTypes - traverseInterfaceType interfaceType foundTypes = - let Out.InterfaceType typeName _ interfaces fields = interfaceType - element = Schema.InterfaceType interfaceType - traverser = polymorphicTraverser interfaces fields - in collect traverser typeName element foundTypes - polymorphicTraverser interfaces fields - = flip (foldr visitFields) fields - . flip (foldr traverseInterfaceType) interfaces - doesFragmentTypeApply :: forall m . CompositeType m -> Out.ObjectType m @@ -128,45 +122,42 @@ instanceOf objectType (AbstractUnionType unionType) = lookupTypeCondition :: forall m . Full.Name - -> HashMap Full.Name (Schema.Type m) + -> HashMap Full.Name (Type m) -> Maybe (CompositeType m) lookupTypeCondition type' types' = case HashMap.lookup type' types' of - Just (Schema.ObjectType objectType) -> + Just (ObjectType objectType) -> Just $ CompositeObjectType objectType - Just (Schema.UnionType unionType) -> Just $ CompositeUnionType unionType - Just (Schema.InterfaceType interfaceType) -> + Just (UnionType unionType) -> Just $ CompositeUnionType unionType + Just (InterfaceType interfaceType) -> Just $ CompositeInterfaceType interfaceType _ -> Nothing -lookupInputType - :: Full.Type - -> HashMap.HashMap Full.Name (Schema.Type m) - -> Maybe In.Type -lookupInputType (Full.TypeNamed name) types = - case HashMap.lookup name types of - Just (Schema.ScalarType scalarType) -> +lookupInputType :: Full.Type -> HashMap Full.Name (Type m) -> Maybe In.Type +lookupInputType (Full.TypeNamed name) types' = + case HashMap.lookup name types' of + Just (ScalarType scalarType) -> Just $ In.NamedScalarType scalarType - Just (Schema.EnumType enumType) -> + Just (EnumType enumType) -> Just $ In.NamedEnumType enumType - Just (Schema.InputObjectType objectType) -> + Just (InputObjectType objectType) -> Just $ In.NamedInputObjectType objectType _ -> Nothing -lookupInputType (Full.TypeList list) types +lookupInputType (Full.TypeList list) types' = In.ListType - <$> lookupInputType list types -lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types = - case HashMap.lookup nonNull types of - Just (Schema.ScalarType scalarType) -> + <$> lookupInputType list types' +lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types' = + case HashMap.lookup nonNull types' of + Just (ScalarType scalarType) -> Just $ In.NonNullScalarType scalarType - Just (Schema.EnumType enumType) -> + Just (EnumType enumType) -> Just $ In.NonNullEnumType enumType - Just (Schema.InputObjectType objectType) -> + Just (InputObjectType objectType) -> Just $ In.NonNullInputObjectType objectType _ -> Nothing -lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types +lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types' = In.NonNullListType - <$> lookupInputType nonNull types + <$> lookupInputType nonNull types' lookupTypeField :: forall a. Full.Name -> Out.Type a -> Maybe (Out.Field a) lookupTypeField fieldName = \case diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs index 6562fb5..099c256 100644 --- a/src/Language/GraphQL/Type/Schema.hs +++ b/src/Language/GraphQL/Type/Schema.hs @@ -3,60 +3,153 @@ obtain one at https://mozilla.org/MPL/2.0/. -} {-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE OverloadedStrings #-} -- | This module provides a representation of a @GraphQL@ Schema in addition to -- functions for defining and manipulating schemas. module Language.GraphQL.Type.Schema - ( Directive(..) - , Directives - , Schema(..) - , Type(..) - , schema + ( schema + , module Language.GraphQL.Type.Internal ) where import Data.HashMap.Strict (HashMap) -import Data.Text (Text) -import qualified Language.GraphQL.AST.Document as Full -import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation) +import qualified Data.HashMap.Strict as HashMap +import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..)) +import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation +import qualified Language.GraphQL.AST as Full +import Language.GraphQL.Type.Internal + ( Directive(..) + , Directives + , Schema + , Type(..) + , directives + , mutation + , subscription + , query + , types + ) import qualified Language.GraphQL.Type.Definition as Definition +import qualified Language.GraphQL.Type.Internal as Internal import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out --- | These are all of the possible kinds of types. -data Type m - = ScalarType Definition.ScalarType - | EnumType Definition.EnumType - | ObjectType (Out.ObjectType m) - | InputObjectType In.InputObjectType - | InterfaceType (Out.InterfaceType m) - | UnionType (Out.UnionType m) - deriving Eq +-- | Schema constructor. +schema :: forall m + . Out.ObjectType m -- ^ Query type. + -> Maybe (Out.ObjectType m) -- ^ Mutation type. + -> Maybe (Out.ObjectType m) -- ^ Subscription type. + -> Directives -- ^ Directive definitions. + -> Schema m -- ^ Schema. +schema queryRoot mutationRoot subscriptionRoot directiveDefinitions = + Internal.Schema queryRoot mutationRoot subscriptionRoot allDirectives collectedTypes + where + collectedTypes = collectReferencedTypes queryRoot mutationRoot subscriptionRoot + allDirectives = HashMap.union directiveDefinitions defaultDirectives + defaultDirectives = HashMap.fromList + [ ("skip", skipDirective) + , ("include", includeDirective) + , ("deprecated", deprecatedDirective) + ] + includeDirective = + Directive includeDescription skipIncludeLocations includeArguments + includeArguments = HashMap.singleton "if" + $ In.Argument (Just "Included when true.") ifType Nothing + includeDescription = Just + "Directs the executor to include this field or fragment only when the \ + \`if` argument is true." + skipDirective = Directive skipDescription skipIncludeLocations skipArguments + skipArguments = HashMap.singleton "if" + $ In.Argument (Just "skipped when true.") ifType Nothing + ifType = In.NonNullScalarType Definition.boolean + skipDescription = Just + "Directs the executor to skip this field or fragment when the `if` \ + \argument is true." + skipIncludeLocations = + [ ExecutableDirectiveLocation DirectiveLocation.Field + , ExecutableDirectiveLocation DirectiveLocation.FragmentSpread + , ExecutableDirectiveLocation DirectiveLocation.InlineFragment + ] + deprecatedDirective = + Directive deprecatedDescription deprecatedLocations deprecatedArguments + reasonDescription = Just + "Explains why this element was deprecated, usually also including a \ + \suggestion for how to access supported similar data. Formatted using \ + \the Markdown syntax, as specified by \ + \[CommonMark](https://commonmark.org/).'" + deprecatedArguments = HashMap.singleton "reason" + $ In.Argument reasonDescription reasonType + $ Just "No longer supported" + reasonType = In.NamedScalarType Definition.string + deprecatedDescription = Just + "Marks an element of a GraphQL schema as no longer supported." + deprecatedLocations = + [ TypeSystemDirectiveLocation DirectiveLocation.FieldDefinition + , TypeSystemDirectiveLocation DirectiveLocation.ArgumentDefinition + , TypeSystemDirectiveLocation DirectiveLocation.InputFieldDefinition + , TypeSystemDirectiveLocation DirectiveLocation.EnumValue + ] --- | Directive definition. -data Directive = Directive (Maybe Text) [DirectiveLocation] In.Arguments - --- | Directive definitions. -type Directives = HashMap Full.Name Directive - --- | A Schema is created by supplying the root types of each type of operation, --- query and mutation (optional). A schema definition is then supplied to the --- validator and executor. --- --- __Note:__ When the schema is constructed, by default only the types that --- are reachable by traversing the root types are included, other types must --- be explicitly referenced. -data Schema m = Schema - { query :: Out.ObjectType m - , mutation :: Maybe (Out.ObjectType m) - , subscription :: Maybe (Out.ObjectType m) - , directives :: Directives - } - --- | Shortcut for creating a schema. -schema :: forall m. Out.ObjectType m -> Schema m -schema query' = Schema - { query = query' - , mutation = Nothing - , subscription = Nothing - , directives = mempty - } +-- | Traverses the schema and finds all referenced types. +collectReferencedTypes :: forall m + . Out.ObjectType m + -> Maybe (Out.ObjectType m) + -> Maybe (Out.ObjectType m) + -> HashMap Full.Name (Type m) +collectReferencedTypes queryRoot mutationRoot subscriptionRoot = + let queryTypes = traverseObjectType queryRoot HashMap.empty + mutationTypes = maybe queryTypes (`traverseObjectType` queryTypes) + mutationRoot + in maybe mutationTypes (`traverseObjectType` queryTypes) subscriptionRoot + where + collect traverser typeName element foundTypes + | HashMap.member typeName foundTypes = foundTypes + | otherwise = traverser $ HashMap.insert typeName element foundTypes + visitFields (Out.Field _ outputType arguments) foundTypes + = traverseOutputType outputType + $ foldr visitArguments foundTypes arguments + visitArguments (In.Argument _ inputType _) = traverseInputType inputType + visitInputFields (In.InputField _ inputType _) = traverseInputType inputType + getField (Out.ValueResolver field _) = field + getField (Out.EventStreamResolver field _ _) = field + traverseInputType (In.InputObjectBaseType objectType) = + let In.InputObjectType typeName _ inputFields = objectType + element = InputObjectType objectType + traverser = flip (foldr visitInputFields) inputFields + in collect traverser typeName element + traverseInputType (In.ListBaseType listType) = + traverseInputType listType + traverseInputType (In.ScalarBaseType scalarType) = + let Definition.ScalarType typeName _ = scalarType + in collect Prelude.id typeName (ScalarType scalarType) + traverseInputType (In.EnumBaseType enumType) = + let Definition.EnumType typeName _ _ = enumType + in collect Prelude.id typeName (EnumType enumType) + traverseOutputType (Out.ObjectBaseType objectType) = + traverseObjectType objectType + traverseOutputType (Out.InterfaceBaseType interfaceType) = + traverseInterfaceType interfaceType + traverseOutputType (Out.UnionBaseType unionType) = + let Out.UnionType typeName _ types' = unionType + traverser = flip (foldr traverseObjectType) types' + in collect traverser typeName (UnionType unionType) + traverseOutputType (Out.ListBaseType listType) = + traverseOutputType listType + traverseOutputType (Out.ScalarBaseType scalarType) = + let Definition.ScalarType typeName _ = scalarType + in collect Prelude.id typeName (ScalarType scalarType) + traverseOutputType (Out.EnumBaseType enumType) = + let Definition.EnumType typeName _ _ = enumType + in collect Prelude.id typeName (EnumType enumType) + traverseObjectType objectType foundTypes = + let Out.ObjectType typeName _ interfaces fields = objectType + element = ObjectType objectType + traverser = polymorphicTraverser interfaces (getField <$> fields) + in collect traverser typeName element foundTypes + traverseInterfaceType interfaceType foundTypes = + let Out.InterfaceType typeName _ interfaces fields = interfaceType + element = InterfaceType interfaceType + traverser = polymorphicTraverser interfaces fields + in collect traverser typeName element foundTypes + polymorphicTraverser interfaces fields + = flip (foldr visitFields) fields + . flip (foldr traverseInterfaceType) interfaces diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs index d904e8c..277f84d 100644 --- a/src/Language/GraphQL/Validate.hs +++ b/src/Language/GraphQL/Validate.hs @@ -25,8 +25,7 @@ import qualified Data.Sequence as Seq import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..)) import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation import qualified Language.GraphQL.AST.Document as Full -import Language.GraphQL.Type.Internal -import qualified Language.GraphQL.Type.Definition as Definition +import qualified Language.GraphQL.Type.Internal as Type import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out import Language.GraphQL.Type.Schema (Schema) @@ -57,55 +56,7 @@ document schema' rules' document' = context = Validation { Validation.ast = document' , Validation.schema = schema' - , Validation.types = collectReferencedTypes schema' - , Validation.directives = allDirectives } - allDirectives = - HashMap.union (Schema.directives schema') defaultDirectives - defaultDirectives = HashMap.fromList - [ ("skip", skipDirective) - , ("include", includeDirective) - , ("deprecated", deprecatedDirective) - ] - includeDirective = - Schema.Directive includeDescription skipIncludeLocations includeArguments - includeArguments = HashMap.singleton "if" - $ In.Argument (Just "Included when true.") ifType Nothing - includeDescription = Just - "Directs the executor to include this field or fragment only when the \ - \`if` argument is true." - skipDirective = - Schema.Directive skipDescription skipIncludeLocations skipArguments - skipArguments = HashMap.singleton "if" - $ In.Argument (Just "skipped when true.") ifType Nothing - ifType = In.NonNullScalarType Definition.boolean - skipDescription = Just - "Directs the executor to skip this field or fragment when the `if` \ - \argument is true." - skipIncludeLocations = - [ ExecutableDirectiveLocation DirectiveLocation.Field - , ExecutableDirectiveLocation DirectiveLocation.FragmentSpread - , ExecutableDirectiveLocation DirectiveLocation.InlineFragment - ] - deprecatedDirective = - Schema.Directive deprecatedDescription deprecatedLocations deprecatedArguments - reasonDescription = Just - "Explains why this element was deprecated, usually also including a \ - \suggestion for how to access supported similar data. Formatted using \ - \the Markdown syntax, as specified by \ - \[CommonMark](https://commonmark.org/).'" - deprecatedArguments = HashMap.singleton "reason" - $ In.Argument reasonDescription reasonType - $ Just "No longer supported" - reasonType = In.NamedScalarType Definition.string - deprecatedDescription = Just - "Marks an element of a GraphQL schema as no longer supported." - deprecatedLocations = - [ TypeSystemDirectiveLocation DirectiveLocation.FieldDefinition - , TypeSystemDirectiveLocation DirectiveLocation.ArgumentDefinition - , TypeSystemDirectiveLocation DirectiveLocation.InputFieldDefinition - , TypeSystemDirectiveLocation DirectiveLocation.EnumValue - ] reader = do rule' <- lift $ Seq.fromList rules' join $ lift $ foldr (definition rule' context) Seq.empty document' @@ -332,7 +283,7 @@ operationDefinition rule context operation where schema' = Validation.schema context queryRoot = Just $ Out.NamedObjectType $ Schema.query schema' - types' = Validation.types context + types' = Schema.types schema' typeToOut :: forall m. Schema.Type m -> Maybe (Out.Type m) typeToOut (Schema.ObjectType objectType) = @@ -349,7 +300,8 @@ variableDefinition :: forall m -> ApplyRule m Full.VariableDefinition variableDefinition context rule (Full.VariableDefinition _ typeName value' _) | Just defaultValue' <- value' - , variableType <- lookupInputType typeName $ Validation.types context = + , types <- Schema.types $ Validation.schema context + , variableType <- Type.lookupInputType typeName types = constValue rule variableType defaultValue' variableDefinition _ _ _ = mempty @@ -395,7 +347,7 @@ fragmentDefinition rule context definition' | Full.FragmentDefinition _ typeCondition directives' selections _ <- definition' = applyToChildren typeCondition directives' selections where - types' = Validation.types context + types' = Schema.types $ Validation.schema context applyToChildren typeCondition directives' selections = selectionSet context types' rule (lookupType' typeCondition) selections >< directives context rule fragmentDefinitionLocation directives' @@ -442,7 +394,7 @@ field context types' rule objectType field' = go field' typeFieldArguments (Out.Field _ _ argumentTypes) = argumentTypes applyToChildren fieldName = let Full.Field _ _ arguments' directives' selections _ = field' - typeField = objectType >>= lookupTypeField fieldName + typeField = objectType >>= Type.lookupTypeField fieldName argumentTypes = maybe mempty typeFieldArguments typeField in selectionSet context types' rule (typeFieldType <$> typeField) selections >< directives context rule fieldLocation directives' @@ -546,7 +498,9 @@ directive _ (Validation.ArgumentsRule _ argumentsRule) directive' = pure $ argumentsRule directive' directive context rule (Full.Directive directiveName arguments' _) = let argumentTypes = maybe HashMap.empty directiveArguments - $ HashMap.lookup directiveName (Validation.directives context) + $ HashMap.lookup directiveName + $ Schema.directives + $ Validation.schema context in arguments rule argumentTypes arguments' where directiveArguments (Schema.Directive _ _ argumentTypes) = argumentTypes diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs index 11f4482..b794b64 100644 --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -55,16 +55,17 @@ import Data.Sequence (Seq(..), (|>)) import qualified Data.Sequence as Seq import Data.Text (Text) import qualified Data.Text as Text -import Language.GraphQL.AST.Document +import qualified Language.GraphQL.AST.Document as Full import qualified Language.GraphQL.Type.Definition as Definition -import Language.GraphQL.Type.Internal +import qualified Language.GraphQL.Type.Internal as Type import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Schema as Schema import Language.GraphQL.Validate.Validation -- Local help type that contains a hash set to track visited fragments. -type ValidationState m a = StateT (HashSet Name) (ReaderT (Validation m) Seq) a +type ValidationState m a = + StateT (HashSet Full.Name) (ReaderT (Validation m) Seq) a -- | Default rules given in the specification. specifiedRules :: forall m. [Rule m] @@ -107,9 +108,9 @@ specifiedRules = -- | Definition must be OperationDefinition or FragmentDefinition. executableDefinitionsRule :: forall m. Rule m executableDefinitionsRule = DefinitionRule $ \case - ExecutableDefinition _ -> lift mempty - TypeSystemDefinition _ location' -> pure $ error' location' - TypeSystemExtension _ location' -> pure $ error' location' + Full.ExecutableDefinition _ -> lift mempty + Full.TypeSystemDefinition _ location' -> pure $ error' location' + Full.TypeSystemExtension _ location' -> pure $ error' location' where error' location' = Error { message = @@ -120,7 +121,7 @@ executableDefinitionsRule = DefinitionRule $ \case -- | Subscription operations must have exactly one root field. singleFieldSubscriptionsRule :: forall m. Rule m singleFieldSubscriptionsRule = OperationDefinitionRule $ \case - OperationDefinition Subscription name' _ _ rootFields location' -> do + Full.OperationDefinition Full.Subscription name' _ _ rootFields location' -> do groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty case HashSet.size groupedFieldSet of 1 -> lift mempty @@ -143,46 +144,46 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case "Anonymous Subscription must select only one top level field." collectFields selectionSet = foldM forEach HashSet.empty selectionSet forEach accumulator = \case - FieldSelection fieldSelection -> forField accumulator fieldSelection - FragmentSpreadSelection fragmentSelection -> + Full.FieldSelection fieldSelection -> forField accumulator fieldSelection + Full.FragmentSpreadSelection fragmentSelection -> forSpread accumulator fragmentSelection - InlineFragmentSelection fragmentSelection -> + Full.InlineFragmentSelection fragmentSelection -> forInline accumulator fragmentSelection - forField accumulator (Field alias name _ directives' _ _) + forField accumulator (Full.Field alias name _ directives' _ _) | any skip directives' = pure accumulator | Just aliasedName <- alias = pure $ HashSet.insert aliasedName accumulator | otherwise = pure $ HashSet.insert name accumulator - forSpread accumulator (FragmentSpread fragmentName directives' _) + forSpread accumulator (Full.FragmentSpread fragmentName directives' _) | any skip directives' = pure accumulator | otherwise = do inVisitetFragments <- gets $ HashSet.member fragmentName if inVisitetFragments then pure accumulator else collectFromSpread fragmentName accumulator - forInline accumulator (InlineFragment maybeType directives' selections _) + forInline accumulator (Full.InlineFragment maybeType directives' selections _) | any skip directives' = pure accumulator | Just typeCondition <- maybeType = collectFromFragment typeCondition selections accumulator | otherwise = HashSet.union accumulator <$> collectFields selections - skip (Directive "skip" [Argument "if" (Node argumentValue _) _] _) = - Boolean True == argumentValue - skip (Directive "include" [Argument "if" (Node argumentValue _) _] _) = - Boolean False == argumentValue + skip (Full.Directive "skip" [Full.Argument "if" (Full.Node argumentValue _) _] _) = + Full.Boolean True == argumentValue + skip (Full.Directive "include" [Full.Argument "if" (Full.Node argumentValue _) _] _) = + Full.Boolean False == argumentValue skip _ = False - findFragmentDefinition (ExecutableDefinition executableDefinition) Nothing - | DefinitionFragment fragmentDefinition <- executableDefinition = + findFragmentDefinition (Full.ExecutableDefinition executableDefinition) Nothing + | Full.DefinitionFragment fragmentDefinition <- executableDefinition = Just fragmentDefinition findFragmentDefinition _ accumulator = accumulator collectFromFragment typeCondition selectionSet accumulator = do - types' <- lift $ asks types + types' <- lift $ asks $ Schema.types . schema schema' <- lift $ asks schema - case lookupTypeCondition typeCondition types' of + case Type.lookupTypeCondition typeCondition types' of Nothing -> pure accumulator Just compositeType | Just objectType <- Schema.subscription schema' - , True <- doesFragmentTypeApply compositeType objectType -> + , True <- Type.doesFragmentTypeApply compositeType objectType -> HashSet.union accumulator <$> collectFields selectionSet | otherwise -> pure accumulator collectFromSpread fragmentName accumulator = do @@ -190,15 +191,16 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case ast' <- lift $ asks ast case foldr findFragmentDefinition Nothing ast' of Nothing -> pure accumulator - Just (FragmentDefinition _ typeCondition _ selectionSet _) -> + Just (Full.FragmentDefinition _ typeCondition _ selectionSet _) -> collectFromFragment typeCondition selectionSet accumulator -- | GraphQL allows a short‐hand form for defining query operations when only -- that one operation exists in the document. loneAnonymousOperationRule :: forall m. Rule m loneAnonymousOperationRule = OperationDefinitionRule $ \case - SelectionSet _ thisLocation -> check thisLocation - OperationDefinition _ Nothing _ _ _ thisLocation -> check thisLocation + Full.SelectionSet _ thisLocation -> check thisLocation + Full.OperationDefinition _ Nothing _ _ _ thisLocation -> + check thisLocation _ -> lift mempty where check thisLocation = asks ast @@ -208,9 +210,9 @@ loneAnonymousOperationRule = OperationDefinitionRule $ \case compareAnonymousOperations thisLocation operationDefinition filterAnonymousOperations _ _ accumulator = accumulator compareAnonymousOperations thisLocation = \case - OperationDefinition _ _ _ _ _ thatLocation + Full.OperationDefinition _ _ _ _ _ thatLocation | thisLocation /= thatLocation -> pure $ error' thisLocation - SelectionSet _ thatLocation + Full.SelectionSet _ thatLocation | thisLocation /= thatLocation -> pure $ error' thisLocation _ -> mempty error' location' = Error @@ -223,7 +225,7 @@ loneAnonymousOperationRule = OperationDefinitionRule $ \case -- referred to by its name. uniqueOperationNamesRule :: forall m. Rule m uniqueOperationNamesRule = OperationDefinitionRule $ \case - OperationDefinition _ (Just thisName) _ _ _ thisLocation -> + Full.OperationDefinition _ (Just thisName) _ _ _ thisLocation -> findDuplicates (filterByName thisName) thisLocation (error' thisName) _ -> lift mempty where @@ -234,12 +236,12 @@ uniqueOperationNamesRule = OperationDefinitionRule $ \case ] filterByName thisName definition' accumulator | (viewOperation -> Just operationDefinition) <- definition' - , OperationDefinition _ (Just thatName) _ _ _ thatLocation <- operationDefinition + , Full.OperationDefinition _ (Just thatName) _ _ _ thatLocation <- operationDefinition , thisName == thatName = thatLocation : accumulator | otherwise = accumulator -findDuplicates :: (Definition -> [Location] -> [Location]) - -> Location +findDuplicates :: (Full.Definition -> [Full.Location] -> [Full.Location]) + -> Full.Location -> String -> RuleT m findDuplicates filterByName thisLocation errorMessage = do @@ -254,17 +256,17 @@ findDuplicates filterByName thisLocation errorMessage = do , locations = locations' } -viewOperation :: Definition -> Maybe OperationDefinition +viewOperation :: Full.Definition -> Maybe Full.OperationDefinition viewOperation definition - | ExecutableDefinition executableDefinition <- definition - , DefinitionOperation operationDefinition <- executableDefinition = + | Full.ExecutableDefinition executableDefinition <- definition + , Full.DefinitionOperation operationDefinition <- executableDefinition = Just operationDefinition viewOperation _ = Nothing -viewFragment :: Definition -> Maybe FragmentDefinition +viewFragment :: Full.Definition -> Maybe Full.FragmentDefinition viewFragment definition - | ExecutableDefinition executableDefinition <- definition - , DefinitionFragment fragmentDefinition <- executableDefinition = + | Full.ExecutableDefinition executableDefinition <- definition + , Full.DefinitionFragment fragmentDefinition <- executableDefinition = Just fragmentDefinition viewFragment _ = Nothing @@ -275,7 +277,7 @@ viewFragment _ = Nothing -- by this validation rule. uniqueFragmentNamesRule :: forall m. Rule m uniqueFragmentNamesRule = FragmentDefinitionRule $ \case - FragmentDefinition thisName _ _ _ thisLocation -> + Full.FragmentDefinition thisName _ _ _ thisLocation -> findDuplicates (filterByName thisName) thisLocation (error' thisName) where error' fragmentName = concat @@ -285,7 +287,7 @@ uniqueFragmentNamesRule = FragmentDefinitionRule $ \case ] filterByName thisName definition accumulator | Just fragmentDefinition <- viewFragment definition - , FragmentDefinition thatName _ _ _ thatLocation <- fragmentDefinition + , Full.FragmentDefinition thatName _ _ _ thatLocation <- fragmentDefinition , thisName == thatName = thatLocation : accumulator | otherwise = accumulator @@ -293,7 +295,7 @@ uniqueFragmentNamesRule = FragmentDefinitionRule $ \case -- It is a validation error if the target of a spread is not defined. fragmentSpreadTargetDefinedRule :: forall m. Rule m fragmentSpreadTargetDefinedRule = FragmentSpreadRule $ \case - FragmentSpread fragmentName _ location' -> do + Full.FragmentSpread fragmentName _ location' -> do ast' <- asks ast case find (isSpreadTarget fragmentName) ast' of Nothing -> pure $ Error @@ -308,9 +310,9 @@ fragmentSpreadTargetDefinedRule = FragmentSpreadRule $ \case , "\" is undefined." ] -isSpreadTarget :: Text -> Definition -> Bool +isSpreadTarget :: Text -> Full.Definition -> Bool isSpreadTarget thisName (viewFragment -> Just fragmentDefinition) - | FragmentDefinition thatName _ _ _ _ <- fragmentDefinition + | Full.FragmentDefinition thatName _ _ _ _ <- fragmentDefinition , thisName == thatName = True isSpreadTarget _ _ = False @@ -319,22 +321,22 @@ isSpreadTarget _ _ = False -- the query does not validate. fragmentSpreadTypeExistenceRule :: forall m. Rule m fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case - FragmentSpreadSelection fragmentSelection - | FragmentSpread fragmentName _ location' <- fragmentSelection -> do + Full.FragmentSpreadSelection fragmentSelection + | Full.FragmentSpread fragmentName _ location' <- fragmentSelection -> do ast' <- asks ast let target = find (isSpreadTarget fragmentName) ast' typeCondition <- lift $ maybeToSeq $ target >>= extractTypeCondition - types' <- asks types + types' <- asks $ Schema.types . schema case HashMap.lookup typeCondition types' of Nothing -> pure $ Error { message = spreadError fragmentName typeCondition , locations = [location'] } Just _ -> lift mempty - InlineFragmentSelection fragmentSelection - | InlineFragment maybeType _ _ location' <- fragmentSelection + Full.InlineFragmentSelection fragmentSelection + | Full.InlineFragment maybeType _ _ location' <- fragmentSelection , Just typeCondition <- maybeType -> do - types' <- asks types + types' <- asks $ Schema.types . schema case HashMap.lookup typeCondition types' of Nothing -> pure $ Error { message = inlineError typeCondition @@ -344,7 +346,7 @@ fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case _ -> lift mempty where extractTypeCondition (viewFragment -> Just fragmentDefinition) = - let FragmentDefinition _ typeCondition _ _ _ = fragmentDefinition + let Full.FragmentDefinition _ typeCondition _ _ _ = fragmentDefinition in Just typeCondition extractTypeCondition _ = Nothing spreadError fragmentName typeCondition = concat @@ -370,16 +372,16 @@ maybeToSeq Nothing = mempty fragmentsOnCompositeTypesRule :: forall m. Rule m fragmentsOnCompositeTypesRule = FragmentRule definitionRule inlineRule where - inlineRule (InlineFragment (Just typeCondition) _ _ location') = + inlineRule (Full.InlineFragment (Just typeCondition) _ _ location') = check typeCondition location' inlineRule _ = lift mempty - definitionRule (FragmentDefinition _ typeCondition _ _ location') = + definitionRule (Full.FragmentDefinition _ typeCondition _ _ location') = check typeCondition location' check typeCondition location' = do - types' <- asks types + types' <- asks $ Schema.types . schema -- Skip unknown types, they are checked by another rule. _ <- lift $ maybeToSeq $ HashMap.lookup typeCondition types' - case lookupTypeCondition typeCondition types' of + case Type.lookupTypeCondition typeCondition types' of Nothing -> pure $ Error { message = errorMessage typeCondition , locations = [location'] @@ -394,7 +396,7 @@ fragmentsOnCompositeTypesRule = FragmentRule definitionRule inlineRule -- | Defined fragments must be used within a document. noUnusedFragmentsRule :: forall m. Rule m noUnusedFragmentsRule = FragmentDefinitionRule $ \fragment -> do - let FragmentDefinition fragmentName _ _ _ location' = fragment + let Full.FragmentDefinition fragmentName _ _ _ location' = fragment in mapReaderT (checkFragmentName fragmentName location') $ asks ast >>= flip evalStateT HashSet.empty @@ -414,35 +416,36 @@ noUnusedFragmentsRule = FragmentDefinitionRule $ \fragment -> do , "\" is never used." ] evaluateSelection selection - | FragmentSpreadSelection spreadSelection <- selection - , FragmentSpread spreadName _ _ <- spreadSelection = + | Full.FragmentSpreadSelection spreadSelection <- selection + , Full.FragmentSpread spreadName _ _ <- spreadSelection = lift $ pure spreadName evaluateSelection _ = lift $ lift mempty -definitionSelections :: Definition -> SelectionSetOpt +definitionSelections :: Full.Definition -> Full.SelectionSetOpt definitionSelections (viewOperation -> Just operation) - | OperationDefinition _ _ _ _ selections _ <- operation = toList selections - | SelectionSet selections _ <- operation = toList selections + | Full.OperationDefinition _ _ _ _ selections _ <- operation = + toList selections + | Full.SelectionSet selections _ <- operation = toList selections definitionSelections (viewFragment -> Just fragment) - | FragmentDefinition _ _ _ selections _ <- fragment = toList selections + | Full.FragmentDefinition _ _ _ selections _ <- fragment = toList selections definitionSelections _ = [] filterSelections :: Foldable t => forall a m - . (Selection -> ValidationState m a) - -> t Selection + . (Full.Selection -> ValidationState m a) + -> t Full.Selection -> ValidationState m a filterSelections applyFilter selections = (lift . lift) (Seq.fromList $ foldr evaluateSelection mempty selections) >>= applyFilter where evaluateSelection selection accumulator - | FragmentSpreadSelection{} <- selection = selection : accumulator - | FieldSelection fieldSelection <- selection - , Field _ _ _ _ subselections _ <- fieldSelection = + | Full.FragmentSpreadSelection{} <- selection = selection : accumulator + | Full.FieldSelection fieldSelection <- selection + , Full.Field _ _ _ _ subselections _ <- fieldSelection = selection : foldr evaluateSelection accumulator subselections - | InlineFragmentSelection inlineSelection <- selection - , InlineFragment _ _ subselections _ <- inlineSelection = + | Full.InlineFragmentSelection inlineSelection <- selection + , Full.InlineFragment _ _ subselections _ <- inlineSelection = selection : foldr evaluateSelection accumulator subselections -- | The graph of fragment spreads must not form any cycles including spreading @@ -450,7 +453,7 @@ filterSelections applyFilter selections -- on cycles in the underlying data. noFragmentCyclesRule :: forall m. Rule m noFragmentCyclesRule = FragmentDefinitionRule $ \case - FragmentDefinition fragmentName _ _ selections location' -> do + Full.FragmentDefinition fragmentName _ _ selections location' -> do state <- evalStateT (collectFields selections) (0, fragmentName) let spreadPath = fst <$> sortBy (comparing snd) (HashMap.toList state) @@ -468,16 +471,16 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case _ -> lift mempty where collectFields :: Traversable t - => t Selection - -> StateT (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int) + => t Full.Selection + -> StateT (Int, Full.Name) (ReaderT (Validation m) Seq) (HashMap Full.Name Int) collectFields selectionSet = foldM forEach HashMap.empty selectionSet forEach accumulator = \case - FieldSelection fieldSelection -> forField accumulator fieldSelection - InlineFragmentSelection fragmentSelection -> + Full.FieldSelection fieldSelection -> forField accumulator fieldSelection + Full.InlineFragmentSelection fragmentSelection -> forInline accumulator fragmentSelection - FragmentSpreadSelection fragmentSelection -> + Full.FragmentSpreadSelection fragmentSelection -> forSpread accumulator fragmentSelection - forSpread accumulator (FragmentSpread fragmentName _ _) = do + forSpread accumulator (Full.FragmentSpread fragmentName _ _) = do firstFragmentName <- gets snd modify $ first (+ 1) lastIndex <- gets fst @@ -486,20 +489,20 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case if fragmentName == firstFragmentName || inVisitetFragment then pure newAccumulator else collectFromSpread fragmentName newAccumulator - forInline accumulator (InlineFragment _ _ selections _) = + forInline accumulator (Full.InlineFragment _ _ selections _) = (accumulator <>) <$> collectFields selections - forField accumulator (Field _ _ _ _ selections _) = + forField accumulator (Full.Field _ _ _ _ selections _) = (accumulator <>) <$> collectFields selections - findFragmentDefinition n (ExecutableDefinition executableDefinition) Nothing - | DefinitionFragment fragmentDefinition <- executableDefinition - , FragmentDefinition fragmentName _ _ _ _ <- fragmentDefinition + findFragmentDefinition n (Full.ExecutableDefinition executableDefinition) Nothing + | Full.DefinitionFragment fragmentDefinition <- executableDefinition + , Full.FragmentDefinition fragmentName _ _ _ _ <- fragmentDefinition , fragmentName == n = Just fragmentDefinition findFragmentDefinition _ _ accumulator = accumulator collectFromSpread _fragmentName accumulator = do ast' <- lift $ asks ast case foldr (findFragmentDefinition _fragmentName) Nothing ast' of Nothing -> pure accumulator - Just (FragmentDefinition _ _ _ selections _) -> + Just (Full.FragmentDefinition _ _ _ selections _) -> (accumulator <>) <$> collectFields selections -- | Fields and directives treat arguments as a mapping of argument name to @@ -508,11 +511,11 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case uniqueArgumentNamesRule :: forall m. Rule m uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule where - fieldRule _ (Field _ _ arguments _ _ _) = + fieldRule _ (Full.Field _ _ arguments _ _ _) = lift $ filterDuplicates extract "argument" arguments - directiveRule (Directive _ arguments _) = + directiveRule (Full.Directive _ arguments _) = lift $ filterDuplicates extract "argument" arguments - extract (Argument argumentName _ location') = (argumentName, location') + extract (Full.Argument argumentName _ location') = (argumentName, location') -- | Directives are used to describe some metadata or behavioral change on the -- definition they apply to. When more than one directive of the same name is @@ -522,9 +525,10 @@ uniqueDirectiveNamesRule :: forall m. Rule m uniqueDirectiveNamesRule = DirectivesRule $ const $ lift . filterDuplicates extract "directive" where - extract (Directive directiveName _ location') = (directiveName, location') + extract (Full.Directive directiveName _ location') = + (directiveName, location') -filterDuplicates :: (a -> (Text, Location)) -> String -> [a] -> Seq Error +filterDuplicates :: (a -> (Text, Full.Location)) -> String -> [a] -> Seq Error filterDuplicates extract nodeType = Seq.fromList . fmap makeError . filter ((> 1) . length) @@ -552,7 +556,7 @@ uniqueVariableNamesRule :: forall m. Rule m uniqueVariableNamesRule = VariablesRule $ lift . filterDuplicates extract "variable" where - extract (VariableDefinition variableName _ _ location') = + extract (Full.VariableDefinition variableName _ _ location') = (variableName, location') -- | Variables can only be input types. Objects, unions and interfaces cannot be @@ -561,11 +565,11 @@ variablesAreInputTypesRule :: forall m. Rule m variablesAreInputTypesRule = VariablesRule $ (traverse check . Seq.fromList) >=> lift where - check (VariableDefinition name typeName _ location') - = asks types + check (Full.VariableDefinition name typeName _ location') + = asks (Schema.types . schema) >>= lift . maybe (makeError name typeName location') (const mempty) - . lookupInputType typeName + . Type.lookupInputType typeName makeError name typeName location' = pure $ Error { message = concat [ "Variable \"$" @@ -576,10 +580,11 @@ variablesAreInputTypesRule = VariablesRule ] , locations = [location'] } - getTypeName (TypeNamed name) = name - getTypeName (TypeList name) = getTypeName name - getTypeName (TypeNonNull (NonNullTypeNamed nonNull)) = nonNull - getTypeName (TypeNonNull (NonNullTypeList nonNull)) = getTypeName nonNull + getTypeName (Full.TypeNamed name) = name + getTypeName (Full.TypeList name) = getTypeName name + getTypeName (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) = nonNull + getTypeName (Full.TypeNonNull (Full.NonNullTypeList nonNull)) = + getTypeName nonNull -- | Variables are scoped on a per‐operation basis. That means that any variable -- used within the context of an operation must be defined at the top level of @@ -601,13 +606,17 @@ noUndefinedVariablesRule = , "\"." ] -variableUsageDifference :: forall m - . (HashMap Name [Location] -> HashMap Name [Location] -> HashMap Name [Location]) - -> (Maybe Name -> Name -> String) +type UsageDifference + = HashMap Full.Name [Full.Location] + -> HashMap Full.Name [Full.Location] + -> HashMap Full.Name [Full.Location] + +variableUsageDifference :: forall m. UsageDifference + -> (Maybe Full.Name -> Full.Name -> String) -> Rule m variableUsageDifference difference errorMessage = OperationDefinitionRule $ \case - SelectionSet _ _ -> lift mempty - OperationDefinition _ operationName variables _ selections _ -> + Full.SelectionSet _ _ -> lift mempty + Full.OperationDefinition _ operationName variables _ selections _ -> let variableNames = HashMap.fromList $ getVariableName <$> variables in mapReaderT (readerMapper operationName variableNames) $ flip evalStateT HashSet.empty @@ -620,21 +629,21 @@ variableUsageDifference difference errorMessage = OperationDefinitionRule $ \cas . difference variableNames' . HashMap.fromListWith (++) . toList - getVariableName (VariableDefinition variableName _ _ location') = + getVariableName (Full.VariableDefinition variableName _ _ location') = (variableName, [location']) filterSelections' :: Foldable t - => t Selection - -> ValidationState m (Name, [Location]) + => t Full.Selection + -> ValidationState m (Full.Name, [Full.Location]) filterSelections' = filterSelections variableFilter - variableFilter :: Selection -> ValidationState m (Name, [Location]) - variableFilter (InlineFragmentSelection inline) - | InlineFragment _ directives' _ _ <- inline = + variableFilter :: Full.Selection -> ValidationState m (Full.Name, [Full.Location]) + variableFilter (Full.InlineFragmentSelection inline) + | Full.InlineFragment _ directives' _ _ <- inline = lift $ lift $ mapDirectives directives' - variableFilter (FieldSelection fieldSelection) - | Field _ _ arguments directives' _ _ <- fieldSelection = + variableFilter (Full.FieldSelection fieldSelection) + | Full.Field _ _ arguments directives' _ _ <- fieldSelection = lift $ lift $ mapArguments arguments <> mapDirectives directives' - variableFilter (FragmentSpreadSelection spread) - | FragmentSpread fragmentName _ _ <- spread = do + variableFilter (Full.FragmentSpreadSelection spread) + | Full.FragmentSpread fragmentName _ _ <- spread = do definitions <- lift $ asks ast visited <- gets (HashSet.member fragmentName) modify (HashSet.insert fragmentName) @@ -642,13 +651,13 @@ variableUsageDifference difference errorMessage = OperationDefinitionRule $ \cas Just (viewFragment -> Just fragmentDefinition) | not visited -> diveIntoSpread fragmentDefinition _ -> lift $ lift mempty - diveIntoSpread (FragmentDefinition _ _ directives' selections _) + diveIntoSpread (Full.FragmentDefinition _ _ directives' selections _) = filterSelections' selections >>= lift . mapReaderT (<> mapDirectives directives') . pure - findDirectiveVariables (Directive _ arguments _) = mapArguments arguments + findDirectiveVariables (Full.Directive _ arguments _) = mapArguments arguments mapArguments = Seq.fromList . mapMaybe findArgumentVariables mapDirectives = foldMap findDirectiveVariables - findArgumentVariables (Argument _ Node{ node = Variable value', ..} _) = + findArgumentVariables (Full.Argument _ Full.Node{ node = Full.Variable value', ..} _) = Just (value', [location]) findArgumentVariables _ = Nothing makeError operationName (variableName, locations') = Error @@ -682,12 +691,12 @@ uniqueInputFieldNamesRule :: forall m. Rule m uniqueInputFieldNamesRule = ValueRule (const $ lift . go) (const $ lift . constGo) where - go (Node (Object fields) _) = filterFieldDuplicates fields + go (Full.Node (Full.Object fields) _) = filterFieldDuplicates fields go _ = mempty filterFieldDuplicates fields = filterDuplicates getFieldName "input field" fields - getFieldName (ObjectField fieldName _ location') = (fieldName, location') - constGo (Node (ConstObject fields) _) = filterFieldDuplicates fields + getFieldName (Full.ObjectField fieldName _ location') = (fieldName, location') + constGo (Full.Node (Full.ConstObject fields) _) = filterFieldDuplicates fields constGo _ = mempty -- | The target field of a field selection must be defined on the scoped type of @@ -695,9 +704,9 @@ uniqueInputFieldNamesRule = fieldsOnCorrectTypeRule :: forall m. Rule m fieldsOnCorrectTypeRule = FieldRule fieldRule where - fieldRule parentType (Field _ fieldName _ _ _ location') + fieldRule parentType (Full.Field _ fieldName _ _ _ location') | Just objectType <- parentType - , Nothing <- lookupTypeField fieldName objectType + , Nothing <- Type.lookupTypeField fieldName objectType , Just typeName <- compositeTypeName objectType = pure $ Error { message = errorMessage fieldName typeName , locations = [location'] @@ -711,7 +720,7 @@ fieldsOnCorrectTypeRule = FieldRule fieldRule , "\"." ] -compositeTypeName :: forall m. Out.Type m -> Maybe Name +compositeTypeName :: forall m. Out.Type m -> Maybe Full.Name compositeTypeName (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) = Just typeName compositeTypeName (Out.InterfaceBaseType interfaceType) = @@ -731,9 +740,9 @@ compositeTypeName (Out.ListBaseType wrappedType) = scalarLeafsRule :: forall m. Rule m scalarLeafsRule = FieldRule fieldRule where - fieldRule parentType selectionField@(Field _ fieldName _ _ _ _) + fieldRule parentType selectionField@(Full.Field _ fieldName _ _ _ _) | Just objectType <- parentType - , Just field <- lookupTypeField fieldName objectType = + , Just field <- Type.lookupTypeField fieldName objectType = let Out.Field _ fieldType _ = field in lift $ check fieldType selectionField | otherwise = lift mempty @@ -748,7 +757,7 @@ scalarLeafsRule = FieldRule fieldRule check (Out.EnumBaseType (Definition.EnumType typeName _ _)) = checkEmpty typeName check (Out.ListBaseType wrappedType) = check wrappedType - checkNotEmpty typeName (Field _ fieldName _ _ [] location') = + checkNotEmpty typeName (Full.Field _ fieldName _ _ [] location') = let fieldName' = Text.unpack fieldName in makeError location' $ concat [ "Field \"" @@ -760,9 +769,9 @@ scalarLeafsRule = FieldRule fieldRule , " { ... }\"?" ] checkNotEmpty _ _ = mempty - checkEmpty _ (Field _ _ _ _ [] _) = mempty + checkEmpty _ (Full.Field _ _ _ _ [] _) = mempty checkEmpty typeName field' = - let Field _ fieldName _ _ _ location' = field' + let Full.Field _ fieldName _ _ _ location' = field' in makeError location' $ concat [ "Field \"" , Text.unpack fieldName @@ -780,12 +789,12 @@ scalarLeafsRule = FieldRule fieldRule knownArgumentNamesRule :: forall m. Rule m knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule where - fieldRule (Just objectType) (Field _ fieldName arguments _ _ _) - | Just typeField <- lookupTypeField fieldName objectType + fieldRule (Just objectType) (Full.Field _ fieldName arguments _ _ _) + | Just typeField <- Type.lookupTypeField fieldName objectType , Just typeName <- compositeTypeName objectType = lift $ foldr (go typeName fieldName typeField) Seq.empty arguments fieldRule _ _ = lift mempty - go typeName fieldName fieldDefinition (Argument argumentName _ location') errors + go typeName fieldName fieldDefinition (Full.Argument argumentName _ location') errors | Out.Field _ _ definitions <- fieldDefinition , Just _ <- HashMap.lookup argumentName definitions = errors | otherwise = errors |> Error @@ -801,9 +810,10 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule , Text.unpack fieldName , "\"." ] - directiveRule (Directive directiveName arguments _) = do - available <- asks $ HashMap.lookup directiveName . directives - Argument argumentName _ location' <- lift $ Seq.fromList arguments + directiveRule (Full.Directive directiveName arguments _) = do + available <- asks $ HashMap.lookup directiveName + . Schema.directives . schema + Full.Argument argumentName _ location' <- lift $ Seq.fromList arguments case available of Just (Schema.Directive _ _ definitions) | not $ HashMap.member argumentName definitions -> @@ -825,7 +835,7 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule -- directive, the directive must be available on that server. knownDirectiveNamesRule :: Rule m knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do - definitions' <- asks directives + definitions' <- asks $ Schema.directives . schema let directiveSet = HashSet.fromList $ fmap directiveName directives' let definitionSet = HashSet.fromList $ HashMap.keys definitions' let difference = HashSet.difference directiveSet definitionSet @@ -834,8 +844,8 @@ knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do where definitionFilter difference = flip HashSet.member difference . directiveName - directiveName (Directive directiveName' _ _) = directiveName' - makeError (Directive directiveName' _ location') = Error + directiveName (Full.Directive directiveName' _ _) = directiveName' + makeError (Full.Directive directiveName' _ location') = Error { message = errorMessage directiveName' , locations = [location'] } @@ -850,15 +860,15 @@ knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do knownInputFieldNamesRule :: Rule m knownInputFieldNamesRule = ValueRule go constGo where - go (Just valueType) (Node (Object inputFields) _) + go (Just valueType) (Full.Node (Full.Object inputFields) _) | In.InputObjectBaseType objectType <- valueType = lift $ Seq.fromList $ mapMaybe (forEach objectType) inputFields go _ _ = lift mempty - constGo (Just valueType) (Node (ConstObject inputFields) _) + constGo (Just valueType) (Full.Node (Full.ConstObject inputFields) _) | In.InputObjectBaseType objectType <- valueType = lift $ Seq.fromList $ mapMaybe (forEach objectType) inputFields constGo _ _ = lift mempty - forEach objectType (ObjectField inputFieldName _ location') + forEach objectType (Full.ObjectField inputFieldName _ location') | In.InputObjectType _ _ fieldTypes <- objectType , Just _ <- HashMap.lookup inputFieldName fieldTypes = Nothing | otherwise @@ -881,8 +891,9 @@ directivesInValidLocationsRule :: Rule m directivesInValidLocationsRule = DirectivesRule directivesRule where directivesRule directiveLocation directives' = do - Directive directiveName _ location <- lift $ Seq.fromList directives' - maybeDefinition <- asks $ HashMap.lookup directiveName . directives + Full.Directive directiveName _ location <- lift $ Seq.fromList directives' + maybeDefinition <- asks + $ HashMap.lookup directiveName . Schema.directives . schema case maybeDefinition of Just (Schema.Directive _ allowedLocations _) | directiveLocation `notElem` allowedLocations -> pure $ Error @@ -904,14 +915,15 @@ directivesInValidLocationsRule = DirectivesRule directivesRule providedRequiredArgumentsRule :: Rule m providedRequiredArgumentsRule = ArgumentsRule fieldRule directiveRule where - fieldRule (Just objectType) (Field _ fieldName arguments _ _ location') - | Just typeField <- lookupTypeField fieldName objectType + fieldRule (Just objectType) (Full.Field _ fieldName arguments _ _ location') + | Just typeField <- Type.lookupTypeField fieldName objectType , Out.Field _ _ definitions <- typeField = let forEach = go (fieldMessage fieldName) arguments location' in lift $ HashMap.foldrWithKey forEach Seq.empty definitions fieldRule _ _ = lift mempty - directiveRule (Directive directiveName arguments location') = do - available <- asks $ HashMap.lookup directiveName . directives + directiveRule (Full.Directive directiveName arguments location') = do + available <- asks + $ HashMap.lookup directiveName . Schema.directives . schema case available of Just (Schema.Directive _ _ definitions) -> let forEach = go (directiveMessage directiveName) arguments location' @@ -930,9 +942,10 @@ providedRequiredArgumentsRule = ArgumentsRule fieldRule directiveRule { message = errorMessage , locations = [location'] } - isNothingOrNull (Just (Argument _ (Node Null _) _)) = True + isNothingOrNull (Just (Full.Argument _ (Full.Node Full.Null _) _)) = True isNothingOrNull x = isNothing x - lookupArgument needle (Argument argumentName _ _) = needle == argumentName + lookupArgument needle (Full.Argument argumentName _ _) = + needle == argumentName fieldMessage fieldName argumentName typeName = concat [ "Field \"" , Text.unpack fieldName @@ -966,7 +979,7 @@ inputTypeName (In.ListBaseType listType) = inputTypeName listType providedRequiredInputFieldsRule :: Rule m providedRequiredInputFieldsRule = ValueRule go constGo where - go (Just valueType) (Node (Object inputFields) location') + go (Just valueType) (Full.Node (Full.Object inputFields) location') | In.InputObjectBaseType objectType <- valueType , In.InputObjectType objectTypeName _ fieldDefinitions <- objectType = lift @@ -983,9 +996,9 @@ providedRequiredInputFieldsRule = ValueRule go constGo , isNothingOrNull $ find (lookupField definitionName) inputFields = Just $ makeError definitionName typeName location' | otherwise = Nothing - isNothingOrNull (Just (ObjectField _ (Node Null _) _)) = True + isNothingOrNull (Just (Full.ObjectField _ (Full.Node Full.Null _) _)) = True isNothingOrNull x = isNothing x - lookupField needle (ObjectField fieldName _ _) = needle == fieldName + lookupField needle (Full.ObjectField fieldName _ _) = needle == fieldName makeError fieldName typeName location' = Error { message = errorMessage fieldName typeName , locations = [location'] diff --git a/src/Language/GraphQL/Validate/Validation.hs b/src/Language/GraphQL/Validate/Validation.hs index 7ffab10..0432a1a 100644 --- a/src/Language/GraphQL/Validate/Validation.hs +++ b/src/Language/GraphQL/Validate/Validation.hs @@ -11,14 +11,12 @@ module Language.GraphQL.Validate.Validation ) where import Control.Monad.Trans.Reader (ReaderT) -import Data.HashMap.Strict (HashMap) import Data.Sequence (Seq) import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..)) import Language.GraphQL.AST.Document import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out import Language.GraphQL.Type.Schema (Schema) -import qualified Language.GraphQL.Type.Schema as Schema -- | Validation error. data Error = Error @@ -30,8 +28,6 @@ data Error = Error data Validation m = Validation { ast :: Document , schema :: Schema m - , types :: HashMap Name (Schema.Type m) - , directives :: Schema.Directives } -- | 'Rule' assigns a function to each AST node that can be validated. If the diff --git a/stack.yaml b/stack.yaml index 9a89c01..fda0cf5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-16.16 +resolver: lts-16.17 packages: - . diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs index e6dd8d9..f6e3e6f 100644 --- a/tests/Language/GraphQL/ExecuteSpec.hs +++ b/tests/Language/GraphQL/ExecuteSpec.hs @@ -26,12 +26,7 @@ import Text.Megaparsec (parse) import Text.RawString.QQ (r) philosopherSchema :: Schema (Either SomeException) -philosopherSchema = Schema - { query = queryType - , mutation = Nothing - , subscription = Just subscriptionType - , directives = HashMap.empty - } +philosopherSchema = schema queryType Nothing (Just subscriptionType) mempty queryType :: Out.ObjectType (Either SomeException) queryType = Out.ObjectType "Query" Nothing [] diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs index 92b3001..3bfa018 100644 --- a/tests/Language/GraphQL/ValidateSpec.hs +++ b/tests/Language/GraphQL/ValidateSpec.hs @@ -22,12 +22,7 @@ import Text.Megaparsec (parse) import Text.RawString.QQ (r) petSchema :: Schema IO -petSchema = Schema - { query = queryType - , mutation = Nothing - , subscription = Just subscriptionType - , directives = HashMap.empty - } +petSchema = schema queryType Nothing (Just subscriptionType) mempty queryType :: ObjectType IO queryType = ObjectType "Query" Nothing [] $ HashMap.fromList diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs index c115163..2d586f6 100644 --- a/tests/Test/DirectiveSpec.hs +++ b/tests/Test/DirectiveSpec.hs @@ -19,7 +19,7 @@ import Test.Hspec.GraphQL import Text.RawString.QQ (r) experimentalResolver :: Schema IO -experimentalResolver = schema queryType +experimentalResolver = schema queryType Nothing Nothing mempty where queryType = Out.ObjectType "Query" Nothing [] $ HashMap.singleton "experimentalField" diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs index 4fecad8..f426e2c 100644 --- a/tests/Test/FragmentSpec.hs +++ b/tests/Test/FragmentSpec.hs @@ -67,7 +67,7 @@ sizeFieldType $ pure $ snd size toSchema :: Text -> (Text, Value) -> Schema IO -toSchema t (_, resolve) = schema queryType +toSchema t (_, resolve) = schema queryType Nothing Nothing mempty where garmentType = Out.UnionType "Garment" Nothing [hatType, shirtType] typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty diff --git a/tests/Test/RootOperationSpec.hs b/tests/Test/RootOperationSpec.hs index 33b5d3b..1921ec9 100644 --- a/tests/Test/RootOperationSpec.hs +++ b/tests/Test/RootOperationSpec.hs @@ -24,13 +24,10 @@ hatType = Out.ObjectType "Hat" Nothing [] $ pure $ Int 60 garmentSchema :: Schema IO -garmentSchema = Schema - { query = Out.ObjectType "Query" Nothing [] hatFieldResolver - , mutation = Just $ Out.ObjectType "Mutation" Nothing [] incrementFieldResolver - , subscription = Nothing - , directives = HashMap.empty - } +garmentSchema = schema queryType (Just mutationType) Nothing mempty where + queryType = Out.ObjectType "Query" Nothing [] hatFieldResolver + mutationType = Out.ObjectType "Mutation" Nothing [] incrementFieldResolver garment = pure $ Object $ HashMap.fromList [ ("circumference", Int 60) ] diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs index 706d9b3..90ce9fc 100644 --- a/tests/Test/StarWars/Schema.hs +++ b/tests/Test/StarWars/Schema.hs @@ -18,7 +18,7 @@ import Prelude hiding (id) -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js starWarsSchema :: Schema (Either SomeException) -starWarsSchema = schema queryType +starWarsSchema = schema queryType Nothing Nothing mempty where queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList [ ("hero", heroFieldResolver)