{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Validation.Internal.Arguments
  ( validateDirectiveArguments,
    validateFieldArguments,
    ArgumentsConstraints,
    Resolve,
  )
where

import Data.Morpheus.Types.Internal.AST
  ( Argument (..),
    ArgumentDefinition (..),
    Arguments,
    ArgumentsDefinition,
    CONST,
    DirectiveDefinition (..),
    FieldDefinition (..),
    IN,
    OUT,
    ObjectEntry (..),
    Position (..),
    RAW,
    VALID,
    Value (..),
    VariableDefinitions,
    fieldArguments,
    typed,
  )
import Data.Morpheus.Types.Internal.Validation
  ( FragmentValidator,
    InputSource (..),
    MissingRequired,
    OperationContext,
    Scope (..),
    Validator,
    askVariables,
    asksScope,
    selectKnown,
    selectRequired,
    selectWithDefaultValue,
    setPosition,
    startInput,
    withScope,
  )
import Data.Morpheus.Validation.Internal.Value
  ( ValidateWithDefault,
    validateInputByTypeRef,
  )
import Relude hiding (empty)

type VariableConstraints ctx =
  ( MissingRequired (VariableDefinitions VALID) ctx
  )

type ArgumentsConstraints c schemaS valueS =
  ( Resolve Argument valueS c,
    ValidateWithDefault c schemaS schemaS,
    ValidateWithDefault c schemaS CONST
  )

validateArgument ::
  ( ValidateWithDefault ctx schemaS valueS,
    ValidateWithDefault ctx schemaS schemaS
  ) =>
  Arguments valueS ->
  ArgumentDefinition schemaS ->
  Validator schemaS ctx (Argument VALID)
validateArgument :: Arguments valueS
-> ArgumentDefinition schemaS
-> Validator schemaS ctx (Argument VALID)
validateArgument
  Arguments valueS
requestArgs
  ArgumentDefinition {FieldDefinition IN schemaS
argument :: forall (s :: Stage). ArgumentDefinition s -> FieldDefinition IN s
argument :: FieldDefinition IN schemaS
argument} =
    (Value schemaS -> Validator schemaS ctx (Argument VALID))
-> (Argument valueS -> Validator schemaS ctx (Argument VALID))
-> FieldDefinition IN schemaS
-> Arguments valueS
-> Validator schemaS ctx (Argument VALID)
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 schemaS
-> Value schemaS -> Validator schemaS ctx (Argument schemaS)
forall (s :: Stage) (schemaS :: Stage) (schemaStage :: Stage) ctx.
FieldDefinition IN s
-> Value schemaS -> Validator schemaStage ctx (Argument schemaS)
toArgument FieldDefinition IN schemaS
argument (Value schemaS -> Validator schemaS ctx (Argument schemaS))
-> (Argument schemaS -> Validator schemaS ctx (Argument VALID))
-> Value schemaS
-> Validator schemaS ctx (Argument VALID)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> FieldDefinition IN schemaS
-> Argument schemaS -> Validator schemaS ctx (Argument VALID)
forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
FieldDefinition IN schemaS
-> Argument valueS -> Validator schemaS ctx (Argument VALID)
validateArgumentValue FieldDefinition IN schemaS
argument)
      (FieldDefinition IN schemaS
-> Argument valueS -> Validator schemaS ctx (Argument VALID)
forall ctx (schemaS :: Stage) (valueS :: Stage).
ValidateWithDefault ctx schemaS valueS =>
FieldDefinition IN schemaS
-> Argument valueS -> Validator schemaS ctx (Argument VALID)
validateArgumentValue FieldDefinition IN schemaS
argument)
      FieldDefinition IN schemaS
argument
      Arguments valueS
requestArgs

toArgument :: FieldDefinition IN s -> Value schemaS -> Validator schemaStage ctx (Argument schemaS)
toArgument :: FieldDefinition IN s
-> Value schemaS -> Validator schemaStage ctx (Argument schemaS)
toArgument
  FieldDefinition {FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName :: FieldName
fieldName}
  Value schemaS
