{-# 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