{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Validation.Internal.Value
  ( validateInputByTypeRef,
    validateInputByType,
    ValidateWithDefault,
  )
where

import Data.Morpheus.Error.Input (typeViolation)
import Data.Morpheus.Error.Variable (incompatibleVariableType)
import Data.Morpheus.Internal.Utils
  ( Failure (..),
    fromElems,
  )
import Data.Morpheus.Types.Internal.AST
  ( CONST,
    DataEnumValue (..),
    DataInputUnion,
    FieldDefinition (..),
    FieldsDefinition,
    IN,
    Message,
    Object,
    ObjectEntry (..),
    Ref (..),
    ScalarDefinition (..),
    ScalarValue (..),
    TRUE,
    TypeContent (..),
    TypeDefinition (..),
    TypeName (..),
    TypeRef (..),
    TypeWrapper (..),
    Typed (..),
    UnionMember (..),
    VALID,
    ValidValue,
    ValidationErrors,
    Value (..),
    Variable (..),
    Variable (..),
    VariableContent (..),
    isNullable,
    isWeaker,
    msg,
    msgValidation,
    toFieldName,
    typed,
    untyped,
    withPosition,
  )
import Data.Morpheus.Types.Internal.Validation
  ( InputContext,
    InputSource (..),
    InputValidator,
    Scope (..),
    Validator,
    askType,
    askTypeMember,
    asksScope,
    constraintInputUnion,
    inField,
    inputMessagePrefix,
    inputValueSource,
    selectKnown,
    selectWithDefaultValue,
    withScopeType,
  )
import Relude

violation ::
  Maybe Message ->
  Value s ->
  InputValidator schemaS ctx a
violation :: Maybe Message -> Value s -> InputValidator schemaS ctx a
violation Maybe Message
message Value s
value = do
  Scope
    { Maybe Position
position :: Scope -> Maybe Position
position :: Maybe Position
position,
      TypeName
currentTypeName :: Scope -> TypeName
currentTypeName :: TypeName
currentTypeName,
      [TypeWrapper]
currentTypeWrappers :: Scope -> [TypeWrapper]
currentTypeWrappers :: [TypeWrapper]
currentTypeWrappers
    } <-
    (Scope -> Scope) -> Validator schemaS (InputContext ctx) Scope
forall (m :: * -> * -> *) (s :: Stage) c a.
MonadContext m s c =>
(Scope -> a) -> m c a
asksScope Scope -> Scope
forall a. a -> a
id
  ValidationError
prefix <- InputValidator schemaS ctx ValidationError
forall (s :: Stage) ctx. InputValidator s ctx ValidationError
inputMessagePrefix
  ValidationError -> InputValidator schemaS ctx a
forall error (f :: * -> *) v. Failure error f => error -> f v
failure
    (ValidationError -> InputValidator schemaS ctx a)
-> ValidationError -> InputValidator schemaS ctx a
forall a b. (a -> b) -> a -> b
$ Maybe Position -> ValidationError -> ValidationError
withPosition Maybe Position
position
    (ValidationError -> ValidationError)
-> ValidationError -> ValidationError
forall a b. (a -> b) -> a -> b
$ ValidationError
prefix
      ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> TypeRef -> Value s -> ValidationError
forall (s :: Stage). TypeRef -> Value s -> ValidationError
typeViolation
        (TypeName -> Maybe String -> [TypeWrapper] -> TypeRef
TypeRef TypeName
currentTypeName Maybe String
forall a. Maybe a
Nothing [TypeWrapper]
currentTypeWrappers)
        Value s
value
      ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<> ValidationError
-> (Message -> ValidationError) -> Maybe Message -> ValidationError
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ValidationError
"" ((ValidationError
" " ValidationError -> ValidationError -> ValidationError
forall a. Semigroup a => a -> a -> a
<>) (ValidationError -> ValidationError)
-> (Message -> ValidationError) -> Message -> ValidationError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> ValidationError
forall a. Msg a => a -> ValidationError
msgValidation) Maybe Message
message

checkTypeEquality ::
  (TypeName, [TypeWrapper]) ->
  Ref ->
  Variable VALID ->
  InputValidator schemaS ctx ValidValue
checkTypeEquality :: (TypeName, [TypeWrapper])
-> Ref -> Variable VALID -> InputValidator schemaS ctx ValidValue
checkTypeEquality (TypeName
tyConName, [TypeWrapper]
tyWrappers) Ref
ref var :: Variable VALID
var@Variable {variableValue :: forall (stage :: Stage).
Variable stage -> VariableContent (CONST_OR_VALID stage)
variableValue = ValidVariableValue ValidValue
value, TypeRef
variableType :: forall (stage :: Stage). Variable stage -> TypeRef
variableType :: TypeRef
variableType}
  | TypeRef -> TypeName
typeConName TypeRef
variableType TypeName -> TypeName -> Bool
forall a. Eq a => a -> a -> Bool
== TypeName
tyConName
      Bool -> Bool -> Bool
&& Bool -> Bool
not
        ([TypeWrapper] -> [TypeWrapper] -> Bool
isWeaker (TypeRef -> [TypeWrapper]
typeWrappers TypeRef
variableType) [TypeWrapper]
tyWrappers) =
    ValidValue -> InputValidator schemaS ctx ValidValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure ValidValue
value
  | Bool
otherwise =
    ValidationError -> InputValidator schemaS ctx ValidValue
forall error (f :: * -> *) v. Failure error f => error -> f v
failure (ValidationError -> InputValidator schemaS ctx ValidValue)
-> ValidationError -> InputValidator schemaS ctx ValidValue
forall a b. (a -> b) -> a -> b
$
      Ref -> Variable VALID -> TypeRef -> ValidationError
forall (s :: Stage).
Ref -> Variable s -> TypeRef -> ValidationError
incompatibleVariableType
        Ref
ref
        Variable VALID
var
        TypeRef :: TypeName -> Maybe String -> [TypeWrapper] -> TypeRef
TypeRef
          { typeConName :: TypeName
typeConName = TypeName
tyConName,
            typeWrappers :: [TypeWrapper]
typeWrappers = [TypeWrapper]
tyWrappers,
            typeArgs :: Maybe String
typeArgs = Maybe String
forall a. Maybe a
Nothing
          }

validateInputByTypeRef ::
  ValidateWithDefault c schemaS s =>
  Typed IN schemaS TypeRef ->
  Value s ->
  Validator schemaS (InputContext c) (Value VALID)
validateInputByTypeRef :: Typed IN schemaS TypeRef
-> Value s -> Validator schemaS (InputContext c) ValidValue
validateInputByTypeRef
  Typed IN schemaS TypeRef
ref
  Value s
value = do
    TypeDefinition IN schemaS
inputTypeDef <- Typed IN schemaS TypeRef
-> Validator schemaS (InputContext c) (TypeDefinition IN schemaS)
forall (m :: * -> * -> *) c (cat :: TypeCategory) (s :: Stage).
Constraints m c cat s =>
Typed cat s TypeRef -> m c (TypeDefinition cat s)
askType Typed IN schemaS TypeRef
ref
    [TypeWrapper]
-> TypeDefinition IN schemaS
-> Value s
-> Validator schemaS (InputContext c) ValidValue
forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
[TypeWrapper]
-> TypeDefinition IN schemaS
-> Value valueS
-> InputValidator schemaS ctx ValidValue
validateInputByType
      ((TypeRef -> [TypeWrapper])
-> Typed IN schemaS TypeRef -> [TypeWrapper]
forall a b (c :: TypeCategory) (s :: Stage).
(a -> b) -> Typed c s a -> b
untyped TypeRef -> [TypeWrapper]
typeWrappers Typed IN schemaS TypeRef
ref)
      TypeDefinition IN schemaS
inputTypeDef
      Value s
value

validateValueByField ::
  ValidateWithDefault c schemaS s =>
  FieldDefinition IN schemaS ->
  Value s ->
  Validator schemaS (InputContext c) (Value VALID)
validateValueByField :: FieldDefinition IN schemaS
-> Value s -> Validator schemaS (InputContext c) ValidValue
validateValueByField FieldDefinition IN schemaS
field =
  FieldDefinition IN schemaS
-> Validator schemaS (InputContext c) ValidValue
-> Validator schemaS (InputContext c) ValidValue
forall (s :: Stage) c a.
FieldDefinition IN s
-> InputValidator s c a -> InputValidator s c a
inField FieldDefinition IN schemaS
field
    (Validator schemaS (InputContext c) ValidValue
 -> Validator schemaS (InputContext c) ValidValue)
-> (Value s -> Validator schemaS (InputContext c) ValidValue)
-> Value s
-> Validator schemaS (InputContext c) ValidValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Typed IN schemaS TypeRef
-> Value s -> Validator schemaS (InputContext c) ValidValue
forall c (schemaS :: Stage) (s :: Stage).
ValidateWithDefault c schemaS s =>
Typed IN schemaS TypeRef
-> Value s -> Validator schemaS (InputContext c) ValidValue
validateInputByTypeRef
      ((FieldDefinition IN schemaS -> TypeRef)
-> FieldDefinition IN schemaS -> Typed IN schemaS TypeRef
forall (a :: TypeCategory -> Stage -> *) (c :: TypeCategory)
       (s :: Stage) b.
(a c s -> b) -> a c s -> Typed c s b
typed FieldDefinition IN schemaS -> TypeRef
forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType FieldDefinition IN schemaS
field)

-- Validate input Values
validateInputByType ::
  ValidateWithDefault ctx schemaS valueS =>
  [TypeWrapper] ->
  TypeDefinition IN schemaS ->
  Value valueS ->
  InputValidator schemaS ctx ValidValue
validateInputByType :: [TypeWrapper]
-> TypeDefinition IN schemaS
-> Value valueS
-> InputValidator schemaS ctx ValidValue
validateInputByType [TypeWrapper]
tyWrappers TypeDefinition IN schemaS
typeDef =
  (TypeDefinition IN schemaS, [TypeWrapper])
-> InputValidator schemaS ctx ValidValue
-> InputValidator schemaS ctx ValidValue
forall (m :: * -> * -> *) (s :: Stage) c (cat :: TypeCategory) a.
MonadContext m s c =>
(TypeDefinition cat s, [TypeWrapper]) -> m c a -> m c a
withScopeType (TypeDefinition IN schemaS
typeDef, [TypeWrapper]
tyWrappers) (InputValidator schemaS ctx ValidValue
 -> InputValidator schemaS ctx ValidValue)
-> (Value valueS -> InputValidator schemaS ctx ValidValue)
-> Value valueS
-> InputValidator schemaS ctx ValidValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeWrapper]
-> TypeDefinition IN schemaS
-> Value valueS
-> InputValidator schemaS ctx ValidValue
forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
[TypeWrapper]
-> TypeDefinition IN schemaS
-> Value valueS
-> InputValidator schemaS ctx ValidValue
validateWrapped [TypeWrapper]
tyWrappers TypeDefinition IN schemaS
typeDef

