{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Validation.Query.Variable
  ( resolveOperationVariables,
  )
where

import Control.Monad.Except (throwError)
import Data.Mergeable
import Data.Morpheus.Error.Variable (uninitializedVariable)
import Data.Morpheus.Internal.Utils
  ( selectOr,
  )
import Data.Morpheus.Types.Internal.AST
  ( Argument (..),
    DefaultValue,
    Directive (..),
    FieldName,
    Fragment (..),
    IN,
    ObjectEntry (..),
    Operation (..),
    Position,
    RAW,
    RawValue,
    Ref (..),
    ResolvedValue,
    Selection (..),
    SelectionContent (..),
    SelectionSet,
    TypeDefinition,
    TypeRef (..),
    VALID,
    ValidValue,
    Value (..),
    Variable (..),
    VariableContent (..),
    VariableDefinitions,
    Variables,
    isNullable,
  )
import Data.Morpheus.Types.Internal.Config
  ( Config (..),
    VALIDATION_MODE (..),
  )
import Data.Morpheus.Types.Internal.Validation
  ( BaseValidator,
    Constraint (..),
    InputSource (..),
    askFragments,
    askTypeDefinitions,
    checkUnused,
    constraint,
    selectKnown,
    setPosition,
    startInput,
    withScope,
  )
import Data.Morpheus.Validation.Internal.Value
  ( validateInputByType,
  )
import Relude

class ExploreRefs a where
  exploreRefs :: a -> [Ref FieldName]

instance ExploreRefs RawValue where
  exploreRefs :: RawValue -> [Ref FieldName]
exploreRefs (VariableValue Ref FieldName
ref) = [Ref FieldName
ref]
  exploreRefs (Object Object RAW
fields) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. ExploreRefs a => a -> [Ref FieldName]
exploreRefs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Stage). ObjectEntry s -> Value s
entryValue) Object RAW
fields
  exploreRefs (List [RawValue]
ls) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. ExploreRefs a => a -> [Ref FieldName]
exploreRefs [RawValue]
ls
  exploreRefs RawValue
_ = []

instance ExploreRefs (Directive RAW) where
  exploreRefs :: Directive RAW -> [Ref FieldName]
exploreRefs Directive {Arguments RAW
directiveArgs :: forall (s :: Stage). Directive s -> Arguments s
directiveArgs :: Arguments RAW
directiveArgs} = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. ExploreRefs a => a -> [Ref FieldName]
exploreRefs Arguments RAW
directiveArgs

instance ExploreRefs (Argument RAW) where
  exploreRefs :: Argument RAW -> [Ref FieldName]
exploreRefs = forall a. ExploreRefs a => a -> [Ref FieldName]
exploreRefs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (valid :: Stage). Argument valid -> Value valid
argumentValue

mapSelection :: (Selection RAW -> BaseValidator [b]) -> SelectionSet RAW -> BaseValidator [b]
mapSelection :: forall b.
(Selection RAW -> BaseValidator [b])
-> SelectionSet RAW -> BaseValidator [b]
mapSelection Selection RAW -> BaseValidator [b]
f = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Selection RAW -> BaseValidator [b]
f

allVariableRefs :: [SelectionSet RAW] -> BaseValidator (HashMap FieldName [Position])
allVariableRefs :: [SelectionSet RAW] -> BaseValidator (HashMap FieldName [Position])
allVariableRefs = forall k (m :: * -> *) v.
(Eq k, Hashable k, Monad m, Semigroup v) =>
[(k, v)] -> m (HashMap k v)
collect forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Ref a -> (a, [Position])
toEntry forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall b.
(Selection RAW -> BaseValidator [b])
-> SelectionSet RAW -> BaseValidator [b]
mapSelection Selection RAW -> BaseValidator [Ref FieldName]
searchRefs)
  where
    toEntry :: Ref a -> (a, [Position])
toEntry (Ref a
x Position
y) = (a
x, [Position
y])
    exploreSelectionContent :: SelectionContent RAW -> BaseValidator [Ref FieldName]
    exploreSelectionContent :: SelectionContent RAW -> BaseValidator [Ref FieldName]
