graphql/src/Language/GraphQL/Validate.hs

{- This Source Code Form is subject to the terms of the Mozilla Public License,
   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 LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | GraphQL validator.
module Language.GraphQL.Validate
    ( Validation.Error(..)
    , document
    , module Language.GraphQL.Validate.Rules
    ) where

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.DirectiveLocation (DirectiveLocation(..))
import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation
import qualified Language.GraphQL.AST.Document as Full
import Language.GraphQL.Type.Internal
import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type.In as In
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 (Validation(Validation))
import qualified Language.GraphQL.Validate.Validation as Validation

type ApplySelectionRule m a
    = HashMap Full.Name (Schema.Type m)
    -> Validation.Rule m
    -> Maybe (Out.Type m)
    -> a
    -> Seq (Validation.RuleT m)

type ApplyRule m a = Validation.Rule m -> a -> Seq (Validation.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
    -> [Validation.Rule m]
    -> Full.Document
    -> Seq Validation.Error
document schema' rules' document' =
    runReaderT reader context
  where
    context = Validation
        { Validation.ast = document'
        , Validation.schema = schema'
        , Validation.types = collectReferencedTypes schema'
        , Validation.directives = allDirectives
        }
    allDirectives = 
        HashMap.union (Schema.directives schema') defaultDirectives
    defaultDirectives = HashMap.fromList
        [ ("skip", skipDirective)
        , ("include", includeDirective)
        , ("deprecated", deprecatedDirective)
        ]
    includeDirective =
        Schema.Directive includeDescription skipIncludeLocations includeArguments
    includeArguments = HashMap.singleton "if"
        $ In.Argument (Just "Included when true.") ifType Nothing
    includeDescription = Just
        "Directs the executor to include this field or fragment only when the \
        \`if` argument is true."
    skipDirective =
        Schema.Directive skipDescription skipIncludeLocations skipArguments
    skipArguments = HashMap.singleton "if"
        $ In.Argument (Just "skipped when true.") ifType Nothing
    ifType = In.NonNullScalarType Definition.boolean
    skipDescription = Just
        "Directs the executor to skip this field or fragment when the `if` \
        \argument is true."
    skipIncludeLocations =
        [ ExecutableDirectiveLocation DirectiveLocation.Field
        , ExecutableDirectiveLocation DirectiveLocation.FragmentSpread
        , ExecutableDirectiveLocation DirectiveLocation.InlineFragment
        ]
    deprecatedDirective =
        Schema.Directive deprecatedDescription deprecatedLocations deprecatedArguments
    reasonDescription = Just
        "Explains why this element was deprecated, usually also including a \
        \suggestion for how to access supported similar data. Formatted using \
        \the Markdown syntax, as specified by \
        \[CommonMark](https://commonmark.org/).'"
    deprecatedArguments = HashMap.singleton "reason"
        $ In.Argument reasonDescription reasonType
        $ Just "No longer supported"
    reasonType = In.NamedScalarType Definition.string
    deprecatedDescription = Just
        "Marks an element of a GraphQL schema as no longer supported."
    deprecatedLocations =
        [ TypeSystemDirectiveLocation DirectiveLocation.FieldDefinition
        , TypeSystemDirectiveLocation DirectiveLocation.ArgumentDefinition
        , TypeSystemDirectiveLocation DirectiveLocation.InputFieldDefinition
        , TypeSystemDirectiveLocation DirectiveLocation.EnumValue
        ]
    reader = do
        rule' <- lift $ Seq.fromList rules'
        join $ lift $ foldr (definition rule' context) Seq.empty document'

definition :: Validation.Rule m
    -> Validation m
    -> Full.Definition
    -> Seq (Validation.RuleT m)
    -> Seq (Validation.RuleT m)
definition (Validation.DefinitionRule rule) _ definition' accumulator =
    accumulator |> rule definition'
definition rule context (Full.ExecutableDefinition definition') accumulator =
    accumulator >< executableDefinition rule context definition'
definition rule context (Full.TypeSystemDefinition typeSystemDefinition' _) accumulator =
    accumulator >< typeSystemDefinition context rule typeSystemDefinition'
definition rule context (Full.TypeSystemExtension extension _) accumulator =
    accumulator >< typeSystemExtension context rule extension

typeSystemExtension :: forall m
    . Validation m
    -> ApplyRule m Full.TypeSystemExtension
typeSystemExtension context rule = \case
    Full.SchemaExtension extension -> schemaExtension context rule extension
    Full.TypeExtension extension -> typeExtension context rule extension

typeExtension :: forall m. Validation m -> ApplyRule m Full.TypeExtension
typeExtension context rule = \case
    Full.ScalarTypeExtension _ directives' ->
        directives context rule scalarLocation directives'
    Full.ObjectTypeFieldsDefinitionExtension _ _ directives' fields
        -> directives context rule objectLocation directives'
        >< foldMap (fieldDefinition context rule) fields
    Full.ObjectTypeDirectivesExtension _ _ directives' ->
        directives context rule objectLocation directives'
    Full.ObjectTypeImplementsInterfacesExtension _ _ -> mempty
    Full.InterfaceTypeFieldsDefinitionExtension _ directives' fields
        -> directives context rule interfaceLocation directives'
        >< foldMap (fieldDefinition context rule) fields
    Full.InterfaceTypeDirectivesExtension _ directives' ->
        directives context rule interfaceLocation directives'
    Full.UnionTypeUnionMemberTypesExtension _ directives' _ ->
        directives context rule unionLocation directives'
    Full.UnionTypeDirectivesExtension _ directives' ->
        directives context rule unionLocation directives'
    Full.EnumTypeEnumValuesDefinitionExtension _ directives' values
        -> directives context rule enumLocation directives'
        >< foldMap (enumValueDefinition context rule) values
    Full.EnumTypeDirectivesExtension _ directives' ->
        directives context rule enumLocation directives'
    Full.InputObjectTypeInputFieldsDefinitionExtension _ directives' fields
        -> directives context rule inputObjectLocation directives'
        >< foldMap forEachInputFieldDefinition fields
    Full.InputObjectTypeDirectivesExtension _ directives' ->
        directives context rule inputObjectLocation directives'
  where
    forEachInputFieldDefinition =
        inputValueDefinition context rule inputFieldDefinitionLocation

schemaExtension :: forall m. Validation m -> ApplyRule m Full.SchemaExtension
schemaExtension context rule = \case
    Full.SchemaOperationExtension directives' _ ->
        directives context rule schemaLocation directives'
    Full.SchemaDirectivesExtension directives' ->
        directives context rule schemaLocation directives'

schemaLocation :: DirectiveLocation
schemaLocation = TypeSystemDirectiveLocation DirectiveLocation.Schema

interfaceLocation :: DirectiveLocation
interfaceLocation = TypeSystemDirectiveLocation DirectiveLocation.Interface

objectLocation :: DirectiveLocation
objectLocation = TypeSystemDirectiveLocation DirectiveLocation.Object

unionLocation :: DirectiveLocation
unionLocation = TypeSystemDirectiveLocation DirectiveLocation.Union

enumLocation :: DirectiveLocation
enumLocation = TypeSystemDirectiveLocation DirectiveLocation.Enum

inputObjectLocation :: DirectiveLocation
inputObjectLocation = TypeSystemDirectiveLocation DirectiveLocation.InputObject

scalarLocation :: DirectiveLocation
scalarLocation = TypeSystemDirectiveLocation DirectiveLocation.Scalar

enumValueLocation :: DirectiveLocation
enumValueLocation = TypeSystemDirectiveLocation DirectiveLocation.EnumValue

fieldDefinitionLocation :: DirectiveLocation
fieldDefinitionLocation =
    TypeSystemDirectiveLocation DirectiveLocation.FieldDefinition

inputFieldDefinitionLocation :: DirectiveLocation
inputFieldDefinitionLocation =
    TypeSystemDirectiveLocation DirectiveLocation.InputFieldDefinition

argumentDefinitionLocation :: DirectiveLocation
argumentDefinitionLocation =
    TypeSystemDirectiveLocation DirectiveLocation.ArgumentDefinition

queryLocation :: DirectiveLocation
queryLocation = ExecutableDirectiveLocation DirectiveLocation.Query

mutationLocation :: DirectiveLocation
mutationLocation = ExecutableDirectiveLocation DirectiveLocation.Mutation

subscriptionLocation :: DirectiveLocation
subscriptionLocation =
    ExecutableDirectiveLocation DirectiveLocation.Subscription

fieldLocation :: DirectiveLocation
fieldLocation = ExecutableDirectiveLocation DirectiveLocation.Field

fragmentDefinitionLocation :: DirectiveLocation
fragmentDefinitionLocation =
    ExecutableDirectiveLocation DirectiveLocation.FragmentDefinition

fragmentSpreadLocation :: DirectiveLocation
fragmentSpreadLocation =
    ExecutableDirectiveLocation DirectiveLocation.FragmentSpread

inlineFragmentLocation :: DirectiveLocation
inlineFragmentLocation =
    ExecutableDirectiveLocation DirectiveLocation.InlineFragment

executableDefinition :: forall m
    . Validation.Rule m
    -> Validation m
    -> Full.ExecutableDefinition
    -> Seq (Validation.RuleT m)
executableDefinition rule context (Full.DefinitionOperation operation) =
    operationDefinition rule context operation
executableDefinition rule context (Full.DefinitionFragment fragment) =
    fragmentDefinition rule context fragment

typeSystemDefinition :: forall m
    . Validation m
    -> ApplyRule m Full.TypeSystemDefinition
typeSystemDefinition context rule = \case
    Full.SchemaDefinition directives' _ ->
        directives context rule schemaLocation directives'
    Full.TypeDefinition typeDefinition' ->
        typeDefinition context rule typeDefinition'
    Full.DirectiveDefinition _ _ arguments' _ ->
        argumentsDefinition context rule arguments'

typeDefinition :: forall m. Validation m -> ApplyRule m Full.TypeDefinition
typeDefinition context rule = \case
    Full.ScalarTypeDefinition _ _ directives' ->
        directives context rule scalarLocation directives'
    Full.ObjectTypeDefinition _ _ _ directives' fields
        -> directives context rule objectLocation directives'
         >< foldMap (fieldDefinition context rule) fields
    Full.InterfaceTypeDefinition _ _ directives' fields
        -> directives context rule interfaceLocation directives'
        >< foldMap (fieldDefinition context rule) fields
    Full.UnionTypeDefinition _ _ directives' _ ->
        directives context rule unionLocation directives'
    Full.EnumTypeDefinition _ _ directives' values
        -> directives context rule enumLocation directives'
        >< foldMap (enumValueDefinition context rule) values
    Full.InputObjectTypeDefinition _ _ directives' fields
        -> directives context rule inputObjectLocation directives'
        <> foldMap forEachInputFieldDefinition fields
  where
    forEachInputFieldDefinition =
        inputValueDefinition context rule inputFieldDefinitionLocation

enumValueDefinition :: forall m
    . Validation m
    -> ApplyRule m Full.EnumValueDefinition
enumValueDefinition context rule (Full.EnumValueDefinition _ _ directives') =
    directives context rule enumValueLocation directives'

fieldDefinition :: forall m. Validation m -> ApplyRule m Full.FieldDefinition
fieldDefinition context rule (Full.FieldDefinition _ _ arguments' _ directives')
    = directives context rule fieldDefinitionLocation directives'
    >< argumentsDefinition context rule arguments'

argumentsDefinition :: forall m
    . Validation m
    -> ApplyRule m Full.ArgumentsDefinition
argumentsDefinition context rule (Full.ArgumentsDefinition definitions) =
    foldMap forEachArgument definitions
  where
    forEachArgument =
        inputValueDefinition context rule argumentDefinitionLocation

inputValueDefinition :: forall m
    . Validation m
    -> Validation.Rule m
    -> DirectiveLocation
    -> Full.InputValueDefinition
    -> Seq (Validation.RuleT m)
inputValueDefinition context rule directiveLocation definition' =
    let Full.InputValueDefinition _ _ _ _ directives' = definition'
     in directives context rule directiveLocation directives'

operationDefinition :: forall m
    . Validation.Rule m
    -> Validation m
    -> Full.OperationDefinition
    -> Seq (Validation.RuleT m)
operationDefinition rule context operation
    | Validation.OperationDefinitionRule operationRule <- rule =
        pure $ operationRule operation
    | Validation.VariablesRule variablesRule <- rule
    , Full.OperationDefinition _ _ variables _ _ _ <- operation =
        foldMap (variableDefinition context rule) variables |> variablesRule variables
    | Full.SelectionSet selections _ <- operation =
        selectionSet context types' rule queryRoot selections
    | Full.OperationDefinition Full.Query _ _ directives' selections _  <- operation
        = selectionSet context types' rule queryRoot selections
        >< directives context rule queryLocation directives'
    | Full.OperationDefinition Full.Mutation _ _ directives' selections _  <- operation =
        let root = Out.NamedObjectType <$> Schema.mutation schema'
         in selectionSet context types' rule root selections
        >< directives context rule mutationLocation directives'
    | Full.OperationDefinition Full.Subscription _ _ directives' selections _  <- operation =
        let root = Out.NamedObjectType <$> Schema.subscription schema'
         in selectionSet context types' rule root selections
        >< directives context rule subscriptionLocation directives'
  where
    schema' = Validation.schema context
    queryRoot = Just $ Out.NamedObjectType $ Schema.query schema'
    types' = Validation.types 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 :: forall m
    . Validation m
    -> ApplyRule m Full.VariableDefinition
variableDefinition context rule (Full.VariableDefinition _ typeName value' _)
    | Just defaultValue' <- value'
    , variableType <- lookupInputType typeName $ Validation.types context =
        constValue rule variableType defaultValue'
variableDefinition _ _ _ = mempty

constValue :: forall m
    . Validation.Rule m
    -> Maybe In.Type
    -> Full.Node Full.ConstValue
    -> Seq (Validation.RuleT m)
constValue (Validation.ValueRule _ rule) valueType = go valueType
  where
    go inputObjectType value'@(Full.Node (Full.ConstObject fields) _)
        = foldMap (forEach inputObjectType) (Seq.fromList fields)
        |> rule inputObjectType value'
    go listType value'@(Full.Node (Full.ConstList values) location')
        = embedListLocation go listType values location'
        |> rule listType value'
    go anotherValue value' = pure $ rule anotherValue value'
    forEach inputObjectType Full.ObjectField{value = value', ..} =
        go (valueTypeByName name inputObjectType) value'
constValue _ _ = const mempty

inputFieldType :: In.InputField -> In.Type
inputFieldType (In.InputField _ inputFieldType' _) = inputFieldType'

valueTypeByName :: Full.Name -> Maybe In.Type -> Maybe In.Type
valueTypeByName fieldName (Just( In.InputObjectBaseType inputObjectType)) =
    let In.InputObjectType _ _ fieldTypes = inputObjectType
     in inputFieldType <$> HashMap.lookup fieldName fieldTypes
valueTypeByName _ _ = Nothing

fragmentDefinition :: forall m
    . Validation.Rule m
    -> Validation m
    -> Full.FragmentDefinition
    -> Seq (Validation.RuleT m)
fragmentDefinition (Validation.FragmentDefinitionRule rule) _ definition' =
    pure $ rule definition'
fragmentDefinition rule context definition'
    | Full.FragmentDefinition _ typeCondition directives' selections _ <- definition'
    , Validation.FragmentRule definitionRule _ <- rule
        = applyToChildren typeCondition directives' selections
        |> definitionRule definition'
    | Full.FragmentDefinition _ typeCondition directives' selections _ <- definition'
        = applyToChildren typeCondition directives' selections
  where
    types' = Validation.types context
    applyToChildren typeCondition directives' selections
        = selectionSet context types' rule (lookupType' typeCondition) selections
        >< directives context rule fragmentDefinitionLocation directives'
    lookupType' = flip lookupType types'

lookupType :: forall m
    . Full.TypeCondition
    -> HashMap Full.Name (Schema.Type m)
    -> Maybe (Out.Type m)
lookupType typeCondition types' = HashMap.lookup typeCondition types'
    >>= typeToOut

selectionSet :: Traversable t
    => forall m
    . Validation m
    -> ApplySelectionRule m (t Full.Selection)
selectionSet context types' rule = foldMap . selection context types' rule

selection :: forall m. Validation m -> ApplySelectionRule m Full.Selection
selection context types' rule objectType selection'
    | Validation.SelectionRule selectionRule <- rule =
        applyToChildren |> selectionRule objectType selection'
    | otherwise = applyToChildren
  where
    applyToChildren =
        case selection' of
            Full.FieldSelection field' ->
                field context types' rule objectType field'
            Full.InlineFragmentSelection inlineFragment' ->
                inlineFragment context types' rule objectType inlineFragment'
            Full.FragmentSpreadSelection fragmentSpread' ->
                fragmentSpread context rule fragmentSpread'

field :: forall m. Validation m -> ApplySelectionRule m Full.Field
field context types' rule objectType field' = go field'
  where
    go (Full.Field _ fieldName _ _ _ _)
        | Validation.FieldRule fieldRule <- rule =
            applyToChildren fieldName |> fieldRule objectType field'
        | Validation.ArgumentsRule argumentsRule _  <- rule =
            applyToChildren fieldName |> argumentsRule objectType field'
        | otherwise = applyToChildren fieldName
    typeFieldType (Out.Field _ type' _) = type'
    typeFieldArguments (Out.Field _ _ argumentTypes) = argumentTypes
    applyToChildren fieldName =
        let Full.Field _ _ arguments' directives' selections _ = field'
            typeField = objectType >>= lookupTypeField fieldName
            argumentTypes = maybe mempty typeFieldArguments typeField
         in selectionSet context types' rule (typeFieldType <$> typeField) selections
            >< directives context rule fieldLocation directives'
            >< arguments rule argumentTypes arguments'

arguments :: forall m
    . Validation.Rule m
    -> In.Arguments
    -> [Full.Argument]
    -> Seq (Validation.RuleT m)
arguments rule argumentTypes = foldMap forEach . Seq.fromList
  where
    forEach argument'@(Full.Argument argumentName _ _) = 
       let argumentType = HashMap.lookup argumentName argumentTypes
        in argument rule argumentType argument'

argument :: forall m
    . Validation.Rule m
    -> Maybe In.Argument
    -> Full.Argument
    -> Seq (Validation.RuleT m)
argument rule argumentType (Full.Argument _ value' _) =
    value rule (valueType <$> argumentType) value'
  where
    valueType (In.Argument _ valueType' _) = valueType'

-- valueTypeFromList :: Maybe In.Type -> Maybe In.Type
embedListLocation :: forall a m
    . (Maybe In.Type -> Full.Node a -> Seq m)
    -> Maybe In.Type
    -> [a]
    -> Full.Location
    -> Seq m
embedListLocation go listType values location'
    = foldMap (go $ valueTypeFromList listType) 
    $ flip Full.Node location' <$> Seq.fromList values
  where
    valueTypeFromList (Just (In.ListBaseType baseType)) = Just baseType
    valueTypeFromList _ = Nothing

value :: forall m
    . Validation.Rule m
    -> Maybe In.Type
    -> Full.Node Full.Value
    -> Seq (Validation.RuleT m)
value (Validation.ValueRule rule _) valueType = go valueType
  where
    go inputObjectType value'@(Full.Node (Full.Object fields) _)
        = foldMap (forEach inputObjectType) (Seq.fromList fields)
        |> rule inputObjectType value'
    go listType value'@(Full.Node (Full.List values) location')
        = embedListLocation go listType values location'
        |> rule listType value'
    go anotherValue value' = pure $ rule anotherValue value'
    forEach inputObjectType Full.ObjectField{value = value', ..} =
        go (valueTypeByName name inputObjectType) value'
value _ _ = const mempty

inlineFragment :: forall m
    . Validation m
    -> ApplySelectionRule m Full.InlineFragment
inlineFragment context types' rule objectType inlineFragment' =
    go inlineFragment'
  where
    go (Full.InlineFragment optionalType directives' selections _)
        | Validation.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 context types' rule objectType' selections
        >< directives context rule inlineFragmentLocation directives'

fragmentSpread :: forall m. Validation m -> ApplyRule m Full.FragmentSpread
fragmentSpread context rule fragmentSpread'@(Full.FragmentSpread _ directives' _)
    | Validation.FragmentSpreadRule fragmentRule <- rule =
        applyToChildren |> fragmentRule fragmentSpread'
    | otherwise = applyToChildren
  where
    applyToChildren = directives context rule fragmentSpreadLocation directives'

directives :: Traversable t
    => forall m
    . Validation m
    -> Validation.Rule m
    -> DirectiveLocation
    -> t Full.Directive
    -> Seq (Validation.RuleT m)
directives context rule directiveLocation directives'
    | Validation.DirectivesRule directivesRule <- rule =
        applyToChildren |> directivesRule directiveLocation directiveList
    | otherwise = applyToChildren
  where
    directiveList = toList directives'
    applyToChildren = foldMap (directive context rule) directiveList

directive :: forall m. Validation m -> ApplyRule m Full.Directive
directive _ (Validation.ArgumentsRule _ argumentsRule) directive' =
    pure $ argumentsRule directive'
directive context rule (Full.Directive directiveName arguments' _) =
    let argumentTypes = maybe HashMap.empty directiveArguments
            $ HashMap.lookup directiveName (Validation.directives context)
     in arguments rule argumentTypes arguments'
  where
    directiveArguments (Schema.Directive _ _ argumentTypes) = argumentTypes