-- VALIDATION
validateWrapped ::
  ValidateWithDefault ctx schemaS valueS =>
  [TypeWrapper] ->
  TypeDefinition IN schemaS ->
  Value valueS ->
  InputValidator schemaS ctx ValidValue
-- Validate Null. value = null ?
validateWrapped :: [TypeWrapper]
-> TypeDefinition IN schemaS
-> Value valueS
-> InputValidator schemaS ctx ValidValue
validateWrapped [TypeWrapper]
wrappers TypeDefinition IN schemaS
_ (ResolvedVariable Ref
ref Variable VALID
variable) = do
  TypeName
typeName <- (Scope -> TypeName)
-> Validator schemaS (InputContext ctx) TypeName
forall (m :: * -> * -> *) (s :: Stage) c a.
MonadContext m s c =>
(Scope -> a) -> m c a
asksScope Scope -> TypeName
currentTypeName
  (TypeName, [TypeWrapper])
-> Ref -> Variable VALID -> InputValidator schemaS ctx ValidValue
forall (schemaS :: Stage) ctx.
(TypeName, [TypeWrapper])
-> Ref -> Variable VALID -> InputValidator schemaS ctx ValidValue
checkTypeEquality (TypeName
typeName, [TypeWrapper]
wrappers) Ref
ref Variable VALID
variable
validateWrapped [TypeWrapper]
wrappers TypeDefinition IN schemaS
_ Value valueS
Null
  | [TypeWrapper] -> Bool
