Collect types from the subscription root

This commit is contained in:
Eugen Wissner 2020-09-04 19:12:19 +02:00
parent 33318a3b01
commit 14ed209828
6 changed files with 108 additions and 42 deletions

View File

@ -12,7 +12,12 @@ and this project adheres to
### Added ### Added
- `Validate.Validation.Rule`: `SelectionRule` constructor. - `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 ## [0.10.0.0] - 2020-08-29
### Changed ### Changed

View File

@ -38,7 +38,10 @@ data AbstractType m
collectReferencedTypes :: forall m. Schema m -> HashMap Name (Type m) collectReferencedTypes :: forall m. Schema m -> HashMap Name (Type m)
collectReferencedTypes schema = collectReferencedTypes schema =
let queryTypes = traverseObjectType (query schema) HashMap.empty 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 where
collect traverser typeName element foundTypes collect traverser typeName element foundTypes
| HashMap.member typeName foundTypes = foundTypes | HashMap.member typeName foundTypes = foundTypes

View File

@ -10,6 +10,8 @@
-- | This module contains default rules defined in the GraphQL specification. -- | This module contains default rules defined in the GraphQL specification.
module Language.GraphQL.Validate.Rules module Language.GraphQL.Validate.Rules
( executableDefinitionsRule ( executableDefinitionsRule
, fragmentSpreadTargetDefinedRule
, fragmentSpreadTypeExistenceRule
, loneAnonymousOperationRule , loneAnonymousOperationRule
, singleFieldSubscriptionsRule , singleFieldSubscriptionsRule
, specifiedRules , specifiedRules
@ -22,7 +24,9 @@ import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Reader (asks) import Control.Monad.Trans.Reader (asks)
import Control.Monad.Trans.State (evalStateT, gets, modify) import Control.Monad.Trans.State (evalStateT, gets, modify)
import Data.Foldable (find) import Data.Foldable (find)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.HashSet as HashSet import qualified Data.HashSet as HashSet
import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
import Language.GraphQL.AST.Document import Language.GraphQL.AST.Document
import Language.GraphQL.Type.Internal import Language.GraphQL.Type.Internal
@ -32,12 +36,16 @@ import Language.GraphQL.Validate.Validation
-- | Default rules given in the specification. -- | Default rules given in the specification.
specifiedRules :: forall m. [Rule m] specifiedRules :: forall m. [Rule m]
specifiedRules = specifiedRules =
-- Documents.
[ executableDefinitionsRule [ executableDefinitionsRule
-- Operations.
, singleFieldSubscriptionsRule , singleFieldSubscriptionsRule
, loneAnonymousOperationRule , loneAnonymousOperationRule
, uniqueOperationNamesRule , uniqueOperationNamesRule
-- Fragments.
, uniqueFragmentNamesRule , uniqueFragmentNamesRule
, fragmentSpreadTargetDefinedRule , fragmentSpreadTargetDefinedRule
, fragmentSpreadTypeExistenceRule
] ]
-- | Definition must be OperationDefinition or FragmentDefinition. -- | Definition must be OperationDefinition or FragmentDefinition.
@ -228,7 +236,7 @@ fragmentSpreadTargetDefinedRule :: forall m. Rule m
fragmentSpreadTargetDefinedRule = SelectionRule $ \case fragmentSpreadTargetDefinedRule = SelectionRule $ \case
FragmentSpread fragmentName _ location -> do FragmentSpread fragmentName _ location -> do
ast' <- asks ast ast' <- asks ast
case find (findTarget fragmentName) ast' of case find (isSpreadTarget fragmentName) ast' of
Nothing -> pure $ Error Nothing -> pure $ Error
{ message = error' fragmentName { message = error' fragmentName
, locations = [location] , locations = [location]
@ -242,7 +250,40 @@ fragmentSpreadTargetDefinedRule = SelectionRule $ \case
, Text.unpack fragmentName , Text.unpack fragmentName
, "\" is undefined." , "\" is undefined."
] ]
findTarget thisName (viewFragment -> Just fragmentDefinition)
isSpreadTarget :: Text -> Definition -> Bool
isSpreadTarget thisName (viewFragment -> Just fragmentDefinition)
| FragmentDefinition thatName _ _ _ _ <- fragmentDefinition | FragmentDefinition thatName _ _ _ _ <- fragmentDefinition
, thisName == thatName = True , thisName == thatName = True
findTarget _ _ = False 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."
]

View File

@ -26,7 +26,7 @@ schema :: Schema IO
schema = Schema schema = Schema
{ query = queryType { query = queryType
, mutation = Nothing , mutation = Nothing
, subscription = Nothing , subscription = Just subscriptionType
} }
queryType :: ObjectType IO queryType :: ObjectType IO
@ -81,19 +81,27 @@ petType :: InterfaceType IO
petType = InterfaceType "Pet" Nothing [] petType = InterfaceType "Pet" Nothing []
$ HashMap.singleton "name" $ HashMap.singleton "name"
$ Field Nothing (Out.NonNullScalarType string) mempty $ Field Nothing (Out.NonNullScalarType string) mempty
{-
alienType :: ObjectType IO subscriptionType :: ObjectType IO
alienType = ObjectType "Alien" Nothing [sentientType] $ HashMap.fromList subscriptionType = ObjectType "Subscription" Nothing [] $ HashMap.fromList
[ ("name", nameResolver) [ ("newMessage", newMessageResolver)
, ("homePlanet", homePlanetResolver)
] ]
where where
nameField = Field Nothing (Out.NonNullScalarType string) mempty newMessageField = Field Nothing (Out.NonNullObjectType messageType) mempty
nameResolver = ValueResolver nameField $ pure "Name" newMessageResolver = ValueResolver newMessageField
homePlanetField = $ pure $ Object HashMap.empty
Field Nothing (Out.NamedScalarType string) mempty
homePlanetResolver = ValueResolver homePlanetField $ pure "Home planet" 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 IO
humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList humanType = ObjectType "Human" Nothing [sentientType] $ HashMap.fromList
[ ("name", nameResolver) [ ("name", nameResolver)
@ -133,12 +141,6 @@ catType = ObjectType "Cat" Nothing [petType] $ HashMap.fromList
catOrDogType :: UnionType IO catOrDogType :: UnionType IO
catOrDogType = UnionType "CatOrDog" Nothing [catType, dogType] 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 :: Text -> Seq Error
validate queryString = validate queryString =
@ -297,3 +299,23 @@ spec =
, path = [] , path = []
} }
in validate queryString `shouldBe` Seq.singleton expected 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

View File

@ -72,7 +72,7 @@ spec =
...experimentalFragment @skip(if: true) ...experimentalFragment @skip(if: true)
} }
fragment experimentalFragment on ExperimentalType { fragment experimentalFragment on Query {
experimentalField experimentalField
} }
|] |]
@ -83,7 +83,7 @@ spec =
it "should be able to @skip an inline fragment" $ do it "should be able to @skip an inline fragment" $ do
let sourceQuery = [r| let sourceQuery = [r|
{ {
... on ExperimentalType @skip(if: true) { ... on Query @skip(if: true) {
experimentalField experimentalField
} }
} }

View File

@ -46,15 +46,12 @@ inlineQuery = [r|{
}|] }|]
shirtType :: Out.ObjectType IO shirtType :: Out.ObjectType IO
shirtType = Out.ObjectType "Shirt" Nothing [] shirtType = Out.ObjectType "Shirt" Nothing [] $ HashMap.fromList
$ HashMap.fromList
[ ("size", sizeFieldType) [ ("size", sizeFieldType)
, ("circumference", circumferenceFieldType)
] ]
hatType :: Out.ObjectType IO hatType :: Out.ObjectType IO
hatType = Out.ObjectType "Hat" Nothing [] hatType = Out.ObjectType "Hat" Nothing [] $ HashMap.fromList
$ HashMap.fromList
[ ("size", sizeFieldType) [ ("size", sizeFieldType)
, ("circumference", circumferenceFieldType) , ("circumference", circumferenceFieldType)
] ]
@ -73,9 +70,9 @@ toSchema :: Text -> (Text, Value) -> Schema IO
toSchema t (_, resolve) = Schema toSchema t (_, resolve) = Schema
{ query = queryType, mutation = Nothing, subscription = Nothing } { query = queryType, mutation = Nothing, subscription = Nothing }
where where
unionMember = if t == "Hat" then hatType else shirtType garmentType = Out.UnionType "Garment" Nothing [hatType, shirtType]
typeNameField = Out.Field Nothing (Out.NamedScalarType string) mempty 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 = queryType =
case t of case t of
"circumference" -> hatType "circumference" -> hatType
@ -118,9 +115,7 @@ spec = do
} }
} }
}|] }|]
resolvers = ("garment", Object $ HashMap.fromList [circumference, size]) actual <- graphql (toSchema "garment" $ garment "Hat") sourceQuery
actual <- graphql (toSchema "garment" resolvers) sourceQuery
let expected = HashMap.singleton "data" let expected = HashMap.singleton "data"
$ Aeson.object $ Aeson.object
[ "garment" .= Aeson.object [ "garment" .= Aeson.object