exploreSelectionContent SelectionContent RAW
SelectionField = forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    exploreSelectionContent (SelectionSet SelectionSet RAW
selSet) = forall b.
(Selection RAW -> BaseValidator [b])
-> SelectionSet RAW -> BaseValidator [b]
mapSelection Selection RAW -> BaseValidator [Ref FieldName]
searchRefs SelectionSet RAW
selSet
    ---------------------------------------
    searchRefs :: Selection RAW -> BaseValidator [Ref FieldName]
    searchRefs :: Selection RAW -> BaseValidator [Ref FieldName]
searchRefs Selection {Arguments RAW
selectionArguments :: forall (s :: Stage). Selection s -> Arguments s
selectionArguments :: Arguments RAW
selectionArguments, Directives RAW
selectionDirectives :: forall (s :: Stage). Selection s -> Directives s
selectionDirectives :: Directives RAW
selectionDirectives, SelectionContent RAW
selectionContent :: forall (s :: Stage). Selection s -> SelectionContent s
selectionContent :: SelectionContent RAW
selectionContent} =
      (([Ref FieldName]
directiveRefs forall a. Semigroup a => a -> a -> a
<> [Ref FieldName]
argumentRefs) forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SelectionContent RAW -> BaseValidator [Ref FieldName]
exploreSelectionContent SelectionContent RAW
selectionContent
      where
        directiveRefs :: [Ref FieldName]
directiveRefs = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. ExploreRefs a => a -> [Ref FieldName]
exploreRefs Directives RAW
selectionDirectives
        argumentRefs :: [Ref FieldName]
argumentRefs = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. ExploreRefs a => a -> [Ref FieldName]
exploreRefs Arguments RAW
selectionArguments
    searchRefs (InlineFragment Fragment {SelectionSet RAW
fragmentSelection :: forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentSelection :: SelectionSet RAW
fragmentSelection, Directives RAW
fragmentDirectives :: forall (stage :: Stage). Fragment stage -> Directives stage
fragmentDirectives :: Directives RAW
fragmentDirectives}) =
      (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. ExploreRefs a => a -> [Ref FieldName]
exploreRefs Directives RAW
fragmentDirectives forall a. Semigroup a => a -> a -> a
<>)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall b.
(Selection RAW -> BaseValidator [b])
-> SelectionSet RAW -> BaseValidator [b]
mapSelection Selection RAW -> BaseValidator [Ref FieldName]
searchRefs SelectionSet RAW
fragmentSelection
    searchRefs (Spread Directives RAW
directives Ref (Name 'FRAGMENT)
reference) =
      (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. ExploreRefs a => a -> [Ref FieldName]
exploreRefs Directives RAW
directives forall a. Semigroup a => a -> a -> a
<>)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( forall (s1 :: Stage) (s2 :: Stage) (s3 :: Stage) (m :: * -> *).
MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m =>
m (Fragments s3)
askFragments
                forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall k (c :: * -> *) sel ctx a (s :: Stage).
(IsMap k c, Unknown sel ctx, KeyOf k sel) =>
sel -> c a -> Validator s ctx a
selectKnown Ref (Name 'FRAGMENT)
reference
                forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b.
(Selection RAW -> BaseValidator [b])
-> SelectionSet RAW -> BaseValidator [b]
mapSelection Selection RAW -> BaseValidator [Ref FieldName]
searchRefs
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentSelection
            )

resolveOperationVariables ::
  Config ->
  Variables ->
  Operation RAW ->
  BaseValidator (VariableDefinitions VALID)
resolveOperationVariables :: Config
-> Variables
-> Operation RAW
-> BaseValidator (VariableDefinitions VALID)
resolveOperationVariables
  Config {VALIDATION_MODE
validationMode :: Config -> VALIDATION_MODE
validationMode :: VALIDATION_MODE
validationMode}
  Variables
root
  Operation
    { SelectionSet RAW
operationSelection :: forall (s :: Stage). Operation s -> SelectionSet s
operationSelection :: SelectionSet RAW
operationSelection,
      VariableDefinitions RAW
operationArguments :: forall (s :: Stage). Operation s -> VariableDefinitions s
operationArguments :: VariableDefinitions RAW
operationArguments
    } =
    BaseValidator ()
checkUnusedVariables
      forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Variables
-> VALIDATION_MODE
-> Variable RAW
-> BaseValidator (Variable VALID)
lookupAndValidateValueOnBody Variables
root VALIDATION_MODE
validationMode) VariableDefinitions RAW
operationArguments
    where
      checkUnusedVariables :: BaseValidator ()
      checkUnusedVariables :: BaseValidator ()
checkUnusedVariables = do
        HashMap FieldName [Position]
uses <- [SelectionSet RAW] -> BaseValidator (HashMap FieldName [Position])
allVariableRefs [SelectionSet RAW
operationSelection]
        forall k b (c :: * -> *) (t :: * -> *) a (s :: Stage) (s1 :: Stage)
       (s2 :: Stage).
(KeyOf k b, IsMap k c, Unused b, Foldable t) =>
c a -> t b -> Validator s (OperationContext s1 s2) ()
checkUnused HashMap FieldName [Position]
uses (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList VariableDefinitions RAW
operationArguments)

lookupAndValidateValueOnBody ::
  Variables ->
  VALIDATION_MODE ->
  Variable RAW ->
  BaseValidator (Variable VALID)
lookupAndValidateValueOnBody :: Variables
-> VALIDATION_MODE
-> Variable RAW
-> BaseValidator (Variable VALID)
lookupAndValidateValueOnBody
  Variables
bodyVariables
  VALIDATION_MODE
validationMode
  var :: Variable RAW
var@Variable
    { FieldName
variableName :: forall (stage :: Stage). Variable stage -> FieldName
variableName :: FieldName
variableName,
      variableType :: forall (stage :: Stage). Variable stage -> TypeRef
variableType = variableType :: TypeRef
variableType@TypeRef {TypeWrapper
typeWrappers :: TypeRef -> TypeWrapper
typeWrappers :: TypeWrapper
typeWrappers, TypeName
typeConName :: TypeRef -> TypeName
typeConName :: TypeName
typeConName},
      Position
variablePosition :: forall (stage :: Stage). Variable stage -> Position
variablePosition :: Position
variablePosition,
      variableValue :: forall (stage :: Stage).
Variable stage -> VariableContent (CONST_OR_VALID stage)
variableValue = DefaultValue Maybe ResolvedValue
defaultValue
    } =
    forall (s :: Stage) c (m :: * -> *) b.
MonadReader (ValidatorContext s c) m =>
(Scope -> Scope) -> m b -> m b
withScope (Position -> Scope -> Scope
setPosition Position
variablePosition) forall a b. (a -> b) -> a -> b
$
      ValidValue -> Variable VALID
toVariable
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( forall (s :: Stage) ctx (m :: * -> *).
MonadReader (ValidatorContext s ctx) m =>
m (HashMap TypeName (TypeDefinition ANY s))
askTypeDefinitions
                forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall k (c :: * -> *) sel ctx a (s :: Stage).
(IsMap k c, Unknown sel ctx, KeyOf k sel) =>
sel -> c a -> Validator s ctx a
selectKnown (forall name. name -> Position -> Ref name
Ref TypeName
typeConName Position
variablePosition)
                forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (k :: TypeCategory) inp (s :: Stage) ctx.
KindViolation k inp =>
Constraint k
-> inp
-> TypeDefinition ANY s
-> Validator s ctx (TypeDefinition k s)
constraint Constraint 'IN
INPUT Variable RAW
var
                forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe ResolvedValue
-> Maybe ResolvedValue
-> TypeDefinition 'IN VALID
-> BaseValidator ValidValue
checkType Maybe ResolvedValue
getVariable Maybe ResolvedValue
defaultValue
            )
    where
      toVariable :: ValidValue -> Variable VALID
toVariable ValidValue
x = Variable RAW
var {variableValue :: VariableContent (CONST_OR_VALID VALID)
variableValue = ValidValue -> VariableContent VALID
ValidVariableValue ValidValue
x}
      getVariable :: Maybe ResolvedValue
      getVariable :: Maybe ResolvedValue
getVariable = forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr forall a. Maybe a
Nothing forall a. a -> Maybe a
Just FieldName
variableName Variables
bodyVariables
      ------------------------------------------------------------------
      -- checkType ::
      checkType ::
        Maybe ResolvedValue ->
        DefaultValue ->
        TypeDefinition IN VALID ->
        BaseValidator ValidValue
      checkType :: Maybe ResolvedValue
-> Maybe ResolvedValue
-> TypeDefinition 'IN VALID
-> BaseValidator ValidValue
checkType (Just ResolvedValue
variable) Maybe ResolvedValue
Nothing TypeDefinition 'IN VALID
varType = TypeDefinition 'IN VALID
-> Bool -> ResolvedValue -> BaseValidator ValidValue
validator TypeDefinition 'IN VALID
varType Bool
False ResolvedValue
variable
      checkType (Just ResolvedValue
variable) (Just ResolvedValue
defValue) TypeDefinition 'IN VALID
varType =
        TypeDefinition 'IN VALID
-> Bool -> ResolvedValue -> BaseValidator ValidValue
validator TypeDefinition 'IN VALID
varType Bool
True ResolvedValue
defValue forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> TypeDefinition 'IN VALID
-> Bool -> ResolvedValue -> BaseValidator ValidValue
validator TypeDefinition 'IN VALID
varType Bool
False ResolvedValue
variable
      checkType Maybe ResolvedValue
Nothing (Just ResolvedValue
defValue) TypeDefinition 'IN VALID
varType = TypeDefinition 'IN VALID
-> Bool -> ResolvedValue -> BaseValidator ValidValue
validator TypeDefinition 'IN VALID
varType Bool
True ResolvedValue
defValue
      checkType Maybe ResolvedValue
Nothing Maybe ResolvedValue
Nothing TypeDefinition 'IN VALID
varType
        | VALIDATION_MODE
validationMode forall a. Eq a => a -> a -> Bool
/= VALIDATION_MODE
WITHOUT_VARIABLES Bool -> Bool -> Bool
&& Bool -> Bool
not (forall a. Nullable a => a -> Bool
isNullable TypeRef
variableType) =
            forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ forall (s :: Stage). Variable s -> GQLError
uninitializedVariable Variable RAW
var
        | Bool
otherwise =
            BaseValidator ValidValue
returnNull
        where
          returnNull :: BaseValidator ValidValue
          returnNull :: BaseValidator ValidValue
returnNull = forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (stage :: Stage). Value stage
Null) (TypeDefinition 'IN VALID
-> Bool -> ResolvedValue -> BaseValidator ValidValue
validator TypeDefinition 'IN VALID
varType Bool
False) FieldName
variableName Variables
bodyVariables
      -----------------------------------------------------------------------------------------------
      validator :: TypeDefinition IN VALID -> Bool -> ResolvedValue -> BaseValidator ValidValue
      validator :: TypeDefinition 'IN VALID
-> Bool -> ResolvedValue -> BaseValidator ValidValue
validator TypeDefinition 'IN VALID
varTypeDef Bool
isDefaultValue ResolvedValue
varValue =
        forall (s :: Stage) ctx a.
InputSource -> InputValidator s ctx a -> Validator s ctx a
startInput
          (Variable RAW -> Bool -> InputSource
SourceVariable Variable RAW
var Bool
isDefaultValue)
          ( forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
TypeWrapper
-> TypeDefinition 'IN schemaS
-> Value valueS
-> InputValidator schemaS ctx ValidValue
validateInputByType
              TypeWrapper
typeWrappers
              TypeDefinition 'IN VALID
varTypeDef
              ResolvedValue
varValue
          )