forall a. Nullable a => a -> Bool
isNullable [TypeWrapper]
wrappers = ValidValue -> InputValidator schemaS ctx ValidValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure ValidValue
forall (stage :: Stage). Value stage
Null
  | Bool
otherwise = Maybe Message -> Value Any -> InputValidator schemaS ctx ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe Message -> Value s -> InputValidator schemaS ctx a
violation Maybe Message
forall a. Maybe a
Nothing Value Any
forall (stage :: Stage). Value stage
Null
-- Validate LIST
validateWrapped [TypeWrapper
TypeMaybe] TypeDefinition {TypeContent TRUE IN schemaS
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent :: TypeContent TRUE IN schemaS
typeContent} Value valueS
entryValue =
  TypeContent TRUE IN schemaS
-> Value valueS -> InputValidator schemaS ctx ValidValue
forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
TypeContent TRUE IN schemaS
-> Value valueS -> InputValidator schemaS ctx ValidValue
validateUnwrapped TypeContent TRUE IN schemaS
typeContent Value valueS
entryValue
validateWrapped (TypeWrapper
TypeMaybe : [TypeWrapper]
wrappers) TypeDefinition IN schemaS
typeDef Value valueS
value =
  [TypeWrapper]
-> TypeDefinition IN schemaS
-> Value valueS
-> InputValidator schemaS ctx ValidValue
forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
[TypeWrapper]
-> TypeDefinition IN schemaS
-> Value valueS
-> InputValidator schemaS ctx ValidValue
validateInputByType [TypeWrapper]
wrappers TypeDefinition IN schemaS
typeDef Value valueS
value
validateWrapped (TypeWrapper
TypeList : [TypeWrapper]
wrappers) TypeDefinition IN schemaS
tyCont (List [Value valueS]
list) =
  [ValidValue] -> ValidValue