value = Position -> Argument schemaS
mkArg (Position -> Argument schemaS)
-> (Maybe Position -> Position)
-> Maybe Position
-> Argument schemaS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Position -> Maybe Position -> Position
forall a. a -> Maybe a -> a
fromMaybe (Int -> Int -> Position
Position Int
0 Int
0) (Maybe Position -> Argument schemaS)
-> Validator schemaStage ctx (Maybe Position)
-> Validator schemaStage ctx (Argument schemaS)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Scope -> Maybe Position)
-> Validator schemaStage ctx (Maybe Position)
forall (s :: Stage) ctx (m :: * -> *) a.
MonadReader (ValidatorContext s ctx) m =>
(Scope -> a) -> m a
asksScope Scope -> Maybe Position
position
    where
      mkArg :: Position -> Argument schemaS
mkArg Position
pos = Position -> FieldName -> Value schemaS -> Argument schemaS
forall (valid :: Stage).
Position -> FieldName -> Value valid -> Argument valid
Argument Position
pos FieldName
fieldName Value schemaS
value

validateArgumentValue ::
  (ValidateWithDefault ctx schemaS valueS) =>
  FieldDefinition IN schemaS ->
  Argument valueS ->
  Validator schemaS ctx (Argument VALID)
validateArgumentValue :: FieldDefinition IN schemaS
-> Argument valueS -> Validator schemaS ctx (Argument VALID)
validateArgumentValue
  FieldDefinition IN schemaS
field
  Argument {Value valueS
argumentValue :: forall (valid :: Stage). Argument valid -> Value valid
argumentValue :: Value valueS
argumentValue, Position
FieldName
argumentName :: forall (valid :: Stage). Argument valid -> FieldName
argumentPosition :: forall (valid :: Stage). Argument valid -> Position
argumentName :: FieldName
argumentPosition :: Position
..} =
    (Scope -> Scope)
-> Validator schemaS ctx (Argument VALID)
-> Validator schemaS ctx (Argument VALID)
forall (s :: Stage) c (m :: * -> *) b.
MonadReader (ValidatorContext s c) m =>
(Scope -> Scope) -> m b -> m b
withScope (Position -> Scope -> Scope
setPosition Position
argumentPosition) (Validator schemaS ctx (Argument VALID)
 -> Validator schemaS ctx (Argument VALID))
-> Validator schemaS ctx (Argument VALID)
-> Validator schemaS ctx (Argument VALID)
forall a b. (a -> b) -> a -> b
$
      InputSource
-> InputValidator schemaS ctx (Argument VALID)
-> Validator schemaS ctx (Argument VALID)
forall (s :: Stage) ctx a.
InputSource -> InputValidator s ctx a -> Validator s ctx a
startInput (FieldName -> InputSource
SourceArgument FieldName
argumentName) (InputValidator schemaS ctx (Argument VALID)
 -> Validator schemaS ctx (Argument VALID))
-> InputValidator schemaS ctx (Argument VALID)
-> Validator schemaS ctx (Argument VALID)
forall a b. (a -> b) -> a -> b
$
        Position -> FieldName -> Value VALID -> Argument VALID
forall (valid :: Stage).
Position -> FieldName -> Value valid -> Argument valid
Argument
          Position
argumentPosition
          FieldName
argumentName
          (Value VALID -> Argument VALID)
-> Validator schemaS (InputContext ctx) (Value VALID)
-> InputValidator schemaS ctx (Argument VALID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Typed IN schemaS TypeRef
-> Value valueS
-> Validator schemaS (InputContext ctx) (Value VALID)
forall c (schemaS :: Stage) (s :: Stage).
ValidateWithDefault c schemaS s =>
Typed IN schemaS TypeRef
-> Value s -> Validator schemaS (InputContext c) (Value VALID)
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) Value valueS
argumentValue

validateFieldArguments ::
  FieldDefinition OUT VALID ->
  Arguments RAW ->
  FragmentValidator s (Arguments VALID)
