{-# 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 ::
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
)