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

Collect types from the subscription root

Browse Source
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
CHANGELOG.md
View File

@ -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

5
src/Language/GraphQL/Type/Internal.hs
View File

@ -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

47
src/Language/GraphQL/Validate/Rules.hs
View File

@ -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)
isSpreadTarget :: Text -> Definition -> Bool
isSpreadTarget thisName (viewFragment -> Just fragmentDefinition)
| FragmentDefinition thatName _ _ _ _ <- fragmentDefinition
, 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."
]

58
tests/Language/GraphQL/ValidateSpec.hs
View File

@ -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

4
tests/Test/DirectiveSpec.hs
View File

@ -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
}
}

15
tests/Test/FragmentSpec.hs
View File

@ -46,15 +46,12 @@ inlineQuery = [r|{
}|]
shirtType :: Out.ObjectType IO
shirtType = Out.ObjectType "Shirt" Nothing []
$ HashMap.fromList
shirtType = Out.ObjectType "Shirt" Nothing [] $ HashMap.fromList
[ ("size", sizeFieldType)
, ("circumference", circumferenceFieldType)
]
hatType :: Out.ObjectType IO
hatType = Out.ObjectType "Hat" Nothing []
$ HashMap.fromList
hatType = Out.ObjectType "Hat" Nothing [] $ HashMap.fromList
[ ("size", sizeFieldType)
, ("circumference", 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