forall (stage :: Stage). [Value stage] -> Value stage
List ([ValidValue] -> ValidValue)
-> Validator schemaS (InputContext ctx) [ValidValue]
-> InputValidator schemaS ctx ValidValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value valueS -> InputValidator schemaS ctx ValidValue)
-> [Value valueS]
-> Validator schemaS (InputContext ctx) [ValidValue]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([TypeWrapper]
-> TypeDefinition IN schemaS
-> Value valueS
-> InputValidator schemaS ctx ValidValue
forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
[TypeWrapper]
-> TypeDefinition IN schemaS
-> Value valueS
-> InputValidator schemaS ctx ValidValue
validateInputByType [TypeWrapper]
wrappers TypeDefinition IN schemaS
tyCont) [Value valueS]
list
{-- 2. VALIDATE TYPES, all wrappers are already Processed --}
{-- VALIDATE OBJECT--}
validateWrapped [] TypeDefinition {TypeContent TRUE IN schemaS
typeContent :: TypeContent TRUE IN schemaS
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent} Value valueS
entryValue =
  TypeContent TRUE IN schemaS
-> Value valueS -> InputValidator schemaS ctx ValidValue
forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
TypeContent TRUE IN schemaS
-> Value valueS -> InputValidator schemaS ctx ValidValue
validateUnwrapped TypeContent TRUE IN schemaS
typeContent Value valueS
entryValue
{-- 3. THROW ERROR: on invalid values --}
validateWrapped [TypeWrapper]
_ TypeDefinition IN schemaS
_ Value valueS
entryValue = Maybe Message
-> Value valueS -> InputValidator schemaS ctx ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe Message -> Value s -> InputValidator schemaS ctx a
violation Maybe Message
forall a. Maybe a
Nothing Value valueS
entryValue

validateUnwrapped ::
  ValidateWithDefault ctx schemaS valueS =>
  TypeContent TRUE IN schemaS ->
  Value valueS ->
  InputValidator schemaS ctx ValidValue
validateUnwrapped :: TypeContent TRUE IN schemaS
-> Value valueS -> InputValidator schemaS ctx ValidValue
validateUnwrapped (DataInputObject FieldsDefinition IN schemaS
parentFields) (Object Object valueS
fields) =
  Object VALID -> ValidValue
forall (stage :: Stage). Object stage -> Value stage
Object (Object VALID -> ValidValue)
-> Validator schemaS (InputContext ctx) (Object VALID)
-> InputValidator schemaS ctx ValidValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldsDefinition IN schemaS
-> Object valueS
-> Validator schemaS (InputContext ctx) (Object VALID)
forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
FieldsDefinition IN schemaS
-> Object valueS -> InputValidator schemaS ctx (Object VALID)
validateInputObject FieldsDefinition IN schemaS
parentFields Object valueS
fields
validateUnwrapped (DataInputUnion DataInputUnion schemaS
inputUnion) (Object Object valueS
rawFields) =
  DataInputUnion schemaS
-> Object valueS -> InputValidator schemaS ctx ValidValue
forall ctx (schemaS :: Stage) (s :: Stage).
ValidateWithDefault ctx schemaS s =>
DataInputUnion schemaS
-> Object s -> InputValidator schemaS ctx ValidValue
validatInputUnion DataInputUnion schemaS
inputUnion Object valueS
rawFields
validateUnwrapped (DataEnum DataEnum schemaS
tags) Value valueS
value =
  DataEnum schemaS
-> Value valueS -> InputValidator schemaS ctx ValidValue
forall (s :: Stage) (valueS :: Stage) (schemaS :: Stage) c.
[DataEnumValue s]
-> Value valueS -> InputValidator schemaS c ValidValue
validateEnum DataEnum schemaS
tags Value valueS
value
validateUnwrapped (DataScalar ScalarDefinition
dataScalar) Value valueS
value =
  ScalarDefinition
-> Value valueS -> InputValidator schemaS ctx ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx.
ScalarDefinition
-> Value s -> InputValidator schemaS ctx ValidValue
validateScalar ScalarDefinition
dataScalar Value valueS
value
validateUnwrapped TypeContent TRUE IN schemaS
_ Value valueS
value = Maybe Message
-> Value valueS -> InputValidator schemaS ctx ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe Message -> Value s -> InputValidator schemaS ctx a
violation Maybe Message
forall a. Maybe a
Nothing Value valueS
value

-- INPUT UNION
validatInputUnion ::
  ValidateWithDefault ctx schemaS s =>
  DataInputUnion schemaS ->
  Object s ->
  InputValidator schemaS ctx (Value VALID)
validatInputUnion :: DataInputUnion schemaS
-> Object s -> InputValidator schemaS ctx ValidValue
validatInputUnion DataInputUnion schemaS
inputUnion Object s
rawFields =
  case DataInputUnion schemaS
