{-# LANGUAGE DuplicateRecordFields #-}
{-# 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 Control.Monad.Except (throwError)
import Data.Morpheus.Error.Input (typeViolation)
import Data.Morpheus.Error.Variable (incompatibleVariableType)
import Data.Morpheus.Internal.Utils
  ( singleton,
  )
import Data.Morpheus.Types.Internal.AST
  ( CONST,
    DataEnumValue (..),
    FieldDefinition (..),
    FieldName,
    FieldsDefinition,
    GQLError,
    IN,
    Object,
    ObjectEntry (..),
    Ref (..),
    ScalarDefinition (..),
    ScalarValue (..),
    TRUE,
    TypeContent (..),
    TypeDefinition (..),
    TypeName,
    TypeRef (..),
    TypeWrapper (..),
    Typed (..),
    UnionMember (..),
    UnionTypeDefinition,
    VALID,
    ValidValue,
    Value (..),
    Variable (..),
    VariableContent (..),
    atPositions,
    isNullable,
    isSubtype,
    mkMaybeType,
    mkTypeRef,
    msg,
    packName,
    toCategory,
    typed,
    unitFieldName,
    unitTypeName,
    untyped,
  )
import Data.Morpheus.Types.Internal.Validation
  ( askType,
    askTypeMember,
    constraintInputUnion,
    selectKnown,
    selectWithDefaultValue,
  )
import Data.Morpheus.Types.Internal.Validation.Scope (setType)
import Data.Morpheus.Types.Internal.Validation.Validator
import Relude

violation ::
  Maybe GQLError ->
  Value s ->
  InputValidator schemaS ctx a
violation :: Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation Maybe GQLError
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 (s :: Stage) ctx (m :: * -> *) a.
MonadReader (ValidatorContext s ctx) m =>
(Scope -> a) -> m a
asksScope Scope -> Scope
forall a. a -> a
id
  GQLError
prefix <- InputValidator schemaS ctx GQLError
forall (s :: Stage) ctx. InputValidator s ctx GQLError
inputMessagePrefix
  GQLError -> InputValidator schemaS ctx a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> InputValidator schemaS ctx a)
-> GQLError -> InputValidator schemaS ctx a
forall a b. (a -> b) -> a -> b
$
    ( GQLError
prefix
        GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> TypeRef -> Value s -> GQLError
forall (s :: Stage). TypeRef -> Value s -> GQLError
typeViolation
          (TypeName -> TypeWrapper -> TypeRef
TypeRef TypeName
currentTypeName TypeWrapper
currentTypeWrappers)
          Value s
value
        GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError -> (GQLError -> GQLError) -> Maybe GQLError -> GQLError
forall b a. b -> (a -> b) -> Maybe a -> b
maybe GQLError
"" (GQLError
" " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<>) Maybe GQLError
message
    )
      GQLError -> Maybe Position -> GQLError
forall (t :: * -> *).
Foldable t =>
GQLError -> t Position -> GQLError
`atPositions` Maybe Position
position

checkTypeCompatibility ::
  TypeRef ->
  Ref FieldName ->
  Variable VALID ->
  InputValidator schemaS ctx ValidValue
checkTypeCompatibility :: TypeRef
-> Ref FieldName
-> Variable VALID
-> InputValidator schemaS ctx ValidValue
checkTypeCompatibility TypeRef
valueType Ref FieldName
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
variableType TypeRef -> TypeRef -> Bool
forall t. Subtyping t => t -> t -> Bool
`isSubtype` TypeRef
valueType = ValidValue -> InputValidator schemaS ctx ValidValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure ValidValue
value
  | Bool
otherwise = GQLError -> InputValidator schemaS ctx ValidValue
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> InputValidator schemaS ctx ValidValue)
-> GQLError -> InputValidator schemaS ctx ValidValue
forall a b. (a -> b) -> a -> b
$ Ref FieldName -> Variable VALID -> TypeRef -> GQLError
forall (s :: Stage).
Ref FieldName -> Variable s -> TypeRef -> GQLError
incompatibleVariableType Ref FieldName
ref Variable VALID
var TypeRef
valueType

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) ctx.
Constraints m c cat s ctx =>
Typed cat s TypeRef -> m (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 =
  (Scope -> Scope)
-> InputValidator schemaS ctx ValidValue
-> InputValidator schemaS ctx ValidValue
forall (s :: Stage) c (m :: * -> *) b.
MonadReader (ValidatorContext s c) m =>
(Scope -> Scope) -> m b -> m b
withScope (TypeDefinition IN schemaS -> TypeWrapper -> Scope -> Scope
forall (c :: TypeCategory) (s :: Stage).
TypeDefinition c s -> TypeWrapper -> Scope -> Scope
setType 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 FieldName
ref Variable VALID
variable) = do
  TypeName
typeName <- (Scope -> TypeName)
-> Validator schemaS (InputContext ctx) TypeName
forall (s :: Stage) ctx (m :: * -> *) a.
MonadReader (ValidatorContext s ctx) m =>
(Scope -> a) -> m a
asksScope Scope -> TypeName
currentTypeName
  TypeRef
-> Ref FieldName
-> Variable VALID
-> InputValidator schemaS ctx ValidValue
forall (schemaS :: Stage) ctx.
TypeRef
-> Ref FieldName
-> Variable VALID
-> InputValidator schemaS ctx ValidValue
checkTypeCompatibility (TypeName -> TypeWrapper -> TypeRef
TypeRef TypeName
typeName TypeWrapper
wrappers) Ref FieldName
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 GQLError
-> Value Any -> InputValidator schemaS ctx ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation Maybe GQLError
forall a. Maybe a
Nothing Value Any
forall (stage :: Stage). Value stage
Null
-- Validate LIST
validateWrapped (TypeList TypeWrapper
wrappers Bool
_) 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 BaseType {} 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
{-- 3. THROW ERROR: on invalid values --}
validateWrapped TypeWrapper
_ TypeDefinition IN schemaS
_ Value valueS
entryValue = Maybe GQLError
-> Value valueS -> InputValidator schemaS ctx ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation Maybe GQLError
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 UnionTypeDefinition IN schemaS
inputUnion) (Object Object valueS
rawFields) =
  UnionTypeDefinition IN schemaS