validateFieldArguments :: FieldDefinition OUT VALID
-> Arguments RAW -> FragmentValidator s (Arguments VALID)
validateFieldArguments FieldDefinition OUT VALID
field =
  (Argument CONST
 -> Validator
      VALID (OperationContext VALID s) (ArgumentDefinition VALID))
-> ArgumentsDefinition VALID
-> Arguments RAW
-> FragmentValidator s (Arguments VALID)
forall ctx (schemaStage :: Stage) (s :: Stage).
ArgumentsConstraints ctx schemaStage s =>
(Argument CONST
 -> Validator schemaStage ctx (ArgumentDefinition schemaStage))
-> ArgumentsDefinition schemaStage
-> Arguments s
-> Validator schemaStage ctx (Arguments VALID)
validateArguments
    (Argument CONST
-> ArgumentsDefinition VALID
-> Validator
     VALID (OperationContext VALID s) (ArgumentDefinition VALID)
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` ArgumentsDefinition VALID
arguments)
    ArgumentsDefinition VALID
arguments
  where
    arguments :: ArgumentsDefinition VALID
arguments = FieldDefinition OUT VALID -> ArgumentsDefinition VALID
forall (c :: TypeCategory) (s :: Stage).
FieldDefinition c s -> ArgumentsDefinition s
fieldArguments FieldDefinition OUT VALID
field

validateDirectiveArguments ::
  ArgumentsConstraints ctx schemaStage valueStage =>
  DirectiveDefinition schemaStage ->
  Arguments valueStage ->
  Validator schemaStage ctx (Arguments VALID)
validateDirectiveArguments :: DirectiveDefinition schemaStage
-> Arguments valueStage
-> Validator schemaStage ctx (Arguments VALID)
validateDirectiveArguments
  DirectiveDefinition
    { ArgumentsDefinition schemaStage
directiveDefinitionArgs :: forall (s :: Stage). DirectiveDefinition s -> ArgumentsDefinition s
directiveDefinitionArgs :: ArgumentsDefinition schemaStage
directiveDefinitionArgs
    } =
    (Argument CONST
 -> Validator schemaStage ctx (ArgumentDefinition schemaStage))
-> ArgumentsDefinition schemaStage
-> Arguments valueStage
-> Validator schemaStage ctx (Arguments VALID)
forall ctx (schemaStage :: Stage) (s :: Stage).
ArgumentsConstraints ctx schemaStage s =>
(Argument CONST
 -> Validator schemaStage ctx (ArgumentDefinition schemaStage))
-> ArgumentsDefinition schemaStage
-> Arguments s
-> Validator schemaStage ctx (Arguments VALID)
validateArguments
      (Argument CONST
-> ArgumentsDefinition schemaStage
-> Validator schemaStage ctx (ArgumentDefinition schemaStage)
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` ArgumentsDefinition schemaStage
directiveDefinitionArgs)
      ArgumentsDefinition schemaStage
directiveDefinitionArgs

validateArguments ::
  ArgumentsConstraints ctx schemaStage s =>
  (Argument CONST -> Validator schemaStage ctx (ArgumentDefinition schemaStage)) ->
  ArgumentsDefinition schemaStage ->
  Arguments s ->
  Validator schemaStage ctx (Arguments VALID)
validateArguments :: (Argument CONST
 -> Validator schemaStage ctx (ArgumentDefinition schemaStage))
-> ArgumentsDefinition schemaStage
-> Arguments s
-> Validator schemaStage ctx (Arguments VALID)
validateArguments Argument CONST
-> Validator schemaStage ctx (ArgumentDefinition schemaStage)
checkUnknown ArgumentsDefinition schemaStage
argsDef Arguments s
rawArgs = do
  OrdMap FieldName (Argument CONST)
args <- (Argument s -> Validator schemaStage ctx (Argument CONST))
-> Arguments s
-> Validator schemaStage ctx (OrdMap FieldName (Argument CONST))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Argument s -> Validator schemaStage ctx (Argument CONST)
forall (f :: Stage -> *) (s :: Stage) ctx (schemaS :: Stage).
Resolve f s ctx =>
f s -> Validator schemaS ctx (f CONST)
resolve Arguments s
rawArgs
  (Argument CONST
 -> Validator schemaStage ctx (ArgumentDefinition schemaStage))
