Validate field selections on composite types

5 files changed, 183 insertions, 62 deletions

diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs
index f9d33d6..3caa7f0 100644
--- a/src/Language/GraphQL/Execute/Execution.hs
+++ b/src/Language/GraphQL/Execute/Execution.hs
@@ -124,7 +124,7 @@ completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) =
     let Type.EnumType _ _ enumMembers = enumType
      in if HashMap.member enum enumMembers
         then coerceResult outputType $ Enum enum
-        else addErrMsg "Value completion failed."
+        else addErrMsg "Enum value completion failed."
 completeValue (Out.ObjectBaseType objectType) fields result =
     executeSelectionSet result objectType $ mergeSelectionSets fields
 completeValue (Out.InterfaceBaseType interfaceType) fields result
@@ -134,7 +134,7 @@ completeValue (Out.InterfaceBaseType interfaceType) fields result
         case concreteType of
             Just objectType -> executeSelectionSet result objectType
                 $ mergeSelectionSets fields
-            Nothing -> addErrMsg "Value completion failed."
+            Nothing -> addErrMsg "Interface value completion failed."
 completeValue (Out.UnionBaseType unionType) fields result
     | Type.Object objectMap <- result = do
         let abstractType = AbstractUnionType unionType
@@ -142,7 +142,7 @@ completeValue (Out.UnionBaseType unionType) fields result
         case concreteType of
             Just objectType -> executeSelectionSet result objectType
                 $ mergeSelectionSets fields
-            Nothing -> addErrMsg "Value completion failed."
+            Nothing -> addErrMsg "Union value completion failed."
 completeValue _ _ _ = addErrMsg "Value completion failed."
 
 mergeSelectionSets :: MonadCatch m
