Validate field selections on composite types
This commit is contained in:
parent
9bfa2aa7e8
commit
3373c94895
@ -27,7 +27,6 @@ and this project adheres to
|
||||
### Added
|
||||
- `Validate.Validation.Rule` constructors:
|
||||
- `SelectionRule`
|
||||
- `FieldRule`
|
||||
- `FragmentRule`
|
||||
- `FragmentSpreadRule`
|
||||
- `ArgumentsRule`
|
||||
@ -47,6 +46,7 @@ and this project adheres to
|
||||
- `noUndefinedVariablesRule`
|
||||
- `noUnusedVariablesRule`
|
||||
- `uniqueInputFieldNamesRule`
|
||||
- `fieldsOnCorrectTypeRule`
|
||||
- `AST.Document.Field`.
|
||||
- `AST.Document.FragmentSpread`.
|
||||
- `AST.Document.InlineFragment`.
|
||||
|
||||
@ -124,7 +124,7 @@ completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) =
|
||||
let Type.EnumType _ _ enumMembers = enumType
|
||||
in if HashMap.member enum enumMembers
|
||||
then coerceResult outputType $ Enum enum
|
||||
else addErrMsg "Value completion failed."
|
||||
else addErrMsg "Enum value completion failed."
|
||||
completeValue (Out.ObjectBaseType objectType) fields result =
|
||||
executeSelectionSet result objectType $ mergeSelectionSets fields
|
||||
completeValue (Out.InterfaceBaseType interfaceType) fields result
|
||||
@ -134,7 +134,7 @@ completeValue (Out.InterfaceBaseType interfaceType) fields result
|
||||
case concreteType of
|
||||
Just objectType -> executeSelectionSet result objectType
|
||||
$ mergeSelectionSets fields
|
||||
Nothing -> addErrMsg "Value completion failed."
|
||||
Nothing -> addErrMsg "Interface value completion failed."
|
||||
completeValue (Out.UnionBaseType unionType) fields result
|
||||
| Type.Object objectMap <- result = do
|
||||
let abstractType = AbstractUnionType unionType
|
||||
@ -142,7 +142,7 @@ completeValue (Out.UnionBaseType unionType) fields result
|
||||
case concreteType of
|
||||
Just objectType -> executeSelectionSet result objectType
|
||||
$ mergeSelectionSets fields
|
||||
Nothing -> addErrMsg "Value completion failed."
|
||||
Nothing -> addErrMsg "Union value completion failed."
|
||||
completeValue _ _ _ = addErrMsg "Value completion failed."
|
||||
|
||||
mergeSelectionSets :: MonadCatch m
|
||||
|
||||
@ -3,6 +3,7 @@
|
||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module Language.GraphQL.Type.Internal
|
||||
( AbstractType(..)
|
||||
@ -12,10 +13,12 @@ module Language.GraphQL.Type.Internal
|
||||
, instanceOf
|
||||
, lookupInputType
|
||||
, lookupTypeCondition
|
||||
, lookupTypeField
|
||||
) where
|
||||
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Text (Text)
|
||||
import qualified Language.GraphQL.AST as Full
|
||||
import qualified Language.GraphQL.Type.Definition as Definition
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
@ -55,41 +58,41 @@ collectReferencedTypes schema =
|
||||
getField (Out.ValueResolver field _) = field
|
||||
getField (Out.EventStreamResolver field _ _) = field
|
||||
traverseInputType (In.InputObjectBaseType objectType) =
|
||||
let (In.InputObjectType typeName _ inputFields) = objectType
|
||||
let In.InputObjectType typeName _ inputFields = objectType
|
||||
element = InputObjectType objectType
|
||||
traverser = flip (foldr visitInputFields) inputFields
|
||||
in collect traverser typeName element
|
||||
traverseInputType (In.ListBaseType listType) =
|
||||
traverseInputType listType
|
||||
traverseInputType (In.ScalarBaseType scalarType) =
|
||||
let (Definition.ScalarType typeName _) = scalarType
|
||||
let Definition.ScalarType typeName _ = scalarType
|
||||
in collect Prelude.id typeName (ScalarType scalarType)
|
||||
traverseInputType (In.EnumBaseType enumType) =
|
||||
let (Definition.EnumType typeName _ _) = 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
|
||||
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
|
||||
let Definition.ScalarType typeName _ = scalarType
|
||||
in collect Prelude.id typeName (ScalarType scalarType)
|
||||
traverseOutputType (Out.EnumBaseType enumType) =
|
||||
let (Definition.EnumType typeName _ _) = enumType
|
||||
let Definition.EnumType typeName _ _ = enumType
|
||||
in collect Prelude.id typeName (EnumType enumType)
|
||||
traverseObjectType objectType foundTypes =
|
||||
let (Out.ObjectType typeName _ interfaces fields) = objectType
|
||||
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
|
||||
let Out.InterfaceType typeName _ interfaces fields = interfaceType
|
||||
element = InterfaceType interfaceType
|
||||
traverser = polymorphicTraverser interfaces fields
|
||||
in collect traverser typeName element foundTypes
|
||||
@ -161,3 +164,21 @@ lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types =
|
||||
lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types
|
||||
= In.NonNullListType
|
||||
<$> lookupInputType nonNull types
|
||||
|
||||
lookupTypeField :: forall a. Text -> Out.Type a -> Maybe (Out.Type a)
|
||||
lookupTypeField fieldName = \case
|
||||
Out.ObjectBaseType objectType ->
|
||||
objectChild objectType
|
||||
Out.InterfaceBaseType interfaceType ->
|
||||
interfaceChild interfaceType
|
||||
Out.ListBaseType listType -> lookupTypeField fieldName listType
|
||||
_ -> Nothing
|
||||
where
|
||||
objectChild (Out.ObjectType _ _ _ resolvers) =
|
||||
resolverType <$> HashMap.lookup fieldName resolvers
|
||||
interfaceChild (Out.InterfaceType _ _ _ fields) =
|
||||
fieldType <$> HashMap.lookup fieldName fields
|
||||
resolverType (Out.ValueResolver objectField _) = fieldType objectField
|
||||
resolverType (Out.EventStreamResolver objectField _ _) =
|
||||
fieldType objectField
|
||||
fieldType (Out.Field _ type' _) = type'
|
||||
|
||||
@ -2,8 +2,8 @@
|
||||
v. 2.0. If a copy of the MPL was not distributed with this file, You can
|
||||
obtain one at https://mozilla.org/MPL/2.0/. -}
|
||||
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
-- | GraphQL validator.
|
||||
module Language.GraphQL.Validate
|
||||
@ -16,14 +16,21 @@ import Control.Monad (join)
|
||||
import Control.Monad.Trans.Class (MonadTrans(..))
|
||||
import Control.Monad.Trans.Reader (runReaderT)
|
||||
import Data.Foldable (toList)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Sequence (Seq(..), (><), (|>))
|
||||
import qualified Data.Sequence as Seq
|
||||
import Language.GraphQL.AST.Document
|
||||
import Language.GraphQL.Type.Internal
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import Language.GraphQL.Type.Schema (Schema(..))
|
||||
import qualified Language.GraphQL.Type.Schema as Schema
|
||||
import Language.GraphQL.Validate.Rules
|
||||
import Language.GraphQL.Validate.Validation
|
||||
|
||||
type ApplyRule m a =
|
||||
HashMap Name (Schema.Type m) -> Rule m -> Maybe (Out.Type m) -> a -> Seq (RuleT m)
|
||||
|
||||
-- | Validates a document and returns a list of found errors. If the returned
|
||||
-- list is empty, the document is valid.
|
||||
document :: forall m. Schema m -> [Rule m] -> Document -> Seq Error
|
||||
@ -37,16 +44,20 @@ document schema' rules' document' =
|
||||
}
|
||||
reader = do
|
||||
rule' <- lift $ Seq.fromList rules'
|
||||
join $ lift $ foldr (definition rule') Seq.empty document'
|
||||
join $ lift $ foldr (definition rule' context) Seq.empty document'
|
||||
|
||||
definition :: Rule m -> Definition -> Seq (RuleT m) -> Seq (RuleT m)
|
||||
definition (DefinitionRule rule) definition' accumulator =
|
||||
definition :: Rule m
|
||||
-> Validation m
|
||||
-> Definition
|
||||
-> Seq (RuleT m)
|
||||
-> Seq (RuleT m)
|
||||
definition (DefinitionRule rule) _ definition' accumulator =
|
||||
accumulator |> rule definition'
|
||||
definition rule (ExecutableDefinition executableDefinition') accumulator =
|
||||
accumulator >< executableDefinition rule executableDefinition'
|
||||
definition rule (TypeSystemDefinition typeSystemDefinition' _) accumulator =
|
||||
definition rule context (ExecutableDefinition definition') accumulator =
|
||||
accumulator >< executableDefinition rule context definition'
|
||||
definition rule _ (TypeSystemDefinition typeSystemDefinition' _) accumulator =
|
||||
accumulator >< typeSystemDefinition rule typeSystemDefinition'
|
||||
definition rule (TypeSystemExtension extension _) accumulator =
|
||||
definition rule _ (TypeSystemExtension extension _) accumulator =
|
||||
accumulator >< typeSystemExtension rule extension
|
||||
|
||||
typeSystemExtension :: Rule m -> TypeSystemExtension -> Seq (RuleT m)
|
||||
@ -82,11 +93,14 @@ schemaExtension rule = \case
|
||||
SchemaOperationExtension directives' _ -> directives rule directives'
|
||||
SchemaDirectivesExtension directives' -> directives rule directives'
|
||||
|
||||
executableDefinition :: Rule m -> ExecutableDefinition -> Seq (RuleT m)
|
||||
executableDefinition rule (DefinitionOperation operation) =
|
||||
operationDefinition rule operation
|
||||
executableDefinition rule (DefinitionFragment fragment) =
|
||||
fragmentDefinition rule fragment
|
||||
executableDefinition :: Rule m
|
||||
-> Validation m
|
||||
-> ExecutableDefinition
|
||||
-> Seq (RuleT m)
|
||||
executableDefinition rule context (DefinitionOperation operation) =
|
||||
operationDefinition rule context operation
|
||||
executableDefinition rule context (DefinitionFragment fragment) =
|
||||
fragmentDefinition rule context fragment
|
||||
|
||||
typeSystemDefinition :: Rule m -> TypeSystemDefinition -> Seq (RuleT m)
|
||||
typeSystemDefinition rule = \case
|
||||
@ -124,58 +138,101 @@ inputValueDefinition :: Rule m -> InputValueDefinition -> Seq (RuleT m)
|
||||
inputValueDefinition rule (InputValueDefinition _ _ _ _ directives') =
|
||||
directives rule directives'
|
||||
|
||||
operationDefinition :: Rule m -> OperationDefinition -> Seq (RuleT m)
|
||||
operationDefinition rule operation
|
||||
operationDefinition :: Rule m
|
||||
-> Validation m
|
||||
-> OperationDefinition
|
||||
-> Seq (RuleT m)
|
||||
operationDefinition rule context operation
|
||||
| OperationDefinitionRule operationRule <- rule =
|
||||
pure $ operationRule operation
|
||||
| VariablesRule variablesRule <- rule
|
||||
, OperationDefinition _ _ variables _ _ _ <- operation
|
||||
= Seq.fromList (variableDefinition rule <$> variables)
|
||||
|> variablesRule variables
|
||||
| SelectionSet selections _ <- operation = selectionSet rule selections
|
||||
| OperationDefinition _ _ _ directives' selections _ <- operation =
|
||||
selectionSet rule selections >< directives rule directives'
|
||||
| SelectionSet selections _ <- operation =
|
||||
selectionSet types' rule (getRootType Query) selections
|
||||
| OperationDefinition operationType _ _ directives' selections _ <- operation
|
||||
= selectionSet types' rule (getRootType operationType) selections
|
||||
>< directives rule directives'
|
||||
where
|
||||
types' = types context
|
||||
getRootType Query = Just $ Out.NamedObjectType $ query $ schema context
|
||||
getRootType Mutation = Out.NamedObjectType <$> mutation (schema context)
|
||||
getRootType Subscription =
|
||||
Out.NamedObjectType <$> subscription (schema context)
|
||||
|
||||
typeToOut :: forall m. Schema.Type m -> Maybe (Out.Type m)
|
||||
typeToOut (Schema.ObjectType objectType) =
|
||||
Just $ Out.NamedObjectType objectType
|
||||
typeToOut (Schema.InterfaceType interfaceType) =
|
||||
Just $ Out.NamedInterfaceType interfaceType
|
||||
typeToOut (Schema.UnionType unionType) = Just $ Out.NamedUnionType unionType
|
||||
typeToOut (Schema.EnumType enumType) = Just $ Out.NamedEnumType enumType
|
||||
typeToOut (Schema.ScalarType scalarType) = Just $ Out.NamedScalarType scalarType
|
||||
typeToOut _ = Nothing
|
||||
|
||||
variableDefinition :: Rule m -> VariableDefinition -> RuleT m
|
||||
variableDefinition (ValueRule _ rule) (VariableDefinition _ _ value _) =
|
||||
maybe (lift mempty) rule value
|
||||
variableDefinition _ _ = lift mempty
|
||||
|
||||
fragmentDefinition :: Rule m -> FragmentDefinition -> Seq (RuleT m)
|
||||
fragmentDefinition (FragmentDefinitionRule rule) fragmentDefinition' =
|
||||
pure $ rule fragmentDefinition'
|
||||
fragmentDefinition rule fragmentDefinition'@(FragmentDefinition _ _ directives' selections _)
|
||||
| FragmentRule definitionRule _ <- rule =
|
||||
applyToChildren |> definitionRule fragmentDefinition'
|
||||
| otherwise = applyToChildren
|
||||
fragmentDefinition :: forall m
|
||||
. Rule m
|
||||
-> Validation m
|
||||
-> FragmentDefinition
|
||||
-> Seq (RuleT m)
|
||||
fragmentDefinition (FragmentDefinitionRule rule) _ definition' =
|
||||
pure $ rule definition'
|
||||
fragmentDefinition rule context definition'
|
||||
| FragmentDefinition _ typeCondition directives' selections _ <- definition'
|
||||
, FragmentRule definitionRule _ <- rule
|
||||
= applyToChildren typeCondition directives' selections
|
||||
|> definitionRule definition'
|
||||
| FragmentDefinition _ typeCondition directives' selections _ <- definition'
|
||||
= applyToChildren typeCondition directives' selections
|
||||
where
|
||||
applyToChildren = selectionSet rule selections
|
||||
types' = types context
|
||||
applyToChildren typeCondition directives' selections
|
||||
= selectionSet types' rule (lookupType' typeCondition) selections
|
||||
>< directives rule directives'
|
||||
lookupType' = flip lookupType types'
|
||||
|
||||
selectionSet :: Traversable t => Rule m -> t Selection -> Seq (RuleT m)
|
||||
selectionSet = foldMap . selection
|
||||
lookupType :: forall m
|
||||
. TypeCondition
|
||||
-> HashMap Name (Schema.Type m)
|
||||
-> Maybe (Out.Type m)
|
||||
lookupType typeCondition types' = HashMap.lookup typeCondition types'
|
||||
>>= typeToOut
|
||||
|
||||
selection :: Rule m -> Selection -> Seq (RuleT m)
|
||||
selection rule selection'
|
||||
selectionSet :: Traversable t => forall m. ApplyRule m (t Selection)
|
||||
selectionSet types' rule = foldMap . selection types' rule
|
||||
|
||||
selection :: forall m. ApplyRule m Selection
|
||||
selection types' rule objectType selection'
|
||||
| SelectionRule selectionRule <- rule =
|
||||
applyToChildren |> selectionRule selection'
|
||||
applyToChildren |> selectionRule objectType selection'
|
||||
| otherwise = applyToChildren
|
||||
where
|
||||
applyToChildren =
|
||||
case selection' of
|
||||
FieldSelection field' -> field rule field'
|
||||
FieldSelection field' -> field types' rule objectType field'
|
||||
InlineFragmentSelection inlineFragment' ->
|
||||
inlineFragment rule inlineFragment'
|
||||
inlineFragment types' rule objectType inlineFragment'
|
||||
FragmentSpreadSelection fragmentSpread' ->
|
||||
fragmentSpread rule fragmentSpread'
|
||||
|
||||
field :: Rule m -> Field -> Seq (RuleT m)
|
||||
field rule field'@(Field _ _ arguments' directives' selections _)
|
||||
| FieldRule fieldRule <- rule = applyToChildren |> fieldRule field'
|
||||
| ArgumentsRule fieldRule _ <- rule = applyToChildren |> fieldRule field'
|
||||
| otherwise = applyToChildren
|
||||
field :: forall m. ApplyRule m Field
|
||||
field types' rule objectType field' = go field'
|
||||
where
|
||||
applyToChildren = selectionSet rule selections
|
||||
go (Field _ fieldName arguments' directives' selections _)
|
||||
| ArgumentsRule fieldRule _ <- rule
|
||||
= applyToChildren fieldName arguments' directives' selections
|
||||
|> fieldRule field'
|
||||
| otherwise =
|
||||
applyToChildren fieldName arguments' directives' selections
|
||||
applyToChildren fieldName arguments' directives' selections =
|
||||
let child = objectType >>= lookupTypeField fieldName
|
||||
in selectionSet types' rule child selections
|
||||
>< directives rule directives'
|
||||
>< arguments rule arguments'
|
||||
|
||||
@ -186,13 +243,18 @@ argument :: Rule m -> Argument -> RuleT m
|
||||
argument (ValueRule rule _) (Argument _ (Node value _) _) = rule value
|
||||
argument _ _ = lift mempty
|
||||
|
||||
inlineFragment :: Rule m -> InlineFragment -> Seq (RuleT m)
|
||||
inlineFragment rule inlineFragment'@(InlineFragment _ directives' selections _)
|
||||
| FragmentRule _ fragmentRule <- rule =
|
||||
applyToChildren |> fragmentRule inlineFragment'
|
||||
| otherwise = applyToChildren
|
||||
inlineFragment :: forall m. ApplyRule m InlineFragment
|
||||
inlineFragment types' rule objectType inlineFragment' = go inlineFragment'
|
||||
where
|
||||
applyToChildren = selectionSet rule selections
|
||||
go (InlineFragment optionalType directives' selections _)
|
||||
| FragmentRule _ fragmentRule <- rule
|
||||
= applyToChildren (refineTarget optionalType) directives' selections
|
||||
|> fragmentRule inlineFragment'
|
||||
| otherwise = applyToChildren (refineTarget optionalType) directives' selections
|
||||
refineTarget (Just typeCondition) = lookupType typeCondition types'
|
||||
refineTarget Nothing = objectType
|
||||
applyToChildren objectType' directives' selections
|
||||
= selectionSet types' rule objectType' selections
|
||||
>< directives rule directives'
|
||||
|
||||
fragmentSpread :: Rule m -> FragmentSpread -> Seq (RuleT m)
|
||||
|
||||
@ -10,6 +10,7 @@
|
||||
-- | This module contains default rules defined in the GraphQL specification.
|
||||
module Language.GraphQL.Validate.Rules
|
||||
( executableDefinitionsRule
|
||||
, fieldsOnCorrectTypeRule
|
||||
, fragmentsOnCompositeTypesRule
|
||||
, fragmentSpreadTargetDefinedRule
|
||||
, fragmentSpreadTypeExistenceRule
|
||||
@ -40,14 +41,16 @@ import Data.HashMap.Strict (HashMap)
|
||||
import Data.HashSet (HashSet)
|
||||
import qualified Data.HashSet as HashSet
|
||||
import Data.List (groupBy, sortBy, sortOn)
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Data.Maybe (isJust, mapMaybe)
|
||||
import Data.Ord (comparing)
|
||||
import Data.Sequence (Seq(..))
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Language.GraphQL.AST.Document
|
||||
import qualified Language.GraphQL.Type.Definition as Definition
|
||||
import Language.GraphQL.Type.Internal
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import qualified Language.GraphQL.Type.Schema as Schema
|
||||
import Language.GraphQL.Validate.Validation
|
||||
|
||||
@ -63,6 +66,8 @@ specifiedRules =
|
||||
, singleFieldSubscriptionsRule
|
||||
, loneAnonymousOperationRule
|
||||
, uniqueOperationNamesRule
|
||||
-- Fields
|
||||
, fieldsOnCorrectTypeRule
|
||||
-- Arguments.
|
||||
, uniqueArgumentNamesRule
|
||||
-- Fragments.
|
||||
@ -297,7 +302,7 @@ isSpreadTarget _ _ = False
|
||||
-- for both named and inline fragments. If they are not defined in the schema,
|
||||
-- the query does not validate.
|
||||
fragmentSpreadTypeExistenceRule :: forall m. Rule m
|
||||
fragmentSpreadTypeExistenceRule = SelectionRule $ \case
|
||||
fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case
|
||||
FragmentSpreadSelection fragmentSelection
|
||||
| FragmentSpread fragmentName _ location <- fragmentSelection -> do
|
||||
ast' <- asks ast
|
||||
@ -672,3 +677,36 @@ uniqueInputFieldNamesRule = ValueRule (lift . go) (lift . constGo)
|
||||
<> filterFieldDuplicates fields
|
||||
constGo (ConstList values) = foldMap constGo values
|
||||
constGo _ = mempty
|
||||
|
||||
-- | The target field of a field selection must be defined on the scoped type of
|
||||
-- the selection set. There are no limitations on alias names.
|
||||
fieldsOnCorrectTypeRule :: forall m. Rule m
|
||||
fieldsOnCorrectTypeRule = SelectionRule go
|
||||
where
|
||||
go (Just objectType) (FieldSelection fieldSelection) =
|
||||
fieldRule objectType fieldSelection
|
||||
go _ _ = lift mempty
|
||||
fieldRule objectType (Field _ fieldName _ _ _ location)
|
||||
| isJust (lookupTypeField fieldName objectType) = lift mempty
|
||||
| otherwise = pure $ Error
|
||||
{ message = errorMessage fieldName objectType
|
||||
, locations = [location]
|
||||
}
|
||||
errorMessage fieldName objectType = concat
|
||||
[ "Cannot query field \""
|
||||
, Text.unpack fieldName
|
||||
, "\" on type \""
|
||||
, Text.unpack $ outputTypeName objectType
|
||||
, "\"."
|
||||
]
|
||||
outputTypeName (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) =
|
||||
typeName
|
||||
outputTypeName (Out.InterfaceBaseType (Out.InterfaceType typeName _ _ _)) =
|
||||
typeName
|
||||
outputTypeName (Out.UnionBaseType (Out.UnionType typeName _ _)) =
|
||||
typeName
|
||||
outputTypeName (Out.ScalarBaseType (Definition.ScalarType typeName _)) =
|
||||
typeName
|
||||
outputTypeName (Out.EnumBaseType (Definition.EnumType typeName _ _)) =
|
||||
typeName
|
||||
outputTypeName (Out.ListBaseType wrappedType) = outputTypeName wrappedType
|
||||
|
||||
@ -14,6 +14,7 @@ import Control.Monad.Trans.Reader (ReaderT)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.Sequence (Seq)
|
||||
import Language.GraphQL.AST.Document
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import Language.GraphQL.Type.Schema (Schema)
|
||||
import qualified Language.GraphQL.Type.Schema as Schema
|
||||
|
||||
@ -37,10 +38,9 @@ data Rule m
|
||||
= DefinitionRule (Definition -> RuleT m)
|
||||
| OperationDefinitionRule (OperationDefinition -> RuleT m)
|
||||
| FragmentDefinitionRule (FragmentDefinition -> RuleT m)
|
||||
| SelectionRule (Selection -> RuleT m)
|
||||
| SelectionRule (Maybe (Out.Type m) -> Selection -> RuleT m)
|
||||
| FragmentRule (FragmentDefinition -> RuleT m) (InlineFragment -> RuleT m)
|
||||
| FragmentSpreadRule (FragmentSpread -> RuleT m)
|
||||
| FieldRule (Field -> RuleT m)
|
||||
| ArgumentsRule (Field -> RuleT m) (Directive -> RuleT m)
|
||||
| DirectivesRule ([Directive] -> RuleT m)
|
||||
| VariablesRule ([VariableDefinition] -> RuleT m)
|
||||
|
||||
@ -9,8 +9,7 @@ module Language.GraphQL.ValidateSpec
|
||||
( spec
|
||||
) where
|
||||
|
||||
import Data.Sequence (Seq(..))
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.Foldable (toList)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Text (Text)
|
||||
import qualified Language.GraphQL.AST as AST
|
||||
@ -18,7 +17,7 @@ import Language.GraphQL.Type
|
||||
import qualified Language.GraphQL.Type.In as In
|
||||
import qualified Language.GraphQL.Type.Out as Out
|
||||
import Language.GraphQL.Validate
|
||||
import Test.Hspec (Spec, describe, it, shouldBe)
|
||||
import Test.Hspec (Spec, describe, it, shouldBe, shouldContain)
|
||||
import Text.Megaparsec (parse)
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
@ -30,11 +29,17 @@ schema = Schema
|
||||
}
|
||||
|
||||
queryType :: ObjectType IO
|
||||
queryType = ObjectType "Query" Nothing []
|
||||
$ HashMap.singleton "dog" dogResolver
|
||||
queryType = ObjectType "Query" Nothing [] $ HashMap.fromList
|
||||
[ ("dog", dogResolver)
|
||||
, ("findDog", findDogResolver)
|
||||
]
|
||||
where
|
||||
dogField = Field Nothing (Out.NamedObjectType dogType) mempty
|
||||
dogResolver = ValueResolver dogField $ pure Null
|
||||
findDogArguments = HashMap.singleton "complex"
|
||||
$ In.Argument Nothing (In.NonNullInputObjectType dogDataType) Nothing
|
||||
findDogField = Field Nothing (Out.NamedObjectType dogType) findDogArguments
|
||||
findDogResolver = ValueResolver findDogField $ pure Null
|
||||
|
||||
dogCommandType :: EnumType
|
||||
dogCommandType = EnumType "DogCommand" Nothing $ HashMap.fromList
|
||||
@ -72,6 +77,12 @@ dogType = ObjectType "Dog" Nothing [petType] $ HashMap.fromList
|
||||
ownerField = Field Nothing (Out.NamedObjectType humanType) mempty
|
||||
ownerResolver = ValueResolver ownerField $ pure Null
|
||||
|
||||
dogDataType :: InputObjectType
|
||||
dogDataType = InputObjectType "DogData" Nothing
|
||||
$ HashMap.singleton "name" nameInputField
|
||||
where
|
||||
nameInputField = InputField Nothing (In.NonNullScalarType string) Nothing
|
||||
|
||||
sentientType :: InterfaceType IO
|
||||
sentientType = InterfaceType "Sentient" Nothing []
|
||||
$ HashMap.singleton "name"
|
||||
@ -114,39 +125,14 @@ humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList
|
||||
Field Nothing (Out.ListType $ Out.NonNullInterfaceType petType) mempty
|
||||
petsResolver = ValueResolver petsField $ pure $ List []
|
||||
{-
|
||||
catCommandType :: EnumType
|
||||
catCommandType = EnumType "CatCommand" Nothing $ HashMap.fromList
|
||||
[ ("JUMP", EnumValue Nothing)
|
||||
]
|
||||
|
||||
catType :: ObjectType IO
|
||||
catType = ObjectType "Cat" Nothing [petType] $ HashMap.fromList
|
||||
[ ("name", nameResolver)
|
||||
, ("nickname", nicknameResolver)
|
||||
, ("doesKnowCommand", doesKnowCommandResolver)
|
||||
, ("meowVolume", meowVolumeResolver)
|
||||
]
|
||||
where
|
||||
nameField = Field Nothing (Out.NonNullScalarType string) mempty
|
||||
nameResolver = ValueResolver nameField $ pure "Name"
|
||||
nicknameField = Field Nothing (Out.NamedScalarType string) mempty
|
||||
nicknameResolver = ValueResolver nicknameField $ pure "Nickname"
|
||||
doesKnowCommandField = Field Nothing (Out.NonNullScalarType boolean)
|
||||
$ HashMap.singleton "catCommand"
|
||||
$ In.Argument Nothing (In.NonNullEnumType catCommandType) Nothing
|
||||
doesKnowCommandResolver = ValueResolver doesKnowCommandField
|
||||
$ pure $ Boolean True
|
||||
meowVolumeField = Field Nothing (Out.NamedScalarType int) mempty
|
||||
meowVolumeResolver = ValueResolver meowVolumeField $ pure $ Int 2
|
||||
|
||||
catOrDogType :: UnionType IO
|
||||
catOrDogType = UnionType "CatOrDog" Nothing [catType, dogType]
|
||||
-}
|
||||
validate :: Text -> Seq Error
|
||||
validate :: Text -> [Error]
|
||||
validate queryString =
|
||||
case parse AST.document "" queryString of
|
||||
Left _ -> Seq.empty
|
||||
Right ast -> document schema specifiedRules ast
|
||||
Left _ -> []
|
||||
Right ast -> toList $ document schema specifiedRules ast
|
||||
|
||||
spec :: Spec
|
||||
spec =
|
||||
@ -169,7 +155,7 @@ spec =
|
||||
"Definition must be OperationDefinition or FragmentDefinition."
|
||||
, locations = [AST.Location 9 15]
|
||||
}
|
||||
in validate queryString `shouldBe` Seq.singleton expected
|
||||
in validate queryString `shouldContain` [expected]
|
||||
|
||||
it "rejects multiple subscription root fields" $
|
||||
let queryString = [r|
|
||||
@ -186,7 +172,7 @@ spec =
|
||||
"Subscription sub must select only one top level field."
|
||||
, locations = [AST.Location 2 15]
|
||||
}
|
||||
in validate queryString `shouldBe` Seq.singleton expected
|
||||
in validate queryString `shouldContain` [expected]
|
||||
|
||||
it "rejects multiple subscription root fields coming from a fragment" $
|
||||
let queryString = [r|
|
||||
@ -207,7 +193,7 @@ spec =
|
||||
"Subscription sub must select only one top level field."
|
||||
, locations = [AST.Location 2 15]
|
||||
}
|
||||
in validate queryString `shouldBe` Seq.singleton expected
|
||||
in validate queryString `shouldContain` [expected]
|
||||
|
||||
it "rejects multiple anonymous operations" $
|
||||
let queryString = [r|
|
||||
@ -230,7 +216,7 @@ spec =
|
||||
"This anonymous operation must be the only defined operation."
|
||||
, locations = [AST.Location 2 15]
|
||||
}
|
||||
in validate queryString `shouldBe` Seq.singleton expected
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects operations with the same name" $
|
||||
let queryString = [r|
|
||||
@ -251,7 +237,7 @@ spec =
|
||||
"There can be only one operation named \"dogOperation\"."
|
||||
, locations = [AST.Location 2 15, AST.Location 8 15]
|
||||
}
|
||||
in validate queryString `shouldBe` Seq.singleton expected
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects fragments with the same name" $
|
||||
let queryString = [r|
|
||||
@ -276,7 +262,7 @@ spec =
|
||||
"There can be only one fragment named \"fragmentOne\"."
|
||||
, locations = [AST.Location 8 15, AST.Location 12 15]
|
||||
}
|
||||
in validate queryString `shouldBe` Seq.singleton expected
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects the fragment spread without a target" $
|
||||
let queryString = [r|
|
||||
@ -291,7 +277,7 @@ spec =
|
||||
"Fragment target \"undefinedFragment\" is undefined."
|
||||
, locations = [AST.Location 4 19]
|
||||
}
|
||||
in validate queryString `shouldBe` Seq.singleton expected
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects fragment spreads without an unknown target type" $
|
||||
let queryString = [r|
|
||||
@ -310,7 +296,7 @@ spec =
|
||||
\\"NotInSchema\" which doesn't exist in the schema."
|
||||
, locations = [AST.Location 4 19]
|
||||
}
|
||||
in validate queryString `shouldBe` Seq.singleton expected
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects inline fragments without a target" $
|
||||
let queryString = [r|
|
||||
@ -326,7 +312,7 @@ spec =
|
||||
\which doesn't exist in the schema."
|
||||
, locations = [AST.Location 3 17]
|
||||
}
|
||||
in validate queryString `shouldBe` Seq.singleton expected
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects fragments on scalar types" $
|
||||
let queryString = [r|
|
||||
@ -345,7 +331,7 @@ spec =
|
||||
\\"Int\"."
|
||||
, locations = [AST.Location 7 15]
|
||||
}
|
||||
in validate queryString `shouldBe` Seq.singleton expected
|
||||
in validate queryString `shouldContain` [expected]
|
||||
|
||||
it "rejects inline fragments on scalar types" $
|
||||
let queryString = [r|
|
||||
@ -361,7 +347,7 @@ spec =
|
||||
\\"Boolean\"."
|
||||
, locations = [AST.Location 3 17]
|
||||
}
|
||||
in validate queryString `shouldBe` Seq.singleton expected
|
||||
in validate queryString `shouldContain` [expected]
|
||||
|
||||
it "rejects unused fragments" $
|
||||
let queryString = [r|
|
||||
@ -380,7 +366,7 @@ spec =
|
||||
"Fragment \"nameFragment\" is never used."
|
||||
, locations = [AST.Location 2 15]
|
||||
}
|
||||
in validate queryString `shouldBe` Seq.singleton expected
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects spreads that form cycles" $
|
||||
let queryString = [r|
|
||||
@ -412,7 +398,7 @@ spec =
|
||||
\nameFragment)."
|
||||
, locations = [AST.Location 7 15]
|
||||
}
|
||||
in validate queryString `shouldBe` Seq.fromList [error1, error2]
|
||||
in validate queryString `shouldBe` [error1, error2]
|
||||
|
||||
it "rejects duplicate field arguments" $ do
|
||||
let queryString = [r|
|
||||
@ -427,20 +413,22 @@ spec =
|
||||
"There can be only one argument named \"atOtherHomes\"."
|
||||
, locations = [AST.Location 4 34, AST.Location 4 54]
|
||||
}
|
||||
in validate queryString `shouldBe` Seq.singleton expected
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects more than one directive per location" $ do
|
||||
let queryString = [r|
|
||||
query ($foo: Boolean = true, $bar: Boolean = false) {
|
||||
field @skip(if: $foo) @skip(if: $bar)
|
||||
dog @skip(if: $foo) @skip(if: $bar) {
|
||||
name
|
||||
}
|
||||
}
|
||||
|]
|
||||
expected = Error
|
||||
{ message =
|
||||
"There can be only one directive named \"skip\"."
|
||||
, locations = [AST.Location 3 23, AST.Location 3 39]
|
||||
, locations = [AST.Location 3 21, AST.Location 3 37]
|
||||
}
|
||||
in validate queryString `shouldBe` Seq.singleton expected
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects duplicate variables" $
|
||||
let queryString = [r|
|
||||
@ -455,7 +443,7 @@ spec =
|
||||
"There can be only one variable named \"atOtherHomes\"."
|
||||
, locations = [AST.Location 2 39, AST.Location 2 63]
|
||||
}
|
||||
in validate queryString `shouldBe` Seq.singleton expected
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects non-input types as variables" $
|
||||
let queryString = [r|
|
||||
@ -470,7 +458,7 @@ spec =
|
||||
"Variable \"$dog\" cannot be non-input type \"Dog\"."
|
||||
, locations = [AST.Location 2 34]
|
||||
}
|
||||
in validate queryString `shouldBe` Seq.singleton expected
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects undefined variables" $
|
||||
let queryString = [r|
|
||||
@ -491,7 +479,7 @@ spec =
|
||||
\\"variableIsNotDefinedUsedInSingleFragment\"."
|
||||
, locations = [AST.Location 9 46]
|
||||
}
|
||||
in validate queryString `shouldBe` Seq.singleton expected
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects unused variables" $
|
||||
let queryString = [r|
|
||||
@ -507,7 +495,7 @@ spec =
|
||||
\\"variableUnused\"."
|
||||
, locations = [AST.Location 2 36]
|
||||
}
|
||||
in validate queryString `shouldBe` Seq.singleton expected
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
it "rejects duplicate fields in input objects" $
|
||||
let queryString = [r|
|
||||
@ -520,4 +508,4 @@ spec =
|
||||
"There can be only one input field named \"name\"."
|
||||
, locations = [AST.Location 3 36, AST.Location 3 50]
|
||||
}
|
||||
in validate queryString `shouldBe` Seq.singleton expected
|
||||
in validate queryString `shouldBe` [expected]
|
||||
|
||||
@ -108,21 +108,17 @@ spec = do
|
||||
|
||||
it "embeds inline fragments without type" $ do
|
||||
let sourceQuery = [r|{
|
||||
garment {
|
||||
circumference
|
||||
... {
|
||||
size
|
||||
}
|
||||
}
|
||||
}|]
|
||||
actual <- graphql (toSchema "garment" $ garment "Hat") sourceQuery
|
||||
actual <- graphql (toSchema "circumference" circumference) sourceQuery
|
||||
let expected = HashMap.singleton "data"
|
||||
$ Aeson.object
|
||||
[ "garment" .= Aeson.object
|
||||
[ "circumference" .= (60 :: Int)
|
||||
, "size" .= ("L" :: Text)
|
||||
]
|
||||
]
|
||||
in actual `shouldResolveTo` expected
|
||||
|
||||
it "evaluates fragments on Query" $ do
|
||||
|
||||
@ -41,72 +41,88 @@ schema = Schema
|
||||
droidFieldResolver = ValueResolver droidField droid
|
||||
|
||||
heroObject :: Out.ObjectType (Either SomeException)
|
||||
heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
|
||||
heroObject = Out.ObjectType "Human" Nothing [characterType] $ HashMap.fromList
|
||||
[ ("id", idFieldType)
|
||||
, ("name", nameFieldType)
|
||||
, ("friends", friendsFieldType)
|
||||
, ("appearsIn", appearsInField)
|
||||
, ("friends", friendsFieldResolver)
|
||||
, ("appearsIn", appearsInFieldResolver)
|
||||
, ("homePlanet", homePlanetFieldType)
|
||||
, ("secretBackstory", secretBackstoryFieldType)
|
||||
, ("__typename", typenameFieldType)
|
||||
, ("secretBackstory", secretBackstoryFieldResolver)
|
||||
, ("__typename", typenameFieldResolver)
|
||||
]
|
||||
where
|
||||
homePlanetFieldType
|
||||
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
|
||||
$ idField "homePlanet"
|
||||
$ defaultResolver "homePlanet"
|
||||
|
||||
droidObject :: Out.ObjectType (Either SomeException)
|
||||
droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
|
||||
droidObject = Out.ObjectType "Droid" Nothing [characterType] $ HashMap.fromList
|
||||
[ ("id", idFieldType)
|
||||
, ("name", nameFieldType)
|
||||
, ("friends", friendsFieldType)
|
||||
, ("appearsIn", appearsInField)
|
||||
, ("friends", friendsFieldResolver)
|
||||
, ("appearsIn", appearsInFieldResolver)
|
||||
, ("primaryFunction", primaryFunctionFieldType)
|
||||
, ("secretBackstory", secretBackstoryFieldType)
|
||||
, ("__typename", typenameFieldType)
|
||||
, ("secretBackstory", secretBackstoryFieldResolver)
|
||||
, ("__typename", typenameFieldResolver)
|
||||
]
|
||||
where
|
||||
primaryFunctionFieldType
|
||||
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
|
||||
$ idField "primaryFunction"
|
||||
$ defaultResolver "primaryFunction"
|
||||
|
||||
typenameFieldType :: Resolver (Either SomeException)
|
||||
typenameFieldType
|
||||
typenameFieldResolver :: Resolver (Either SomeException)
|
||||
typenameFieldResolver
|
||||
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
|
||||
$ idField "__typename"
|
||||
$ defaultResolver "__typename"
|
||||
|
||||
idFieldType :: Resolver (Either SomeException)
|
||||
idFieldType
|
||||
= ValueResolver (Out.Field Nothing (Out.NamedScalarType id) mempty)
|
||||
$ idField "id"
|
||||
idFieldType = ValueResolver idField $ defaultResolver "id"
|
||||
|
||||
nameFieldType :: Resolver (Either SomeException)
|
||||
nameFieldType
|
||||
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
|
||||
$ idField "name"
|
||||
nameFieldType = ValueResolver nameField $ defaultResolver "name"
|
||||
|
||||
friendsFieldType :: Resolver (Either SomeException)
|
||||
friendsFieldType
|
||||
= ValueResolver (Out.Field Nothing fieldType mempty)
|
||||
$ idField "friends"
|
||||
friendsFieldResolver :: Resolver (Either SomeException)
|
||||
friendsFieldResolver = ValueResolver friendsField $ defaultResolver "friends"
|
||||
|
||||
characterType :: InterfaceType (Either SomeException)
|
||||
characterType = InterfaceType "Character" Nothing [] $ HashMap.fromList
|
||||
[ ("id", idField)
|
||||
, ("name", nameField)
|
||||
, ("friends", friendsField)
|
||||
, ("appearsIn", appearsInField)
|
||||
, ("secretBackstory", secretBackstoryField)
|
||||
]
|
||||
|
||||
idField :: Field (Either SomeException)
|
||||
idField = Field Nothing (Out.NonNullScalarType id) mempty
|
||||
|
||||
nameField :: Field (Either SomeException)
|
||||
nameField = Field Nothing (Out.NamedScalarType string) mempty
|
||||
|
||||
friendsField :: Field (Either SomeException)
|
||||
friendsField = Field Nothing friendsFieldType mempty
|
||||
where
|
||||
fieldType = Out.ListType $ Out.NamedObjectType droidObject
|
||||
friendsFieldType = Out.ListType (Out.NamedInterfaceType characterType)
|
||||
|
||||
appearsInField :: Resolver (Either SomeException)
|
||||
appearsInField
|
||||
= ValueResolver (Out.Field (Just description) fieldType mempty)
|
||||
$ idField "appearsIn"
|
||||
appearsInField :: Field (Either SomeException)
|
||||
appearsInField = Field appearsInDescription appearsInFieldType mempty
|
||||
where
|
||||
fieldType = Out.ListType $ Out.NamedEnumType episodeEnum
|
||||
description = "Which movies they appear in."
|
||||
appearsInDescription = Just "Which movies they appear in."
|
||||
appearsInFieldType = Out.ListType $ Out.NamedEnumType episodeEnum
|
||||
|
||||
secretBackstoryFieldType :: Resolver (Either SomeException)
|
||||
secretBackstoryFieldType = ValueResolver field secretBackstory
|
||||
where
|
||||
field = Out.Field Nothing (Out.NamedScalarType string) mempty
|
||||
secretBackstoryField :: Field (Either SomeException)
|
||||
secretBackstoryField =
|
||||
Out.Field Nothing (Out.NamedScalarType string) mempty
|
||||
|
||||
idField :: Text -> Resolve (Either SomeException)
|
||||
idField f = do
|
||||
appearsInFieldResolver :: Resolver (Either SomeException)
|
||||
appearsInFieldResolver = ValueResolver appearsInField
|
||||
$ defaultResolver "appearsIn"
|
||||
|
||||
secretBackstoryFieldResolver :: Resolver (Either SomeException)
|
||||
secretBackstoryFieldResolver = ValueResolver secretBackstoryField secretBackstory
|
||||
|
||||
defaultResolver :: Text -> Resolve (Either SomeException)
|
||||
defaultResolver f = do
|
||||
v <- asks values
|
||||
let (Object v') = v
|
||||
pure $ v' HashMap.! f
|
||||
|
||||
Loading…
Reference in New Issue
Block a user