-> Object s
-> Either Message (UnionMember IN schemaS, Maybe (Value s))
forall (stage :: Stage) (schemaStage :: Stage).
[UnionMember IN schemaStage]
-> Object stage
-> Either Message (UnionMember IN schemaStage, Maybe (Value stage))
constraintInputUnion DataInputUnion schemaS
inputUnion Object s
rawFields of
    Left Message
message -> Maybe Message -> Value s -> InputValidator schemaS ctx ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe Message -> Value s -> InputValidator schemaS ctx a
violation (Message -> Maybe Message
forall a. a -> Maybe a
Just Message
message) (Object s -> Value s
forall (stage :: Stage). Object stage -> Value stage
Object Object s
rawFields)
    Right (UnionMember {TypeName
memberName :: forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> TypeName
memberName :: TypeName
memberName}, Maybe (Value s)
Nothing) -> TypeName
-> [ObjectEntry VALID] -> InputValidator schemaS ctx ValidValue
forall (m :: * -> *) (s :: Stage).
(Monad m, Failure ValidationErrors m) =>
TypeName -> [ObjectEntry s] -> m (Value s)
mkInputObject TypeName
memberName []
    Right (UnionMember IN schemaS
name, Just Value s
value) -> UnionMember IN schemaS
-> Value s -> InputValidator schemaS ctx ValidValue
forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
UnionMember IN schemaS
-> Value valueS -> InputValidator schemaS ctx ValidValue
validatInputUnionMember UnionMember IN schemaS
name Value s
value

validatInputUnionMember ::
  ValidateWithDefault ctx schemaS valueS =>
  UnionMember IN schemaS ->
  Value valueS ->
  InputValidator schemaS ctx (Value VALID)
validatInputUnionMember :: UnionMember IN schemaS
-> Value valueS -> InputValidator schemaS ctx ValidValue
validatInputUnionMember member :: UnionMember IN schemaS
member@UnionMember {TypeName
memberName :: TypeName
memberName :: forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> TypeName
memberName} Value valueS
value = do
  TypeDefinition IN schemaS
inputDef <- (TypeDefinition IN schemaS, FieldsDefinition IN schemaS)
-> TypeDefinition IN schemaS
forall a b. (a, b) -> a
fst ((TypeDefinition IN schemaS, FieldsDefinition IN schemaS)
 -> TypeDefinition IN schemaS)
-> Validator
     schemaS
     (InputContext ctx)
     (TypeDefinition IN schemaS, FieldsDefinition IN schemaS)
-> Validator schemaS (InputContext ctx) (TypeDefinition IN schemaS)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UnionMember IN schemaS
-> Validator
     schemaS (InputContext ctx) (TypeMemberResponse IN schemaS)
forall (m :: * -> * -> *) c (cat :: TypeCategory) (s :: Stage).
Constraints m c cat s =>
UnionMember cat s -> m c (TypeMemberResponse cat s)
askTypeMember UnionMember IN schemaS
member
  ValidValue
validValue <- [TypeWrapper]
-> TypeDefinition IN schemaS
-> Value valueS
-> InputValidator schemaS ctx ValidValue
forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
[TypeWrapper]
-> TypeDefinition IN schemaS
-> Value valueS
-> InputValidator schemaS ctx ValidValue
validateInputByType [TypeWrapper
TypeMaybe] TypeDefinition IN schemaS
inputDef Value valueS
value
  TypeName
-> [ObjectEntry VALID] -> InputValidator schemaS ctx ValidValue
forall (m :: * -> *) (s :: Stage).
(Monad m, Failure ValidationErrors m) =>
TypeName -> [ObjectEntry s] -> m (Value s)
mkInputObject TypeName
memberName [FieldName -> ValidValue -> ObjectEntry VALID
forall (s :: Stage). FieldName -> Value s -> ObjectEntry s
ObjectEntry (TypeName -> FieldName
toFieldName TypeName
memberName) ValidValue
validValue]

mkInputObject :: (Monad m, Failure ValidationErrors m) => TypeName -> [ObjectEntry s] -> m (Value s)
mkInputObject :: TypeName -> [ObjectEntry s] -> m (Value s)
mkInputObject TypeName
name [ObjectEntry s]
xs = Object s -> Value s
forall (stage :: Stage). Object stage -> Value stage
Object (Object s -> Value s) -> m (Object s) -> m (Value s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ObjectEntry s] -> m (Object s)
forall k (m :: k -> *) a (coll :: k).
FromElems m a coll =>
[a] -> m coll
fromElems (FieldName -> Value s -> ObjectEntry s
forall (s :: Stage). FieldName -> Value s -> ObjectEntry s
ObjectEntry FieldName
"__typename" (TypeName -> Value s
forall (stage :: Stage). TypeName -> Value stage
Enum TypeName
name) ObjectEntry s -> [ObjectEntry s] -> [ObjectEntry s]
forall a. a -> [a] -> [a]
: [ObjectEntry s]
xs)