diff --git a/src/Language/GraphQL/Type/Internal.hs b/src/Language/GraphQL/Type/Internal.hs
index 6438ad1..444a52d 100644
--- a/src/Language/GraphQL/Type/Internal.hs
+++ b/src/Language/GraphQL/Type/Internal.hs
@@ -3,6 +3,7 @@
    obtain one at https://mozilla.org/MPL/2.0/. -}
 
 {-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Language.GraphQL.Type.Internal
     ( AbstractType(..)
@@ -12,10 +13,12 @@ module Language.GraphQL.Type.Internal
     , instanceOf
     , lookupInputType
     , lookupTypeCondition
+    , lookupTypeField
     ) where
 
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
+import Data.Text (Text)
 import qualified Language.GraphQL.AST as Full
 import qualified Language.GraphQL.Type.Definition as Definition
 import qualified Language.GraphQL.Type.In as In
@@ -55,41 +58,41 @@ collectReferencedTypes schema =
     getField (Out.ValueResolver field _) = field
     getField (Out.EventStreamResolver field _ _) = field
     traverseInputType (In.InputObjectBaseType objectType) =
-        let (In.InputObjectType typeName _ inputFields) = objectType
+        let In.InputObjectType typeName _ inputFields = objectType
             element = InputObjectType objectType
             traverser = flip (foldr visitInputFields) inputFields
          in collect traverser typeName element
     traverseInputType (In.ListBaseType listType) =
         traverseInputType listType
     traverseInputType (In.ScalarBaseType scalarType) =
-        let (Definition.ScalarType typeName _) = scalarType
+        let Definition.ScalarType typeName _ = scalarType
          in collect Prelude.id typeName (ScalarType scalarType)
     traverseInputType (In.EnumBaseType enumType) =
-        let (Definition.EnumType typeName _ _) = enumType
+        let Definition.EnumType typeName _ _ = enumType
          in collect Prelude.id typeName (EnumType enumType)
     traverseOutputType (Out.ObjectBaseType objectType) =
         traverseObjectType objectType
     traverseOutputType (Out.InterfaceBaseType interfaceType) =
         traverseInterfaceType interfaceType
     traverseOutputType (Out.UnionBaseType unionType) =
-        let (Out.UnionType typeName _ types) = unionType
+        let Out.UnionType typeName _ types = unionType
             traverser = flip (foldr traverseObjectType) types
          in collect traverser typeName (UnionType unionType)
     traverseOutputType (Out.ListBaseType listType) =
         traverseOutputType listType
     traverseOutputType (Out.ScalarBaseType scalarType) =
-        let (Definition.ScalarType typeName _) = scalarType
+        let Definition.ScalarType typeName _ = scalarType
          in collect Prelude.id typeName (ScalarType scalarType)
     traverseOutputType (Out.EnumBaseType enumType) =
-        let (Definition.EnumType typeName _ _) = enumType
+        let Definition.EnumType typeName _ _ = enumType
          in collect Prelude.id typeName (EnumType enumType)
     traverseObjectType objectType foundTypes =
-        let (Out.ObjectType typeName _ interfaces fields) = objectType
+        let Out.ObjectType typeName _ interfaces fields = objectType
             element = ObjectType objectType
             traverser = polymorphicTraverser interfaces (getField <$> fields)
          in collect traverser typeName element foundTypes
     traverseInterfaceType interfaceType foundTypes =
-        let (Out.InterfaceType typeName _ interfaces fields) = interfaceType
+        let Out.InterfaceType typeName _ interfaces fields = interfaceType
             element = InterfaceType interfaceType
             traverser = polymorphicTraverser interfaces fields
          in collect traverser typeName element foundTypes
@@ -161,3 +164,21 @@ lookupInputType (Full.TypeNonNull (Full.NonNullTypeNamed nonNull)) types  =
 lookupInputType (Full.TypeNonNull (Full.NonNullTypeList nonNull)) types
     = In.NonNullListType
     <$> lookupInputType nonNull types
+
+lookupTypeField :: forall a. Text -> Out.Type a -> Maybe (Out.Type a)
+lookupTypeField fieldName = \case
+    Out.ObjectBaseType objectType ->
+        objectChild objectType
+    Out.InterfaceBaseType interfaceType ->
+        interfaceChild interfaceType
+    Out.ListBaseType listType -> lookupTypeField fieldName listType
+    _ -> Nothing
+  where
+    objectChild (Out.ObjectType _ _ _ resolvers) =
+        resolverType <$> HashMap.lookup fieldName resolvers
+    interfaceChild (Out.InterfaceType _ _ _ fields) =
+        fieldType <$> HashMap.lookup fieldName fields
+    resolverType (Out.ValueResolver objectField _) = fieldType objectField
+    resolverType (Out.EventStreamResolver objectField _ _) =
+        fieldType objectField
+    fieldType (Out.Field _ type' _) = type'
diff --git a/src/Language/GraphQL/Validate.hs b/src/Language/GraphQL/Validate.hs
index be9ba33..0fa04cb 100644
--- a/src/Language/GraphQL/Validate.hs
+++ b/src/Language/GraphQL/Validate.hs
@@ -2,8 +2,8 @@
    v. 2.0. If a copy of the MPL was not distributed with this file, You can
    obtain one at https://mozilla.org/MPL/2.0/. -}
 
-{-# LANGUAGE ExplicitForAll #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 -- | GraphQL validator.
 module Language.GraphQL.Validate
@@ -16,14 +16,21 @@ import Control.Monad (join)
 import Control.Monad.Trans.Class (MonadTrans(..))
 import Control.Monad.Trans.Reader (runReaderT)
 import Data.Foldable (toList)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
 import Data.Sequence (Seq(..), (><), (|>))
 import qualified Data.Sequence as Seq
 import Language.GraphQL.AST.Document
 import Language.GraphQL.Type.Internal
+import qualified Language.GraphQL.Type.Out as Out
 import Language.GraphQL.Type.Schema (Schema(..))
+import qualified Language.GraphQL.Type.Schema as Schema
 import Language.GraphQL.Validate.Rules
 import Language.GraphQL.Validate.Validation
 
+type ApplyRule m a =
+    HashMap Name (Schema.Type m) -> Rule m -> Maybe (Out.Type m) -> a -> Seq (RuleT m)
+
 -- | Validates a document and returns a list of found errors. If the returned
 -- list is empty, the document is valid.
 document :: forall m. Schema m -> [Rule m] -> Document -> Seq Error
@@ -37,16 +44,20 @@ document schema' rules' document' =
         }
     reader = do
         rule' <- lift $ Seq.fromList rules'
-        join $ lift $ foldr (definition rule') Seq.empty document'
+        join $ lift $ foldr (definition rule' context) Seq.empty document'
 
-definition :: Rule m -> Definition -> Seq (RuleT m) -> Seq (RuleT m)
-definition (DefinitionRule rule) definition' accumulator =
+definition :: Rule m
+    -> Validation m
+    -> Definition
+    -> Seq (RuleT m)
+    -> Seq (RuleT m)
+definition (DefinitionRule rule) _ definition' accumulator =
     accumulator |> rule definition'
-definition rule (ExecutableDefinition executableDefinition') accumulator =
-    accumulator >< executableDefinition rule executableDefinition'
-definition rule (TypeSystemDefinition typeSystemDefinition' _) accumulator =
+definition rule context (ExecutableDefinition definition') accumulator =
+    accumulator >< executableDefinition rule context definition'
+definition rule _ (TypeSystemDefinition typeSystemDefinition' _) accumulator =
     accumulator >< typeSystemDefinition rule typeSystemDefinition'
-definition rule (TypeSystemExtension extension _) accumulator =
+definition rule _ (TypeSystemExtension extension _) accumulator =
     accumulator >< typeSystemExtension rule extension
 
 typeSystemExtension :: Rule m -> TypeSystemExtension -> Seq (RuleT m)
@@ -82,11 +93,14 @@ schemaExtension rule = \case
     SchemaOperationExtension directives' _ -> directives rule directives'
     SchemaDirectivesExtension directives' -> directives rule directives'
 
-executableDefinition :: Rule m -> ExecutableDefinition -> Seq (RuleT m)
-executableDefinition rule (DefinitionOperation operation) =
-    operationDefinition rule operation
-executableDefinition rule (DefinitionFragment fragment) =
-    fragmentDefinition rule fragment
+executableDefinition :: Rule m
+    -> Validation m
+    -> ExecutableDefinition
+    -> Seq (RuleT m)
+executableDefinition rule context (DefinitionOperation operation) =
+    operationDefinition rule context operation
+executableDefinition rule context (DefinitionFragment fragment) =
+    fragmentDefinition rule context fragment
 
 typeSystemDefinition :: Rule m -> TypeSystemDefinition -> Seq (RuleT m)
 typeSystemDefinition rule = \case
@@ -124,60 +138,103 @@ inputValueDefinition :: Rule m -> InputValueDefinition -> Seq (RuleT m)
 inputValueDefinition rule (InputValueDefinition _ _ _ _ directives') =
     directives rule directives'
 
-operationDefinition :: Rule m -> OperationDefinition -> Seq (RuleT m)
-operationDefinition rule operation
+operationDefinition :: Rule m
+    -> Validation m
+    -> OperationDefinition
+    -> Seq (RuleT m)
+operationDefinition rule context operation
     | OperationDefinitionRule operationRule <- rule =
         pure $ operationRule operation
     | VariablesRule variablesRule <- rule
     , OperationDefinition _ _ variables _ _ _ <- operation
         = Seq.fromList (variableDefinition rule <$> variables)
         |> variablesRule variables
-    | SelectionSet selections _ <- operation = selectionSet rule selections
-    | OperationDefinition _ _ _ directives' selections _  <- operation =
-        selectionSet rule selections >< directives rule directives'
+    | SelectionSet selections _ <- operation =
+        selectionSet types' rule (getRootType Query) selections
+    | OperationDefinition operationType _ _ directives' selections _  <- operation
+        = selectionSet types' rule (getRootType operationType) selections
+        >< directives rule directives'
+  where
+    types' = types context
+    getRootType Query = Just $ Out.NamedObjectType $ query $ schema context
+    getRootType Mutation = Out.NamedObjectType <$> mutation (schema context)
+    getRootType Subscription =
+        Out.NamedObjectType <$> subscription (schema context)
+        
+typeToOut :: forall m. Schema.Type m -> Maybe (Out.Type m)
+typeToOut (Schema.ObjectType objectType) =
+    Just $ Out.NamedObjectType objectType
+typeToOut (Schema.InterfaceType interfaceType) =
+    Just $ Out.NamedInterfaceType interfaceType
+typeToOut (Schema.UnionType unionType) = Just $ Out.NamedUnionType unionType
+typeToOut (Schema.EnumType enumType) = Just $ Out.NamedEnumType enumType
+typeToOut (Schema.ScalarType scalarType) = Just $ Out.NamedScalarType scalarType
+typeToOut _ = Nothing
 
 variableDefinition :: Rule m -> VariableDefinition -> RuleT m
 variableDefinition (ValueRule _ rule) (VariableDefinition _ _ value _) =
     maybe (lift mempty) rule value
 variableDefinition _ _ = lift mempty
 
-fragmentDefinition :: Rule m -> FragmentDefinition -> Seq (RuleT m)
-fragmentDefinition (FragmentDefinitionRule rule) fragmentDefinition' =
-    pure $ rule fragmentDefinition'
-fragmentDefinition rule fragmentDefinition'@(FragmentDefinition _ _ directives' selections _)
-    | FragmentRule definitionRule _ <- rule =
-        applyToChildren |> definitionRule fragmentDefinition'
-    | otherwise = applyToChildren
+fragmentDefinition :: forall m
+    . Rule m
+    -> Validation m
+    -> FragmentDefinition
+    -> Seq (RuleT m)
+fragmentDefinition (FragmentDefinitionRule rule) _ definition' =
+    pure $ rule definition'
+fragmentDefinition rule context definition'
+    | FragmentDefinition _ typeCondition directives' selections _ <- definition'
+    , FragmentRule definitionRule _ <- rule
+        = applyToChildren typeCondition directives' selections
+        |> definitionRule definition'
+    | FragmentDefinition _ typeCondition directives' selections _ <- definition'
+        = applyToChildren typeCondition directives' selections
   where
-    applyToChildren = selectionSet rule selections
+    types' = types context
+    applyToChildren typeCondition directives' selections
+        = selectionSet types' rule (lookupType' typeCondition) selections
         >< directives rule directives'
+    lookupType' = flip lookupType types'
 
-selectionSet :: Traversable t => Rule m -> t Selection -> Seq (RuleT m)
-selectionSet = foldMap . selection
+lookupType :: forall m
+    . TypeCondition
+    -> HashMap Name (Schema.Type m)
+    -> Maybe (Out.Type m)
+lookupType typeCondition types' = HashMap.lookup typeCondition types'
+    >>= typeToOut
 
-selection :: Rule m -> Selection -> Seq (RuleT m)
-selection rule selection'
+selectionSet :: Traversable t => forall m. ApplyRule m (t Selection)
+selectionSet types' rule = foldMap . selection types' rule
+
+selection :: forall m. ApplyRule m Selection
+selection types' rule objectType selection'
     | SelectionRule selectionRule <- rule =
-        applyToChildren |> selectionRule selection'
+        applyToChildren |> selectionRule objectType selection'
     | otherwise = applyToChildren
   where
     applyToChildren =
         case selection' of
-            FieldSelection field' -> field rule field'
+            FieldSelection field' -> field types' rule objectType field'
             InlineFragmentSelection inlineFragment' ->
-                inlineFragment rule inlineFragment'
+                inlineFragment types' rule objectType inlineFragment'
             FragmentSpreadSelection fragmentSpread' ->
                 fragmentSpread rule fragmentSpread'
 
-field :: Rule m -> Field -> Seq (RuleT m)
-field rule field'@(Field _ _ arguments' directives' selections _)
-    | FieldRule fieldRule <- rule = applyToChildren |> fieldRule field'
-    | ArgumentsRule fieldRule _  <- rule = applyToChildren |> fieldRule field'
-    | otherwise = applyToChildren
+field :: forall m. ApplyRule m Field
+field types' rule objectType field' = go field'
   where
-    applyToChildren = selectionSet rule selections
-        >< directives rule directives'
-        >< arguments rule arguments'
+    go (Field _ fieldName arguments' directives' selections _)
+        | ArgumentsRule fieldRule _  <- rule
+            = applyToChildren fieldName arguments' directives' selections
+            |> fieldRule field'
+        | otherwise =
+            applyToChildren fieldName arguments' directives' selections
+    applyToChildren fieldName arguments' directives' selections =
+        let child = objectType >>= lookupTypeField fieldName
+         in selectionSet types' rule child selections
+            >< directives rule directives'
+            >< arguments rule arguments'
 
 arguments :: Rule m -> [Argument] -> Seq (RuleT m)
 arguments = (.) Seq.fromList . fmap . argument
@@ -186,13 +243,18 @@ argument :: Rule m -> Argument -> RuleT m
 argument (ValueRule rule _) (Argument _ (Node value _) _) = rule value
 argument _ _ = lift mempty
 
-inlineFragment :: Rule m -> InlineFragment -> Seq (RuleT m)
-inlineFragment rule inlineFragment'@(InlineFragment _ directives' selections _)
-    | FragmentRule _ fragmentRule <- rule =
-        applyToChildren |> fragmentRule inlineFragment'
-    | otherwise = applyToChildren
+inlineFragment :: forall m. ApplyRule m InlineFragment
+inlineFragment types' rule objectType inlineFragment' = go inlineFragment'
   where
-    applyToChildren = selectionSet rule selections
+    go (InlineFragment optionalType directives' selections _)
+        | FragmentRule _ fragmentRule <- rule
+            = applyToChildren (refineTarget optionalType) directives' selections
+            |> fragmentRule inlineFragment'
+        | otherwise = applyToChildren (refineTarget optionalType) directives' selections
+    refineTarget (Just typeCondition) = lookupType typeCondition types'
+    refineTarget Nothing = objectType
+    applyToChildren objectType' directives' selections
+        = selectionSet types' rule objectType' selections
         >< directives rule directives'
 
 fragmentSpread :: Rule m -> FragmentSpread -> Seq (RuleT m)
diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs
index 1d34162..ee3729a 100644
--- a/src/Language/GraphQL/Validate/Rules.hs
+++ b/src/Language/GraphQL/Validate/Rules.hs
@@ -10,6 +10,7 @@
 -- | This module contains default rules defined in the GraphQL specification.
 module Language.GraphQL.Validate.Rules
     ( executableDefinitionsRule
+    , fieldsOnCorrectTypeRule
     , fragmentsOnCompositeTypesRule
     , fragmentSpreadTargetDefinedRule
     , fragmentSpreadTypeExistenceRule
@@ -40,14 +41,16 @@ import Data.HashMap.Strict (HashMap)
 import Data.HashSet (HashSet)
 import qualified Data.HashSet as HashSet
 import Data.List (groupBy, sortBy, sortOn)
-import Data.Maybe (mapMaybe)
+import Data.Maybe (isJust, mapMaybe)
 import Data.Ord (comparing)
 import Data.Sequence (Seq(..))
 import qualified Data.Sequence as Seq
 import Data.Text (Text)
 import qualified Data.Text as Text
 import Language.GraphQL.AST.Document
+import qualified Language.GraphQL.Type.Definition as Definition
 import Language.GraphQL.Type.Internal
+import qualified Language.GraphQL.Type.Out as Out
 import qualified Language.GraphQL.Type.Schema as Schema
 import Language.GraphQL.Validate.Validation
 
@@ -63,6 +66,8 @@ specifiedRules =
     , singleFieldSubscriptionsRule
     , loneAnonymousOperationRule
     , uniqueOperationNamesRule
+    -- Fields
+    , fieldsOnCorrectTypeRule
     -- Arguments.
     , uniqueArgumentNamesRule
     -- Fragments.
@@ -297,7 +302,7 @@ isSpreadTarget _ _ = False
 -- 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
+fragmentSpreadTypeExistenceRule = SelectionRule $ const $ \case
     FragmentSpreadSelection fragmentSelection
         | FragmentSpread fragmentName _ location <- fragmentSelection -> do
             ast' <- asks ast
@@ -672,3 +677,36 @@ uniqueInputFieldNamesRule = ValueRule (lift . go) (lift . constGo)
         <> filterFieldDuplicates fields
     constGo (ConstList values) = foldMap constGo values
     constGo _ = mempty
+
+-- | The target field of a field selection must be defined on the scoped type of
+-- the selection set. There are no limitations on alias names.
+fieldsOnCorrectTypeRule :: forall m. Rule m
+fieldsOnCorrectTypeRule = SelectionRule go
+  where
+    go (Just objectType) (FieldSelection fieldSelection) =
+       fieldRule objectType fieldSelection
+    go _ _ = lift mempty
+    fieldRule objectType (Field _ fieldName _ _ _ location)
+        | isJust (lookupTypeField fieldName objectType) = lift mempty
+        | otherwise = pure $ Error
+            { message = errorMessage fieldName objectType
+            , locations = [location]
+            }
+    errorMessage fieldName objectType = concat
+        [ "Cannot query field \""
+        , Text.unpack fieldName
+        , "\" on type \""
+        , Text.unpack $ outputTypeName objectType
+        , "\"."
+        ]
+    outputTypeName (Out.ObjectBaseType (Out.ObjectType typeName _ _ _)) =
+        typeName
+    outputTypeName (Out.InterfaceBaseType (Out.InterfaceType typeName _ _ _)) =
+        typeName
+    outputTypeName (Out.UnionBaseType (Out.UnionType typeName _ _)) =
+        typeName
+    outputTypeName (Out.ScalarBaseType (Definition.ScalarType typeName _)) =
+        typeName
+    outputTypeName (Out.EnumBaseType (Definition.EnumType typeName _ _)) =
+        typeName
+    outputTypeName (Out.ListBaseType wrappedType) = outputTypeName wrappedType
diff --git a/src/Language/GraphQL/Validate/Validation.hs b/src/Language/GraphQL/Validate/Validation.hs
index a56d930..6c2654a 100644
--- a/src/Language/GraphQL/Validate/Validation.hs
+++ b/src/Language/GraphQL/Validate/Validation.hs
@@ -14,6 +14,7 @@ import Control.Monad.Trans.Reader (ReaderT)
 import Data.HashMap.Strict (HashMap)
 import Data.Sequence (Seq)
 import Language.GraphQL.AST.Document
+import qualified Language.GraphQL.Type.Out as Out
 import Language.GraphQL.Type.Schema (Schema)
 import qualified Language.GraphQL.Type.Schema as Schema
 
@@ -37,10 +38,9 @@ data Rule m
     = DefinitionRule (Definition -> RuleT m)
     | OperationDefinitionRule (OperationDefinition -> RuleT m)
     | FragmentDefinitionRule (FragmentDefinition -> RuleT m)
-    | SelectionRule (Selection -> RuleT m)
+    | SelectionRule (Maybe (Out.Type m) -> Selection -> RuleT m)
     | FragmentRule (FragmentDefinition -> RuleT m) (InlineFragment -> RuleT m)
     | FragmentSpreadRule (FragmentSpread -> RuleT m)
-    | FieldRule (Field -> RuleT m)
     | ArgumentsRule (Field -> RuleT m) (Directive -> RuleT m)
     | DirectivesRule ([Directive] -> RuleT m)
     | VariablesRule ([VariableDefinition] -> RuleT m)