{-# 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 :: 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 valueS) requestArgs ArgumentDefinition {FieldDefinition IN schemaS argument :: forall (s :: Stage). ArgumentDefinition s -> FieldDefinition IN s argument :: FieldDefinition IN schemaS argument} = 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 (forall (s :: Stage) (schemaS :: Stage) (schemaStage :: Stage) ctx. FieldDefinition IN s -> Value schemaS -> Validator schemaStage ctx (Argument schemaS) toArgument FieldDefinition IN schemaS argument forall (m :: * -> *) a b c. Monad m => (a -> m b) -> (b -> m c) -> a -> m c >=> 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) (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 OrdMap FieldName (Argument valueS) requestArgs toArgument :: FieldDefinition IN s -> Value schemaS -> Validator schemaStage ctx (Argument schemaS) toArgument :: forall (s :: Stage) (schemaS :: Stage) (schemaStage :: Stage) ctx. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. a -> Maybe a -> a fromMaybe (Int -> Int -> Position Position Int 0 Int 0) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> 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 = 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 :: forall ctx (schemaS :: Stage) (valueS :: Stage). ValidateWithDefault ctx schemaS valueS => 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 ..} = forall (s :: Stage) c (m :: * -> *) b. MonadReader (ValidatorContext s c) m => (Scope -> Scope) -> m b -> m b withScope (Position -> Scope -> Scope setPosition Position argumentPosition) forall a b. (a -> b) -> a -> b $ forall (s :: Stage) ctx a. InputSource -> InputValidator s ctx a -> Validator s ctx a startInput (FieldName -> InputSource SourceArgument FieldName argumentName) forall a b. (a -> b) -> a -> b $ forall (valid :: Stage). Position -> FieldName -> Value valid -> Argument valid Argument Position argumentPosition FieldName argumentName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall c (schemaS :: Stage) (s :: Stage). ValidateWithDefault c schemaS s => Typed IN schemaS TypeRef -> Value s -> Validator schemaS (InputContext c) (Value VALID) validateInputByTypeRef (forall (a :: TypeCategory -> Stage -> *) (c :: TypeCategory) (s :: Stage) b. (a c s -> b) -> a c s -> Typed c s b typed 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 :: forall (s :: Stage). FieldDefinition OUT VALID -> Arguments RAW -> FragmentValidator s (Arguments VALID) validateFieldArguments FieldDefinition OUT VALID field = 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 (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 = 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 :: forall ctx (schemaStage :: Stage) (valueStage :: Stage). ArgumentsConstraints ctx schemaStage valueStage => 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 } = 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 (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 :: 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 -> Validator schemaStage ctx (ArgumentDefinition schemaStage) checkUnknown ArgumentsDefinition schemaStage argsDef Arguments s rawArgs = do OrdMap FieldName (Argument CONST) args <- forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse forall (f :: Stage -> *) (s :: Stage) ctx (schemaS :: Stage). Resolve f s ctx => f s -> Validator schemaS ctx (f CONST) resolve Arguments s rawArgs 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 forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b *> forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse (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 :: forall (schemaS :: Stage). Argument RAW -> Validator schemaS (OperationContext VALID s) (Argument CONST) resolve (Argument Position key FieldName position Value RAW val) = forall (valid :: Stage). Position -> FieldName -> Value valid -> Argument valid Argument Position key FieldName position forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> 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 :: forall (schemaS :: Stage). f CONST -> Validator schemaS ctx (f CONST) resolve = forall (f :: * -> *) a. Applicative f => a -> f a pure instance VariableConstraints (OperationContext VALID s) => Resolve Value RAW (OperationContext VALID s) where resolve :: forall (schemaS :: Stage). Value RAW -> Validator schemaS (OperationContext VALID s) (Value CONST) resolve Value RAW Null = forall (f :: * -> *) a. Applicative f => a -> f a pure forall (stage :: Stage). Value stage Null resolve (Scalar ScalarValue x) = forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (stage :: Stage). ScalarValue -> Value stage Scalar ScalarValue x resolve (Enum TypeName x) = forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall (stage :: Stage). TypeName -> Value stage Enum TypeName x resolve (List [Value RAW] elems) = forall (stage :: Stage). [Value stage] -> Value stage List forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse 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) = forall (stage :: Stage). Object stage -> Value stage Object forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse 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) = forall (s1 :: Stage) (s2 :: Stage) (s3 :: Stage) (m :: * -> *). MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m => m (VariableDefinitions s2) askVariables forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (Ref FieldName -> Variable VALID -> Value CONST ResolvedVariable Ref FieldName ref) forall b c a. (b -> c) -> (a -> b) -> a -> c . 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 :: forall (schemaS :: Stage). ObjectEntry RAW -> Validator schemaS (OperationContext VALID s) (ObjectEntry CONST) resolve (ObjectEntry FieldName name Value RAW value) = forall (s :: Stage). FieldName -> Value s -> ObjectEntry s ObjectEntry FieldName name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall (f :: Stage -> *) (s :: Stage) ctx (schemaS :: Stage). Resolve f s ctx => f s -> Validator schemaS ctx (f CONST) resolve Value RAW value