{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.Morpheus.Validation.Internal.Value (validateInput) where
import Data.Foldable (traverse_)
import Data.List (elem)
import Data.Maybe (maybe)
import Data.Morpheus.Error.Input (typeViolation)
import Data.Morpheus.Error.Utils (errorMessage)
import Data.Morpheus.Error.Variable (incompatibleVariableType)
import Data.Morpheus.Internal.Utils
( Failure (..),
elems,
)
import Data.Morpheus.Types.Internal.AST
( DataEnumValue (..),
FieldDefinition (..),
IN,
Message,
ObjectEntry (..),
RESOLVED,
Ref (..),
ResolvedValue,
ScalarDefinition (..),
ScalarValue (..),
TRUE,
TypeContent (..),
TypeDefinition (..),
TypeName (..),
TypeRef (..),
TypeRef (..),
TypeWrapper (..),
VALID,
ValidValue,
Value (..),
Variable (..),
Variable (..),
VariableContent (..),
isNullableWrapper,
isWeaker,
msg,
toFieldName,
)
import Data.Morpheus.Types.Internal.AST.OrderedMap
( unsafeFromValues,
)
import Data.Morpheus.Types.Internal.Validation
( InputValidator,
Prop (..),
askInputFieldType,
askInputMember,
askScopePosition,
constraintInputUnion,
inputMessagePrefix,
selectKnown,
selectWithDefaultValue,
withInputScope,
withScopeType,
)
import Data.Semigroup ((<>))
castFailure :: TypeRef -> Maybe Message -> ResolvedValue -> InputValidator a
castFailure expected message value = do
pos <- askScopePosition
prefix <- inputMessagePrefix
failure
$ errorMessage pos
$ prefix <> typeViolation expected value <> maybe "" (" " <>) message
checkTypeEquality ::
(TypeName, [TypeWrapper]) ->
Ref ->
Variable VALID ->
InputValidator ValidValue
checkTypeEquality (tyConName, tyWrappers) ref var@Variable {variableValue = ValidVariableValue value, variableType}
| typeConName variableType == tyConName
&& not
(isWeaker (typeWrappers variableType) tyWrappers) =
pure value
| otherwise =
failure $
incompatibleVariableType
ref
var
TypeRef
{ typeConName = tyConName,
typeWrappers = tyWrappers,
typeArgs = Nothing
}
validateInput ::
[TypeWrapper] ->
TypeDefinition IN ->
ObjectEntry RESOLVED ->
InputValidator ValidValue
validateInput tyWrappers TypeDefinition {typeContent = tyCont, typeName} =
withScopeType typeName
. validateWrapped tyWrappers tyCont
where
mismatchError :: [TypeWrapper] -> ResolvedValue -> InputValidator ValidValue
mismatchError wrappers = castFailure (TypeRef typeName Nothing wrappers) Nothing
validateWrapped ::
[TypeWrapper] ->
TypeContent TRUE IN ->
ObjectEntry RESOLVED ->
InputValidator ValidValue
validateWrapped wrappers _ ObjectEntry {entryValue = ResolvedVariable ref variable} =
checkTypeEquality (typeName, wrappers) ref variable
validateWrapped wrappers _ ObjectEntry {entryValue = Null}
| isNullableWrapper wrappers = return Null
| otherwise = mismatchError wrappers Null
validateWrapped (TypeMaybe : wrappers) _ value =
validateWrapped wrappers tyCont value
validateWrapped (TypeList : wrappers) _ (ObjectEntry key (List list)) =
List <$> traverse validateElement list
where
validateElement = validateWrapped wrappers tyCont . ObjectEntry key
validateWrapped [] dt v = validate dt v
where
validate ::
TypeContent TRUE IN -> ObjectEntry RESOLVED -> InputValidator ValidValue
validate (DataInputObject parentFields) ObjectEntry {entryValue = Object fields} = do
traverse_ requiredFieldsDefined (elems parentFields)
Object <$> traverse validateField fields
where
requiredFieldsDefined :: FieldDefinition IN -> InputValidator (ObjectEntry RESOLVED)
requiredFieldsDefined fieldDef@FieldDefinition {fieldName} =
selectWithDefaultValue (ObjectEntry fieldName Null) fieldDef fields
validateField ::
ObjectEntry RESOLVED -> InputValidator (ObjectEntry VALID)
validateField entry@ObjectEntry {entryName} = do
inputField@FieldDefinition {fieldType = TypeRef {typeConName, typeWrappers}} <- getField
inputTypeDef <- askInputFieldType inputField
withInputScope (Prop entryName typeConName) $
ObjectEntry entryName
<$> validateInput
typeWrappers
inputTypeDef
entry
where
getField = selectKnown entry parentFields
validate (DataInputUnion inputUnion) ObjectEntry {entryValue = Object rawFields} =
case constraintInputUnion inputUnion rawFields of
Left message -> castFailure (TypeRef typeName Nothing []) (Just message) (Object rawFields)
Right (name, Nothing) -> return (Object $ unsafeFromValues [ObjectEntry "__typename" (Enum name)])
Right (name, Just value) -> do
inputDef <- askInputMember name
validValue <-
validateInput
[TypeMaybe]
inputDef
(ObjectEntry (toFieldName name) value)
return (Object $ unsafeFromValues [ObjectEntry "__typename" (Enum name), ObjectEntry (toFieldName name) validValue])
validate (DataEnum tags) ObjectEntry {entryValue} =
validateEnum (castFailure (TypeRef typeName Nothing []) Nothing) tags entryValue
validate (DataScalar dataScalar) ObjectEntry {entryValue} =
validateScalar typeName dataScalar entryValue (castFailure (TypeRef typeName Nothing []))
validate _ ObjectEntry {entryValue} = mismatchError [] entryValue
validateWrapped wrappers _ ObjectEntry {entryValue} = mismatchError wrappers entryValue
validateScalar ::
TypeName ->
ScalarDefinition ->
ResolvedValue ->
(Maybe Message -> ResolvedValue -> InputValidator ValidValue) ->
InputValidator ValidValue
validateScalar typeName ScalarDefinition {validateValue} value err = do
scalarValue <- toScalar value
case validateValue scalarValue of
Right _ -> pure scalarValue
Left "" -> err Nothing value
Left message -> err (Just $ msg message) value
where
toScalar :: ResolvedValue -> InputValidator ValidValue
toScalar (Scalar x) | isValidDefault typeName x = pure (Scalar x)
toScalar _ = err Nothing value
isValidDefault :: TypeName -> ScalarValue -> Bool
isValidDefault "Boolean" = isBoolean
isValidDefault "String" = isString
isValidDefault "Float" = \x -> isFloat x || isInt x
isValidDefault "Int" = isInt
isValidDefault _ = const True
isBoolean :: ScalarValue -> Bool
isBoolean Boolean {} = True
isBoolean _ = False
isString :: ScalarValue -> Bool
isString String {} = True
isString _ = False
isFloat :: ScalarValue -> Bool
isFloat Float {} = True
isFloat _ = False
isInt :: ScalarValue -> Bool
isInt Int {} = True
isInt _ = False
validateEnum ::
(ResolvedValue -> InputValidator ValidValue) ->
[DataEnumValue] ->
ResolvedValue ->
InputValidator ValidValue
validateEnum err enumValues value@(Enum enumValue)
| enumValue `elem` tags = pure (Enum enumValue)
| otherwise = err value
where
tags = map enumName enumValues
validateEnum err _ value = err value