-> OrdMap FieldName (Argument CONST)
-> Validator schemaStage ctx ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Argument CONST
-> Validator schemaStage ctx (ArgumentDefinition schemaStage)
checkUnknown OrdMap FieldName (Argument CONST)
args
    Validator schemaStage ctx ()
-> Validator schemaStage ctx (Arguments VALID)
-> Validator schemaStage ctx (Arguments VALID)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (ArgumentDefinition schemaStage
 -> Validator schemaStage ctx (Argument VALID))
-> ArgumentsDefinition schemaStage
-> Validator schemaStage ctx (Arguments VALID)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (OrdMap FieldName (Argument CONST)
-> ArgumentDefinition schemaStage
-> Validator schemaStage ctx (Argument VALID)
forall ctx (schemaS :: Stage) (valueS :: Stage).
(ValidateWithDefault ctx schemaS valueS,
 ValidateWithDefault ctx schemaS schemaS) =>
Arguments valueS
-> ArgumentDefinition schemaS
-> Validator schemaS ctx (Argument VALID)
validateArgument OrdMap FieldName (Argument CONST)
args) ArgumentsDefinition schemaStage
argsDef

class Resolve f s ctx where
  resolve :: f s -> Validator schemaS ctx (f CONST)

instance VariableConstraints (OperationContext VALID s) => Resolve Argument RAW (OperationContext VALID s) where
  resolve :: Argument RAW
-> Validator schemaS (OperationContext VALID s) (Argument CONST)
resolve (Argument Position
key FieldName
position Value RAW
val) = Position -> FieldName -> Value CONST -> Argument CONST
forall (valid :: Stage).
Position -> FieldName -> Value valid -> Argument valid
Argument Position
key FieldName
position (Value CONST -> Argument CONST)
-> Validator schemaS (OperationContext VALID s) (Value CONST)
-> Validator schemaS (OperationContext VALID s) (Argument CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value RAW
-> Validator schemaS (OperationContext VALID s) (Value CONST)
forall (f :: Stage -> *) (s :: Stage) ctx (schemaS :: Stage).
Resolve f s ctx =>
f s -> Validator schemaS ctx (f CONST)
resolve Value RAW
val

instance Resolve f CONST ctx where
  resolve :: f CONST -> Validator schemaS ctx (f CONST)
resolve = f CONST -> Validator schemaS ctx (f CONST)
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance VariableConstraints (OperationContext VALID s) => Resolve Value RAW (OperationContext VALID s) where
  resolve :: Value RAW
-> Validator schemaS (OperationContext VALID s) (Value CONST)
resolve Value RAW
Null = Value CONST
-> Validator schemaS (OperationContext VALID s) (Value CONST)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value CONST
forall (stage :: Stage). Value stage
Null
  resolve (Scalar ScalarValue
x) = Value CONST
-> Validator schemaS (OperationContext VALID s) (Value CONST)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value CONST
 -> Validator schemaS (OperationContext VALID s) (Value CONST))
-> Value CONST
-> Validator schemaS (OperationContext VALID s) (Value CONST)
forall a b. (a -> b) -> a -> b
$ ScalarValue -> Value CONST
forall (stage :: Stage). ScalarValue -> Value stage
Scalar ScalarValue
x
  resolve (Enum TypeName
x) = Value CONST
-> Validator schemaS (OperationContext VALID s) (Value CONST)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value CONST
 -> Validator schemaS (OperationContext VALID s) (Value CONST))
-> Value CONST
-> Validator schemaS (OperationContext VALID s) (Value CONST)
forall a b. (a -> b) -> a -> b
$ TypeName -> Value CONST
forall (stage :: Stage). TypeName -> Value stage
Enum TypeName
x
  resolve (List [Value RAW]
elems) = [Value CONST] -> Value CONST
forall (stage :: Stage). [Value stage] -> Value stage
List ([Value CONST] -> Value CONST)
-> Validator schemaS (OperationContext VALID s) [Value CONST]
-> Validator schemaS (OperationContext VALID s) (Value CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value RAW
 -> Validator schemaS (OperationContext VALID s) (Value CONST))