-- INUT Object
validateInputObject ::
  ValidateWithDefault ctx schemaS valueS =>
  FieldsDefinition IN schemaS ->
  Object valueS ->
  InputValidator schemaS ctx (Object VALID)
validateInputObject :: FieldsDefinition IN schemaS
-> Object valueS -> InputValidator schemaS ctx (Object VALID)
validateInputObject FieldsDefinition IN schemaS
fieldsDef Object valueS
object =
  (ObjectEntry valueS
 -> Validator
      schemaS (InputContext ctx) (FieldDefinition IN schemaS))
-> Object valueS -> Validator schemaS (InputContext ctx) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (ObjectEntry valueS
-> FieldsDefinition IN schemaS
-> Validator
     schemaS (InputContext ctx) (FieldDefinition IN schemaS)
forall k a c sel ctx (s :: Stage).
(Selectable k a c, Unknown c sel ctx, KeyOf k sel) =>
sel -> c -> Validator s ctx a
`selectKnown` FieldsDefinition IN schemaS
fieldsDef) Object valueS
object
    Validator schemaS (InputContext ctx) ()
-> InputValidator schemaS ctx (Object VALID)
-> InputValidator schemaS ctx (Object VALID)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (FieldDefinition IN schemaS
 -> Validator schemaS (InputContext ctx) (ObjectEntry VALID))
-> FieldsDefinition IN schemaS
-> InputValidator schemaS ctx (Object VALID)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Object valueS
-> FieldDefinition IN schemaS
-> Validator schemaS (InputContext ctx) (ObjectEntry VALID)
forall c (schemaS :: Stage) (s :: Stage).
ValidateWithDefault c schemaS s =>
Object s
-> FieldDefinition IN schemaS
-> Validator schemaS (InputContext c) (ObjectEntry VALID)
validateWithDefault Object valueS
object) FieldsDefinition IN schemaS
fieldsDef

class ValidateWithDefault c schemaS s where
  validateWithDefault ::
    Object s ->
    FieldDefinition IN schemaS ->
    Validator schemaS (InputContext c) (ObjectEntry VALID)

instance ValidateWithDefault c VALID s where
  validateWithDefault :: Object s
-> FieldDefinition IN VALID
-> Validator VALID (InputContext c) (ObjectEntry VALID)
validateWithDefault Object s
object fieldDef :: FieldDefinition IN VALID
fieldDef@FieldDefinition {FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName :: FieldName
fieldName} =
    FieldName -> ValidValue -> ObjectEntry VALID
forall (s :: Stage). FieldName -> Value s -> ObjectEntry s
ObjectEntry FieldName
fieldName
      (ValidValue -> ObjectEntry VALID)
-> Validator VALID (InputContext c) ValidValue
-> Validator VALID (InputContext c) (ObjectEntry VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ValidValue -> Validator VALID (InputContext c) ValidValue)
-> (ObjectEntry s -> Validator VALID (InputContext c) ValidValue)
-> FieldDefinition IN VALID
-> Object s
-> Validator VALID (InputContext c) ValidValue
forall ctx values value (s :: Stage) validValue.
(Selectable FieldName value values, MissingRequired values ctx,
 MonadContext (Validator s) s ctx) =>
(Value s -> Validator s ctx validValue)
-> (value -> Validator s ctx validValue)
-> FieldDefinition IN s
-> values
-> Validator s ctx validValue
selectWithDefaultValue
        ValidValue -> Validator VALID (InputContext c) ValidValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (FieldDefinition IN VALID
-> Value s -> Validator VALID (InputContext c) ValidValue
forall c (schemaS :: Stage) (s :: Stage).
ValidateWithDefault c schemaS s =>
FieldDefinition IN schemaS
-> Value s -> Validator schemaS (InputContext c) ValidValue
validateValueByField FieldDefinition IN VALID
fieldDef (Value s -> Validator VALID (InputContext c) ValidValue)
-> (ObjectEntry s -> Value s)
-> ObjectEntry s
-> Validator VALID (InputContext c) ValidValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectEntry s -> Value s
forall (s :: Stage). ObjectEntry s -> Value s
entryValue)
        FieldDefinition IN VALID
fieldDef
        Object s
object

instance ValidateWithDefault c CONST s where
  validateWithDefault :: Object s
-> FieldDefinition IN CONST
-> Validator CONST (InputContext c) (ObjectEntry VALID)
validateWithDefault Object s
object fieldDef :: FieldDefinition IN CONST
fieldDef@FieldDefinition {FieldName
fieldName :: FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName} =
    FieldName -> ValidValue -> ObjectEntry VALID
forall (s :: Stage). FieldName -> Value s -> ObjectEntry s
ObjectEntry FieldName
fieldName
      (ValidValue -> ObjectEntry VALID)
