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

Collect types once the schema is created

Browse Source
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
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. the path without executing the query.
- `Error.Error`: `path` added. It is currently always empty. - `Error.Error`: `path` added. It is currently always empty.
- `Validate.Validation.Path` was moved to `Error`. - `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 ### Added
- `Validate.Validation.Rule` constructors: - `Validate.Validation.Rule` constructors:
@@ -62,7 +64,7 @@ and this project adheres to
- `Type.In.Arguments`: Type alias for an argument map. - `Type.In.Arguments`: Type alias for an argument map.
- `Type.Schema.Directive` and `Type.Schema.Directives` are directive definition - `Type.Schema.Directive` and `Type.Schema.Directives` are directive definition
representation. representation.
- `Type.Schema.schema`: Shortcut for creating a schema. - `Type.Schema.schema`: Schema constructor.
### Fixed ### Fixed
- Collecting existing types from the schema considers subscriptions. - 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. -- GraphQL supports 3 kinds of operations: queries, mutations and subscriptions.
-- Our first schema supports only queries. -- Our first schema supports only queries.
citeSchema :: Schema IO citeSchema :: Schema IO
citeSchema = schema queryType citeSchema = schema queryType Nothing Nothing mempty
-- GraphQL distinguishes between input and output types. Input types are field -- GraphQL distinguishes between input and output types. Input types are field
-- argument types and they are defined in Language.GraphQL.Type.In. Output types -- 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. First we build a GraphQL schema.
> schema1 :: Schema IO > schema1 :: Schema IO
> schema1 = schema queryType > schema1 = schema queryType Nothing Nothing mempty
> >
> queryType :: ObjectType IO > queryType :: ObjectType IO
> queryType = ObjectType "Query" Nothing [] > 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. For this example, we're going to be using time.
> schema2 :: Schema IO > schema2 :: Schema IO
> schema2 = schema queryType2 > schema2 = schema queryType2 Nothing Nothing mempty
> >
> queryType2 :: ObjectType IO > queryType2 :: ObjectType IO
> queryType2 = ObjectType "Query" Nothing [] > 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. Now that we have two resolvers, we can define a schema which uses them both.
> schema3 :: Schema IO > schema3 :: Schema IO
> schema3 = schema queryType3 > schema3 = schema queryType3 Nothing Nothing mempty
> >
> queryType3 :: ObjectType IO > queryType3 :: ObjectType IO
> queryType3 = ObjectType "Query" Nothing [] $ HashMap.fromList > 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 definition formatter executableDefinition' : acc
executableDefinition _ acc = 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 -> Full.ExecutableDefinition -> Lazy.Text
definition formatter x definition formatter x
| Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n' | Pretty _ <- formatter = Lazy.Text.snoc (encodeDefinition x) '\n'
@@ -67,7 +67,7 @@ definition formatter x
encodeDefinition (Full.DefinitionFragment fragment) encodeDefinition (Full.DefinitionFragment fragment)
= fragmentDefinition formatter 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 -> Full.OperationDefinition -> Lazy.Text
operationDefinition formatter = \case operationDefinition formatter = \case
Full.SelectionSet sels _ -> selectionSet formatter sels Full.SelectionSet sels _ -> selectionSet formatter sels
@@ -192,7 +192,7 @@ fragmentDefinition formatter (Full.FragmentDefinition name tc dirs sels _)
-- * Miscellaneous -- * Miscellaneous
-- | Converts a 'Directive' into a string. -- | Converts a 'Full.Directive' into a string.
directive :: Formatter -> Full.Directive -> Lazy.Text directive :: Formatter -> Full.Directive -> Lazy.Text
directive formatter (Full.Directive name args _) directive formatter (Full.Directive name args _)
= "@" <> Lazy.Text.fromStrict name <> optempty (arguments formatter) 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 Minified = spaces (directive Minified)
directives formatter = Lazy.Text.cons ' ' . spaces (directive formatter) 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 :: Formatter -> Full.Value -> Lazy.Text
value _ (Full.Variable x) = variable x value _ (Full.Variable x) = variable x
value _ (Full.Int x) = Builder.toLazyText $ decimal 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' _) _) = objectField formatter (Full.ObjectField name (Full.Node value' _) _) =
Lazy.Text.fromStrict name <> colon formatter <> value formatter 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.Type -> Lazy.Text
type' (Full.TypeNamed x) = Lazy.Text.fromStrict x type' (Full.TypeNamed x) = Lazy.Text.fromStrict x
type' (Full.TypeList x) = listType x type' (Full.TypeList x) = listType x

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

@@ -5,8 +5,7 @@
-- | Error handling. -- | Error handling.
module Language.GraphQL.Error module Language.GraphQL.Error
( parseError ( CollectErrsT
, CollectErrsT
, Error(..) , Error(..)
, Path(..) , Path(..)
, Resolution(..) , Resolution(..)
@@ -15,6 +14,7 @@ module Language.GraphQL.Error
, ResponseEventStream , ResponseEventStream
, addErr , addErr
, addErrMsg , addErrMsg
, parseError
, runCollectErrs , runCollectErrs
, singleError , singleError
) where ) where
@@ -29,7 +29,7 @@ import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
import Language.GraphQL.AST (Location(..), Name) import Language.GraphQL.AST (Location(..), Name)
import Language.GraphQL.Execute.Coerce import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Type.Schema import qualified Language.GraphQL.Type.Schema as Schema
import Prelude hiding (null) import Prelude hiding (null)
import Text.Megaparsec import Text.Megaparsec
( ParseErrorBundle(..) ( ParseErrorBundle(..)
@@ -44,7 +44,7 @@ import Text.Megaparsec
-- | Executor context. -- | Executor context.
data Resolution m = Resolution data Resolution m = Resolution
{ errors :: Seq Error { errors :: Seq Error
, types :: HashMap Name (Type m) , types :: HashMap Name (Schema.Type m)
} }
-- | Wraps a parse error into a list of errors. -- | 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 -- | Runs the given query computation, but collects the errors into an error
-- list, which is then sent back with the data. -- list, which is then sent back with the data.
runCollectErrs :: (Monad m, Serialize a) runCollectErrs :: (Monad m, Serialize a)
=> HashMap Name (Type m) => HashMap Name (Schema.Type m)
-> CollectErrsT m a -> CollectErrsT m a
-> m (Response a) -> m (Response a)
runCollectErrs types' res = do 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 as Type
import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Internal import qualified Language.GraphQL.Type.Internal as Internal
import Language.GraphQL.Type.Schema
import Prelude hiding (null) import Prelude hiding (null)
resolveFieldValue :: MonadCatch m resolveFieldValue :: MonadCatch m
@@ -60,7 +59,7 @@ collectFields objectType = foldl forEach Map.empty
in Map.insertWith (<>) responseKey (field :| []) groupedFields in Map.insertWith (<>) responseKey (field :| []) groupedFields
forEach groupedFields (Transform.SelectionFragment selectionFragment) forEach groupedFields (Transform.SelectionFragment selectionFragment)
| Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment | Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment
, doesFragmentTypeApply fragmentType objectType = , Internal.doesFragmentTypeApply fragmentType objectType =
let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet
in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet
| otherwise = groupedFields | otherwise = groupedFields
@@ -69,15 +68,15 @@ aliasOrName :: forall m. Transform.Field m -> Name
aliasOrName (Transform.Field alias name _ _) = fromMaybe name alias aliasOrName (Transform.Field alias name _ _) = fromMaybe name alias
resolveAbstractType :: Monad m resolveAbstractType :: Monad m
=> AbstractType m => Internal.AbstractType m
-> Type.Subs -> Type.Subs
-> CollectErrsT m (Maybe (Out.ObjectType m)) -> CollectErrsT m (Maybe (Out.ObjectType m))
resolveAbstractType abstractType values' resolveAbstractType abstractType values'
| Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do | Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do
types' <- gets types types' <- gets types
case HashMap.lookup typeName types' of case HashMap.lookup typeName types' of
Just (ObjectType objectType) -> Just (Internal.ObjectType objectType) ->
if instanceOf objectType abstractType if Internal.instanceOf objectType abstractType
then pure $ Just objectType then pure $ Just objectType
else pure Nothing else pure Nothing
_ -> pure Nothing _ -> pure Nothing
@@ -129,7 +128,7 @@ completeValue (Out.ObjectBaseType objectType) fields result =
executeSelectionSet result objectType $ mergeSelectionSets fields executeSelectionSet result objectType $ mergeSelectionSets fields
completeValue (Out.InterfaceBaseType interfaceType) fields result completeValue (Out.InterfaceBaseType interfaceType) fields result
| Type.Object objectMap <- result = do | Type.Object objectMap <- result = do
let abstractType = AbstractInterfaceType interfaceType let abstractType = Internal.AbstractInterfaceType interfaceType
concreteType <- resolveAbstractType abstractType objectMap concreteType <- resolveAbstractType abstractType objectMap
case concreteType of case concreteType of
Just objectType -> executeSelectionSet result objectType Just objectType -> executeSelectionSet result objectType
@@ -137,7 +136,7 @@ completeValue (Out.InterfaceBaseType interfaceType) fields result
Nothing -> addErrMsg "Interface value completion failed." Nothing -> addErrMsg "Interface value completion failed."
completeValue (Out.UnionBaseType unionType) fields result completeValue (Out.UnionBaseType unionType) fields result
| Type.Object objectMap <- result = do | Type.Object objectMap <- result = do
let abstractType = AbstractUnionType unionType let abstractType = Internal.AbstractUnionType unionType
concreteType <- resolveAbstractType abstractType objectMap concreteType <- resolveAbstractType abstractType objectMap
case concreteType of case concreteType of
Just objectType -> executeSelectionSet result objectType 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.Execute.Coerce as Coerce
import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type as Type 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 qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema (Schema)
import qualified Language.GraphQL.Type.Schema as Schema import qualified Language.GraphQL.Type.Schema as Schema
-- | Associates a fragment name with a list of 'Field's. -- | 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. -- | Represents fragments and inline fragments.
data Fragment m data Fragment m
= Fragment (CompositeType m) (Seq (Selection m)) = Fragment (Type.CompositeType m) (Seq (Selection m))
-- | Single selection element. -- | Single selection element.
data Selection m data Selection m
@@ -154,7 +153,7 @@ coerceVariableValues types operationDefinition variableValues =
let Full.VariableDefinition variableName variableTypeName defaultValue _ = let Full.VariableDefinition variableName variableTypeName defaultValue _ =
variableDefinition variableDefinition
let defaultValue' = constValue . Full.node <$> defaultValue let defaultValue' = constValue . Full.node <$> defaultValue
variableType <- lookupInputType variableTypeName types variableType <- Type.lookupInputType variableTypeName types
Coerce.matchFieldValues Coerce.matchFieldValues
coerceVariableValue' coerceVariableValue'
@@ -185,13 +184,13 @@ constValue (Full.ConstObject o) =
-- for query execution. -- for query execution.
document :: Coerce.VariableValue a document :: Coerce.VariableValue a
=> forall m => forall m
. Schema m . Type.Schema m
-> Maybe Full.Name -> Maybe Full.Name
-> HashMap Full.Name a -> HashMap Full.Name a
-> Full.Document -> Full.Document
-> Either QueryError (Document m) -> Either QueryError (Document m)
document schema operationName subs ast = do document schema operationName subs ast = do
let referencedTypes = collectReferencedTypes schema let referencedTypes = Schema.types schema
(operations, fragmentTable) <- defragment ast (operations, fragmentTable) <- defragment ast
chosenOperation <- getOperation operationName operations chosenOperation <- getOperation operationName operations
@@ -311,7 +310,7 @@ inlineFragment (Full.InlineFragment type' directives' selections _) = do
Nothing -> pure $ Left fragmentSelectionSet Nothing -> pure $ Left fragmentSelectionSet
Just typeName -> do Just typeName -> do
types' <- gets types types' <- gets types
case lookupTypeCondition typeName types' of case Type.lookupTypeCondition typeName types' of
Just typeCondition -> pure $ Just typeCondition -> pure $
selectionFragment typeCondition fragmentSelectionSet selectionFragment typeCondition fragmentSelectionSet
Nothing -> pure $ Left mempty Nothing -> pure $ Left mempty
@@ -358,7 +357,7 @@ fragmentDefinition (Full.FragmentDefinition name type' _ selections _) = do
fragmentSelection <- appendSelection selections fragmentSelection <- appendSelection selections
types' <- gets types types' <- gets types
case lookupTypeCondition type' types' of case Type.lookupTypeCondition type' types' of
Just compositeType -> do Just compositeType -> do
let newValue = Fragment compositeType fragmentSelection let newValue = Fragment compositeType fragmentSelection
modify $ insertFragment newValue modify $ insertFragment newValue

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

@@ -21,6 +21,6 @@ module Language.GraphQL.Type
) where ) where
import Language.GraphQL.Type.Definition 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.In as In
import qualified Language.GraphQL.Type.Out as Out 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 module Language.GraphQL.Type.Internal
( AbstractType(..) ( AbstractType(..)
, CompositeType(..) , CompositeType(..)
, collectReferencedTypes , Directive(..)
, Directives
, Schema(..)
, Type(..)
, directives
, doesFragmentTypeApply , doesFragmentTypeApply
, instanceOf , instanceOf
, lookupInputType , lookupInputType
, lookupTypeCondition , lookupTypeCondition
, lookupTypeField , lookupTypeField
, mutation
, subscription
, query
, types
) where ) where
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text)
import qualified Language.GraphQL.AST as Full 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.Definition as Definition
import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out 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. -- | These types may describe the parent context of a selection set.
data CompositeType m data CompositeType m
@@ -38,70 +96,6 @@ data AbstractType m
| AbstractInterfaceType (Out.InterfaceType m) | AbstractInterfaceType (Out.InterfaceType m)
deriving Eq 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 doesFragmentTypeApply :: forall m
. CompositeType m . CompositeType m
-> Out.ObjectType m -> Out.ObjectType m
@@ -128,45 +122,42 @@ instanceOf objectType (AbstractUnionType unionType) =
lookupTypeCondition :: forall m lookupTypeCondition :: forall m
. Full.Name . Full.Name
-> HashMap Full.Name (Schema.Type m) -> HashMap Full.Name (Type m)
-> Maybe (CompositeType m) -> Maybe (CompositeType m)
lookupTypeCondition type' types' = lookupTypeCondition type' types' =
case HashMap.lookup type' types' of case HashMap.lookup type' types' of
Just (Schema.ObjectType objectType) -> Just (ObjectType objectType) ->
Just $ CompositeObjectType objectType Just $ CompositeObjectType objectType
Just (Schema.UnionType unionType) -> Just $ CompositeUnionType unionType Just (UnionType unionType) -> Just $ CompositeUnionType unionType
Just (Schema.InterfaceType interfaceType) -> Just (InterfaceType interfaceType) ->
Just $ CompositeInterfaceType interfaceType Just $ CompositeInterfaceType interfaceType
_ -> Nothing _ -> Nothing
lookupInputType lookupInputType :: Full.Type -> HashMap Full.Name (Type m) -> Maybe In.Type
:: Full.Type lookupInputType (Full.TypeNamed name) types' =
-> HashMap.HashMap Full.Name (Schema.Type m) case HashMap.lookup name types' of
-> Maybe In.Type Just (ScalarType scalarType) ->
lookupInputType (Full.TypeNamed name) types =
case HashMap.lookup name types of
Just (Schema.ScalarType scalarType) ->
Just $ In.NamedScalarType scalarType Just $ In.NamedScalarType scalarType
Just (Schema.EnumType enumType) -> Just (EnumType enumType) ->
Just $ In.NamedEnumType enumType Just $ In.NamedEnumType enumType
Just (Schema.InputObjectType objectType) -> Just (InputObjectType objectType) ->
Just $ In.NamedInputObjectType objectType Just $ In.NamedInputObjectType objectType
_ -> Nothing _ -> Nothing
lookupInputType (Full.TypeList list) types lookupInputType (Full.TypeList list) types'
= In.ListType = In.ListType
<$> lookupInputType list types <$> lookupInputType list types'
lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types = lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types' =
case HashMap.lookup nonNull types of case HashMap.lookup nonNull types' of
Just (Schema.ScalarType scalarType) -> Just (ScalarType scalarType) ->
Just $ In.NonNullScalarType scalarType Just $ In.NonNullScalarType scalarType
Just (Schema.EnumType enumType) -> Just (EnumType enumType) ->
Just $ In.NonNullEnumType enumType Just $ In.NonNullEnumType enumType
Just (Schema.InputObjectType objectType) -> Just (InputObjectType objectType) ->
Just $ In.NonNullInputObjectType objectType Just $ In.NonNullInputObjectType objectType
_ -> Nothing _ -> Nothing
lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types'
= In.NonNullListType = In.NonNullListType
<$> lookupInputType nonNull types <$> lookupInputType nonNull types'
lookupTypeField :: forall a. Full.Name -> Out.Type a -> Maybe (Out.Field a) lookupTypeField :: forall a. Full.Name -> Out.Type a -> Maybe (Out.Field a)
lookupTypeField fieldName = \case 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/. -} obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-}
-- | This module provides a representation of a @GraphQL@ Schema in addition to -- | This module provides a representation of a @GraphQL@ Schema in addition to
-- functions for defining and manipulating schemas. -- functions for defining and manipulating schemas.
module Language.GraphQL.Type.Schema module Language.GraphQL.Type.Schema
( Directive(..) ( schema
, Directives , module Language.GraphQL.Type.Internal
, Schema(..)
, Type(..)
, schema
) where ) where
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.Text (Text) import qualified Data.HashMap.Strict as HashMap
import qualified Language.GraphQL.AST.Document as Full import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..))
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.Definition as Definition
import qualified Language.GraphQL.Type.Internal as Internal
import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out
-- | These are all of the possible kinds of types. -- | Schema constructor.
data Type m schema :: forall m
= ScalarType Definition.ScalarType . Out.ObjectType m -- ^ Query type.
| EnumType Definition.EnumType -> Maybe (Out.ObjectType m) -- ^ Mutation type.
| ObjectType (Out.ObjectType m) -> Maybe (Out.ObjectType m) -- ^ Subscription type.
| InputObjectType In.InputObjectType -> Directives -- ^ Directive definitions.
| InterfaceType (Out.InterfaceType m) -> Schema m -- ^ Schema.
| UnionType (Out.UnionType m) schema queryRoot mutationRoot subscriptionRoot directiveDefinitions =
deriving Eq 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. -- | Traverses the schema and finds all referenced types.
data Directive = Directive (Maybe Text) [DirectiveLocation] In.Arguments collectReferencedTypes :: forall m
. Out.ObjectType m
-- | Directive definitions. -> Maybe (Out.ObjectType m)
type Directives = HashMap Full.Name Directive -> Maybe (Out.ObjectType m)
-> HashMap Full.Name (Type m)
-- | A Schema is created by supplying the root types of each type of operation, collectReferencedTypes queryRoot mutationRoot subscriptionRoot =
-- query and mutation (optional). A schema definition is then supplied to the let queryTypes = traverseObjectType queryRoot HashMap.empty
-- validator and executor. mutationTypes = maybe queryTypes (`traverseObjectType` queryTypes)
-- mutationRoot
-- __Note:__ When the schema is constructed, by default only the types that in maybe mutationTypes (`traverseObjectType` queryTypes) subscriptionRoot
-- are reachable by traversing the root types are included, other types must where
-- be explicitly referenced. collect traverser typeName element foundTypes
data Schema m = Schema | HashMap.member typeName foundTypes = foundTypes
{ query :: Out.ObjectType m | otherwise = traverser $ HashMap.insert typeName element foundTypes
, mutation :: Maybe (Out.ObjectType m) visitFields (Out.Field _ outputType arguments) foundTypes
, subscription :: Maybe (Out.ObjectType m) = traverseOutputType outputType
, directives :: Directives $ foldr visitArguments foundTypes arguments
} visitArguments (In.Argument _ inputType _) = traverseInputType inputType
visitInputFields (In.InputField _ inputType _) = traverseInputType inputType
-- | Shortcut for creating a schema. getField (Out.ValueResolver field _) = field
schema :: forall m. Out.ObjectType m -> Schema m getField (Out.EventStreamResolver field _ _) = field
schema query' = Schema traverseInputType (In.InputObjectBaseType objectType) =
{ query = query' let In.InputObjectType typeName _ inputFields = objectType
, mutation = Nothing element = InputObjectType objectType
, subscription = Nothing traverser = flip (foldr visitInputFields) inputFields
, directives = mempty 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 Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..))
import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
import qualified Language.GraphQL.AST.Document as Full import qualified Language.GraphQL.AST.Document as Full
import Language.GraphQL.Type.Internal import qualified Language.GraphQL.Type.Internal as Type
import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema (Schema) import Language.GraphQL.Type.Schema (Schema)
@@ -57,55 +56,7 @@ document schema' rules' document' =
context = Validation context = Validation
{ Validation.ast = document' { Validation.ast = document'
, Validation.schema = schema' , 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 reader = do
rule' <- lift $ Seq.fromList rules' rule' <- lift $ Seq.fromList rules'
join $ lift $ foldr (definition rule' context) Seq.empty document' join $ lift $ foldr (definition rule' context) Seq.empty document'
@@ -332,7 +283,7 @@ operationDefinition rule context operation
where where
schema' = Validation.schema context schema' = Validation.schema context
queryRoot = Just $ Out.NamedObjectType $ Schema.query schema' 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 :: forall m. Schema.Type m -> Maybe (Out.Type m)
typeToOut (Schema.ObjectType objectType) = typeToOut (Schema.ObjectType objectType) =
@@ -349,7 +300,8 @@ variableDefinition :: forall m
-> ApplyRule m Full.VariableDefinition -> ApplyRule m Full.VariableDefinition
variableDefinition context rule (Full.VariableDefinition _ typeName value' _) variableDefinition context rule (Full.VariableDefinition _ typeName value' _)
| Just defaultValue' <- 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' constValue rule variableType defaultValue'
variableDefinition _ _ _ = mempty variableDefinition _ _ _ = mempty
@@ -395,7 +347,7 @@ fragmentDefinition rule context definition'
| Full.FragmentDefinition _ typeCondition directives' selections _ <- definition' | Full.FragmentDefinition _ typeCondition directives' selections _ <- definition'
= applyToChildren typeCondition directives' selections = applyToChildren typeCondition directives' selections
where where
types' = Validation.types context types' = Schema.types $ Validation.schema context
applyToChildren typeCondition directives' selections applyToChildren typeCondition directives' selections
= selectionSet context types' rule (lookupType' typeCondition) selections = selectionSet context types' rule (lookupType' typeCondition) selections
>< directives context rule fragmentDefinitionLocation directives' >< directives context rule fragmentDefinitionLocation directives'
@@ -442,7 +394,7 @@ field context types' rule objectType field' = go field'
typeFieldArguments (Out.Field _ _ argumentTypes) = argumentTypes typeFieldArguments (Out.Field _ _ argumentTypes) = argumentTypes
applyToChildren fieldName = applyToChildren fieldName =
let Full.Field _ _ arguments' directives' selections _ = field' let Full.Field _ _ arguments' directives' selections _ = field'
typeField = objectType >>= lookupTypeField fieldName typeField = objectType >>= Type.lookupTypeField fieldName
argumentTypes = maybe mempty typeFieldArguments typeField argumentTypes = maybe mempty typeFieldArguments typeField
in selectionSet context types' rule (typeFieldType <$> typeField) selections in selectionSet context types' rule (typeFieldType <$> typeField) selections
>< directives context rule fieldLocation directives' >< directives context rule fieldLocation directives'
@@ -546,7 +498,9 @@ directive _ (Validation.ArgumentsRule _ argumentsRule) directive' =
pure $ argumentsRule directive' pure $ argumentsRule directive'
directive context rule (Full.Directive directiveName arguments' _) = directive context rule (Full.Directive directiveName arguments' _) =
let argumentTypes = maybe HashMap.empty directiveArguments 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' in arguments rule argumentTypes arguments'
where where
directiveArguments (Schema.Directive _ _ argumentTypes) = argumentTypes 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 qualified Data.Sequence as Seq
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as 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 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.In as In
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out
import qualified Language.GraphQL.Type.Schema as Schema import qualified Language.GraphQL.Type.Schema as Schema
import Language.GraphQL.Validate.Validation import Language.GraphQL.Validate.Validation
-- Local help type that contains a hash set to track visited fragments. -- 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. -- | Default rules given in the specification.
specifiedRules :: forall m. [Rule m] specifiedRules :: forall m. [Rule m]
@@ -107,9 +108,9 @@ specifiedRules =
-- | Definition must be OperationDefinition or FragmentDefinition. -- | Definition must be OperationDefinition or FragmentDefinition.
executableDefinitionsRule :: forall m. Rule m executableDefinitionsRule :: forall m. Rule m
executableDefinitionsRule = DefinitionRule $ \case executableDefinitionsRule = DefinitionRule $ \case
ExecutableDefinition _ -> lift mempty Full.ExecutableDefinition _ -> lift mempty
TypeSystemDefinition _ location' -> pure $ error' location' Full.TypeSystemDefinition _ location' -> pure $ error' location'
TypeSystemExtension _ location' -> pure $ error' location' Full.TypeSystemExtension _ location' -> pure $ error' location'
where where
error' location' = Error error' location' = Error
{ message = { message =
@@ -120,7 +121,7 @@ executableDefinitionsRule = DefinitionRule $ \case
-- | Subscription operations must have exactly one root field. -- | Subscription operations must have exactly one root field.
singleFieldSubscriptionsRule :: forall m. Rule m singleFieldSubscriptionsRule :: forall m. Rule m
singleFieldSubscriptionsRule = OperationDefinitionRule $ \case singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
OperationDefinition Subscription name' _ _ rootFields location' -> do Full.OperationDefinition Full.Subscription name' _ _ rootFields location' -> do
groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty groupedFieldSet <- evalStateT (collectFields rootFields) HashSet.empty
case HashSet.size groupedFieldSet of case HashSet.size groupedFieldSet of
1 -> lift mempty 1 -> lift mempty
@@ -143,46 +144,46 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
"Anonymous Subscription must select only one top level field." "Anonymous Subscription must select only one top level field."
collectFields selectionSet = foldM forEach HashSet.empty selectionSet collectFields selectionSet = foldM forEach HashSet.empty selectionSet
forEach accumulator = \case forEach accumulator = \case
FieldSelection fieldSelection -> forField accumulator fieldSelection Full.FieldSelection fieldSelection -> forField accumulator fieldSelection
FragmentSpreadSelection fragmentSelection -> Full.FragmentSpreadSelection fragmentSelection ->
forSpread accumulator fragmentSelection forSpread accumulator fragmentSelection
InlineFragmentSelection fragmentSelection -> Full.InlineFragmentSelection fragmentSelection ->
forInline accumulator fragmentSelection forInline accumulator fragmentSelection
forField accumulator (Field alias name _ directives' _ _) forField accumulator (Full.Field alias name _ directives' _ _)
| any skip directives' = pure accumulator | any skip directives' = pure accumulator
| Just aliasedName <- alias = pure | Just aliasedName <- alias = pure
$ HashSet.insert aliasedName accumulator $ HashSet.insert aliasedName accumulator
| otherwise = pure $ HashSet.insert name accumulator | otherwise = pure $ HashSet.insert name accumulator
forSpread accumulator (FragmentSpread fragmentName directives' _) forSpread accumulator (Full.FragmentSpread fragmentName directives' _)
| any skip directives' = pure accumulator | any skip directives' = pure accumulator
| otherwise = do | otherwise = do
inVisitetFragments <- gets $ HashSet.member fragmentName inVisitetFragments <- gets $ HashSet.member fragmentName
if inVisitetFragments if inVisitetFragments
then pure accumulator then pure accumulator
else collectFromSpread fragmentName accumulator else collectFromSpread fragmentName accumulator
forInline accumulator (InlineFragment maybeType directives' selections _) forInline accumulator (Full.InlineFragment maybeType directives' selections _)
| any skip directives' = pure accumulator | any skip directives' = pure accumulator
| Just typeCondition <- maybeType = | Just typeCondition <- maybeType =
collectFromFragment typeCondition selections accumulator collectFromFragment typeCondition selections accumulator
| otherwise = HashSet.union accumulator | otherwise = HashSet.union accumulator
<$> collectFields selections <$> collectFields selections
skip (Directive "skip" [Argument "if" (Node argumentValue _) _] _) = skip (Full.Directive "skip" [Full.Argument "if" (Full.Node argumentValue _) _] _) =
Boolean True == argumentValue Full.Boolean True == argumentValue
skip (Directive "include" [Argument "if" (Node argumentValue _) _] _) = skip (Full.Directive "include" [Full.Argument "if" (Full.Node argumentValue _) _] _) =
Boolean False == argumentValue Full.Boolean False == argumentValue
skip _ = False skip _ = False
findFragmentDefinition (ExecutableDefinition executableDefinition) Nothing findFragmentDefinition (Full.ExecutableDefinition executableDefinition) Nothing
| DefinitionFragment fragmentDefinition <- executableDefinition = | Full.DefinitionFragment fragmentDefinition <- executableDefinition =
Just fragmentDefinition Just fragmentDefinition
findFragmentDefinition _ accumulator = accumulator findFragmentDefinition _ accumulator = accumulator
collectFromFragment typeCondition selectionSet accumulator = do collectFromFragment typeCondition selectionSet accumulator = do
types' <- lift $ asks types types' <- lift $ asks $ Schema.types . schema
schema' <- lift $ asks schema schema' <- lift $ asks schema
case lookupTypeCondition typeCondition types' of case Type.lookupTypeCondition typeCondition types' of
Nothing -> pure accumulator Nothing -> pure accumulator
Just compositeType Just compositeType
| Just objectType <- Schema.subscription schema' | Just objectType <- Schema.subscription schema'
, True <- doesFragmentTypeApply compositeType objectType -> , True <- Type.doesFragmentTypeApply compositeType objectType ->
HashSet.union accumulator <$> collectFields selectionSet HashSet.union accumulator <$> collectFields selectionSet
| otherwise -> pure accumulator | otherwise -> pure accumulator
collectFromSpread fragmentName accumulator = do collectFromSpread fragmentName accumulator = do
@@ -190,15 +191,16 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
ast' <- lift $ asks ast ast' <- lift $ asks ast
case foldr findFragmentDefinition Nothing ast' of case foldr findFragmentDefinition Nothing ast' of
Nothing -> pure accumulator Nothing -> pure accumulator
Just (FragmentDefinition _ typeCondition _ selectionSet _) -> Just (Full.FragmentDefinition _ typeCondition _ selectionSet _) ->
collectFromFragment typeCondition selectionSet accumulator collectFromFragment typeCondition selectionSet accumulator
-- | GraphQL allows a short‐hand form for defining query operations when only -- | GraphQL allows a short‐hand form for defining query operations when only
-- that one operation exists in the document. -- that one operation exists in the document.
loneAnonymousOperationRule :: forall m. Rule m loneAnonymousOperationRule :: forall m. Rule m
loneAnonymousOperationRule = OperationDefinitionRule $ \case loneAnonymousOperationRule = OperationDefinitionRule $ \case
SelectionSet _ thisLocation -> check thisLocation Full.SelectionSet _ thisLocation -> check thisLocation
OperationDefinition _ Nothing _ _ _ thisLocation -> check thisLocation Full.OperationDefinition _ Nothing _ _ _ thisLocation ->
check thisLocation
_ -> lift mempty _ -> lift mempty
where where
check thisLocation = asks ast check thisLocation = asks ast
@@ -208,9 +210,9 @@ loneAnonymousOperationRule = OperationDefinitionRule $ \case
compareAnonymousOperations thisLocation operationDefinition compareAnonymousOperations thisLocation operationDefinition
filterAnonymousOperations _ _ accumulator = accumulator filterAnonymousOperations _ _ accumulator = accumulator
compareAnonymousOperations thisLocation = \case compareAnonymousOperations thisLocation = \case
OperationDefinition _ _ _ _ _ thatLocation Full.OperationDefinition _ _ _ _ _ thatLocation
| thisLocation /= thatLocation -> pure $ error' thisLocation | thisLocation /= thatLocation -> pure $ error' thisLocation
SelectionSet _ thatLocation Full.SelectionSet _ thatLocation
| thisLocation /= thatLocation -> pure $ error' thisLocation | thisLocation /= thatLocation -> pure $ error' thisLocation
_ -> mempty _ -> mempty
error' location' = Error error' location' = Error
@@ -223,7 +225,7 @@ loneAnonymousOperationRule = OperationDefinitionRule $ \case
-- referred to by its name. -- referred to by its name.
uniqueOperationNamesRule :: forall m. Rule m uniqueOperationNamesRule :: forall m. Rule m
uniqueOperationNamesRule = OperationDefinitionRule $ \case uniqueOperationNamesRule = OperationDefinitionRule $ \case
OperationDefinition _ (Just thisName) _ _ _ thisLocation -> Full.OperationDefinition _ (Just thisName) _ _ _ thisLocation ->
findDuplicates (filterByName thisName) thisLocation (error' thisName) findDuplicates (filterByName thisName) thisLocation (error' thisName)
_ -> lift mempty _ -> lift mempty
where where
@@ -234,12 +236,12 @@ uniqueOperationNamesRule = OperationDefinitionRule $ \case
] ]
filterByName thisName definition' accumulator filterByName thisName definition' accumulator
| (viewOperation -> Just operationDefinition) <- definition' | (viewOperation -> Just operationDefinition) <- definition'
, OperationDefinition _ (Just thatName) _ _ _ thatLocation <- operationDefinition , Full.OperationDefinition _ (Just thatName) _ _ _ thatLocation <- operationDefinition
, thisName == thatName = thatLocation : accumulator , thisName == thatName = thatLocation : accumulator
| otherwise = accumulator | otherwise = accumulator
findDuplicates :: (Definition -> [Location] -> [Location]) findDuplicates :: (Full.Definition -> [Full.Location] -> [Full.Location])
-> Location -> Full.Location
-> String -> String
-> RuleT m -> RuleT m
findDuplicates filterByName thisLocation errorMessage = do findDuplicates filterByName thisLocation errorMessage = do
@@ -254,17 +256,17 @@ findDuplicates filterByName thisLocation errorMessage = do
, locations = locations' , locations = locations'
} }
viewOperation :: Definition -> Maybe OperationDefinition viewOperation :: Full.Definition -> Maybe Full.OperationDefinition
viewOperation definition viewOperation definition
| ExecutableDefinition executableDefinition <- definition | Full.ExecutableDefinition executableDefinition <- definition
, DefinitionOperation operationDefinition <- executableDefinition = , Full.DefinitionOperation operationDefinition <- executableDefinition =
Just operationDefinition Just operationDefinition
viewOperation _ = Nothing viewOperation _ = Nothing
viewFragment :: Definition -> Maybe FragmentDefinition viewFragment :: Full.Definition -> Maybe Full.FragmentDefinition
viewFragment definition viewFragment definition
| ExecutableDefinition executableDefinition <- definition | Full.ExecutableDefinition executableDefinition <- definition
, DefinitionFragment fragmentDefinition <- executableDefinition = , Full.DefinitionFragment fragmentDefinition <- executableDefinition =
Just fragmentDefinition Just fragmentDefinition
viewFragment _ = Nothing viewFragment _ = Nothing
@@ -275,7 +277,7 @@ viewFragment _ = Nothing
-- by this validation rule. -- by this validation rule.
uniqueFragmentNamesRule :: forall m. Rule m uniqueFragmentNamesRule :: forall m. Rule m
uniqueFragmentNamesRule = FragmentDefinitionRule $ \case uniqueFragmentNamesRule = FragmentDefinitionRule $ \case
FragmentDefinition thisName _ _ _ thisLocation -> Full.FragmentDefinition thisName _ _ _ thisLocation ->
findDuplicates (filterByName thisName) thisLocation (error' thisName) findDuplicates (filterByName thisName) thisLocation (error' thisName)
where where
error' fragmentName = concat error' fragmentName = concat
@@ -285,7 +287,7 @@ uniqueFragmentNamesRule = FragmentDefinitionRule $ \case
] ]
filterByName thisName definition accumulator filterByName thisName definition accumulator
| Just fragmentDefinition <- viewFragment definition | Just fragmentDefinition <- viewFragment definition
, FragmentDefinition thatName _ _ _ thatLocation <- fragmentDefinition , Full.FragmentDefinition thatName _ _ _ thatLocation <- fragmentDefinition
, thisName == thatName = thatLocation : accumulator , thisName == thatName = thatLocation : accumulator
| otherwise = accumulator | otherwise = accumulator
@@ -293,7 +295,7 @@ uniqueFragmentNamesRule = FragmentDefinitionRule $ \case
-- It is a validation error if the target of a spread is not defined. -- It is a validation error if the target of a spread is not defined.
fragmentSpreadTargetDefinedRule :: forall m. Rule m fragmentSpreadTargetDefinedRule :: forall m. Rule m
fragmentSpreadTargetDefinedRule = FragmentSpreadRule $ \case fragmentSpreadTargetDefinedRule = FragmentSpreadRule $ \case
FragmentSpread fragmentName _ location' -> do Full.FragmentSpread fragmentName _ location' -> do
ast' <- asks ast ast' <- asks ast
case find (isSpreadTarget fragmentName) ast' of case find (isSpreadTarget fragmentName) ast' of
Nothing -> pure $ Error Nothing -> pure $ Error
@@ -308,9 +310,9 @@ fragmentSpreadTargetDefinedRule = FragmentSpreadRule $ \case
, "\" is undefined." , "\" is undefined."
] ]
isSpreadTarget :: Text -> Definition -> Bool isSpreadTarget :: Text -> Full.Definition -> Bool
isSpreadTarget thisName (viewFragment -> Just fragmentDefinition) isSpreadTarget thisName (viewFragment -> Just fragmentDefinition)
| FragmentDefinition thatName _ _ _ _ <- fragmentDefinition | Full.FragmentDefinition thatName _ _ _ _ <- fragmentDefinition
, thisName == thatName = True , thisName == thatName = True
isSpreadTarget _ _ = False isSpreadTarget _ _ = False
@@ -319,22 +321,22 @@ isSpreadTarget _ _ = False
-- the query does not validate. -- the query does not validate.
fragmentSpreadTypeExistenceRule :: forall m. Rule m fragmentSpreadTypeExistenceRule :: forall m. Rule m
fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case
FragmentSpreadSelection fragmentSelection Full.FragmentSpreadSelection fragmentSelection
| FragmentSpread fragmentName _ location' <- fragmentSelection -> do | Full.FragmentSpread fragmentName _ location' <- fragmentSelection -> do
ast' <- asks ast ast' <- asks ast
let target = find (isSpreadTarget fragmentName) ast' let target = find (isSpreadTarget fragmentName) ast'
typeCondition <- lift $ maybeToSeq $ target >>= extractTypeCondition typeCondition <- lift $ maybeToSeq $ target >>= extractTypeCondition
types' <- asks types types' <- asks $ Schema.types . schema
case HashMap.lookup typeCondition types' of case HashMap.lookup typeCondition types' of
Nothing -> pure $ Error Nothing -> pure $ Error
{ message = spreadError fragmentName typeCondition { message = spreadError fragmentName typeCondition
, locations = [location'] , locations = [location']
} }
Just _ -> lift mempty Just _ -> lift mempty
InlineFragmentSelection fragmentSelection Full.InlineFragmentSelection fragmentSelection
| InlineFragment maybeType _ _ location' <- fragmentSelection | Full.InlineFragment maybeType _ _ location' <- fragmentSelection
, Just typeCondition <- maybeType -> do , Just typeCondition <- maybeType -> do
types' <- asks types types' <- asks $ Schema.types . schema
case HashMap.lookup typeCondition types' of case HashMap.lookup typeCondition types' of
Nothing -> pure $ Error Nothing -> pure $ Error
{ message = inlineError typeCondition { message = inlineError typeCondition
@@ -344,7 +346,7 @@ fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case
_ -> lift mempty _ -> lift mempty
where where
extractTypeCondition (viewFragment -> Just fragmentDefinition) = extractTypeCondition (viewFragment -> Just fragmentDefinition) =
let FragmentDefinition _ typeCondition _ _ _ = fragmentDefinition let Full.FragmentDefinition _ typeCondition _ _ _ = fragmentDefinition
in Just typeCondition in Just typeCondition
extractTypeCondition _ = Nothing extractTypeCondition _ = Nothing
spreadError fragmentName typeCondition = concat spreadError fragmentName typeCondition = concat
@@ -370,16 +372,16 @@ maybeToSeq Nothing = mempty
fragmentsOnCompositeTypesRule :: forall m. Rule m fragmentsOnCompositeTypesRule :: forall m. Rule m
fragmentsOnCompositeTypesRule = FragmentRule definitionRule inlineRule fragmentsOnCompositeTypesRule = FragmentRule definitionRule inlineRule
where where
inlineRule (InlineFragment (Just typeCondition) _ _ location') = inlineRule (Full.InlineFragment (Just typeCondition) _ _ location') =
check typeCondition location' check typeCondition location'
inlineRule _ = lift mempty inlineRule _ = lift mempty
definitionRule (FragmentDefinition _ typeCondition _ _ location') = definitionRule (Full.FragmentDefinition _ typeCondition _ _ location') =
check typeCondition location' check typeCondition location'
check typeCondition location' = do check typeCondition location' = do
types' <- asks types types' <- asks $ Schema.types . schema
-- Skip unknown types, they are checked by another rule. -- Skip unknown types, they are checked by another rule.
_ <- lift $ maybeToSeq $ HashMap.lookup typeCondition types' _ <- lift $ maybeToSeq $ HashMap.lookup typeCondition types'
case lookupTypeCondition typeCondition types' of case Type.lookupTypeCondition typeCondition types' of
Nothing -> pure $ Error Nothing -> pure $ Error
{ message = errorMessage typeCondition { message = errorMessage typeCondition
, locations = [location'] , locations = [location']
@@ -394,7 +396,7 @@ fragmentsOnCompositeTypesRule = FragmentRule definitionRule inlineRule
-- | Defined fragments must be used within a document. -- | Defined fragments must be used within a document.
noUnusedFragmentsRule :: forall m. Rule m noUnusedFragmentsRule :: forall m. Rule m
noUnusedFragmentsRule = FragmentDefinitionRule $ \fragment -> do noUnusedFragmentsRule = FragmentDefinitionRule $ \fragment -> do
let FragmentDefinition fragmentName _ _ _ location' = fragment let Full.FragmentDefinition fragmentName _ _ _ location' = fragment
in mapReaderT (checkFragmentName fragmentName location') in mapReaderT (checkFragmentName fragmentName location')
$ asks ast $ asks ast
>>= flip evalStateT HashSet.empty >>= flip evalStateT HashSet.empty
@@ -414,35 +416,36 @@ noUnusedFragmentsRule = FragmentDefinitionRule $ \fragment -> do
, "\" is never used." , "\" is never used."
] ]
evaluateSelection selection evaluateSelection selection
| FragmentSpreadSelection spreadSelection <- selection | Full.FragmentSpreadSelection spreadSelection <- selection
, FragmentSpread spreadName _ _ <- spreadSelection = , Full.FragmentSpread spreadName _ _ <- spreadSelection =
lift $ pure spreadName lift $ pure spreadName
evaluateSelection _ = lift $ lift mempty evaluateSelection _ = lift $ lift mempty
definitionSelections :: Definition -> SelectionSetOpt definitionSelections :: Full.Definition -> Full.SelectionSetOpt
definitionSelections (viewOperation -> Just operation) definitionSelections (viewOperation -> Just operation)
| OperationDefinition _ _ _ _ selections _ <- operation = toList selections | Full.OperationDefinition _ _ _ _ selections _ <- operation =
| SelectionSet selections _ <- operation = toList selections toList selections
| Full.SelectionSet selections _ <- operation = toList selections
definitionSelections (viewFragment -> Just fragment) definitionSelections (viewFragment -> Just fragment)
| FragmentDefinition _ _ _ selections _ <- fragment = toList selections | Full.FragmentDefinition _ _ _ selections _ <- fragment = toList selections
definitionSelections _ = [] definitionSelections _ = []
filterSelections :: Foldable t filterSelections :: Foldable t
=> forall a m => forall a m
. (Selection -> ValidationState m a) . (Full.Selection -> ValidationState m a)
-> t Selection -> t Full.Selection
-> ValidationState m a -> ValidationState m a
filterSelections applyFilter selections filterSelections applyFilter selections
= (lift . lift) (Seq.fromList $ foldr evaluateSelection mempty selections) = (lift . lift) (Seq.fromList $ foldr evaluateSelection mempty selections)
>>= applyFilter >>= applyFilter
where where
evaluateSelection selection accumulator evaluateSelection selection accumulator
| FragmentSpreadSelection{} <- selection = selection : accumulator | Full.FragmentSpreadSelection{} <- selection = selection : accumulator
| FieldSelection fieldSelection <- selection | Full.FieldSelection fieldSelection <- selection
, Field _ _ _ _ subselections _ <- fieldSelection = , Full.Field _ _ _ _ subselections _ <- fieldSelection =
selection : foldr evaluateSelection accumulator subselections selection : foldr evaluateSelection accumulator subselections
| InlineFragmentSelection inlineSelection <- selection | Full.InlineFragmentSelection inlineSelection <- selection
, InlineFragment _ _ subselections _ <- inlineSelection = , Full.InlineFragment _ _ subselections _ <- inlineSelection =
selection : foldr evaluateSelection accumulator subselections selection : foldr evaluateSelection accumulator subselections
-- | The graph of fragment spreads must not form any cycles including spreading -- | 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. -- on cycles in the underlying data.
noFragmentCyclesRule :: forall m. Rule m noFragmentCyclesRule :: forall m. Rule m
noFragmentCyclesRule = FragmentDefinitionRule $ \case noFragmentCyclesRule = FragmentDefinitionRule $ \case
FragmentDefinition fragmentName _ _ selections location' -> do Full.FragmentDefinition fragmentName _ _ selections location' -> do
state <- evalStateT (collectFields selections) state <- evalStateT (collectFields selections)
(0, fragmentName) (0, fragmentName)
let spreadPath = fst <$> sortBy (comparing snd) (HashMap.toList state) let spreadPath = fst <$> sortBy (comparing snd) (HashMap.toList state)
@@ -468,16 +471,16 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case
_ -> lift mempty _ -> lift mempty
where where
collectFields :: Traversable t collectFields :: Traversable t
=> t Selection => t Full.Selection
-> StateT (Int, Name) (ReaderT (Validation m) Seq) (HashMap Name Int) -> StateT (Int, Full.Name) (ReaderT (Validation m) Seq) (HashMap Full.Name Int)
collectFields selectionSet = foldM forEach HashMap.empty selectionSet collectFields selectionSet = foldM forEach HashMap.empty selectionSet
forEach accumulator = \case forEach accumulator = \case
FieldSelection fieldSelection -> forField accumulator fieldSelection Full.FieldSelection fieldSelection -> forField accumulator fieldSelection
InlineFragmentSelection fragmentSelection -> Full.InlineFragmentSelection fragmentSelection ->
forInline accumulator fragmentSelection forInline accumulator fragmentSelection
FragmentSpreadSelection fragmentSelection -> Full.FragmentSpreadSelection fragmentSelection ->
forSpread accumulator fragmentSelection forSpread accumulator fragmentSelection
forSpread accumulator (FragmentSpread fragmentName _ _) = do forSpread accumulator (Full.FragmentSpread fragmentName _ _) = do
firstFragmentName <- gets snd firstFragmentName <- gets snd
modify $ first (+ 1) modify $ first (+ 1)
lastIndex <- gets fst lastIndex <- gets fst
@@ -486,20 +489,20 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case
if fragmentName == firstFragmentName || inVisitetFragment if fragmentName == firstFragmentName || inVisitetFragment
then pure newAccumulator then pure newAccumulator
else collectFromSpread fragmentName newAccumulator else collectFromSpread fragmentName newAccumulator
forInline accumulator (InlineFragment _ _ selections _) = forInline accumulator (Full.InlineFragment _ _ selections _) =
(accumulator <>) <$> collectFields selections (accumulator <>) <$> collectFields selections
forField accumulator (Field _ _ _ _ selections _) = forField accumulator (Full.Field _ _ _ _ selections _) =
(accumulator <>) <$> collectFields selections (accumulator <>) <$> collectFields selections
findFragmentDefinition n (ExecutableDefinition executableDefinition) Nothing findFragmentDefinition n (Full.ExecutableDefinition executableDefinition) Nothing
| DefinitionFragment fragmentDefinition <- executableDefinition | Full.DefinitionFragment fragmentDefinition <- executableDefinition
, FragmentDefinition fragmentName _ _ _ _ <- fragmentDefinition , Full.FragmentDefinition fragmentName _ _ _ _ <- fragmentDefinition
, fragmentName == n = Just fragmentDefinition , fragmentName == n = Just fragmentDefinition
findFragmentDefinition _ _ accumulator = accumulator findFragmentDefinition _ _ accumulator = accumulator
collectFromSpread _fragmentName accumulator = do collectFromSpread _fragmentName accumulator = do
ast' <- lift $ asks ast ast' <- lift $ asks ast
case foldr (findFragmentDefinition _fragmentName) Nothing ast' of case foldr (findFragmentDefinition _fragmentName) Nothing ast' of
Nothing -> pure accumulator Nothing -> pure accumulator
Just (FragmentDefinition _ _ _ selections _) -> Just (Full.FragmentDefinition _ _ _ selections _) ->
(accumulator <>) <$> collectFields selections (accumulator <>) <$> collectFields selections
-- | Fields and directives treat arguments as a mapping of argument name to -- | 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 :: forall m. Rule m
uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule uniqueArgumentNamesRule = ArgumentsRule fieldRule directiveRule
where where
fieldRule _ (Field _ _ arguments _ _ _) = fieldRule _ (Full.Field _ _ arguments _ _ _) =
lift $ filterDuplicates extract "argument" arguments lift $ filterDuplicates extract "argument" arguments
directiveRule (Directive _ arguments _) = directiveRule (Full.Directive _ arguments _) =
lift $ filterDuplicates extract "argument" 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 -- | 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 -- 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 uniqueDirectiveNamesRule = DirectivesRule
$ const $ lift . filterDuplicates extract "directive" $ const $ lift . filterDuplicates extract "directive"
where 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 filterDuplicates extract nodeType = Seq.fromList
. fmap makeError . fmap makeError
. filter ((> 1) . length) . filter ((> 1) . length)
@@ -552,7 +556,7 @@ uniqueVariableNamesRule :: forall m. Rule m
uniqueVariableNamesRule = VariablesRule uniqueVariableNamesRule = VariablesRule
$ lift . filterDuplicates extract "variable" $ lift . filterDuplicates extract "variable"
where where
extract (VariableDefinition variableName _ _ location') = extract (Full.VariableDefinition variableName _ _ location') =
(variableName, location') (variableName, location')
-- | Variables can only be input types. Objects, unions and interfaces cannot be -- | Variables can only be input types. Objects, unions and interfaces cannot be
@@ -561,11 +565,11 @@ variablesAreInputTypesRule :: forall m. Rule m
variablesAreInputTypesRule = VariablesRule variablesAreInputTypesRule = VariablesRule
$ (traverse check . Seq.fromList) >=> lift $ (traverse check . Seq.fromList) >=> lift
where where
check (VariableDefinition name typeName _ location') check (Full.VariableDefinition name typeName _ location')
= asks types = asks (Schema.types . schema)
>>= lift >>= lift
. maybe (makeError name typeName location') (const mempty) . maybe (makeError name typeName location') (const mempty)
. lookupInputType typeName . Type.lookupInputType typeName
makeError name typeName location' = pure $ Error makeError name typeName location' = pure $ Error
{ message = concat { message = concat
[ "Variable \"$" [ "Variable \"$"
@@ -576,10 +580,11 @@ variablesAreInputTypesRule = VariablesRule
] ]
, locations = [location'] , locations = [location']
} }
getTypeName (TypeNamed name) = name getTypeName (Full.TypeNamed name) = name
getTypeName (TypeList name) = getTypeName name getTypeName (Full.TypeList name) = getTypeName name
getTypeName (TypeNonNull (NonNullTypeNamed nonNull)) = nonNull getTypeName (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) = nonNull
getTypeName (TypeNonNull (NonNullTypeList nonNull)) = getTypeName nonNull getTypeName (Full.TypeNonNull (Full.NonNullTypeList nonNull)) =
getTypeName nonNull
-- | Variables are scoped on a per‐operation basis. That means that any variable -- | 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 -- used within the context of an operation must be defined at the top level of
@@ -601,13 +606,17 @@ noUndefinedVariablesRule =
, "\"." , "\"."
] ]
variableUsageDifference :: forall m type UsageDifference
. (HashMap Name [Location] -> HashMap Name [Location] -> HashMap Name [Location]) = HashMap Full.Name [Full.Location]
-> (Maybe Name -> Name -> String) -> HashMap Full.Name [Full.Location]
-> HashMap Full.Name [Full.Location]
variableUsageDifference :: forall m. UsageDifference
-> (Maybe Full.Name -> Full.Name -> String)
-> Rule m -> Rule m
variableUsageDifference difference errorMessage = OperationDefinitionRule $ \case variableUsageDifference difference errorMessage = OperationDefinitionRule $ \case
SelectionSet _ _ -> lift mempty Full.SelectionSet _ _ -> lift mempty
OperationDefinition _ operationName variables _ selections _ -> Full.OperationDefinition _ operationName variables _ selections _ ->
let variableNames = HashMap.fromList $ getVariableName <$> variables let variableNames = HashMap.fromList $ getVariableName <$> variables
in mapReaderT (readerMapper operationName variableNames) in mapReaderT (readerMapper operationName variableNames)
$ flip evalStateT HashSet.empty $ flip evalStateT HashSet.empty
@@ -620,21 +629,21 @@ variableUsageDifference difference errorMessage = OperationDefinitionRule $ \cas
. difference variableNames' . difference variableNames'
. HashMap.fromListWith (++) . HashMap.fromListWith (++)
. toList . toList
getVariableName (VariableDefinition variableName _ _ location') = getVariableName (Full.VariableDefinition variableName _ _ location') =
(variableName, [location']) (variableName, [location'])
filterSelections' :: Foldable t filterSelections' :: Foldable t
=> t Selection => t Full.Selection
-> ValidationState m (Name, [Location]) -> ValidationState m (Full.Name, [Full.Location])
filterSelections' = filterSelections variableFilter filterSelections' = filterSelections variableFilter
variableFilter :: Selection -> ValidationState m (Name, [Location]) variableFilter :: Full.Selection -> ValidationState m (Full.Name, [Full.Location])
variableFilter (InlineFragmentSelection inline) variableFilter (Full.InlineFragmentSelection inline)
| InlineFragment _ directives' _ _ <- inline = | Full.InlineFragment _ directives' _ _ <- inline =
lift $ lift $ mapDirectives directives' lift $ lift $ mapDirectives directives'
variableFilter (FieldSelection fieldSelection) variableFilter (Full.FieldSelection fieldSelection)
| Field _ _ arguments directives' _ _ <- fieldSelection = | Full.Field _ _ arguments directives' _ _ <- fieldSelection =
lift $ lift $ mapArguments arguments <> mapDirectives directives' lift $ lift $ mapArguments arguments <> mapDirectives directives'
variableFilter (FragmentSpreadSelection spread) variableFilter (Full.FragmentSpreadSelection spread)
| FragmentSpread fragmentName _ _ <- spread = do | Full.FragmentSpread fragmentName _ _ <- spread = do
definitions <- lift $ asks ast definitions <- lift $ asks ast
visited <- gets (HashSet.member fragmentName) visited <- gets (HashSet.member fragmentName)
modify (HashSet.insert fragmentName) modify (HashSet.insert fragmentName)
@@ -642,13 +651,13 @@ variableUsageDifference difference errorMessage = OperationDefinitionRule $ \cas
Just (viewFragment -> Just fragmentDefinition) Just (viewFragment -> Just fragmentDefinition)
| not visited -> diveIntoSpread fragmentDefinition | not visited -> diveIntoSpread fragmentDefinition
_ -> lift $ lift mempty _ -> lift $ lift mempty
diveIntoSpread (FragmentDefinition _ _ directives' selections _) diveIntoSpread (Full.FragmentDefinition _ _ directives' selections _)
= filterSelections' selections = filterSelections' selections
>>= lift . mapReaderT (<> mapDirectives directives') . pure >>= lift . mapReaderT (<> mapDirectives directives') . pure
findDirectiveVariables (Directive _ arguments _) = mapArguments arguments findDirectiveVariables (Full.Directive _ arguments _) = mapArguments arguments
mapArguments = Seq.fromList . mapMaybe findArgumentVariables mapArguments = Seq.fromList . mapMaybe findArgumentVariables
mapDirectives = foldMap findDirectiveVariables mapDirectives = foldMap findDirectiveVariables
findArgumentVariables (Argument _ Node{ node = Variable value', ..} _) = findArgumentVariables (Full.Argument _ Full.Node{ node = Full.Variable value', ..} _) =
Just (value', [location]) Just (value', [location])
findArgumentVariables _ = Nothing findArgumentVariables _ = Nothing
makeError operationName (variableName, locations') = Error makeError operationName (variableName, locations') = Error
@@ -682,12 +691,12 @@ uniqueInputFieldNamesRule :: forall m. Rule m
uniqueInputFieldNamesRule = uniqueInputFieldNamesRule =
ValueRule (const $ lift . go) (const $ lift . constGo) ValueRule (const $ lift . go) (const $ lift . constGo)
where where
go (Node (Object fields) _) = filterFieldDuplicates fields go (Full.Node (Full.Object fields) _) = filterFieldDuplicates fields
go _ = mempty go _ = mempty
filterFieldDuplicates fields = filterFieldDuplicates fields =
filterDuplicates getFieldName "input field" fields filterDuplicates getFieldName "input field" fields
getFieldName (ObjectField fieldName _ location') = (fieldName, location') getFieldName (Full.ObjectField fieldName _ location') = (fieldName, location')
constGo (Node (ConstObject fields) _) = filterFieldDuplicates fields constGo (Full.Node (Full.ConstObject fields) _) = filterFieldDuplicates fields
constGo _ = mempty constGo _ = mempty
-- | The target field of a field selection must be defined on the scoped type of -- | 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 :: forall m. Rule m
fieldsOnCorrectTypeRule = FieldRule fieldRule fieldsOnCorrectTypeRule = FieldRule fieldRule
where where
fieldRule parentType (Field _ fieldName _ _ _ location') fieldRule parentType (Full.Field _ fieldName _ _ _ location')
| Just objectType <- parentType | Just objectType <- parentType
, Nothing <- lookupTypeField fieldName objectType , Nothing <- Type.lookupTypeField fieldName objectType
, Just typeName <- compositeTypeName objectType = pure $ Error , Just typeName <- compositeTypeName objectType = pure $ Error
{ message = errorMessage fieldName typeName { message = errorMessage fieldName typeName
, locations = [location'] , 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 _ _ _)) = compositeTypeName (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) =
Just typeName Just typeName
compositeTypeName (Out.InterfaceBaseType interfaceType) = compositeTypeName (Out.InterfaceBaseType interfaceType) =
@@ -731,9 +740,9 @@ compositeTypeName (Out.ListBaseType wrappedType) =
scalarLeafsRule :: forall m. Rule m scalarLeafsRule :: forall m. Rule m
scalarLeafsRule = FieldRule fieldRule scalarLeafsRule = FieldRule fieldRule
where where
fieldRule parentType selectionField@(Field _ fieldName _ _ _ _) fieldRule parentType selectionField@(Full.Field _ fieldName _ _ _ _)
| Just objectType <- parentType | Just objectType <- parentType
, Just field <- lookupTypeField fieldName objectType = , Just field <- Type.lookupTypeField fieldName objectType =
let Out.Field _ fieldType _ = field let Out.Field _ fieldType _ = field
in lift $ check fieldType selectionField in lift $ check fieldType selectionField
| otherwise = lift mempty | otherwise = lift mempty
@@ -748,7 +757,7 @@ scalarLeafsRule = FieldRule fieldRule
check (Out.EnumBaseType (Definition.EnumType typeName _ _)) = check (Out.EnumBaseType (Definition.EnumType typeName _ _)) =
checkEmpty typeName checkEmpty typeName
check (Out.ListBaseType wrappedType) = check wrappedType check (Out.ListBaseType wrappedType) = check wrappedType
checkNotEmpty typeName (Field _ fieldName _ _ [] location') = checkNotEmpty typeName (Full.Field _ fieldName _ _ [] location') =
let fieldName' = Text.unpack fieldName let fieldName' = Text.unpack fieldName
in makeError location' $ concat in makeError location' $ concat
[ "Field \"" [ "Field \""
@@ -760,9 +769,9 @@ scalarLeafsRule = FieldRule fieldRule
, " { ... }\"?" , " { ... }\"?"
] ]
checkNotEmpty _ _ = mempty checkNotEmpty _ _ = mempty
checkEmpty _ (Field _ _ _ _ [] _) = mempty checkEmpty _ (Full.Field _ _ _ _ [] _) = mempty
checkEmpty typeName field' = checkEmpty typeName field' =
let Field _ fieldName _ _ _ location' = field' let Full.Field _ fieldName _ _ _ location' = field'
in makeError location' $ concat in makeError location' $ concat
[ "Field \"" [ "Field \""
, Text.unpack fieldName , Text.unpack fieldName
@@ -780,12 +789,12 @@ scalarLeafsRule = FieldRule fieldRule
knownArgumentNamesRule :: forall m. Rule m knownArgumentNamesRule :: forall m. Rule m
knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule
where where
fieldRule (Just objectType) (Field _ fieldName arguments _ _ _) fieldRule (Just objectType) (Full.Field _ fieldName arguments _ _ _)
| Just typeField <- lookupTypeField fieldName objectType | Just typeField <- Type.lookupTypeField fieldName objectType
, Just typeName <- compositeTypeName objectType = , Just typeName <- compositeTypeName objectType =
lift $ foldr (go typeName fieldName typeField) Seq.empty arguments lift $ foldr (go typeName fieldName typeField) Seq.empty arguments
fieldRule _ _ = lift mempty fieldRule _ _ = lift mempty
go typeName fieldName fieldDefinition (Argument argumentName _ location') errors go typeName fieldName fieldDefinition (Full.Argument argumentName _ location') errors
| Out.Field _ _ definitions <- fieldDefinition | Out.Field _ _ definitions <- fieldDefinition
, Just _ <- HashMap.lookup argumentName definitions = errors , Just _ <- HashMap.lookup argumentName definitions = errors
| otherwise = errors |> Error | otherwise = errors |> Error
@@ -801,9 +810,10 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule
, Text.unpack fieldName , Text.unpack fieldName
, "\"." , "\"."
] ]
directiveRule (Directive directiveName arguments _) = do directiveRule (Full.Directive directiveName arguments _) = do
available <- asks $ HashMap.lookup directiveName . directives available <- asks $ HashMap.lookup directiveName
Argument argumentName _ location' <- lift $ Seq.fromList arguments . Schema.directives . schema
Full.Argument argumentName _ location' <- lift $ Seq.fromList arguments
case available of case available of
Just (Schema.Directive _ _ definitions) Just (Schema.Directive _ _ definitions)
| not $ HashMap.member argumentName definitions -> | not $ HashMap.member argumentName definitions ->
@@ -825,7 +835,7 @@ knownArgumentNamesRule = ArgumentsRule fieldRule directiveRule
-- directive, the directive must be available on that server. -- directive, the directive must be available on that server.
knownDirectiveNamesRule :: Rule m knownDirectiveNamesRule :: Rule m
knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do
definitions' <- asks directives definitions' <- asks $ Schema.directives . schema
let directiveSet = HashSet.fromList $ fmap directiveName directives' let directiveSet = HashSet.fromList $ fmap directiveName directives'
let definitionSet = HashSet.fromList $ HashMap.keys definitions' let definitionSet = HashSet.fromList $ HashMap.keys definitions'
let difference = HashSet.difference directiveSet definitionSet let difference = HashSet.difference directiveSet definitionSet
@@ -834,8 +844,8 @@ knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do
where where
definitionFilter difference = flip HashSet.member difference definitionFilter difference = flip HashSet.member difference
. directiveName . directiveName
directiveName (Directive directiveName' _ _) = directiveName' directiveName (Full.Directive directiveName' _ _) = directiveName'
makeError (Directive directiveName' _ location') = Error makeError (Full.Directive directiveName' _ location') = Error
{ message = errorMessage directiveName' { message = errorMessage directiveName'
, locations = [location'] , locations = [location']
} }
@@ -850,15 +860,15 @@ knownDirectiveNamesRule = DirectivesRule $ const $ \directives' -> do
knownInputFieldNamesRule :: Rule m knownInputFieldNamesRule :: Rule m
knownInputFieldNamesRule = ValueRule go constGo knownInputFieldNamesRule = ValueRule go constGo
where where
go (Just valueType) (Node (Object inputFields) _) go (Just valueType) (Full.Node (Full.Object inputFields) _)
| In.InputObjectBaseType objectType <- valueType = | In.InputObjectBaseType objectType <- valueType =
lift $ Seq.fromList $ mapMaybe (forEach objectType) inputFields lift $ Seq.fromList $ mapMaybe (forEach objectType) inputFields
go _ _ = lift mempty go _ _ = lift mempty
constGo (Just valueType) (Node (ConstObject inputFields) _) constGo (Just valueType) (Full.Node (Full.ConstObject inputFields) _)
| In.InputObjectBaseType objectType <- valueType = | In.InputObjectBaseType objectType <- valueType =
lift $ Seq.fromList $ mapMaybe (forEach objectType) inputFields lift $ Seq.fromList $ mapMaybe (forEach objectType) inputFields
constGo _ _ = lift mempty constGo _ _ = lift mempty
forEach objectType (ObjectField inputFieldName _ location') forEach objectType (Full.ObjectField inputFieldName _ location')
| In.InputObjectType _ _ fieldTypes <- objectType | In.InputObjectType _ _ fieldTypes <- objectType
, Just _ <- HashMap.lookup inputFieldName fieldTypes = Nothing , Just _ <- HashMap.lookup inputFieldName fieldTypes = Nothing
| otherwise | otherwise
@@ -881,8 +891,9 @@ directivesInValidLocationsRule :: Rule m
directivesInValidLocationsRule = DirectivesRule directivesRule directivesInValidLocationsRule = DirectivesRule directivesRule
where where
directivesRule directiveLocation directives' = do directivesRule directiveLocation directives' = do
Directive directiveName _ location <- lift $ Seq.fromList directives' Full.Directive directiveName _ location <- lift $ Seq.fromList directives'
maybeDefinition <- asks $ HashMap.lookup directiveName . directives maybeDefinition <- asks
$ HashMap.lookup directiveName . Schema.directives . schema
case maybeDefinition of case maybeDefinition of
Just (Schema.Directive _ allowedLocations _) Just (Schema.Directive _ allowedLocations _)
| directiveLocation `notElem` allowedLocations -> pure $ Error | directiveLocation `notElem` allowedLocations -> pure $ Error
@@ -904,14 +915,15 @@ directivesInValidLocationsRule = DirectivesRule directivesRule
providedRequiredArgumentsRule :: Rule m providedRequiredArgumentsRule :: Rule m
providedRequiredArgumentsRule = ArgumentsRule fieldRule directiveRule providedRequiredArgumentsRule = ArgumentsRule fieldRule directiveRule
where where
fieldRule (Just objectType) (Field _ fieldName arguments _ _ location') fieldRule (Just objectType) (Full.Field _ fieldName arguments _ _ location')
| Just typeField <- lookupTypeField fieldName objectType | Just typeField <- Type.lookupTypeField fieldName objectType
, Out.Field _ _ definitions <- typeField = , Out.Field _ _ definitions <- typeField =
let forEach = go (fieldMessage fieldName) arguments location' let forEach = go (fieldMessage fieldName) arguments location'
in lift $ HashMap.foldrWithKey forEach Seq.empty definitions in lift $ HashMap.foldrWithKey forEach Seq.empty definitions
fieldRule _ _ = lift mempty fieldRule _ _ = lift mempty
directiveRule (Directive directiveName arguments location') = do directiveRule (Full.Directive directiveName arguments location') = do
available <- asks $ HashMap.lookup directiveName . directives available <- asks
$ HashMap.lookup directiveName . Schema.directives . schema
case available of case available of
Just (Schema.Directive _ _ definitions) -> Just (Schema.Directive _ _ definitions) ->
let forEach = go (directiveMessage directiveName) arguments location' let forEach = go (directiveMessage directiveName) arguments location'
@@ -930,9 +942,10 @@ providedRequiredArgumentsRule = ArgumentsRule fieldRule directiveRule
{ message = errorMessage { message = errorMessage
, locations = [location'] , locations = [location']
} }
isNothingOrNull (Just (Argument _ (Node Null _) _)) = True isNothingOrNull (Just (Full.Argument _ (Full.Node Full.Null _) _)) = True
isNothingOrNull x = isNothing x isNothingOrNull x = isNothing x
lookupArgument needle (Argument argumentName _ _) = needle == argumentName lookupArgument needle (Full.Argument argumentName _ _) =
needle == argumentName
fieldMessage fieldName argumentName typeName = concat fieldMessage fieldName argumentName typeName = concat
[ "Field \"" [ "Field \""
, Text.unpack fieldName , Text.unpack fieldName
@@ -966,7 +979,7 @@ inputTypeName (In.ListBaseType listType) = inputTypeName listType
providedRequiredInputFieldsRule :: Rule m providedRequiredInputFieldsRule :: Rule m
providedRequiredInputFieldsRule = ValueRule go constGo providedRequiredInputFieldsRule = ValueRule go constGo
where where
go (Just valueType) (Node (Object inputFields) location') go (Just valueType) (Full.Node (Full.Object inputFields) location')
| In.InputObjectBaseType objectType <- valueType | In.InputObjectBaseType objectType <- valueType
, In.InputObjectType objectTypeName _ fieldDefinitions <- objectType , In.InputObjectType objectTypeName _ fieldDefinitions <- objectType
= lift = lift
@@ -983,9 +996,9 @@ providedRequiredInputFieldsRule = ValueRule go constGo
, isNothingOrNull $ find (lookupField definitionName) inputFields = , isNothingOrNull $ find (lookupField definitionName) inputFields =
Just $ makeError definitionName typeName location' Just $ makeError definitionName typeName location'
| otherwise = Nothing | otherwise = Nothing
isNothingOrNull (Just (ObjectField _ (Node Null _) _)) = True isNothingOrNull (Just (Full.ObjectField _ (Full.Node Full.Null _) _)) = True
isNothingOrNull x = isNothing x isNothingOrNull x = isNothing x
lookupField needle (ObjectField fieldName _ _) = needle == fieldName lookupField needle (Full.ObjectField fieldName _ _) = needle == fieldName
makeError fieldName typeName location' = Error makeError fieldName typeName location' = Error
{ message = errorMessage fieldName typeName { message = errorMessage fieldName typeName
, locations = [location'] , locations = [location']

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

@@ -11,14 +11,12 @@ module Language.GraphQL.Validate.Validation
) where ) where
import Control.Monad.Trans.Reader (ReaderT) import Control.Monad.Trans.Reader (ReaderT)
import Data.HashMap.Strict (HashMap)
import Data.Sequence (Seq) import Data.Sequence (Seq)
import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..)) import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..))
import Language.GraphQL.AST.Document import Language.GraphQL.AST.Document
import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema (Schema) import Language.GraphQL.Type.Schema (Schema)
import qualified Language.GraphQL.Type.Schema as Schema
-- | Validation error. -- | Validation error.
data Error = Error data Error = Error
@@ -30,8 +28,6 @@ data Error = Error
data Validation m = Validation data Validation m = Validation
{ ast :: Document { ast :: Document
, schema :: Schema m , 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 -- | '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: packages:
- . - .

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

@@ -26,12 +26,7 @@ import Text.Megaparsec (parse)
import Text.RawString.QQ (r) import Text.RawString.QQ (r)
philosopherSchema :: Schema (Either SomeException) philosopherSchema :: Schema (Either SomeException)
philosopherSchema = Schema philosopherSchema = schema queryType Nothing (Just subscriptionType) mempty
{ query = queryType
, mutation = Nothing
, subscription = Just subscriptionType
, directives = HashMap.empty
}
queryType :: Out.ObjectType (Either SomeException) queryType :: Out.ObjectType (Either SomeException)
queryType = Out.ObjectType "Query" Nothing [] 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) import Text.RawString.QQ (r)
petSchema :: Schema IO petSchema :: Schema IO
petSchema = Schema petSchema = schema queryType Nothing (Just subscriptionType) mempty
{ query = queryType
, mutation = Nothing
, subscription = Just subscriptionType
, directives = HashMap.empty
}
queryType :: ObjectType IO queryType :: ObjectType IO
queryType = ObjectType "Query" Nothing [] $ HashMap.fromList 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) import Text.RawString.QQ (r)
experimentalResolver :: Schema IO experimentalResolver :: Schema IO
experimentalResolver = schema queryType experimentalResolver = schema queryType Nothing Nothing mempty
where where
queryType = Out.ObjectType "Query" Nothing [] queryType = Out.ObjectType "Query" Nothing []
$ HashMap.singleton "experimentalField" $ HashMap.singleton "experimentalField"

2
tests/Test/FragmentSpec.hs
View File

@@ -67,7 +67,7 @@ sizeFieldType
$ pure $ snd size $ pure $ snd size
toSchema :: Text -> (Text, Value) -> Schema IO toSchema :: Text -> (Text, Value) -> Schema IO
toSchema t (_, resolve) = schema queryType toSchema t (_, resolve) = schema queryType Nothing Nothing mempty
where where
garmentType = Out.UnionType "Garment" Nothing [hatType, shirtType] garmentType = Out.UnionType "Garment" Nothing [hatType, shirtType]
typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty 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 $ pure $ Int 60
garmentSchema :: Schema IO garmentSchema :: Schema IO
garmentSchema = Schema garmentSchema = schema queryType (Just mutationType) Nothing mempty
{ query = Out.ObjectType "Query" Nothing [] hatFieldResolver
, mutation = Just $ Out.ObjectType "Mutation" Nothing [] incrementFieldResolver
, subscription = Nothing
, directives = HashMap.empty
}
where where
queryType = Out.ObjectType "Query" Nothing [] hatFieldResolver
mutationType = Out.ObjectType "Mutation" Nothing [] incrementFieldResolver
garment = pure $ Object $ HashMap.fromList garment = pure $ Object $ HashMap.fromList
[ ("circumference", Int 60) [ ("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 -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
starWarsSchema :: Schema (Either SomeException) starWarsSchema :: Schema (Either SomeException)
starWarsSchema = schema queryType starWarsSchema = schema queryType Nothing Nothing mempty
where where
queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList queryType = Out.ObjectType "Query" Nothing [] $ HashMap.fromList
[ ("hero", heroFieldResolver) [ ("hero", heroFieldResolver)