Collect types from the subscription root

2020-09-04 19:12:19 +02:00 · 2020-09-04 19:12:19 +02:00 · 14ed209828
commit 14ed209828
parent 33318a3b01
6 changed files with 108 additions and 42 deletions
--- 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
--- 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
--- 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."
+        ]
--- 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
--- 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
                }
              }
--- 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