-> Validator CONST (InputContext c) ValidValue
-> Validator CONST (InputContext c) (ObjectEntry VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value CONST -> Validator CONST (InputContext c) ValidValue)
-> (ObjectEntry s -> Validator CONST (InputContext c) ValidValue)
-> FieldDefinition IN CONST
-> Object s
-> Validator CONST (InputContext c) ValidValue
forall ctx values value (s :: Stage) validValue.
(Selectable FieldName value values, MissingRequired values ctx,
 MonadContext (Validator s) s ctx) =>
(Value s -> Validator s ctx validValue)
-> (value -> Validator s ctx validValue)
-> FieldDefinition IN s
-> values
-> Validator s ctx validValue
selectWithDefaultValue
        (FieldDefinition IN CONST
-> Value CONST -> Validator CONST (InputContext c) ValidValue
forall c (schemaS :: Stage) (s :: Stage).
ValidateWithDefault c schemaS s =>
FieldDefinition IN schemaS
-> Value s -> Validator schemaS (InputContext c) ValidValue
validateValueByField FieldDefinition IN CONST
fieldDef)
        (FieldDefinition IN CONST
-> Value s -> Validator CONST (InputContext c) ValidValue
forall c (schemaS :: Stage) (s :: Stage).
ValidateWithDefault c schemaS s =>
FieldDefinition IN schemaS
-> Value s -> Validator schemaS (InputContext c) ValidValue
validateValueByField FieldDefinition IN CONST
fieldDef (Value s -> Validator CONST (InputContext c) ValidValue)
-> (ObjectEntry s -> Value s)
-> ObjectEntry s
-> Validator CONST (InputContext c) ValidValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectEntry s -> Value s
forall (s :: Stage). ObjectEntry s -> Value s
entryValue)
        FieldDefinition IN CONST
fieldDef
        Object s
object

-- Leaf Validations
validateScalar ::
  ScalarDefinition ->
  Value s ->
  InputValidator schemaS ctx ValidValue
validateScalar :: ScalarDefinition
-> Value s -> InputValidator schemaS ctx ValidValue
validateScalar ScalarDefinition {ValidValue -> Either Token ValidValue
validateValue :: ScalarDefinition -> ValidValue -> Either Token ValidValue
validateValue :: ValidValue -> Either Token ValidValue
validateValue} Value s
value = do
  TypeName
typeName <- (Scope -> TypeName)
-> Validator schemaS (InputContext ctx) TypeName
forall (m :: * -> * -> *) (s :: Stage) c a.
MonadContext m s c =>
(Scope -> a) -> m c a
asksScope Scope -> TypeName
currentTypeName
  ValidValue
scalarValue <- TypeName -> Value s -> InputValidator schemaS ctx ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx.
TypeName -> Value s -> InputValidator schemaS ctx ValidValue
toScalar TypeName
typeName Value s
value
  case ValidValue -> Either Token ValidValue
validateValue ValidValue
scalarValue of
    Right ValidValue
_ -> ValidValue -> InputValidator schemaS ctx ValidValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure ValidValue
scalarValue
    Left Token
"" -> Maybe Message -> Value s -> InputValidator schemaS ctx ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe Message -> Value s -> InputValidator schemaS ctx a
violation Maybe Message
forall a. Maybe a
Nothing Value s
value
    Left Token
message -> Maybe Message -> Value s -> InputValidator schemaS ctx ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe Message -> Value s -> InputValidator schemaS ctx a
violation (Message -> Maybe Message
forall a. a -> Maybe a
Just (Message -> Maybe Message) -> Message -> Maybe Message
forall a b. (a -> b) -> a -> b
$ Token -> Message
forall a. Msg a => a -> Message
msg Token
message) Value s
value
  where
    toScalar :: TypeName -> Value s -> InputValidator schemaS ctx ValidValue
    toScalar :: TypeName -> Value s -> InputValidator schemaS ctx ValidValue
toScalar TypeName
typeName (Scalar ScalarValue
x) | TypeName -> ScalarValue -> Bool
isValidDefault TypeName
typeName ScalarValue
x = ValidValue -> InputValidator schemaS ctx ValidValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ScalarValue -> ValidValue
forall (stage :: Stage). ScalarValue -> Value stage
Scalar ScalarValue
x)
    toScalar TypeName
_ Value s
_ = Maybe Message -> Value s -> InputValidator schemaS ctx ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe Message -> Value s -> InputValidator schemaS ctx a
violation Maybe Message
forall a. Maybe a
Nothing Value s
value

