{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.Morpheus.Validation.Internal.Value
( validateInputValue
, validateEnum
)
where
import Data.List ( elem )
import Data.Morpheus.Error.Variable ( incompatibleVariableType )
import Data.Morpheus.Error.Input ( InputError(..)
, InputValidation
, Prop(..)
)
import Data.Morpheus.Types.Internal.AST
( DataField(..)
, DataTypeContent(..)
, DataType(..)
, DataTypeLib(..)
, DataValidator(..)
, Key
, TypeRef(..)
, TypeWrapper(..)
, DataEnumValue(..)
, lookupField
, lookupInputType
, Value(..)
, ValidValue
, Variable(..)
, Ref(..)
, isWeaker
, DataScalar
, Message
, Name
, ResolvedValue
, VALID
, VariableContent(..)
, unpackInputUnion
, isFieldNullable
, TypeRef(..)
, isNullableWrapper
)
import Data.Morpheus.Types.Internal.Resolving
( Failure(..) )
import Data.Morpheus.Rendering.RenderGQL
( RenderGQL(..) )
checkTypeEquality
:: (Name, [TypeWrapper])
-> Ref
-> Variable VALID
-> InputValidation ValidValue
checkTypeEquality (tyConName, tyWrappers) Ref { refName, refPosition } Variable { variableValue = ValidVariableValue value, variableType }
| typeConName variableType == tyConName && not
(isWeaker (typeWrappers variableType) tyWrappers)
= pure value
| otherwise
= failure $ GlobalInputError $ incompatibleVariableType refName
varSignature
fieldSignature
refPosition
where
varSignature = render variableType
fieldSignature = render TypeRef { typeConName = tyConName
, typeWrappers = tyWrappers
, typeArgs = Nothing
}
validateInputValue
:: DataTypeLib
-> [Prop]
-> [TypeWrapper]
-> DataType
-> (Key, ResolvedValue)
-> InputValidation ValidValue
validateInputValue lib props rw datatype@DataType { typeContent, typeName } =
validateWrapped rw typeContent
where
throwError :: [TypeWrapper] -> ResolvedValue -> InputValidation ValidValue
throwError wrappers value =
Left $ UnexpectedType props (renderWrapped datatype wrappers) value Nothing
validateWrapped
:: [TypeWrapper]
-> DataTypeContent
-> (Key, ResolvedValue)
-> InputValidation ValidValue
validateWrapped wrappers _ (_, ResolvedVariable ref variable) =
checkTypeEquality (typeName, wrappers) ref variable
validateWrapped wrappers _ (_, Null)
| isNullableWrapper wrappers = return Null
| otherwise = throwError wrappers Null
validateWrapped (TypeMaybe : wrappers) _ value =
validateInputValue lib props wrappers datatype value
validateWrapped (TypeList : wrappers) _ (key, List list) =
List <$> mapM validateElement list
where
validateElement element =
validateInputValue lib props wrappers datatype (key, element)
validateWrapped [] dt v = validate dt v
where
validate
:: DataTypeContent -> (Key, ResolvedValue) -> InputValidation ValidValue
validate (DataInputObject parentFields) (_, Object fields) =
traverse requiredFieldsDefined parentFields
>> Object
<$> traverse validateField fields
where
requiredFieldsDefined (fName, datafield)
| fName `elem` map fst fields || isFieldNullable datafield = pure ()
| otherwise = failure (UndefinedField props fName)
validateField
:: (Name, ResolvedValue) -> InputValidation (Name, ValidValue)
validateField (_name, value) = do
(type', currentProp') <- validationData value
wrappers' <- typeWrappers . fieldType <$> getField
value'' <- validateInputValue lib
currentProp'
wrappers'
type'
(_name, value)
return (_name, value'')
where
validationData :: ResolvedValue -> InputValidation (DataType, [Prop])
validationData x = do
fieldTypeName' <- typeConName . fieldType <$> getField
let currentProp = props ++ [Prop _name fieldTypeName']
type' <- lookupInputType fieldTypeName'
lib
(typeMismatch x fieldTypeName' currentProp)
return (type', currentProp)
getField = lookupField _name parentFields (UnknownField props _name)
validate (DataInputUnion inputUnion) (_, Object rawFields) =
case unpackInputUnion inputUnion rawFields of
Left message -> failure
$ UnexpectedType props typeName (Object rawFields) (Just message)
Right (name, Nothing ) -> return (Object [("__typename", Enum name)])
Right (name, Just value) -> do
currentUnionDatatype <- lookupInputType
name
lib
(typeMismatch value name props)
validValue <- validateInputValue lib
props
[TypeMaybe]
currentUnionDatatype
(name, value)
return (Object [("__typename", Enum name), (name, validValue)])
validate (DataEnum tags) (_, value) =
validateEnum (UnexpectedType props typeName value Nothing) tags value
validate (DataScalar dataScalar) (_, value) =
validateScalar dataScalar value (UnexpectedType props typeName)
validate _ (_, value) = throwError [] value
validateWrapped wrappers _ (_, value) = throwError wrappers value
validateScalar
:: DataScalar
-> ResolvedValue
-> (ResolvedValue -> Maybe Message -> InputError)
-> InputValidation ValidValue
validateScalar DataValidator { validateValue } value err = do
scalarValue <- toScalar value
case validateValue scalarValue of
Right _ -> return scalarValue
Left "" -> failure (err value Nothing)
Left errorMessage -> failure $ err value (Just errorMessage)
where
toScalar :: ResolvedValue -> InputValidation ValidValue
toScalar (Scalar x) = pure (Scalar x)
toScalar scValue = Left (err scValue Nothing)
validateEnum
:: error -> [DataEnumValue] -> ResolvedValue -> Either error ValidValue
validateEnum gqlError enumValues (Enum enumValue)
| enumValue `elem` tags = pure (Enum enumValue)
| otherwise = Left gqlError
where tags = map enumName enumValues
validateEnum gqlError _ _ = Left gqlError
typeMismatch :: ResolvedValue -> Key -> [Prop] -> InputError
typeMismatch jsType expected' path' =
UnexpectedType path' expected' jsType Nothing