{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Morpheus.Types.Internal.Validation.Validator
( Validator (..),
SelectionValidator,
InputValidator,
BaseValidator,
runValidator,
Constraint (..),
withScope,
withScopeType,
withPosition,
withInputScope,
inputMessagePrefix,
InputSource (..),
InputContext (..),
OperationContext (..),
CurrentSelection (..),
renderInputPrefix,
Target (..),
Prop (..),
Resolution,
ScopeKind (..),
inputValueSource,
Scope (..),
withDirective,
startInput,
GetWith (..),
SetWith (..),
MonadContext (..),
withContext,
renderField,
asks,
askSchema,
askVariables,
askFragments,
)
where
import Control.Monad.Reader (MonadReader)
import Control.Monad.Trans.Class (MonadTrans (..))
import Control.Monad.Trans.Reader
( ReaderT (..),
ask,
withReaderT,
)
import Data.Morpheus.Internal.Utils
( Failure (..),
)
import Data.Morpheus.Types.Internal.AST
( Argument (..),
Directive (..),
FieldName (..),
FieldsDefinition,
Fragments,
GQLError (..),
GQLErrors,
IN,
Message,
OUT,
Position,
RAW,
RESOLVED,
Ref (..),
Schema,
TypeDefinition,
TypeName (..),
VALID,
Variable (..),
VariableDefinitions,
intercalateName,
msg,
)
import Data.Morpheus.Types.Internal.Resolving
( Eventless,
)
import Data.Semigroup
( (<>),
)
data Prop = Prop
{ propName :: FieldName,
propTypeName :: TypeName
}
deriving (Show)
type Path = [Prop]
renderPath :: Path -> Message
renderPath [] = ""
renderPath path = "in field " <> msg (intercalateName "." $ map propName path) <> ": "
renderInputPrefix :: InputContext c -> Message
renderInputPrefix InputContext {inputPath, inputSource} =
renderSource inputSource <> renderPath inputPath
renderSource :: InputSource -> Message
renderSource (SourceArgument Argument {argumentName}) =
"Argument " <> msg argumentName <> " got invalid value. "
renderSource (SourceVariable Variable {variableName} _) =
"Variable " <> msg ("$" <> variableName) <> " got invalid value. "
renderSource SourceInputField {sourceTypeName, sourceFieldName, sourceArgumentName} =
"Field " <> renderField sourceTypeName sourceFieldName sourceArgumentName <> " got invalid default value. "
renderField :: TypeName -> FieldName -> Maybe FieldName -> Message
renderField (TypeName tname) (FieldName fname) arg =
msg (tname <> "." <> fname <> renderArg arg)
where
renderArg (Just (FieldName argName)) = "(" <> argName <> ":)"
renderArg Nothing = ""
data ScopeKind
= DIRECTIVE
| SELECTION
| TYPE
deriving (Show)
data OperationContext vars = OperationContext
{ schema :: Schema,
scope :: Scope,
fragments :: Fragments,
selection :: CurrentSelection,
variables :: vars
}
deriving (Show)
data CurrentSelection = CurrentSelection
{ operationName :: Maybe FieldName,
selectionName :: FieldName
}
deriving (Show)
data Scope = Scope
{ position :: Position,
typename :: TypeName,
kind :: ScopeKind
}
deriving (Show)
data InputContext ctx = InputContext
{ inputSource :: InputSource,
inputPath :: [Prop],
sourceContext :: ctx
}
deriving (Show)
data InputSource
= SourceArgument (Argument RESOLVED)
| SourceVariable
{ sourceVariable :: Variable RAW,
isDefaultValue :: Bool
}
| SourceInputField
{ sourceTypeName :: TypeName,
sourceFieldName :: FieldName,
sourceArgumentName :: Maybe FieldName
}
deriving (Show)
data Target
= TARGET_OBJECT
| TARGET_INPUT
data Constraint (a :: Target) where
OBJECT :: Constraint 'TARGET_OBJECT
INPUT :: Constraint 'TARGET_INPUT
type family Resolution (a :: Target)
type instance Resolution 'TARGET_OBJECT = (TypeName, FieldsDefinition OUT)
type instance Resolution 'TARGET_INPUT = TypeDefinition IN
withInputScope :: Prop -> InputValidator c a -> InputValidator c a
withInputScope prop = withContext update
where
update
InputContext
{ inputPath = old,
..
} =
InputContext
{ inputPath = old <> [prop],
..
}
inputValueSource ::
forall m c.
( GetWith c InputSource,
MonadContext m c
) =>
m c InputSource
inputValueSource = get
asks ::
( MonadContext m c,
GetWith c t
) =>
(t -> a) ->
m c a
asks f = f <$> get
setSelectionName ::
( MonadContext m c,
SetWith c CurrentSelection
) =>
FieldName ->
m c a ->
m c a
setSelectionName selectionName = set update
where
update ctx = ctx {selectionName}
askSchema ::
( MonadContext m c,
GetWith c Schema
) =>
m c Schema
askSchema = get
askVariables ::
( MonadContext m c,
GetWith c (VariableDefinitions VALID)
) =>
m c (VariableDefinitions VALID)
askVariables = get
askFragments ::
( MonadContext m c,
GetWith c Fragments
) =>
m c Fragments
askFragments = get
runValidator :: Validator ctx a -> ctx -> Eventless a
runValidator (Validator x) = runReaderT x
withContext ::
(c' -> c) ->
Validator c a ->
Validator c' a
withContext f = Validator . withReaderT f . _runValidator
withDirective ::
( SetWith c CurrentSelection,
SetWith c Scope,
MonadContext m c
) =>
Directive s ->
m c a ->
m c a
withDirective
Directive
{ directiveName,
directivePosition
} = setSelectionName directiveName . set update
where
update Scope {..} =
Scope
{ position = directivePosition,
kind = DIRECTIVE,
..
}
withScope ::
( SetWith c CurrentSelection,
MonadContext m c,
SetWith c Scope
) =>
TypeName ->
Ref ->
m c a ->
m c a
withScope typeName (Ref selName pos) =
setSelectionName selName . set update
where
update Scope {..} = Scope {typename = typeName, position = pos, ..}
withPosition ::
( MonadContext m c,
SetWith c Scope
) =>
Position ->
m c a ->
m c a
withPosition pos = set update
where
update Scope {..} = Scope {position = pos, ..}
withScopeType ::
( MonadContext m c,
SetWith c Scope
) =>
TypeName ->
m c a ->
m c a
withScopeType name = set update
where
update Scope {..} = Scope {typename = name, ..}
inputMessagePrefix :: InputValidator ctx Message
inputMessagePrefix = renderInputPrefix <$> Validator ask
startInput ::
InputSource ->
InputValidator ctx a ->
Validator ctx a
startInput inputSource = withContext update
where
update sourceContext =
InputContext
{ inputSource,
inputPath = [],
sourceContext
}
newtype Validator ctx a = Validator
{ _runValidator ::
ReaderT
ctx
Eventless
a
}
deriving newtype
( Functor,
Applicative,
Monad,
MonadReader ctx
)
type BaseValidator = Validator (OperationContext ())
type SelectionValidator = Validator (OperationContext (VariableDefinitions VALID))
type InputValidator ctx = Validator (InputContext ctx)
get :: (MonadContext m ctx, GetWith ctx a) => m ctx a
get = getContext getWith
set ::
( MonadContext m c,
SetWith c a
) =>
(a -> a) ->
m c b ->
m c b
set f = setContext (setWith f)
class
Monad (m c) =>
MonadContext m c
where
getContext :: (c -> a) -> m c a
setContext :: (c -> c) -> m c b -> m c b
instance MonadContext Validator c where
getContext f = f <$> Validator ask
setContext = withContext
class GetWith (c :: *) (v :: *) where
getWith :: c -> v
instance GetWith (OperationContext v) Scope where
getWith = scope
instance GetWith c Scope => GetWith (InputContext c) Scope where
getWith = getWith . sourceContext
instance GetWith (OperationContext c) Schema where
getWith = schema
instance GetWith c Schema => GetWith (InputContext c) Schema where
getWith = getWith . sourceContext
instance GetWith (OperationContext (VariableDefinitions VALID)) (VariableDefinitions VALID) where
getWith = variables
instance GetWith (InputContext ctx) InputSource where
getWith = inputSource
instance GetWith (OperationContext v) Fragments where
getWith = fragments
class SetWith (c :: *) (v :: *) where
setWith :: (v -> v) -> c -> c
instance SetWith (OperationContext v) CurrentSelection where
setWith f OperationContext {selection = selection, ..} =
OperationContext
{ selection = f selection,
..
}
instance SetWith (OperationContext v) Scope where
setWith f OperationContext {..} =
OperationContext
{ scope = f scope,
..
}
instance SetWith c Scope => SetWith (InputContext c) Scope where
setWith f InputContext {..} =
InputContext
{ sourceContext = setWith f sourceContext,
..
}
instance
( MonadContext Validator ctx,
GetWith ctx Scope
) =>
Failure Message (Validator ctx)
where
failure inputMessage = do
position <- asks position
failure
[ GQLError
{ message = "INTERNAL: " <> inputMessage,
locations = [position]
}
]
instance Failure GQLErrors (Validator ctx) where
failure = Validator . lift . failure