diff options
| -rw-r--r-- | CHANGELOG.md | 2 | ||||
| -rw-r--r-- | src/Language/GraphQL/Execute/Execution.hs | 6 | ||||
| -rw-r--r-- | src/Language/GraphQL/Type/Internal.hs | 37 | ||||
| -rw-r--r-- | src/Language/GraphQL/Validate.hs | 156 | ||||
| -rw-r--r-- | src/Language/GraphQL/Validate/Rules.hs | 42 | ||||
| -rw-r--r-- | src/Language/GraphQL/Validate/Validation.hs | 4 | ||||
| -rw-r--r-- | tests/Language/GraphQL/ValidateSpec.hs | 98 | ||||
| -rw-r--r-- | tests/Test/FragmentSpec.hs | 16 | ||||
| -rw-r--r-- | tests/Test/StarWars/QuerySpec.hs | 16 | ||||
| -rw-r--r-- | tests/Test/StarWars/Schema.hs | 92 |
10 files changed, 295 insertions, 174 deletions
diff --git a/CHANGELOG.md b/CHANGELOG.md index 2494efa..9e0890a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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`. diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs index f9d33d6..3caa7f0 100644 --- a/src/Language/GraphQL/Execute/Execution.hs +++ b/src/Language/GraphQL/Execute/Execution.hs @@ -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 diff --git a/src/Language/GraphQL/Type/Internal.hs b/src/Language/GraphQL/Type/Internal.hs index 6438ad1..444a52d 100644 --- a/src/Language/GraphQL/Type/Internal.hs +++ b/src/Language/GraphQL/Type/Internal.hs @@ -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' diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs index be9ba33..0fa04cb 100644 --- a/src/Language/GraphQL/Validate.hs +++ b/src/Language/GraphQL/Validate.hs @@ -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,60 +138,103 @@ 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 - >< directives rule directives' - >< arguments rule arguments' + 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' arguments :: Rule m -> [Argument] -> Seq (RuleT m) arguments = (.) Seq.fromList . fmap . argument @@ -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) diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs index 1d34162..ee3729a 100644 --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -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 diff --git a/src/Language/GraphQL/Validate/Validation.hs b/src/Language/GraphQL/Validate/Validation.hs index a56d930..6c2654a 100644 --- a/src/Language/GraphQL/Validate/Validation.hs +++ b/src/Language/GraphQL/Validate/Validation.hs @@ -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) diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs index 75e78d4..9127a94 100644 --- a/tests/Language/GraphQL/ValidateSpec.hs +++ b/tests/Language/GraphQL/ValidateSpec.hs @@ -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] diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs index 27b08a2..8ee1ad2 100644 --- a/tests/Test/FragmentSpec.hs +++ b/tests/Test/FragmentSpec.hs @@ -108,20 +108,16 @@ spec = do it "embeds inline fragments without type" $ do let sourceQuery = [r|{ - garment { - circumference - ... { - size - } + 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) - ] + [ "circumference" .= (60 :: Int) + , "size" .= ("L" :: Text) ] in actual `shouldResolveTo` expected diff --git a/tests/Test/StarWars/QuerySpec.hs b/tests/Test/StarWars/QuerySpec.hs index 95b18d3..8d744ab 100644 --- a/tests/Test/StarWars/QuerySpec.hs +++ b/tests/Test/StarWars/QuerySpec.hs @@ -23,9 +23,9 @@ spec = describe "Star Wars Query Tests" $ do it "R2-D2 hero" $ testQuery [r| query HeroNameQuery { hero { - id - } + id } + } |] $ Aeson.object [ "data" .= Aeson.object @@ -35,13 +35,13 @@ spec = describe "Star Wars Query Tests" $ do it "R2-D2 ID and friends" $ testQuery [r| query HeroNameAndFriendsQuery { hero { - id + id + name + friends { name - friends { - name - } - } + } } + } |] $ Aeson.object [ "data" .= Aeson.object [ "hero" .= Aeson.object @@ -266,7 +266,7 @@ spec = describe "Star Wars Query Tests" $ do query HeroNameQuery { hero { name - secretBackstory + secretBackstory } } |] diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs index cecd8eb..34a6a35 100644 --- a/tests/Test/StarWars/Schema.hs +++ b/tests/Test/StarWars/Schema.hs @@ -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" - where - fieldType = Out.ListType $ Out.NamedObjectType droidObject +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 -appearsInField :: Resolver (Either SomeException) -appearsInField - = ValueResolver (Out.Field (Just description) fieldType mempty) - $ idField "appearsIn" +friendsField :: Field (Either SomeException) +friendsField = Field Nothing friendsFieldType mempty where - fieldType = Out.ListType $ Out.NamedEnumType episodeEnum - description = "Which movies they appear in." + friendsFieldType = Out.ListType (Out.NamedInterfaceType characterType) -secretBackstoryFieldType :: Resolver (Either SomeException) -secretBackstoryFieldType = ValueResolver field secretBackstory +appearsInField :: Field (Either SomeException) +appearsInField = Field appearsInDescription appearsInFieldType mempty where - field = Out.Field Nothing (Out.NamedScalarType string) mempty + appearsInDescription = Just "Which movies they appear in." + appearsInFieldType = Out.ListType $ Out.NamedEnumType episodeEnum + +secretBackstoryField :: Field (Either SomeException) +secretBackstoryField = + Out.Field Nothing (Out.NamedScalarType string) mempty + +appearsInFieldResolver :: Resolver (Either SomeException) +appearsInFieldResolver = ValueResolver appearsInField + $ defaultResolver "appearsIn" + +secretBackstoryFieldResolver :: Resolver (Either SomeException) +secretBackstoryFieldResolver = ValueResolver secretBackstoryField secretBackstory -idField :: Text -> Resolve (Either SomeException) -idField f = do +defaultResolver :: Text -> Resolve (Either SomeException) +defaultResolver f = do v <- asks values let (Object v') = v pure $ v' HashMap.! f |