{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.Morpheus.Validation.Query.Input.Object
( validateInputValue
) where
import Data.Morpheus.Error.Input (InputError (..), InputValidation, Prop (..))
import Data.Morpheus.Types.Internal.Data (DataField (..), DataInputType, DataKind (..),
DataType (..), DataTypeLib (..), DataTypeWrapper (..),
DataValidator (..), showFullAstType)
import Data.Morpheus.Types.Internal.Value (Value (..))
import Data.Morpheus.Validation.Query.Input.Enum (validateEnum)
import Data.Morpheus.Validation.Internal.Utils (getInputType, lookupField)
import Data.Text (Text)
typeMismatch :: Value -> Text -> [Prop] -> InputError
typeMismatch jsType expected' path' = UnexpectedType path' expected' jsType Nothing
validateInputValue ::
DataTypeLib -> [Prop] -> [DataTypeWrapper] -> DataInputType -> (Text, Value) -> InputValidation Value
validateInputValue lib' prop' = validate
where
throwError :: [DataTypeWrapper] -> DataInputType -> Value -> InputValidation Value
throwError wrappers' type' value' = Left $ UnexpectedType prop' (showFullAstType wrappers' type') value' Nothing
validate :: [DataTypeWrapper] -> DataInputType -> (Text, Value) -> InputValidation Value
validate (NonNullType:wrappers') type' (_, Null) = throwError wrappers' type' Null
validate _ _ (_, Null) = return Null
validate (NonNullType:wrappers') type' value' = validateInputValue lib' prop' wrappers' type' value'
validate (ListType:wrappers') type' (key', List list') = List <$> mapM validateElement list'
where
validateElement element' = validateInputValue lib' prop' wrappers' type' (key', element')
validate [] (ObjectKind DataType {typeData = parentFields'}) (_, Object fields) =
Object <$> mapM validateField fields
where
validateField (_name, value') = do
(type', currentProp') <- validationData value'
wrappers' <- fieldTypeWrappers <$> getField
value'' <- validateInputValue lib' currentProp' wrappers' type' (_name, value')
return (_name, value'')
where
validationData x = do
fieldTypeName' <- fieldType <$> getField
let currentProp = prop' ++ [Prop _name fieldTypeName']
type' <- getInputType fieldTypeName' lib' (typeMismatch x fieldTypeName' currentProp)
return (type', currentProp)
getField = lookupField _name parentFields' (UnknownField prop' _name)
validate [] (UnionKind DataType {typeData}) (_, Object fields) = return (Object fields)
validate [] (EnumKind DataType {typeData = tags', typeName = name'}) (_, value') =
validateEnum (UnexpectedType prop' name' value' Nothing) tags' value'
validate [] (ScalarKind DataType {typeName = name', typeData = DataValidator {validateValue = validator'}}) (_, value') =
case validator' value' of
Right _ -> return value'
Left "" -> Left $ UnexpectedType prop' name' value' Nothing
Left errorMessage -> Left $ UnexpectedType prop' name' value' (Just errorMessage)
validate wrappers' type' (_, value') = throwError wrappers' type' value'