isValidDefault :: TypeName -> ScalarValue -> Bool
isValidDefault :: TypeName -> ScalarValue -> Bool
isValidDefault TypeName
"Boolean" = ScalarValue -> Bool
isBoolean
isValidDefault TypeName
"String" = ScalarValue -> Bool
isString
isValidDefault TypeName
"Float" = [ScalarValue -> Bool] -> ScalarValue -> Bool
forall a. [a -> Bool] -> a -> Bool
oneOf [ScalarValue -> Bool
isFloat, ScalarValue -> Bool
isInt]
isValidDefault TypeName
"Int" = ScalarValue -> Bool
isInt
isValidDefault TypeName
"ID" = [ScalarValue -> Bool] -> ScalarValue -> Bool
forall a. [a -> Bool] -> a -> Bool
oneOf [ScalarValue -> Bool
isInt, ScalarValue -> Bool
isFloat, ScalarValue -> Bool
isString]
isValidDefault TypeName
_ = Bool -> ScalarValue -> Bool
forall a b. a -> b -> a
const Bool
True

oneOf :: [a -> Bool] -> a -> Bool
oneOf :: [a -> Bool] -> a -> Bool
oneOf [a -> Bool]
ls a
v = ((a -> Bool) -> Bool) -> [a -> Bool] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (a
v a -> (a -> Bool) -> Bool
forall a b. a -> (a -> b) -> b
&) [a -> Bool]
ls

isBoolean :: ScalarValue -> Bool
isBoolean :: ScalarValue -> Bool
isBoolean Boolean {} = Bool
True
isBoolean ScalarValue
_ = Bool
False

isString :: ScalarValue -> Bool
isString :: ScalarValue -> Bool
isString String {} = Bool
True
isString ScalarValue
_ = Bool
False

isFloat :: ScalarValue -> Bool
isFloat :: ScalarValue -> Bool
isFloat Float {} = Bool
True
isFloat ScalarValue
_ = Bool
False

isInt :: ScalarValue -> Bool
isInt :: ScalarValue -> Bool
isInt Int {} = Bool
True
isInt ScalarValue
_ = Bool
False

isVariableValue :: InputValidator schemaS c Bool
isVariableValue :: InputValidator schemaS c Bool
isVariableValue =
  \case
    SourceVariable {Bool
isDefaultValue :: InputSource -> Bool
isDefaultValue :: Bool
isDefaultValue} -> Bool -> Bool
not Bool
isDefaultValue
    InputSource
_ -> Bool
False
    (InputSource -> Bool)
-> Validator schemaS (InputContext c) InputSource
-> InputValidator schemaS c Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Validator schemaS (InputContext c) InputSource
forall (m :: * -> * -> *) c (s :: Stage).
(GetWith c InputSource, MonadContext m s c) =>
m c InputSource
inputValueSource

validateEnum ::
  [DataEnumValue s] ->
  Value valueS ->
  InputValidator schemaS c ValidValue
validateEnum :: [DataEnumValue s]
-> Value valueS -> InputValidator schemaS c ValidValue
validateEnum [DataEnumValue s]
enumValues value :: Value valueS
value@(Scalar (String Token
enumValue))
  | Token -> TypeName
TypeName Token
enumValue TypeName -> [TypeName] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [TypeName]
tags = do
    Bool
isFromVariable <- InputValidator schemaS c Bool
forall (schemaS :: Stage) c. InputValidator schemaS c Bool
isVariableValue
    if Bool
isFromVariable
      then ValidValue -> InputValidator schemaS c ValidValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeName -> ValidValue
forall (stage :: Stage). TypeName -> Value stage
Enum (Token -> TypeName
TypeName Token
enumValue))
      else Maybe Message
-> Value valueS -> InputValidator schemaS c ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe Message -> Value s -> InputValidator schemaS ctx a
violation Maybe Message
forall a. Maybe a
Nothing Value valueS
value
  where
    tags :: [TypeName]
tags = (DataEnumValue s -> TypeName) -> [DataEnumValue s] -> [TypeName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DataEnumValue s -> TypeName
forall (s :: Stage). DataEnumValue s -> TypeName
enumName [DataEnumValue s]
enumValues
validateEnum [DataEnumValue s]
enumValues value :: Value valueS
value@(Enum TypeName
enumValue)
  | TypeName
enumValue TypeName -> [TypeName] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [TypeName]
tags = ValidValue -> InputValidator schemaS c ValidValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeName -> ValidValue
forall (stage :: Stage). TypeName -> Value stage
Enum TypeName
enumValue)
  | Bool
otherwise = Maybe Message
-> Value valueS -> InputValidator schemaS c ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe Message -> Value s -> InputValidator schemaS ctx a
violation Maybe Message
forall a. Maybe a
Nothing Value valueS
value
  where
    tags :: [TypeName]
tags = (DataEnumValue s -> TypeName) -> [DataEnumValue s] -> [TypeName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DataEnumValue s -> TypeName
forall (s :: Stage). DataEnumValue s -> TypeName
enumName [DataEnumValue s]
enumValues
validateEnum [DataEnumValue s]
_ Value valueS
value = Maybe Message
-> Value valueS -> InputValidator schemaS c ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe Message -> Value s -> InputValidator schemaS ctx a
violation Maybe Message
forall a. Maybe a
Nothing Value valueS
value