<commit_before>{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE KindSignatures #-}
{-# OPTIONS_HADDOCK not-home #-}

-- | Description: Transform GraphQL query documents from AST into valid structures
--
-- This corresponds roughly to the
-- [Validation](https://facebook.github.io/graphql/#sec-Validation) section of
-- the specification, except where noted.
--
-- One core difference is that this module doesn't attempt to do any
-- type-level validation, as we attempt to defer all of that to the Haskell
-- type checker.
--
-- Deliberately not going to do:
--
--   * field selections on compound types <https://facebook.github.io/graphql/#sec-Field-Selections-on-Objects-Interfaces-and-Unions-Types>
--   * leaf field selections <https://facebook.github.io/graphql/#sec-Leaf-Field-Selections>
--   * argument names <https://facebook.github.io/graphql/#sec-Argument-Names>
--   * argument value type correctness <https://facebook.github.io/graphql/#sec-Argument-Values-Type-Correctness>
--   * fragment spread type existence <https://facebook.github.io/graphql/#sec-Fragment-Spread-Type-Existence>
--   * fragments on compound types <https://facebook.github.io/graphql/#sec-Fragments-On-Composite-Types>
--   * fragment spread is possible <https://facebook.github.io/graphql/#sec-Fragment-spread-is-possible>
--   * directives are defined <https://facebook.github.io/graphql/#sec-Directives-Are-Defined>
--   * directives are in valid locations <https://facebook.github.io/graphql/#sec-Directives-Are-In-Valid-Locations>
--   * variable default values are correctly typed <https://facebook.github.io/graphql/#sec-Variable-Default-Values-Are-Correctly-Typed>
--   * variables are input types <https://facebook.github.io/graphql/#sec-Variables-Are-Input-Types>
--   * all variable usages are allowed <https://facebook.github.io/graphql/#sec-All-Variable-Usages-are-Allowed>
--
-- Because all of the above rely on type checking.
module GraphQL.Internal.Validation
  ( ValidationError(..)
  , ValidationErrors
  , QueryDocument(..)
  , validate
  , getErrors
  -- * Operating on validated documents
  , Operation
  , getSelectionSet
  -- * Executing validated documents
  , VariableDefinition(..)
  , VariableValue
  , Variable
  , AST.GType(..)
  -- * Resolving queries
  , SelectionSetByType
  , SelectionSet(..)
  , getSelectionSetForType
  , Field
  , lookupArgument
  , getSubSelectionSet
  , ResponseKey
  , getResponseKey
  -- * Exported for testing
  , findDuplicates
  ) where

import Protolude hiding ((<>), throwE)

import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
import Data.Semigroup ((<>))
import qualified Data.Set as Set
import GraphQL.Internal.Name (HasName(..), Name)
import qualified GraphQL.Internal.Syntax.AST as AST
-- Directly import things from the AST that do not need validation, so that
-- @AST.Foo@ in a type signature implies that something hasn't been validated.
import GraphQL.Internal.Syntax.AST (Alias, Variable, NamedType(..))
import GraphQL.Internal.OrderedMap (OrderedMap)
import qualified GraphQL.Internal.OrderedMap as OrderedMap
import GraphQL.Internal.Output (GraphQLError(..))
import GraphQL.Internal.Schema
  ( TypeDefinition
  , ObjectTypeDefinition
  , Schema
  , doesFragmentTypeApply
  , lookupType
  , AnnotatedType(..)
  , InputType
  , InputType (BuiltinInputType, DefinedInputType) 
  , Builtin (..)
  , AnnotatedType (TypeNamed, TypeNonNull)
  , NonNullType(NonNullTypeNamed)
  , getInputTypeDefinition
  )
import GraphQL.Value
  ( Value
  , Value'
  , ConstScalar
  , UnresolvedVariableValue
  , astToVariableValue
  )

-- | A valid query document.
--
-- Construct this using 'validate' on an 'AST.QueryDocument'.
data QueryDocument value
  -- | The query document contains a single anonymous operation.
  = LoneAnonymousOperation (Operation value)
  -- | The query document contains multiple uniquely-named operations.
  | MultipleOperations (Operations value)
  deriving (Eq, Show)

data Operation value
  = Query VariableDefinitions (Directives value) (SelectionSetByType value)
  | Mutation VariableDefinitions (Directives value) (SelectionSetByType value)
  deriving (Eq, Show)

instance Functor Operation where
  fmap f (Query vars directives selectionSet) = Query vars (fmap f directives) (fmap f selectionSet)
  fmap f (Mutation vars directives selectionSet) = Mutation vars (fmap f directives) (fmap f selectionSet)

instance Foldable Operation where
  foldMap f (Query _ directives selectionSet) = foldMap f directives `mappend` foldMap f selectionSet
  foldMap f (Mutation _ directives selectionSet) = foldMap f directives `mappend` foldMap f selectionSet

instance Traversable Operation where
  traverse f (Query vars directives selectionSet) = Query vars <$> traverse f directives <*> traverse f selectionSet
  traverse f (Mutation vars directives selectionSet) = Mutation vars <$> traverse f directives <*> traverse f selectionSet

-- | Get the selection set for an operation.
getSelectionSet :: Operation value -> SelectionSetByType value
getSelectionSet (Query _ _ ss) = ss
getSelectionSet (Mutation _ _ ss) = ss

-- | Type alias for 'Query' and 'Mutation' constructors of 'Operation'.
type OperationType value = VariableDefinitions -> Directives value -> SelectionSetByType value -> Operation value

type Operations value = Map (Maybe Name) (Operation value)

-- | Turn a parsed document into a known valid one.
--
-- The document is known to be syntactically valid, as we've got its AST.
-- Here, we confirm that it's semantically valid (modulo types).
validate :: Schema -> AST.QueryDocument -> Either (NonEmpty ValidationError) (QueryDocument VariableValue)
validate schema (AST.QueryDocument defns) = runValidator $ do
  let (operations, fragments) = splitBy splitDefns defns
  let (anonymous, maybeNamed) = splitBy splitOps operations
  (frags, visitedFrags) <- resolveFragmentDefinitions =<< validateFragmentDefinitions schema fragments
  case (anonymous, maybeNamed) of
    ([], ops) -> do
      (validOps, usedFrags) <- runStateT (validateOperations schema frags ops) mempty
      assertAllFragmentsUsed frags (visitedFrags <> usedFrags)
      resolvedOps <- traverse validateOperation validOps
      pure (MultipleOperations resolvedOps)
    ([x], []) -> do
      (ss, usedFrags) <- runStateT (validateSelectionSet schema frags x) mempty
      assertAllFragmentsUsed frags (visitedFrags <> usedFrags)
      validValuesSS <- validateValues ss
      resolvedValuesSS <- resolveVariables emptyVariableDefinitions validValuesSS
      pure (LoneAnonymousOperation (Query emptyVariableDefinitions emptyDirectives resolvedValuesSS))
    _ -> throwE (MixedAnonymousOperations (length anonymous) (map fst maybeNamed))

  where
    splitBy :: (a -> Either b c) -> [a] -> ([b], [c])
    splitBy f xs = partitionEithers (map f xs)

    splitDefns (AST.DefinitionOperation op) = Left op
    splitDefns (AST.DefinitionFragment frag) = Right frag

    splitOps (AST.AnonymousQuery ss) = Left ss
    splitOps (AST.Query node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Query, node))
    splitOps (AST.Mutation node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Mutation, node))

    assertAllFragmentsUsed :: Fragments value -> Set (Maybe Name) -> Validation ()
    assertAllFragmentsUsed fragments used =
      let unused = ( Set.map pure (Map.keysSet fragments)) `Set.difference` used
      in unless (Set.null unused) (throwE (UnusedFragments unused))

-- * Operations

validateOperations :: Schema -> Fragments AST.Value -> [(Maybe Name, (OperationType AST.Value, AST.Node))] -> StateT (Set (Maybe Name)) Validation (Operations AST.Value)
validateOperations schema fragments ops = do
  deduped <- lift (mapErrors DuplicateOperation (makeMap ops))
  traverse validateNode deduped
  where
    validateNode (operationType, AST.Node _ vars directives ss) =
      operationType <$> lift ((validateVariableDefinitions schema) vars)
                    <*> lift (validateDirectives directives)
                    <*> validateSelectionSet schema fragments ss

-- TODO: Either make operation type (Query, Mutation) a parameter of an
-- Operation constructor or give all the fields accessors. This duplication is
-- driving me batty.
validateOperation :: Operation AST.Value -> Validation (Operation VariableValue)
validateOperation (Query vars directives selectionSet) = do
  validValues <- Query vars <$> validateValues directives <*> validateValues selectionSet
  -- Instead of doing this, we could build up a list of used variables as we
  -- resolve them.
  let usedVariables = getVariables validValues
  let definedVariables = getDefinedVariables vars
  let unusedVariables = definedVariables `Set.difference` usedVariables
  unless (Set.null unusedVariables) $ throwE (UnusedVariables unusedVariables)
  resolveVariables vars validValues
validateOperation (Mutation vars directives selectionSet) = do<commit_msg>fix: pointless parentheses<commit_after>{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE KindSignatures #-}
{-# OPTIONS_HADDOCK not-home #-}

-- | Description: Transform GraphQL query documents from AST into valid structures
--
-- This corresponds roughly to the
-- [Validation](https://facebook.github.io/graphql/#sec-Validation) section of
-- the specification, except where noted.
--
-- One core difference is that this module doesn't attempt to do any
-- type-level validation, as we attempt to defer all of that to the Haskell
-- type checker.
--
-- Deliberately not going to do:
--
--   * field selections on compound types <https://facebook.github.io/graphql/#sec-Field-Selections-on-Objects-Interfaces-and-Unions-Types>
--   * leaf field selections <https://facebook.github.io/graphql/#sec-Leaf-Field-Selections>
--   * argument names <https://facebook.github.io/graphql/#sec-Argument-Names>
--   * argument value type correctness <https://facebook.github.io/graphql/#sec-Argument-Values-Type-Correctness>
--   * fragment spread type existence <https://facebook.github.io/graphql/#sec-Fragment-Spread-Type-Existence>
--   * fragments on compound types <https://facebook.github.io/graphql/#sec-Fragments-On-Composite-Types>
--   * fragment spread is possible <https://facebook.github.io/graphql/#sec-Fragment-spread-is-possible>
--   * directives are defined <https://facebook.github.io/graphql/#sec-Directives-Are-Defined>
--   * directives are in valid locations <https://facebook.github.io/graphql/#sec-Directives-Are-In-Valid-Locations>
--   * variable default values are correctly typed <https://facebook.github.io/graphql/#sec-Variable-Default-Values-Are-Correctly-Typed>
--   * variables are input types <https://facebook.github.io/graphql/#sec-Variables-Are-Input-Types>
--   * all variable usages are allowed <https://facebook.github.io/graphql/#sec-All-Variable-Usages-are-Allowed>
--
-- Because all of the above rely on type checking.
module GraphQL.Internal.Validation
  ( ValidationError(..)
  , ValidationErrors
  , QueryDocument(..)
  , validate
  , getErrors
  -- * Operating on validated documents
  , Operation
  , getSelectionSet
  -- * Executing validated documents
  , VariableDefinition(..)
  , VariableValue
  , Variable
  , AST.GType(..)
  -- * Resolving queries
  , SelectionSetByType
  , SelectionSet(..)
  , getSelectionSetForType
  , Field
  , lookupArgument
  , getSubSelectionSet
  , ResponseKey
  , getResponseKey
  -- * Exported for testing
  , findDuplicates
  ) where

import Protolude hiding ((<>), throwE)

import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map as Map
import Data.Semigroup ((<>))
import qualified Data.Set as Set
import GraphQL.Internal.Name (HasName(..), Name)
import qualified GraphQL.Internal.Syntax.AST as AST
-- Directly import things from the AST that do not need validation, so that
-- @AST.Foo@ in a type signature implies that something hasn't been validated.
import GraphQL.Internal.Syntax.AST (Alias, Variable, NamedType(..))
import GraphQL.Internal.OrderedMap (OrderedMap)
import qualified GraphQL.Internal.OrderedMap as OrderedMap
import GraphQL.Internal.Output (GraphQLError(..))
import GraphQL.Internal.Schema
  ( TypeDefinition
  , ObjectTypeDefinition
  , Schema
  , doesFragmentTypeApply
  , lookupType
  , AnnotatedType(..)
  , InputType
  , InputType (BuiltinInputType, DefinedInputType) 
  , Builtin (..)
  , AnnotatedType (TypeNamed, TypeNonNull)
  , NonNullType(NonNullTypeNamed)
  , getInputTypeDefinition
  )
import GraphQL.Value
  ( Value
  , Value'
  , ConstScalar
  , UnresolvedVariableValue
  , astToVariableValue
  )

-- | A valid query document.
--
-- Construct this using 'validate' on an 'AST.QueryDocument'.
data QueryDocument value
  -- | The query document contains a single anonymous operation.
  = LoneAnonymousOperation (Operation value)
  -- | The query document contains multiple uniquely-named operations.
  | MultipleOperations (Operations value)
  deriving (Eq, Show)

data Operation value
  = Query VariableDefinitions (Directives value) (SelectionSetByType value)
  | Mutation VariableDefinitions (Directives value) (SelectionSetByType value)
  deriving (Eq, Show)

instance Functor Operation where
  fmap f (Query vars directives selectionSet) = Query vars (fmap f directives) (fmap f selectionSet)
  fmap f (Mutation vars directives selectionSet) = Mutation vars (fmap f directives) (fmap f selectionSet)

instance Foldable Operation where
  foldMap f (Query _ directives selectionSet) = foldMap f directives `mappend` foldMap f selectionSet
  foldMap f (Mutation _ directives selectionSet) = foldMap f directives `mappend` foldMap f selectionSet

instance Traversable Operation where
  traverse f (Query vars directives selectionSet) = Query vars <$> traverse f directives <*> traverse f selectionSet
  traverse f (Mutation vars directives selectionSet) = Mutation vars <$> traverse f directives <*> traverse f selectionSet

-- | Get the selection set for an operation.
getSelectionSet :: Operation value -> SelectionSetByType value
getSelectionSet (Query _ _ ss) = ss
getSelectionSet (Mutation _ _ ss) = ss

-- | Type alias for 'Query' and 'Mutation' constructors of 'Operation'.
type OperationType value = VariableDefinitions -> Directives value -> SelectionSetByType value -> Operation value

type Operations value = Map (Maybe Name) (Operation value)

-- | Turn a parsed document into a known valid one.
--
-- The document is known to be syntactically valid, as we've got its AST.
-- Here, we confirm that it's semantically valid (modulo types).
validate :: Schema -> AST.QueryDocument -> Either (NonEmpty ValidationError) (QueryDocument VariableValue)
validate schema (AST.QueryDocument defns) = runValidator $ do
  let (operations, fragments) = splitBy splitDefns defns
  let (anonymous, maybeNamed) = splitBy splitOps operations
  (frags, visitedFrags) <- resolveFragmentDefinitions =<< validateFragmentDefinitions schema fragments
  case (anonymous, maybeNamed) of
    ([], ops) -> do
      (validOps, usedFrags) <- runStateT (validateOperations schema frags ops) mempty
      assertAllFragmentsUsed frags (visitedFrags <> usedFrags)
      resolvedOps <- traverse validateOperation validOps
      pure (MultipleOperations resolvedOps)
    ([x], []) -> do
      (ss, usedFrags) <- runStateT (validateSelectionSet schema frags x) mempty
      assertAllFragmentsUsed frags (visitedFrags <> usedFrags)
      validValuesSS <- validateValues ss
      resolvedValuesSS <- resolveVariables emptyVariableDefinitions validValuesSS
      pure (LoneAnonymousOperation (Query emptyVariableDefinitions emptyDirectives resolvedValuesSS))
    _ -> throwE (MixedAnonymousOperations (length anonymous) (map fst maybeNamed))

  where
    splitBy :: (a -> Either b c) -> [a] -> ([b], [c])
    splitBy f xs = partitionEithers (map f xs)

    splitDefns (AST.DefinitionOperation op) = Left op
    splitDefns (AST.DefinitionFragment frag) = Right frag

    splitOps (AST.AnonymousQuery ss) = Left ss
    splitOps (AST.Query node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Query, node))
    splitOps (AST.Mutation node@(AST.Node maybeName _ _ _)) = Right (maybeName, (Mutation, node))

    assertAllFragmentsUsed :: Fragments value -> Set (Maybe Name) -> Validation ()
    assertAllFragmentsUsed fragments used =
      let unused = ( Set.map pure (Map.keysSet fragments)) `Set.difference` used
      in unless (Set.null unused) (throwE (UnusedFragments unused))

-- * Operations

validateOperations :: Schema -> Fragments AST.Value -> [(Maybe Name, (OperationType AST.Value, AST.Node))] -> StateT (Set (Maybe Name)) Validation (Operations AST.Value)
validateOperations schema fragments ops = do
  deduped <- lift (mapErrors DuplicateOperation (makeMap ops))
  traverse validateNode deduped
  where
    validateNode (operationType, AST.Node _ vars directives ss) =
      operationType <$> lift (validateVariableDefinitions schema vars)
                    <*> lift (validateDirectives directives)
                    <*> validateSelectionSet schema fragments ss

-- TODO: Either make operation type (Query, Mutation) a parameter of an
-- Operation constructor or give all the fields accessors. This duplication is
-- driving me batty.
validateOperation :: Operation AST.Value -> Validation (Operation VariableValue)
validateOperation (Query vars directives selectionSet) = do
  validValues <- Query vars <$> validateValues directives <*> validateValues selectionSet
  -- Instead of doing this, we could build up a list of used variables as we
  -- resolve them.
  let usedVariables = getVariables validValues
  let definedVariables = getDefinedVariables vars
  let unusedVariables = definedVariables `Set.difference` usedVariables
  unless (Set.null unusedVariables) $ throwE (UnusedVariables unusedVariables)
  resolveVariables vars validValues
validateOperation (Mutation vars directives selectionSet) = do
{'fraction_non_alphanumeric': 0.09957847484534954, 'fraction_numerical': 0.0, 'mean_word_length': 4.223906205318845, 'pattern_counts': {'":': 0, '<': 73, '<?xml version=': 0, '>': 89, 'https://': 26, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2957721', 'n_tokens_mistral': 5212, 'n_tokens_neox': 4996, 'n_words': 1607}