OSS
/
graphql
1
1
Fork 1
Code Issues 3 Pull Requests Actions Releases 22 Wiki Activity

Collect types once the schema is created

This commit is contained in:
Eugen Wissner 2020-10-07 05:24:51 +02:00
parent a91bc7f2d2
commit 7c0b0ace4d
20 changed files with 427 additions and 393 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
CHANGELOG.md
View File

@ -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.

2
README.md
View File

@ -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

6
docs/tutorial/tutorial.lhs
View File

@ -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

10
src/Language/GraphQL/AST/Encoder.hs
View File

@ -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

10
src/Language/GraphQL/Error.hs
View File

@ -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

15
src/Language/GraphQL/Execute/Execution.hs
View File

@ -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

15
src/Language/GraphQL/Execute/Transform.hs
View File

@ -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

2
src/Language/GraphQL/Type.hs
View File

@ -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

169
src/Language/GraphQL/Type/Internal.hs
View File

@ -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

183
src/Language/GraphQL/Type/Schema.hs
View File

@ -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

64
src/Language/GraphQL/Validate.hs
View File

@ -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

303
src/Language/GraphQL/Validate/Rules.hs
View File

@ -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']

4
src/Language/GraphQL/Validate/Validation.hs
View File

@ -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

2
stack.yaml
View File

@ -1,4 +1,4 @@
resolver: lts-16.16
resolver: lts-16.17
packages:
- .

7
tests/Language/GraphQL/ExecuteSpec.hs
View File

@ -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 []

7
tests/Language/GraphQL/ValidateSpec.hs
View File

@ -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

2
tests/Test/DirectiveSpec.hs
View File

@ -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"

2
tests/Test/FragmentSpec.hs
View File

@ -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

9
tests/Test/RootOperationSpec.hs
View File

@ -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)
]

2
tests/Test/StarWars/Schema.hs
View File

@ -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)