{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.Morpheus.Validation.Internal.Value
( validateInputValue
, validateEnum
) where
import Data.List (elem)
import Data.Morpheus.Error.Input (InputError (..), InputValidation, Prop (..))
import Data.Morpheus.Rendering.RenderGQL (renderWrapped)
import Data.Morpheus.Types.Internal.Data (DataField (..), DataTyCon (..), DataType (..),
DataTypeLib (..), DataValidator (..), Key, TypeAlias (..),
WrapperD (..), isNullable)
import Data.Morpheus.Types.Internal.Value (Value (..))
import Data.Morpheus.Validation.Internal.Utils (getInputType, lookupField)
validateInputValue :: DataTypeLib -> [Prop] -> [WrapperD] -> DataType -> (Key, Value) -> InputValidation Value
validateInputValue lib prop' = validate
where
throwError :: [WrapperD] -> DataType -> Value -> InputValidation Value
throwError wrappers datatype value = Left $ UnexpectedType prop' (renderWrapped datatype wrappers) value Nothing
validate :: [WrapperD] -> DataType -> (Key, Value) -> InputValidation Value
validate wrappers tName (_, Null)
| isNullable wrappers = return Null
| otherwise = throwError wrappers tName Null
validate (MaybeD:wrappers) type' value' = validateInputValue lib prop' wrappers type' value'
validate (ListD:wrappers) type' (key', List list') = List <$> mapM validateElement list'
where
validateElement element' = validateInputValue lib prop' wrappers type' (key', element')
validate [] (DataInputObject DataTyCon {typeData = parentFields'}) (_, Object fields) =
Object <$> mapM validateField fields
where
validateField (_name, value) = do
(type', currentProp') <- validationData value
wrappers' <- aliasWrappers . fieldType <$> getField
value'' <- validateInputValue lib currentProp' wrappers' type' (_name, value)
return (_name, value'')
where
validationData x = do
fieldTypeName' <- aliasTyCon . 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 [] (DataInputUnion DataTyCon {typeData}) (_, Object fields) = return (Object fields)
validate [] (DataEnum DataTyCon {typeData = tags', typeName = name'}) (_, value') =
validateEnum (UnexpectedType prop' name' value' Nothing) tags' value'
validate [] (DataScalar DataTyCon {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 datatype (_, value) = throwError wrappers datatype value
validateEnum :: error -> [Key] -> Value -> Either error Value
validateEnum error' tags' (Enum enumValue) =
if enumValue `elem` tags'
then pure (Enum enumValue)
else Left error'
validateEnum error' _ _ = Left error'
typeMismatch :: Value -> Key -> [Prop] -> InputError
typeMismatch jsType expected' path' = UnexpectedType path' expected' jsType Nothing