diff --git a/CHANGELOG.md b/CHANGELOG.md index 893f7ab..bb3dbcc 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -12,7 +12,12 @@ and this project adheres to ### Added - `Validate.Validation.Rule`: `SelectionRule` constructor. -- `Validate.Rules`: `fragmentSpreadTargetDefinedRule`. +- `Validate.Rules`: + - `fragmentSpreadTargetDefinedRule` + - `fragmentSpreadTypeExistenceRule` + +### Fixed +- Collecting existing types from the schema considers subscriptions. ## [0.10.0.0] - 2020-08-29 ### Changed diff --git a/src/Language/GraphQL/Type/Internal.hs b/src/Language/GraphQL/Type/Internal.hs index 6f25777..364a7b1 100644 --- a/src/Language/GraphQL/Type/Internal.hs +++ b/src/Language/GraphQL/Type/Internal.hs @@ -38,7 +38,10 @@ data AbstractType m collectReferencedTypes :: forall m. Schema m -> HashMap Name (Type m) collectReferencedTypes schema = let queryTypes = traverseObjectType (query schema) HashMap.empty - in maybe queryTypes (`traverseObjectType` queryTypes) $ mutation schema + mutationTypes = maybe queryTypes (`traverseObjectType` queryTypes) + $ mutation schema + in maybe mutationTypes (`traverseObjectType` queryTypes) + $ subscription schema where collect traverser typeName element foundTypes | HashMap.member typeName foundTypes = foundTypes diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs index c531753..ec51bbd 100644 --- a/src/Language/GraphQL/Validate/Rules.hs +++ b/src/Language/GraphQL/Validate/Rules.hs @@ -10,6 +10,8 @@ -- | This module contains default rules defined in the GraphQL specification. module Language.GraphQL.Validate.Rules ( executableDefinitionsRule + , fragmentSpreadTargetDefinedRule + , fragmentSpreadTypeExistenceRule , loneAnonymousOperationRule , singleFieldSubscriptionsRule , specifiedRules @@ -22,7 +24,9 @@ import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Reader (asks) import Control.Monad.Trans.State (evalStateT, gets, modify) import Data.Foldable (find) +import qualified Data.HashMap.Strict as HashMap import qualified Data.HashSet as HashSet +import Data.Text (Text) import qualified Data.Text as Text import Language.GraphQL.AST.Document import Language.GraphQL.Type.Internal @@ -32,12 +36,16 @@ import Language.GraphQL.Validate.Validation -- | Default rules given in the specification. specifiedRules :: forall m. [Rule m] specifiedRules = + -- Documents. [ executableDefinitionsRule + -- Operations. , singleFieldSubscriptionsRule , loneAnonymousOperationRule , uniqueOperationNamesRule + -- Fragments. , uniqueFragmentNamesRule , fragmentSpreadTargetDefinedRule + , fragmentSpreadTypeExistenceRule ] -- | Definition must be OperationDefinition or FragmentDefinition. @@ -228,7 +236,7 @@ fragmentSpreadTargetDefinedRule :: forall m. Rule m fragmentSpreadTargetDefinedRule = SelectionRule $ \case FragmentSpread fragmentName _ location -> do ast' <- asks ast - case find (findTarget fragmentName) ast' of + case find (isSpreadTarget fragmentName) ast' of Nothing -> pure $ Error { message = error' fragmentName , locations = [location] @@ -242,7 +250,40 @@ fragmentSpreadTargetDefinedRule = SelectionRule $ \case , Text.unpack fragmentName , "\" is undefined." ] - findTarget thisName (viewFragment -> Just fragmentDefinition) - | FragmentDefinition thatName _ _ _ _ <- fragmentDefinition - , thisName == thatName = True - findTarget _ _ = False + +isSpreadTarget :: Text -> Definition -> Bool +isSpreadTarget thisName (viewFragment -> Just fragmentDefinition) + | FragmentDefinition thatName _ _ _ _ <- fragmentDefinition + , thisName == thatName = True +isSpreadTarget _ _ = False + +-- | Fragments must be specified on types that exist in the schema. This applies +-- 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 + FragmentSpread fragmentName _ location -> do + ast' <- asks ast + target <- lift $ find (isSpreadTarget fragmentName) ast' + typeCondition <- extractTypeCondition target + types' <- asks types + case HashMap.lookup typeCondition types' of + Nothing -> pure $ Error + { message = error' fragmentName typeCondition + , locations = [location] + , path = [] + } + Just _ -> lift Nothing + _ -> lift Nothing + where + extractTypeCondition (viewFragment -> Just fragmentDefinition) = + let FragmentDefinition _ typeCondition _ _ _ = fragmentDefinition + in pure typeCondition + extractTypeCondition _ = lift Nothing + error' fragmentName typeCondition = concat + [ "Fragment \"" + , Text.unpack fragmentName + , "\" is specified on type \"" + , Text.unpack typeCondition + , "\" which doesn't exist in the schema." + ] diff --git a/tests/Language/GraphQL/ValidateSpec.hs b/tests/Language/GraphQL/ValidateSpec.hs index f8809f9..eef5d38 100644 --- a/tests/Language/GraphQL/ValidateSpec.hs +++ b/tests/Language/GraphQL/ValidateSpec.hs @@ -26,7 +26,7 @@ schema :: Schema IO schema = Schema { query = queryType , mutation = Nothing - , subscription = Nothing + , subscription = Just subscriptionType } queryType :: ObjectType IO @@ -81,19 +81,27 @@ petType :: InterfaceType IO petType = InterfaceType "Pet" Nothing [] $ HashMap.singleton "name" $ Field Nothing (Out.NonNullScalarType string) mempty -{- -alienType :: ObjectType IO -alienType = ObjectType "Alien" Nothing [sentientType] $ HashMap.fromList - [ ("name", nameResolver) - , ("homePlanet", homePlanetResolver) + +subscriptionType :: ObjectType IO +subscriptionType = ObjectType "Subscription" Nothing [] $ HashMap.fromList + [ ("newMessage", newMessageResolver) ] where - nameField = Field Nothing (Out.NonNullScalarType string) mempty - nameResolver = ValueResolver nameField $ pure "Name" - homePlanetField = - Field Nothing (Out.NamedScalarType string) mempty - homePlanetResolver = ValueResolver homePlanetField $ pure "Home planet" --} + newMessageField = Field Nothing (Out.NonNullObjectType messageType) mempty + newMessageResolver = ValueResolver newMessageField + $ pure $ Object HashMap.empty + +messageType :: ObjectType IO +messageType = ObjectType "Message" Nothing [] $ HashMap.fromList + [ ("sender", senderResolver) + , ("body", bodyResolver) + ] + where + senderField = Field Nothing (Out.NonNullScalarType string) mempty + senderResolver = ValueResolver senderField $ pure "Sender" + bodyField = Field Nothing (Out.NonNullScalarType string) mempty + bodyResolver = ValueResolver bodyField $ pure "Message body." + humanType :: ObjectType IO humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList [ ("name", nameResolver) @@ -133,12 +141,6 @@ catType = ObjectType "Cat" Nothing [petType] $ HashMap.fromList catOrDogType :: UnionType IO catOrDogType = UnionType "CatOrDog" Nothing [catType, dogType] - -dogOrHumanType :: UnionType IO -dogOrHumanType = UnionType "DogOrHuman" Nothing [dogType, humanType] - -humanOrAlienType :: UnionType IO -humanOrAlienType = UnionType "HumanOrAlien" Nothing [humanType, alienType] -} validate :: Text -> Seq Error validate queryString = @@ -297,3 +299,23 @@ spec = , path = [] } in validate queryString `shouldBe` Seq.singleton expected + + it "rejects the fragment spread without a target" $ + let queryString = [r| + { + dog { + ...notOnExistingType + } + } + fragment notOnExistingType on NotInSchema { + name + } + |] + expected = Error + { message = + "Fragment \"notOnExistingType\" is specified on type \ + \\"NotInSchema\" which doesn't exist in the schema." + , locations = [AST.Location 4 19] + , path = [] + } + in validate queryString `shouldBe` Seq.singleton expected diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs index e6b6cea..800189e 100644 --- a/tests/Test/DirectiveSpec.hs +++ b/tests/Test/DirectiveSpec.hs @@ -72,7 +72,7 @@ spec = ...experimentalFragment @skip(if: true) } - fragment experimentalFragment on ExperimentalType { + fragment experimentalFragment on Query { experimentalField } |] @@ -83,7 +83,7 @@ spec = it "should be able to @skip an inline fragment" $ do let sourceQuery = [r| { - ... on ExperimentalType @skip(if: true) { + ... on Query @skip(if: true) { experimentalField } } diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs index 089b721..216ae21 100644 --- a/tests/Test/FragmentSpec.hs +++ b/tests/Test/FragmentSpec.hs @@ -46,18 +46,15 @@ inlineQuery = [r|{ }|] shirtType :: Out.ObjectType IO -shirtType = Out.ObjectType "Shirt" Nothing [] - $ HashMap.fromList - [ ("size", sizeFieldType) - , ("circumference", circumferenceFieldType) - ] +shirtType = Out.ObjectType "Shirt" Nothing [] $ HashMap.fromList + [ ("size", sizeFieldType) + ] hatType :: Out.ObjectType IO -hatType = Out.ObjectType "Hat" Nothing [] - $ HashMap.fromList - [ ("size", sizeFieldType) - , ("circumference", circumferenceFieldType) - ] +hatType = Out.ObjectType "Hat" Nothing [] $ HashMap.fromList + [ ("size", sizeFieldType) + , ("circumference", circumferenceFieldType) + ] circumferenceFieldType :: Out.Resolver IO circumferenceFieldType @@ -73,9 +70,9 @@ toSchema :: Text -> (Text, Value) -> Schema IO toSchema t (_, resolve) = Schema { query = queryType, mutation = Nothing, subscription = Nothing } where - unionMember = if t == "Hat" then hatType else shirtType + garmentType = Out.UnionType "Garment" Nothing [hatType, shirtType] typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty - garmentField = Out.Field Nothing (Out.NamedObjectType unionMember) mempty + garmentField = Out.Field Nothing (Out.NamedUnionType garmentType) mempty queryType = case t of "circumference" -> hatType @@ -118,9 +115,7 @@ spec = do } } }|] - resolvers = ("garment", Object $ HashMap.fromList [circumference, size]) - - actual <- graphql (toSchema "garment" resolvers) sourceQuery + actual <- graphql (toSchema "garment" $ garment "Hat") sourceQuery let expected = HashMap.singleton "data" $ Aeson.object [ "garment" .= Aeson.object