{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Morpheus.Types.Internal.Validation.Validator
( Validator (..),
SelectionValidator,
InputValidator,
BaseValidator,
runValidator,
askSchema,
askContext,
askFragments,
Constraint (..),
withScope,
withScopeType,
withScopePosition,
askScopeTypeName,
askScopePosition,
withInputScope,
inputMessagePrefix,
Context (..),
InputSource (..),
InputContext (..),
SelectionContext (..),
renderInputPrefix,
Target (..),
Prop (..),
Resolution,
ScopeKind (..),
)
where
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 (..),
FieldName,
FieldsDefinition,
Fragments,
GQLError (..),
GQLErrors,
IN,
Message,
OUT,
Position,
RAW,
RESOLVED,
Schema,
TypeDefinition (..),
TypeName,
VALID,
Variable (..),
VariableDefinitions,
intercalateName,
msg,
)
import Data.Morpheus.Types.Internal.Resolving
( Eventless,
)
import Data.Semigroup
( (<>),
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 -> 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. "
data ScopeKind
= DIRECTIVE
| SELECTION
deriving (Show)
data Context = Context
{ schema :: Schema,
fragments :: Fragments,
scopePosition :: Position,
scopeTypeName :: TypeName,
operationName :: Maybe FieldName,
scopeSelectionName :: FieldName,
scopeKind :: ScopeKind
}
deriving (Show)
data InputContext = InputContext
{ inputSource :: InputSource,
inputPath :: [Prop]
}
deriving (Show)
data InputSource
= SourceArgument (Argument RESOLVED)
| SourceVariable (Variable RAW)
deriving (Show)
newtype SelectionContext = SelectionContext
{ variables :: VariableDefinitions VALID
}
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 a -> InputValidator a
withInputScope prop = setContext update
where
update ctx@InputContext {inputPath = old} =
ctx {inputPath = old <> [prop]}
askContext :: Validator ctx ctx
askContext = snd <$> Validator ask
askSchema :: Validator ctx Schema
askSchema = schema . fst <$> Validator ask
askFragments :: Validator ctx Fragments
askFragments = fragments . fst <$> Validator ask
askScopeTypeName :: Validator ctx TypeName
askScopeTypeName = scopeTypeName . fst <$> Validator ask
askScopePosition :: Validator ctx Position
askScopePosition = scopePosition . fst <$> Validator ask
setContext ::
(c' -> c) ->
Validator c a ->
Validator c' a
setContext f = Validator . withReaderT (\(x, y) -> (x, f y)) . _runValidator
setGlobalContext ::
(Context -> Context) ->
Validator c a ->
Validator c a
setGlobalContext f = Validator . withReaderT (\(x, y) -> (f x, y)) . _runValidator
withScope :: TypeName -> Position -> Validator ctx a -> Validator ctx a
withScope scopeTypeName scopePosition = setGlobalContext update
where
update ctx = ctx {scopeTypeName, scopePosition}
withScopePosition :: Position -> Validator ctx a -> Validator ctx a
withScopePosition scopePosition = setGlobalContext update
where
update ctx = ctx {scopePosition}
withScopeType :: TypeName -> Validator ctx a -> Validator ctx a
withScopeType scopeTypeName = setGlobalContext update
where
update ctx = ctx {scopeTypeName}
inputMessagePrefix :: InputValidator Message
inputMessagePrefix = renderInputPrefix <$> askContext
runValidator :: Validator ctx a -> Context -> ctx -> Eventless a
runValidator (Validator x) globalCTX ctx = runReaderT x (globalCTX, ctx)
newtype Validator ctx a = Validator
{ _runValidator ::
ReaderT
(Context, ctx)
Eventless
a
}
deriving
( Functor,
Applicative,
Monad
)
type BaseValidator = Validator ()
type SelectionValidator = Validator SelectionContext
type InputValidator = Validator InputContext
instance Failure Message (Validator ctx) where
failure inputMessage = do
position <- askScopePosition
failure
[ GQLError
{ message = "INTERNAL: " <> inputMessage,
locations = [position]
}
]
instance Failure GQLErrors (Validator ctx) where
failure = Validator . lift . failure