-> Object valueS -> InputValidator schemaS ctx ValidValue
forall ctx (schemaS :: Stage) (s :: Stage).
ValidateWithDefault ctx schemaS s =>
UnionTypeDefinition IN schemaS
-> Object s -> InputValidator schemaS ctx ValidValue
validateInputUnion UnionTypeDefinition IN 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 GQLError
-> Value valueS -> InputValidator schemaS ctx ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation Maybe GQLError
forall a. Maybe a
Nothing Value valueS
value

-- INPUT UNION
validateInputUnion ::
  ValidateWithDefault ctx schemaS s =>
  UnionTypeDefinition IN schemaS ->
  Object s ->
  InputValidator schemaS ctx (Value VALID)
validateInputUnion :: UnionTypeDefinition IN schemaS
-> Object s -> InputValidator schemaS ctx ValidValue
validateInputUnion UnionTypeDefinition IN schemaS
inputUnion Object s
rawFields =
  case UnionTypeDefinition IN schemaS
-> Object s -> Either GQLError (UnionMember IN schemaS, Value s)
forall (stage :: Stage) (schemaStage :: Stage).
UnionTypeDefinition IN schemaStage
-> Object stage
-> Either GQLError (UnionMember IN schemaStage, Value stage)
constraintInputUnion UnionTypeDefinition IN schemaS
inputUnion Object s
rawFields of
    Left GQLError
