{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
module Data.Morpheus.Validation.Query.Variable
( resolveOperationVariables,
)
where
import qualified Data.HashMap.Lazy as M
( lookup,
)
import Data.Maybe (maybe)
import Data.Morpheus.Error.Variable (uninitializedVariable)
import Data.Morpheus.Internal.Utils
( Failure (..),
elems,
)
import Data.Morpheus.Types.Internal.AST
( Argument (..),
DefaultValue,
Directive (..),
Fragment (..),
IN,
ObjectEntry (..),
Operation (..),
RAW,
RawValue,
Ref (..),
ResolvedValue,
Selection (..),
SelectionContent (..),
SelectionSet,
TypeDefinition,
TypeNameRef (..),
TypeRef (..),
VALID,
VALIDATION_MODE (..),
ValidValue,
Value (..),
Variable (..),
VariableContent (..),
VariableDefinitions,
Variables,
isNullable,
)
import Data.Morpheus.Types.Internal.Validation
( BaseValidator,
Constraint (..),
InputSource (..),
askFragments,
askSchema,
checkUnused,
constraint,
selectKnown,
startInput,
withPosition,
)
import Data.Morpheus.Validation.Internal.Value
( validateInput,
)
import Data.Semigroup ((<>))
class ExploreRefs a where
exploreRefs :: a -> [Ref]
instance ExploreRefs RawValue where
exploreRefs (VariableValue ref) = [ref]
exploreRefs (Object fields) = concatMap (exploreRefs . entryValue) fields
exploreRefs (List ls) = concatMap exploreRefs ls
exploreRefs _ = []
instance ExploreRefs (Directive RAW) where
exploreRefs Directive {directiveArgs} = concatMap exploreRefs directiveArgs
instance ExploreRefs (Argument RAW) where
exploreRefs = exploreRefs . argumentValue
mapSelection :: (Selection RAW -> BaseValidator [b]) -> SelectionSet RAW -> BaseValidator [b]
mapSelection f = fmap concat . traverse f
allVariableRefs :: [SelectionSet RAW] -> BaseValidator [Ref]
allVariableRefs = fmap concat . traverse (mapSelection searchRefs)
where
exploreSelectionContent :: SelectionContent RAW -> BaseValidator [Ref]
exploreSelectionContent SelectionField = pure []
exploreSelectionContent (SelectionSet selSet) = mapSelection searchRefs selSet
searchRefs :: Selection RAW -> BaseValidator [Ref]
searchRefs Selection {selectionArguments, selectionDirectives, selectionContent} = do
let directiveRefs = concatMap exploreRefs selectionDirectives
contentRefs <- exploreSelectionContent selectionContent
pure $ directiveRefs <> contentRefs <> concatMap exploreRefs selectionArguments
searchRefs (InlineFragment Fragment {fragmentSelection, fragmentDirectives}) =
(concatMap exploreRefs fragmentDirectives <>)
<$> mapSelection searchRefs fragmentSelection
searchRefs (Spread directives reference) =
(concatMap exploreRefs directives <>)
<$> ( askFragments
>>= selectKnown reference
>>= mapSelection searchRefs
. fragmentSelection
)
resolveOperationVariables ::
Variables ->
VALIDATION_MODE ->
Operation RAW ->
BaseValidator (VariableDefinitions VALID)
resolveOperationVariables
root
validationMode
Operation
{ operationSelection,
operationArguments
} =
checkUnusedVariables
*> traverse (lookupAndValidateValueOnBody root validationMode) operationArguments
where
checkUnusedVariables :: BaseValidator ()
checkUnusedVariables = do
uses <- allVariableRefs [operationSelection]
checkUnused uses (elems operationArguments)
lookupAndValidateValueOnBody ::
Variables ->
VALIDATION_MODE ->
Variable RAW ->
BaseValidator (Variable VALID)
lookupAndValidateValueOnBody
bodyVariables
validationMode
var@Variable
{ variableName,
variableType,
variablePosition,
variableValue = DefaultValue defaultValue
} =
withPosition variablePosition $
toVariable
<$> ( askSchema
>>= selectKnown (TypeNameRef (typeConName variableType) variablePosition)
>>= constraint INPUT var
>>= checkType getVariable defaultValue
)
where
toVariable x = var {variableValue = ValidVariableValue x}
getVariable :: Maybe ResolvedValue
getVariable = M.lookup variableName bodyVariables
checkType ::
Maybe ResolvedValue ->
DefaultValue ->
TypeDefinition IN ->
BaseValidator ValidValue
checkType (Just variable) Nothing varType = validator varType False variable
checkType (Just variable) (Just defValue) varType =
validator varType True defValue >> validator varType False variable
checkType Nothing (Just defValue) varType = validator varType True defValue
checkType Nothing Nothing varType
| validationMode /= WITHOUT_VARIABLES && not (isNullable variableType) =
failure $ uninitializedVariable var
| otherwise =
returnNull
where
returnNull =
maybe (pure Null) (validator varType False) (M.lookup variableName bodyVariables)
validator :: TypeDefinition IN -> Bool -> ResolvedValue -> BaseValidator ValidValue
validator varType isDefaultValue varValue =
startInput (SourceVariable var isDefaultValue) $
validateInput
(typeWrappers variableType)
varType
(ObjectEntry variableName varValue)