{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Types.Internal.Validation.Validator
( Validator (..),
SelectionValidator,
InputValidator,
BaseValidator,
runValidator,
Constraint (..),
setSelection,
inField,
inputMessagePrefix,
InputSource (..),
InputContext (..),
OperationContext (..),
renderInputPrefix,
Prop (..),
ScopeKind (..),
inputValueSource,
Scope (..),
setDirective,
startInput,
withContext,
renderField,
asksScope,
askVariables,
askFragments,
ValidatorContext (..),
FragmentValidator,
askTypeDefinitions,
withScope,
setPosition,
)
where
import Control.Monad.Except (MonadError (catchError, throwError))
import Control.Monad.Reader (asks)
import Data.Morpheus.Ext.Result
( GQLResult,
)
import Data.Morpheus.Types.Internal.AST
( ANY,
FieldDefinition (..),
FieldName,
Fragments,
IMPLEMENTABLE,
IN,
RAW,
Schema,
Stage,
TypeCategory,
TypeDefinition (..),
TypeName,
TypeRef (..),
VALID,
Variable (..),
VariableDefinitions,
intercalate,
typeDefinitions,
unpackName,
)
import Data.Morpheus.Types.Internal.AST.Error
import Data.Morpheus.Types.Internal.Config (Config (..))
import Data.Morpheus.Types.Internal.Validation.Scope
( Scope (..),
ScopeKind (..),
renderScope,
renderSection,
setDirective,
setPosition,
setSelection,
)
import Relude hiding
( Constraint,
asks,
get,
intercalate,
)
data Prop = Prop
{ Prop -> FieldName
propName :: FieldName,
Prop -> TypeName
propTypeName :: TypeName
}
deriving (Int -> Prop -> ShowS
[Prop] -> ShowS
Prop -> String
(Int -> Prop -> ShowS)
-> (Prop -> String) -> ([Prop] -> ShowS) -> Show Prop
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Prop] -> ShowS
$cshowList :: [Prop] -> ShowS
show :: Prop -> String
$cshow :: Prop -> String
showsPrec :: Int -> Prop -> ShowS
$cshowsPrec :: Int -> Prop -> ShowS
Show)
type Path = [Prop]
renderPath :: Path -> GQLError
renderPath :: [Prop] -> GQLError
renderPath [] = GQLError
""
renderPath [Prop]
path = GQLError
"in field " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> Name Any -> GQLError
forall a. Msg a => a -> GQLError
msg (Name Any -> [FieldName] -> Name Any
forall (t1 :: NAME) (t2 :: NAME) (t3 :: NAME).
Name t1 -> [Name t2] -> Name t3
intercalate Name Any
"." ([FieldName] -> Name Any) -> [FieldName] -> Name Any
forall a b. (a -> b) -> a -> b
$ (Prop -> FieldName) -> [Prop] -> [FieldName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Prop -> FieldName
propName [Prop]
path) GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
": "
renderInputPrefix :: InputContext c -> GQLError
renderInputPrefix :: InputContext c -> GQLError
renderInputPrefix InputContext {[Prop]
inputPath :: forall ctx. InputContext ctx -> [Prop]
inputPath :: [Prop]
inputPath, InputSource
inputSource :: forall ctx. InputContext ctx -> InputSource
inputSource :: InputSource
inputSource} =
InputSource -> GQLError
renderSource InputSource
inputSource GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> [Prop] -> GQLError
renderPath [Prop]
inputPath
renderSource :: InputSource -> GQLError
renderSource :: InputSource -> GQLError
renderSource (SourceArgument FieldName
argumentName) =
GQLError
"Argument " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> FieldName -> GQLError
forall a. Msg a => a -> GQLError
msg FieldName
argumentName GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
" got invalid value. "
renderSource (SourceVariable Variable {FieldName
variableName :: forall (stage :: Stage). Variable stage -> FieldName
variableName :: FieldName
variableName} Bool
_) =
GQLError
"Variable " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> FieldName -> GQLError
forall a. Msg a => a -> GQLError
msg (FieldName
"$" FieldName -> FieldName -> FieldName
forall a. Semigroup a => a -> a -> a
<> FieldName
variableName) GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
" got invalid value. "
renderSource SourceInputField {TypeName
sourceTypeName :: InputSource -> TypeName
sourceTypeName :: TypeName
sourceTypeName, FieldName
sourceFieldName :: InputSource -> FieldName
sourceFieldName :: FieldName
sourceFieldName, Maybe FieldName
sourceArgumentName :: InputSource -> Maybe FieldName
sourceArgumentName :: Maybe FieldName
sourceArgumentName} =
GQLError
"Field " GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> TypeName -> FieldName -> Maybe FieldName -> GQLError
renderField TypeName
sourceTypeName FieldName
sourceFieldName Maybe FieldName
sourceArgumentName GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError
" got invalid default value. "
renderField :: TypeName -> FieldName -> Maybe FieldName -> GQLError
renderField :: TypeName -> FieldName -> Maybe FieldName -> GQLError
renderField TypeName
tName FieldName
fName Maybe FieldName
arg =
Text -> GQLError
forall a. Msg a => a -> GQLError
msg (TypeName -> Text
forall a (t :: NAME). NamePacking a => Name t -> a
unpackName TypeName
tName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FieldName -> Text
forall a (t :: NAME). NamePacking a => Name t -> a
unpackName FieldName
fName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Maybe FieldName -> Text
forall p (t :: NAME).
(Semigroup p, IsString p, NamePacking p) =>
Maybe (Name t) -> p
renderArg Maybe FieldName
arg :: Text)
where
renderArg :: Maybe (Name t) -> p
renderArg (Just Name t
argName) = p
"(" p -> p -> p
forall a. Semigroup a => a -> a -> a
<> Name t -> p
forall a (t :: NAME). NamePacking a => Name t -> a
unpackName Name t
argName p -> p -> p
forall a. Semigroup a => a -> a -> a
<> p
":)"
renderArg Maybe (Name t)
Nothing = p
""
data OperationContext (s1 :: Stage) (s2 :: Stage) = OperationContext
{ OperationContext s1 s2 -> Fragments s2
fragments :: Fragments s2,
OperationContext s1 s2 -> VariableDefinitions s1
variables :: VariableDefinitions s1,
OperationContext s1 s2 -> Maybe FieldName
operationName :: Maybe FieldName
}
deriving (Int -> OperationContext s1 s2 -> ShowS
[OperationContext s1 s2] -> ShowS
OperationContext s1 s2 -> String
(Int -> OperationContext s1 s2 -> ShowS)
-> (OperationContext s1 s2 -> String)
-> ([OperationContext s1 s2] -> ShowS)
-> Show (OperationContext s1 s2)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (s1 :: Stage) (s2 :: Stage).
Int -> OperationContext s1 s2 -> ShowS
forall (s1 :: Stage) (s2 :: Stage).
[OperationContext s1 s2] -> ShowS
forall (s1 :: Stage) (s2 :: Stage).
OperationContext s1 s2 -> String
showList :: [OperationContext s1 s2] -> ShowS
$cshowList :: forall (s1 :: Stage) (s2 :: Stage).
[OperationContext s1 s2] -> ShowS
show :: OperationContext s1 s2 -> String
$cshow :: forall (s1 :: Stage) (s2 :: Stage).
OperationContext s1 s2 -> String
showsPrec :: Int -> OperationContext s1 s2 -> ShowS
$cshowsPrec :: forall (s1 :: Stage) (s2 :: Stage).
Int -> OperationContext s1 s2 -> ShowS
Show)
data InputContext ctx = InputContext
{ InputContext ctx -> InputSource
inputSource :: InputSource,
InputContext ctx -> [Prop]
inputPath :: [Prop],
InputContext ctx -> ctx
sourceContext :: ctx
}
deriving (Int -> InputContext ctx -> ShowS
[InputContext ctx] -> ShowS
InputContext ctx -> String
(Int -> InputContext ctx -> ShowS)
-> (InputContext ctx -> String)
-> ([InputContext ctx] -> ShowS)
-> Show (InputContext ctx)
forall ctx. Show ctx => Int -> InputContext ctx -> ShowS
forall ctx. Show ctx => [InputContext ctx] -> ShowS
forall ctx. Show ctx => InputContext ctx -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InputContext ctx] -> ShowS
$cshowList :: forall ctx. Show ctx => [InputContext ctx] -> ShowS
show :: InputContext ctx -> String
$cshow :: forall ctx. Show ctx => InputContext ctx -> String
showsPrec :: Int -> InputContext ctx -> ShowS
$cshowsPrec :: forall ctx. Show ctx => Int -> InputContext ctx -> ShowS
Show)
data InputSource
= SourceArgument FieldName
| SourceVariable
{ InputSource -> Variable RAW
sourceVariable :: Variable RAW,
InputSource -> Bool
isDefaultValue :: Bool
}
| SourceInputField
{ InputSource -> TypeName
sourceTypeName :: TypeName,
InputSource -> FieldName
sourceFieldName :: FieldName,
InputSource -> Maybe FieldName
sourceArgumentName :: Maybe FieldName
}
deriving (Int -> InputSource -> ShowS
[InputSource] -> ShowS
InputSource -> String
(Int -> InputSource -> ShowS)
-> (InputSource -> String)
-> ([InputSource] -> ShowS)
-> Show InputSource
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InputSource] -> ShowS
$cshowList :: [InputSource] -> ShowS
show :: InputSource -> String
$cshow :: InputSource -> String
showsPrec :: Int -> InputSource -> ShowS
$cshowsPrec :: Int -> InputSource -> ShowS
Show)
data Constraint (a :: TypeCategory) where
IMPLEMENTABLE :: Constraint IMPLEMENTABLE
INPUT :: Constraint IN
inField :: FieldDefinition IN s -> InputValidator s c a -> InputValidator s c a
inField :: FieldDefinition IN s
-> InputValidator s c a -> InputValidator s c a
inField
FieldDefinition
{ FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName :: FieldName
fieldName,
fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType = TypeRef {TypeName
typeConName :: TypeRef -> TypeName
typeConName :: TypeName
typeConName}
} = (InputContext c -> InputContext c)
-> InputValidator s c a -> InputValidator s c a
forall c' c (s :: Stage) a.
(c' -> c) -> Validator s c a -> Validator s c' a
withContext InputContext c -> InputContext c
update
where
update :: InputContext c -> InputContext c
update
InputContext
{ inputPath :: forall ctx. InputContext ctx -> [Prop]
inputPath = [Prop]
old,
c
InputSource
sourceContext :: c
inputSource :: InputSource
sourceContext :: forall ctx. InputContext ctx -> ctx
inputSource :: forall ctx. InputContext ctx -> InputSource
..
} =
InputContext :: forall ctx. InputSource -> [Prop] -> ctx -> InputContext ctx
InputContext
{ inputPath :: [Prop]
inputPath = [Prop]
old [Prop] -> [Prop] -> [Prop]
forall a. Semigroup a => a -> a -> a
<> [FieldName -> TypeName -> Prop
Prop FieldName
fieldName TypeName
typeConName],
c
InputSource
sourceContext :: c
inputSource :: InputSource
sourceContext :: c
inputSource :: InputSource
..
}
inputValueSource :: MonadReader (ValidatorContext s (InputContext c)) m => m InputSource
inputValueSource :: m InputSource
inputValueSource = (InputContext c -> InputSource) -> m InputSource
forall (s :: Stage) c (m :: * -> *) a.
MonadReader (ValidatorContext s c) m =>
(c -> a) -> m a
asksLocal InputContext c -> InputSource
forall ctx. InputContext ctx -> InputSource
inputSource
asksScope :: MonadReader (ValidatorContext s ctx) m => (Scope -> a) -> m a
asksScope :: (Scope -> a) -> m a
asksScope Scope -> a
f = (ValidatorContext s ctx -> a) -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Scope -> a
f (Scope -> a)
-> (ValidatorContext s ctx -> Scope) -> ValidatorContext s ctx -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidatorContext s ctx -> Scope
forall (s :: Stage) ctx. ValidatorContext s ctx -> Scope
scope)
askTypeDefinitions ::
MonadReader (ValidatorContext s ctx) m =>
m (HashMap TypeName (TypeDefinition ANY s))
askTypeDefinitions :: m (HashMap TypeName (TypeDefinition ANY s))
askTypeDefinitions = (ValidatorContext s ctx -> HashMap TypeName (TypeDefinition ANY s))
-> m (HashMap TypeName (TypeDefinition ANY s))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Schema s -> HashMap TypeName (TypeDefinition ANY s)
forall (s :: Stage).
Schema s -> HashMap TypeName (TypeDefinition ANY s)
typeDefinitions (Schema s -> HashMap TypeName (TypeDefinition ANY s))
-> (ValidatorContext s ctx -> Schema s)
-> ValidatorContext s ctx
-> HashMap TypeName (TypeDefinition ANY s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidatorContext s ctx -> Schema s
forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s
schema)
askVariables :: MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m => m (VariableDefinitions s2)
askVariables :: m (VariableDefinitions s2)
askVariables = (OperationContext s2 s3 -> VariableDefinitions s2)
-> m (VariableDefinitions s2)
forall (s :: Stage) c (m :: * -> *) a.
MonadReader (ValidatorContext s c) m =>
(c -> a) -> m a
asksLocal OperationContext s2 s3 -> VariableDefinitions s2
forall (s1 :: Stage) (s2 :: Stage).
OperationContext s1 s2 -> VariableDefinitions s1
variables
askFragments :: MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m => m (Fragments s3)
askFragments :: m (Fragments s3)
askFragments = (OperationContext s2 s3 -> Fragments s3) -> m (Fragments s3)
forall (s :: Stage) c (m :: * -> *) a.
MonadReader (ValidatorContext s c) m =>
(c -> a) -> m a
asksLocal OperationContext s2 s3 -> Fragments s3
forall (s1 :: Stage) (s2 :: Stage).
OperationContext s1 s2 -> Fragments s2
fragments
runValidator :: Validator s ctx a -> Config -> Schema s -> Scope -> ctx -> GQLResult a
runValidator :: Validator s ctx a
-> Config -> Schema s -> Scope -> ctx -> GQLResult a
runValidator (Validator ReaderT (ValidatorContext s ctx) GQLResult a
x) Config
config Schema s
schema Scope
scope ctx
localContext =
ReaderT (ValidatorContext s ctx) GQLResult a
-> ValidatorContext s ctx -> GQLResult a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (ValidatorContext s ctx) GQLResult a
x ValidatorContext :: forall (s :: Stage) ctx.
Scope -> Schema s -> ctx -> Config -> ValidatorContext s ctx
ValidatorContext {ctx
Schema s
Config
Scope
config :: Config
localContext :: ctx
localContext :: ctx
scope :: Scope
schema :: Schema s
config :: Config
schema :: Schema s
scope :: Scope
..}
withContext :: (c' -> c) -> Validator s c a -> Validator s c' a
withContext :: (c' -> c) -> Validator s c a -> Validator s c' a
withContext c' -> c
f = ReaderT (ValidatorContext s c') GQLResult a -> Validator s c' a
forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) GQLResult a -> Validator s ctx a
Validator (ReaderT (ValidatorContext s c') GQLResult a -> Validator s c' a)
-> (Validator s c a -> ReaderT (ValidatorContext s c') GQLResult a)
-> Validator s c a
-> Validator s c' a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ValidatorContext s c' -> ValidatorContext s c)
-> ReaderT (ValidatorContext s c) GQLResult a
-> ReaderT (ValidatorContext s c') GQLResult a
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT ((c' -> c) -> ValidatorContext s c' -> ValidatorContext s c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap c' -> c
f) (ReaderT (ValidatorContext s c) GQLResult a
-> ReaderT (ValidatorContext s c') GQLResult a)
-> (Validator s c a -> ReaderT (ValidatorContext s c) GQLResult a)
-> Validator s c a
-> ReaderT (ValidatorContext s c') GQLResult a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validator s c a -> ReaderT (ValidatorContext s c) GQLResult a
forall (s :: Stage) ctx a.
Validator s ctx a -> ReaderT (ValidatorContext s ctx) GQLResult a
_runValidator
inputMessagePrefix :: InputValidator s ctx GQLError
inputMessagePrefix :: InputValidator s ctx GQLError
inputMessagePrefix =
InputContext ctx -> GQLError
forall c. InputContext c -> GQLError
renderInputPrefix
(InputContext ctx -> GQLError)
-> (ValidatorContext s (InputContext ctx) -> InputContext ctx)
-> ValidatorContext s (InputContext ctx)
-> GQLError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidatorContext s (InputContext ctx) -> InputContext ctx
forall (s :: Stage) ctx. ValidatorContext s ctx -> ctx
localContext
(ValidatorContext s (InputContext ctx) -> GQLError)
-> Validator
s (InputContext ctx) (ValidatorContext s (InputContext ctx))
-> InputValidator s ctx GQLError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
(ValidatorContext s (InputContext ctx))
GQLResult
(ValidatorContext s (InputContext ctx))
-> Validator
s (InputContext ctx) (ValidatorContext s (InputContext ctx))
forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) GQLResult a -> Validator s ctx a
Validator ReaderT
(ValidatorContext s (InputContext ctx))
GQLResult
(ValidatorContext s (InputContext ctx))
forall r (m :: * -> *). MonadReader r m => m r
ask
startInput :: InputSource -> InputValidator s ctx a -> Validator s ctx a
startInput :: InputSource -> InputValidator s ctx a -> Validator s ctx a
startInput InputSource
inputSource = (ctx -> InputContext ctx)
-> InputValidator s ctx a -> Validator s ctx a
forall c' c (s :: Stage) a.
(c' -> c) -> Validator s c a -> Validator s c' a
withContext ctx -> InputContext ctx
update
where
update :: ctx -> InputContext ctx
update ctx
sourceContext =
InputContext :: forall ctx. InputSource -> [Prop] -> ctx -> InputContext ctx
InputContext
{ InputSource
inputSource :: InputSource
inputSource :: InputSource
inputSource,
inputPath :: [Prop]
inputPath = [],
ctx
sourceContext :: ctx
sourceContext :: ctx
sourceContext
}
data ValidatorContext (s :: Stage) (ctx :: Type) = ValidatorContext
{ ValidatorContext s ctx -> Scope
scope :: Scope,
ValidatorContext s ctx -> Schema s
schema :: Schema s,
ValidatorContext s ctx -> ctx
localContext :: ctx,
ValidatorContext s ctx -> Config
config :: Config
}
deriving
( Int -> ValidatorContext s ctx -> ShowS
[ValidatorContext s ctx] -> ShowS
ValidatorContext s ctx -> String
(Int -> ValidatorContext s ctx -> ShowS)
-> (ValidatorContext s ctx -> String)
-> ([ValidatorContext s ctx] -> ShowS)
-> Show (ValidatorContext s ctx)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (s :: Stage) ctx.
Show ctx =>
Int -> ValidatorContext s ctx -> ShowS
forall (s :: Stage) ctx.
Show ctx =>
[ValidatorContext s ctx] -> ShowS
forall (s :: Stage) ctx.
Show ctx =>
ValidatorContext s ctx -> String
showList :: [ValidatorContext s ctx] -> ShowS
$cshowList :: forall (s :: Stage) ctx.
Show ctx =>
[ValidatorContext s ctx] -> ShowS
show :: ValidatorContext s ctx -> String
$cshow :: forall (s :: Stage) ctx.
Show ctx =>
ValidatorContext s ctx -> String
showsPrec :: Int -> ValidatorContext s ctx -> ShowS
$cshowsPrec :: forall (s :: Stage) ctx.
Show ctx =>
Int -> ValidatorContext s ctx -> ShowS
Show,
a -> ValidatorContext s b -> ValidatorContext s a
(a -> b) -> ValidatorContext s a -> ValidatorContext s b
(forall a b.
(a -> b) -> ValidatorContext s a -> ValidatorContext s b)
-> (forall a b. a -> ValidatorContext s b -> ValidatorContext s a)
-> Functor (ValidatorContext s)
forall a b. a -> ValidatorContext s b -> ValidatorContext s a
forall a b.
(a -> b) -> ValidatorContext s a -> ValidatorContext s b
forall (s :: Stage) a b.
a -> ValidatorContext s b -> ValidatorContext s a
forall (s :: Stage) a b.
(a -> b) -> ValidatorContext s a -> ValidatorContext s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ValidatorContext s b -> ValidatorContext s a
$c<$ :: forall (s :: Stage) a b.
a -> ValidatorContext s b -> ValidatorContext s a
fmap :: (a -> b) -> ValidatorContext s a -> ValidatorContext s b
$cfmap :: forall (s :: Stage) a b.
(a -> b) -> ValidatorContext s a -> ValidatorContext s b
Functor
)
newtype Validator s ctx a = Validator
{ Validator s ctx a -> ReaderT (ValidatorContext s ctx) GQLResult a
_runValidator ::
ReaderT
(ValidatorContext s ctx)
GQLResult
a
}
deriving newtype
( a -> Validator s ctx b -> Validator s ctx a
(a -> b) -> Validator s ctx a -> Validator s ctx b
(forall a b. (a -> b) -> Validator s ctx a -> Validator s ctx b)
-> (forall a b. a -> Validator s ctx b -> Validator s ctx a)
-> Functor (Validator s ctx)
forall a b. a -> Validator s ctx b -> Validator s ctx a
forall a b. (a -> b) -> Validator s ctx a -> Validator s ctx b
forall (s :: Stage) ctx a b.
a -> Validator s ctx b -> Validator s ctx a
forall (s :: Stage) ctx a b.
(a -> b) -> Validator s ctx a -> Validator s ctx b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> Validator s ctx b -> Validator s ctx a
$c<$ :: forall (s :: Stage) ctx a b.
a -> Validator s ctx b -> Validator s ctx a
fmap :: (a -> b) -> Validator s ctx a -> Validator s ctx b
$cfmap :: forall (s :: Stage) ctx a b.
(a -> b) -> Validator s ctx a -> Validator s ctx b
Functor,
Functor (Validator s ctx)
a -> Validator s ctx a
Functor (Validator s ctx)
-> (forall a. a -> Validator s ctx a)
-> (forall a b.
Validator s ctx (a -> b) -> Validator s ctx a -> Validator s ctx b)
-> (forall a b c.
(a -> b -> c)
-> Validator s ctx a -> Validator s ctx b -> Validator s ctx c)
-> (forall a b.
Validator s ctx a -> Validator s ctx b -> Validator s ctx b)
-> (forall a b.
Validator s ctx a -> Validator s ctx b -> Validator s ctx a)
-> Applicative (Validator s ctx)
Validator s ctx a -> Validator s ctx b -> Validator s ctx b
Validator s ctx a -> Validator s ctx b -> Validator s ctx a
Validator s ctx (a -> b) -> Validator s ctx a -> Validator s ctx b
(a -> b -> c)
-> Validator s ctx a -> Validator s ctx b -> Validator s ctx c
forall a. a -> Validator s ctx a
forall a b.
Validator s ctx a -> Validator s ctx b -> Validator s ctx a
forall a b.
Validator s ctx a -> Validator s ctx b -> Validator s ctx b
forall a b.
Validator s ctx (a -> b) -> Validator s ctx a -> Validator s ctx b
forall a b c.
(a -> b -> c)
-> Validator s ctx a -> Validator s ctx b -> Validator s ctx c
forall (s :: Stage) ctx. Functor (Validator s ctx)
forall (s :: Stage) ctx a. a -> Validator s ctx a
forall (s :: Stage) ctx a b.
Validator s ctx a -> Validator s ctx b -> Validator s ctx a
forall (s :: Stage) ctx a b.
Validator s ctx a -> Validator s ctx b -> Validator s ctx b
forall (s :: Stage) ctx a b.
Validator s ctx (a -> b) -> Validator s ctx a -> Validator s ctx b
forall (s :: Stage) ctx a b c.
(a -> b -> c)
-> Validator s ctx a -> Validator s ctx b -> Validator s ctx c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: Validator s ctx a -> Validator s ctx b -> Validator s ctx a
$c<* :: forall (s :: Stage) ctx a b.
Validator s ctx a -> Validator s ctx b -> Validator s ctx a
*> :: Validator s ctx a -> Validator s ctx b -> Validator s ctx b
$c*> :: forall (s :: Stage) ctx a b.
Validator s ctx a -> Validator s ctx b -> Validator s ctx b
liftA2 :: (a -> b -> c)
-> Validator s ctx a -> Validator s ctx b -> Validator s ctx c
$cliftA2 :: forall (s :: Stage) ctx a b c.
(a -> b -> c)
-> Validator s ctx a -> Validator s ctx b -> Validator s ctx c
<*> :: Validator s ctx (a -> b) -> Validator s ctx a -> Validator s ctx b
$c<*> :: forall (s :: Stage) ctx a b.
Validator s ctx (a -> b) -> Validator s ctx a -> Validator s ctx b
pure :: a -> Validator s ctx a
$cpure :: forall (s :: Stage) ctx a. a -> Validator s ctx a
$cp1Applicative :: forall (s :: Stage) ctx. Functor (Validator s ctx)
Applicative,
Applicative (Validator s ctx)
a -> Validator s ctx a
Applicative (Validator s ctx)
-> (forall a b.
Validator s ctx a -> (a -> Validator s ctx b) -> Validator s ctx b)
-> (forall a b.
Validator s ctx a -> Validator s ctx b -> Validator s ctx b)
-> (forall a. a -> Validator s ctx a)
-> Monad (Validator s ctx)
Validator s ctx a -> (a -> Validator s ctx b) -> Validator s ctx b
Validator s ctx a -> Validator s ctx b -> Validator s ctx b
forall a. a -> Validator s ctx a
forall a b.
Validator s ctx a -> Validator s ctx b -> Validator s ctx b
forall a b.
Validator s ctx a -> (a -> Validator s ctx b) -> Validator s ctx b
forall (s :: Stage) ctx. Applicative (Validator s ctx)
forall (s :: Stage) ctx a. a -> Validator s ctx a
forall (s :: Stage) ctx a b.
Validator s ctx a -> Validator s ctx b -> Validator s ctx b
forall (s :: Stage) ctx a b.
Validator s ctx a -> (a -> Validator s ctx b) -> Validator s ctx b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> Validator s ctx a
$creturn :: forall (s :: Stage) ctx a. a -> Validator s ctx a
>> :: Validator s ctx a -> Validator s ctx b -> Validator s ctx b
$c>> :: forall (s :: Stage) ctx a b.
Validator s ctx a -> Validator s ctx b -> Validator s ctx b
>>= :: Validator s ctx a -> (a -> Validator s ctx b) -> Validator s ctx b
$c>>= :: forall (s :: Stage) ctx a b.
Validator s ctx a -> (a -> Validator s ctx b) -> Validator s ctx b
$cp1Monad :: forall (s :: Stage) ctx. Applicative (Validator s ctx)
Monad,
MonadReader (ValidatorContext s ctx)
)
data ValidationTarget
= Base
| Fragments
| Selections
type family ValidationStage (s :: ValidationTarget) where
ValidationStage 'Base = OperationContext RAW RAW
ValidationStage 'Fragments = OperationContext VALID RAW
ValidationStage 'Selections = OperationContext VALID VALID
type ValidatorM (s :: ValidationTarget) = Validator VALID (ValidationStage s)
type BaseValidator = ValidatorM 'Base
type FragmentValidator (s :: Stage) = Validator VALID (OperationContext VALID s)
type SelectionValidator = ValidatorM 'Selections
type InputValidator s ctx = Validator s (InputContext ctx)
withScope ::
(MonadReader (ValidatorContext s c) m) =>
(Scope -> Scope) ->
m b ->
m b
withScope :: (Scope -> Scope) -> m b -> m b
withScope Scope -> Scope
f = (ValidatorContext s c -> ValidatorContext s c) -> m b -> m b
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\ValidatorContext {c
Schema s
Config
Scope
config :: Config
localContext :: c
schema :: Schema s
scope :: Scope
config :: forall (s :: Stage) ctx. ValidatorContext s ctx -> Config
localContext :: forall (s :: Stage) ctx. ValidatorContext s ctx -> ctx
schema :: forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s
scope :: forall (s :: Stage) ctx. ValidatorContext s ctx -> Scope
..} -> ValidatorContext :: forall (s :: Stage) ctx.
Scope -> Schema s -> ctx -> Config -> ValidatorContext s ctx
ValidatorContext {scope :: Scope
scope = Scope -> Scope
f Scope
scope, c
Schema s
Config
config :: Config
localContext :: c
schema :: Schema s
config :: Config
localContext :: c
schema :: Schema s
..})
asksLocal :: MonadReader (ValidatorContext s c) m => (c -> a) -> m a
asksLocal :: (c -> a) -> m a
asksLocal c -> a
f = (ValidatorContext s c -> a) -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (c -> a
f (c -> a)
-> (ValidatorContext s c -> c) -> ValidatorContext s c -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidatorContext s c -> c
forall (s :: Stage) ctx. ValidatorContext s ctx -> ctx
localContext)
instance MonadError GQLError (Validator s ctx) where
throwError :: GQLError -> Validator s ctx a
throwError GQLError
err = ReaderT (ValidatorContext s ctx) GQLResult a -> Validator s ctx a
forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) GQLResult a -> Validator s ctx a
Validator (ReaderT (ValidatorContext s ctx) GQLResult a -> Validator s ctx a)
-> ReaderT (ValidatorContext s ctx) GQLResult a
-> Validator s ctx a
forall a b. (a -> b) -> a -> b
$ do
ValidatorContext s ctx
ctx <- ReaderT (ValidatorContext s ctx) GQLResult (ValidatorContext s ctx)
forall r (m :: * -> *). MonadReader r m => m r
ask
GQLError -> ReaderT (ValidatorContext s ctx) GQLResult a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ValidatorContext s ctx -> GQLError -> GQLError
forall (s :: Stage) ctx.
ValidatorContext s ctx -> GQLError -> GQLError
fromValidationError ValidatorContext s ctx
ctx GQLError
err)
catchError :: Validator s ctx a
-> (GQLError -> Validator s ctx a) -> Validator s ctx a
catchError (Validator ReaderT (ValidatorContext s ctx) GQLResult a
x) GQLError -> Validator s ctx a
f = ReaderT (ValidatorContext s ctx) GQLResult a -> Validator s ctx a
forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) GQLResult a -> Validator s ctx a
Validator (ReaderT (ValidatorContext s ctx) GQLResult a
-> (GQLError -> ReaderT (ValidatorContext s ctx) GQLResult a)
-> ReaderT (ValidatorContext s ctx) GQLResult a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError ReaderT (ValidatorContext s ctx) GQLResult a
x (Validator s ctx a -> ReaderT (ValidatorContext s ctx) GQLResult a
forall (s :: Stage) ctx a.
Validator s ctx a -> ReaderT (ValidatorContext s ctx) GQLResult a
_runValidator (Validator s ctx a -> ReaderT (ValidatorContext s ctx) GQLResult a)
-> (GQLError -> Validator s ctx a)
-> GQLError
-> ReaderT (ValidatorContext s ctx) GQLResult a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GQLError -> Validator s ctx a
f))
fromValidationError :: ValidatorContext s ctx -> GQLError -> GQLError
fromValidationError :: ValidatorContext s ctx -> GQLError -> GQLError
fromValidationError
context :: ValidatorContext s ctx
context@ValidatorContext
{ Config
config :: Config
config :: forall (s :: Stage) ctx. ValidatorContext s ctx -> Config
config,
scope :: forall (s :: Stage) ctx. ValidatorContext s ctx -> Scope
scope = Scope {Maybe Position
position :: Scope -> Maybe Position
position :: Maybe Position
position, [PropName]
path :: Scope -> [PropName]
path :: [PropName]
path}
}
GQLError
err
| GQLError -> Bool
isInternal GQLError
err Bool -> Bool -> Bool
|| Config -> Bool
debug Config
config =
( GQLError
err GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> ValidatorContext s ctx -> GQLError
forall (s :: Stage) ctx. ValidatorContext s ctx -> GQLError
renderContext ValidatorContext s ctx
context
GQLError -> Maybe Position -> GQLError
forall (t :: * -> *).
Foldable t =>
GQLError -> t Position -> GQLError
`atPositions` Maybe Position
position
)
GQLError -> [PropName] -> GQLError
`withPath` [PropName]
path
| Bool
otherwise = GQLError
err
renderContext :: ValidatorContext s ctx -> GQLError
renderContext :: ValidatorContext s ctx -> GQLError
renderContext
ValidatorContext
{ Schema s
schema :: Schema s
schema :: forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s
schema,
Scope
scope :: Scope
scope :: forall (s :: Stage) ctx. ValidatorContext s ctx -> Scope
scope
} =
Scope -> GQLError
renderScope Scope
scope
GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> GQLError -> Schema s -> GQLError
forall a. RenderGQL a => GQLError -> a -> GQLError
renderSection GQLError
"SchemaDefinition" Schema s
schema