{-# LANGUAGE OverloadedStrings #-} module Data.Morpheus.PreProcess.Input.Object ( validateInputObject , validateInput ) where import Data.Morpheus.Error.Input (InputError (..), InputValidation, Prop (..)) import Data.Morpheus.PreProcess.Input.Enum (validateEnum) import Data.Morpheus.PreProcess.Utils (lookupField, lookupType) import Data.Morpheus.Schema.Internal.Types (Core (..), Field (..), GObject (..), InputField (..), InputObject, InputType, Leaf (..), TypeLib (..)) import qualified Data.Morpheus.Schema.Internal.Types as T (InternalType (..)) import Data.Morpheus.Types.JSType (JSType (..), ScalarValue (..)) import Data.Text (Text) generateError :: JSType -> Text -> [Prop] -> InputError generateError jsType expected' path' = UnexpectedType path' expected' jsType existsInputObjectType :: InputError -> TypeLib -> Text -> InputValidation InputObject existsInputObjectType error' lib' = lookupType error' (inputObject lib') existsLeafType :: InputError -> TypeLib -> Text -> InputValidation Leaf existsLeafType error' lib' = lookupType error' (leaf lib') validateScalarTypes :: Text -> ScalarValue -> [Prop] -> InputValidation ScalarValue validateScalarTypes "String" (String x) = pure . const (String x) validateScalarTypes "String" scalar = Left . generateError (Scalar scalar) "String" validateScalarTypes "Int" (Int x) = pure . const (Int x) validateScalarTypes "Int" scalar = Left . generateError (Scalar scalar) "Int" validateScalarTypes "Boolean" (Boolean x) = pure . const (Boolean x) validateScalarTypes "Boolean" scalar = Left . generateError (Scalar scalar) "Boolean" validateScalarTypes _ scalar = pure . const scalar validateEnumType :: Text -> [Text] -> JSType -> [Prop] -> InputValidation JSType validateEnumType expected' tags jsType props = validateEnum (UnexpectedType props expected' jsType) tags jsType validateLeaf :: Leaf -> JSType -> [Prop] -> InputValidation JSType validateLeaf (LEnum tags core) jsType props = validateEnumType (name core) tags jsType props validateLeaf (LScalar core) (Scalar found) props = Scalar <$> validateScalarTypes (name core) found props validateLeaf (LScalar core) jsType props = Left $ generateError jsType (name core) props validateInputObject :: [Prop] -> TypeLib -> GObject InputField-> (Text, JSType) -> InputValidation (Text, JSType) validateInputObject prop' lib' (GObject parentFields _) (_name, JSObject fields) = do fieldTypeName' <- fieldType . unpackInputField <$> lookupField _name parentFields (UnknownField prop' _name) let currentProp = prop' ++ [Prop _name fieldTypeName'] let error' = generateError (JSObject fields) fieldTypeName' currentProp inputObject' <- existsInputObjectType error' lib' fieldTypeName' mapM (validateInputObject currentProp lib' inputObject') fields >>= \x -> pure (_name, JSObject x) validateInputObject prop' lib' (GObject parentFields _) (_name, jsType) = do fieldTypeName' <- fieldType . unpackInputField <$> lookupField _name parentFields (UnknownField prop' _name) let currentProp = prop' ++ [Prop _name fieldTypeName'] let error' = generateError jsType fieldTypeName' currentProp fieldType' <- existsLeafType error' lib' fieldTypeName' validateLeaf fieldType' jsType currentProp >> pure (_name, jsType) validateInput :: TypeLib -> InputType -> (Text, JSType) -> InputValidation JSType validateInput typeLib (T.Object oType) (_, JSObject fields) = JSObject <$> mapM (validateInputObject [] typeLib oType) fields validateInput _ (T.Object (GObject _ core)) (_, jsType) = Left $ generateError jsType (name core) [] validateInput _ (T.Scalar core) (_, jsValue) = validateLeaf (LScalar core) jsValue [] validateInput _ (T.Enum tags core) (_, jsValue) = validateLeaf (LEnum tags core) jsValue []