Collect types from the subscription root

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

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

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)
+
+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."
+        ]

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

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

tests/Test/FragmentSpec.hs

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