{-# 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.Internal.Utils
  ( empty,
  )
import Data.Morpheus.Types.Internal.AST
  ( Argument (..),
    ArgumentDefinition,
    Arguments,
    ArgumentsDefinition (..),
    CONST,
    DirectiveDefinition,
    DirectiveDefinition (..),
    FieldDefinition (..),
    IN,
    OUT,
    ObjectEntry (..),
    Position (..),
    RAW,
    VALID,
    Value (..),
    VariableDefinitions,
    fieldContentArgs,
    typed,
  )
import Data.Morpheus.Types.Internal.Validation
  ( FragmentValidator,
    GetWith,
    InputSource (..),
    MissingRequired,
    Scope (..),
    Validator,
    askVariables,
    asksScope,
    selectKnown,
    selectRequired,
    selectWithDefaultValue,
    startInput,
    withPosition,
  )
import Data.Morpheus.Validation.Internal.Value
  ( ValidateWithDefault,
    validateInputByTypeRef,
  )
import Relude hiding (empty)

type VariableConstraints ctx =
  ( GetWith ctx (VariableDefinitions VALID),
    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 ->
  FieldDefinition IN schemaS ->
  Validator schemaS ctx (Argument VALID)
validateArgument :: Arguments valueS
-> FieldDefinition IN schemaS
-> Validator schemaS ctx (Argument VALID)
validateArgument
  Arguments valueS
requestArgs
  FieldDefinition IN schemaS
argumentDef =
    (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 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 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
argumentDef (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
argumentDef)
      (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
argumentDef)
      FieldDefinition IN schemaS
argumentDef
      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 (m :: * -> * -> *) (s :: Stage) c a.
MonadContext m s c =>
(Scope -> a) -> m c 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
..} =
    Position
-> Validator schemaS ctx (Argument VALID)
-> Validator schemaS ctx (Argument VALID)
forall (m :: * -> * -> *) (s :: Stage) c a.
MonadContext m s c =>
Position -> m c a -> m c a
withPosition 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 fieldDef :: FieldDefinition OUT VALID
fieldDef@FieldDefinition {Maybe (FieldContent TRUE OUT VALID)
fieldContent :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldContent :: Maybe (FieldContent TRUE OUT VALID)
fieldContent} =
  (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
-> FieldDefinition OUT VALID
-> Validator
     VALID (OperationContext VALID s) (ArgumentDefinition VALID)
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` FieldDefinition OUT VALID
fieldDef)
    ArgumentsDefinition VALID
argsDef
  where
    argsDef :: ArgumentsDefinition VALID
argsDef = ArgumentsDefinition VALID
-> (FieldContent TRUE OUT VALID -> ArgumentsDefinition VALID)
-> Maybe (FieldContent TRUE OUT VALID)
-> ArgumentsDefinition VALID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ArgumentsDefinition VALID
forall a coll. Collection a coll => coll
empty FieldContent TRUE OUT VALID -> ArgumentsDefinition VALID
forall (b :: Bool) (cat :: TypeCategory) (s :: Stage).
FieldContent b cat s -> ArgumentsDefinition s
fieldContentArgs Maybe (FieldContent TRUE OUT VALID)
fieldContent

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
  directiveDef :: DirectiveDefinition schemaStage
directiveDef@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
-> DirectiveDefinition schemaStage
-> Validator schemaStage ctx (ArgumentDefinition schemaStage)
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` DirectiveDefinition schemaStage
directiveDef)
      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))
-> OrdMap FieldName (ArgumentDefinition 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
-> FieldDefinition IN schemaS
-> Validator schemaS ctx (Argument VALID)
validateArgument OrdMap FieldName (Argument CONST)
args) (ArgumentsDefinition schemaStage
-> OrdMap FieldName (ArgumentDefinition schemaStage)
forall (s :: Stage).
ArgumentsDefinition s -> OrdMap FieldName (ArgumentDefinition s)
arguments ArgumentsDefinition schemaStage
argsDef)

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

instance VariableConstraints ctx => Resolve Argument RAW ctx where
  resolve :: Argument RAW -> Validator schemaS ctx (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 ctx (Value CONST)
-> Validator schemaS ctx (Argument CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value RAW -> Validator schemaS ctx (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 ctx => Resolve Value RAW ctx where
  resolve :: Value RAW -> Validator schemaS ctx (Value CONST)
resolve Value RAW
Null = Value CONST -> Validator schemaS ctx (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 ctx (Value CONST)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value CONST -> Validator schemaS ctx (Value CONST))
-> Value CONST -> Validator schemaS ctx (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 ctx (Value CONST)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value CONST -> Validator schemaS ctx (Value CONST))
-> Value CONST -> Validator schemaS ctx (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 ctx [Value CONST]
-> Validator schemaS ctx (Value CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value RAW -> Validator schemaS ctx (Value CONST))
-> [Value RAW] -> Validator schemaS ctx [Value CONST]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Value RAW -> Validator schemaS ctx (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 ctx (Object CONST)
-> Validator schemaS ctx (Value CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ObjectEntry RAW -> Validator schemaS ctx (ObjectEntry CONST))
-> Object RAW -> Validator schemaS ctx (Object CONST)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ObjectEntry RAW -> Validator schemaS ctx (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
ref) =
    Validator schemaS ctx (VariableDefinitions VALID)
forall (m :: * -> * -> *) (s :: Stage) c.
(MonadContext m s c, GetWith c (VariableDefinitions VALID)) =>
m c (VariableDefinitions VALID)
askVariables
      Validator schemaS ctx (VariableDefinitions VALID)
-> (VariableDefinitions VALID
    -> Validator schemaS ctx (Value CONST))
-> Validator schemaS ctx (Value CONST)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Variable VALID -> Value CONST)
-> Validator schemaS ctx (Variable VALID)
-> Validator schemaS ctx (Value CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Ref -> Variable VALID -> Value CONST
ResolvedVariable Ref
ref)
        (Validator schemaS ctx (Variable VALID)
 -> Validator schemaS ctx (Value CONST))
-> (VariableDefinitions VALID
    -> Validator schemaS ctx (Variable VALID))
-> VariableDefinitions VALID
-> Validator schemaS ctx (Value CONST)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ref
-> VariableDefinitions VALID
-> Validator schemaS ctx (Variable VALID)
forall value c ctx (s :: Stage).
(Selectable FieldName value c, MissingRequired c ctx) =>
Ref -> c -> Validator s ctx value
selectRequired Ref
ref

instance VariableConstraints ctx => Resolve ObjectEntry RAW ctx where
  resolve :: ObjectEntry RAW -> Validator schemaS ctx (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 ctx (Value CONST)
-> Validator schemaS ctx (ObjectEntry CONST)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value RAW -> Validator schemaS ctx (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