-> [Value RAW]
-> Validator schemaS (OperationContext VALID s) [Value CONST]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value RAW
-> Validator schemaS (OperationContext VALID s) (Value CONST)
forall (f :: Stage -> *) (s :: Stage) ctx (schemaS :: Stage).
Resolve f s ctx =>
f s -> Validator schemaS ctx (f CONST)
resolve [Value RAW]
elems
  resolve (Object Object RAW
fields) = Object CONST -> Value CONST
forall (stage :: Stage). Object stage -> Value stage
Object (Object CONST -> Value CONST)
-> Validator schemaS (OperationContext VALID s) (Object CONST)
-> Validator schemaS (OperationContext VALID s) (Value CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ObjectEntry RAW
 -> Validator
      schemaS (OperationContext VALID s) (ObjectEntry CONST))
-> Object RAW
-> Validator schemaS (OperationContext VALID s) (Object CONST)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ObjectEntry RAW
-> Validator schemaS (OperationContext VALID s) (ObjectEntry CONST)
forall (f :: Stage -> *) (s :: Stage) ctx (schemaS :: Stage).
Resolve f s ctx =>
f s -> Validator schemaS ctx (f CONST)
resolve Object RAW
fields
  resolve (VariableValue Ref FieldName
ref) =
    Validator
  schemaS (OperationContext VALID s) (VariableDefinitions VALID)
forall (s1 :: Stage) (s2 :: Stage) (s3 :: Stage) (m :: * -> *).
MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m =>
m (VariableDefinitions s2)
askVariables
      Validator
  schemaS (OperationContext VALID s) (VariableDefinitions VALID)
-> (VariableDefinitions VALID
    -> Validator schemaS (OperationContext VALID s) (Value CONST))
-> Validator schemaS (OperationContext VALID s) (Value CONST)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Variable VALID -> Value CONST)
-> Validator schemaS (OperationContext VALID s) (Variable VALID)
-> Validator schemaS (OperationContext VALID s) (Value CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Ref FieldName -> Variable VALID -> Value CONST
ResolvedVariable Ref FieldName
ref)
        (Validator schemaS (OperationContext VALID s) (Variable VALID)
 -> Validator schemaS (OperationContext VALID s) (Value CONST))
-> (VariableDefinitions VALID
    -> Validator schemaS (OperationContext VALID s) (Variable VALID))
-> VariableDefinitions VALID
-> Validator schemaS (OperationContext VALID s) (Value CONST)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ref FieldName
-> VariableDefinitions VALID
-> Validator schemaS (OperationContext VALID s) (Variable VALID)
forall (c :: * -> *) a ctx (s :: Stage).
(IsMap FieldName c, MissingRequired (c a) ctx) =>
Ref FieldName -> c a -> Validator s ctx a
selectRequired Ref FieldName
ref

instance VariableConstraints (OperationContext VALID s) => Resolve ObjectEntry RAW (OperationContext VALID s) where
  resolve :: ObjectEntry RAW
-> Validator schemaS (OperationContext VALID s) (ObjectEntry CONST)
resolve (ObjectEntry FieldName
name Value RAW
value) = FieldName -> Value CONST -> ObjectEntry CONST
forall (s :: Stage). FieldName -> Value s -> ObjectEntry s
ObjectEntry FieldName
name (Value CONST -> ObjectEntry CONST)
-> Validator schemaS (OperationContext VALID s) (Value CONST)
-> Validator schemaS (OperationContext VALID s) (ObjectEntry CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value RAW
-> Validator schemaS (OperationContext VALID s) (Value CONST)
forall (f :: Stage -> *) (s :: Stage) ctx (schemaS :: Stage).
Resolve f s ctx =>
f s -> Validator schemaS ctx (f CONST)
resolve Value RAW
value