Validate field selections on composite types

1 files changed, 109 insertions, 47 deletions

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)