message -> Maybe GQLError -> Value s -> InputValidator schemaS ctx ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation (GQLError -> Maybe GQLError
forall a. a -> Maybe a
Just (GQLError -> Maybe GQLError) -> GQLError -> Maybe GQLError
forall a b. (a -> b) -> a -> b
$ GQLError -> GQLError
forall a. Msg a => a -> GQLError
msg GQLError
message) (Object s -> Value s
forall (stage :: Stage). Object stage -> Value stage
Object Object s
rawFields)
    Right (UnionMember IN schemaS
name, 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
validateInputUnionMember UnionMember IN schemaS
name Value s
value

validateInputUnionMember ::
  ValidateWithDefault ctx schemaS valueS =>
  UnionMember IN schemaS ->
  Value valueS ->
  InputValidator schemaS ctx (Value VALID)
validateInputUnionMember :: UnionMember IN schemaS
-> Value valueS -> InputValidator schemaS ctx ValidValue
validateInputUnionMember UnionMember IN schemaS
member Value valueS
value = do
  TypeDefinition IN schemaS
inputDef <- Validator schemaS (InputContext ctx) (TypeDefinition IN schemaS)
askDef
  UnionMember IN schemaS -> ValidValue -> ValidValue
forall (s' :: Stage) (s :: Stage).
UnionMember IN s' -> Value s -> Value s
mkInputUnionValue UnionMember IN schemaS
member (ValidValue -> ValidValue)
-> InputValidator schemaS ctx ValidValue
-> InputValidator schemaS ctx ValidValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
mkMaybeType TypeDefinition IN schemaS
inputDef Value valueS
value
  where
    askDef :: Validator schemaS (InputContext ctx) (TypeDefinition IN schemaS)
askDef
      | UnionMember IN schemaS -> Bool
forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> Bool
nullary UnionMember IN schemaS
member = Typed IN schemaS TypeRef
-> Validator schemaS (InputContext ctx) (TypeDefinition IN schemaS)
forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx.
Constraints m c cat s ctx =>
Typed cat s TypeRef -> m (TypeDefinition cat s)
askType (TypeRef -> Typed IN schemaS TypeRef
forall (cat :: TypeCategory) (s :: Stage) a. a -> Typed cat s a
Typed (TypeRef -> Typed IN schemaS TypeRef)
-> TypeRef -> Typed IN schemaS TypeRef
forall a b. (a -> b) -> a -> b
$ TypeName -> TypeRef
mkTypeRef TypeName
unitTypeName)
      | Bool
otherwise = TypeDefinition INPUT_OBJECT schemaS -> TypeDefinition IN schemaS
forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory)
       (k' :: TypeCategory) (s :: Stage).
ToCategory a k k' =>
a k s -> a k' s
toCategory (TypeDefinition INPUT_OBJECT schemaS -> TypeDefinition IN schemaS)
-> Validator
     schemaS (InputContext ctx) (TypeDefinition INPUT_OBJECT 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) (TypeDefinition (ToOBJECT IN) schemaS)
forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx.
Constraints m c cat s ctx =>
UnionMember cat s -> m (TypeDefinition (ToOBJECT cat) s)
askTypeMember UnionMember IN schemaS
member

mkInputUnionValue :: UnionMember IN s' -> Value s -> Value s
mkInputUnionValue :: UnionMember IN s' -> Value s -> Value s
mkInputUnionValue
  UnionMember
    { TypeName
memberName :: forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> TypeName
memberName :: TypeName
memberName,
      Bool
nullary :: Bool
nullary :: forall (cat :: TypeCategory) (s :: Stage).
UnionMember cat s -> Bool
nullary
    } = Object s -> Value s
forall (stage :: Stage). Object stage -> Value stage
Object (Object s -> Value s)
-> (Value s -> Object s) -> Value s -> Value s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> ObjectEntry s -> Object s
forall k (m :: * -> *) a. IsMap k m => k -> a -> m a
singleton FieldName
key (ObjectEntry s -> Object s)
-> (Value s -> ObjectEntry s) -> Value s -> Object s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Value s -> ObjectEntry s
forall (s :: Stage). FieldName -> Value s -> ObjectEntry s
ObjectEntry FieldName
key (Value s -> ObjectEntry s)
-> (Value s -> Value s) -> Value s -> ObjectEntry s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value s -> Value s
packNullary
    where
      key :: FieldName
key = TypeName -> FieldName
coerce TypeName
memberName
      packNullary :: Value s -> Value s
packNullary
        | Bool
nullary = Object s -> Value s
forall (stage :: Stage). Object stage -> Value stage
Object (Object s -> Value s)
-> (Value s -> Object s) -> Value s -> Value s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> ObjectEntry s -> Object s
forall k (m :: * -> *) a. IsMap k m => k -> a -> m a
singleton FieldName
unitFieldName (ObjectEntry s -> Object s)
-> (Value s -> ObjectEntry s) -> Value s -> Object s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldName -> Value s -> ObjectEntry s
forall (s :: Stage). FieldName -> Value s -> ObjectEntry s
ObjectEntry FieldName
unitFieldName
        | Bool
otherwise = Value s -> Value s
forall a. a -> a
id

-- INPUT 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 (c :: * -> *) sel ctx a (s :: Stage).
(IsMap k c, Unknown sel ctx, KeyOf k sel) =>
sel -> c a -> 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 (c :: * -> *) (s :: Stage) validValue a.
(IsMap FieldName c, MissingRequired (c a) ctx) =>
(Value s -> Validator s ctx validValue)
-> (a -> Validator s ctx validValue)
-> FieldDefinition IN s
-> c a
-> 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 (c :: * -> *) (s :: Stage) validValue a.
(IsMap FieldName c, MissingRequired (c a) ctx) =>
(Value s -> Validator s ctx validValue)
-> (a -> Validator s ctx validValue)
-> FieldDefinition IN s
-> c a
-> 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 (s :: Stage) ctx (m :: * -> *) a.
MonadReader (ValidatorContext s ctx) m =>
(Scope -> a) -> m 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 GQLError -> Value s -> InputValidator schemaS ctx ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation Maybe GQLError
forall a. Maybe a
Nothing Value s
value
    Left Token
message -> Maybe GQLError -> Value s -> InputValidator schemaS ctx ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation (GQLError -> Maybe GQLError
forall a. a -> Maybe a
Just (GQLError -> Maybe GQLError) -> GQLError -> Maybe GQLError
forall a b. (a -> b) -> a -> b
$ Token -> GQLError
forall a. Msg a => a -> GQLError
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 GQLError -> Value s -> InputValidator schemaS ctx ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation Maybe GQLError
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 (s :: Stage) c (m :: * -> *).
MonadReader (ValidatorContext s (InputContext c)) m =>
m 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
forall a (t :: NAME). NamePacking a => a -> Name t
packName 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
forall a (t :: NAME). NamePacking a => a -> Name t
packName Token
enumValue))
      else Maybe GQLError
-> Value valueS -> InputValidator schemaS c ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation Maybe GQLError
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 GQLError
-> Value valueS -> InputValidator schemaS c ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation Maybe GQLError
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 GQLError
-> Value valueS -> InputValidator schemaS c ValidValue
forall (s :: Stage) (schemaS :: Stage) ctx a.
Maybe GQLError -> Value s -> InputValidator schemaS ctx a
violation Maybe GQLError
forall a. Maybe a
Nothing Value valueS
value