{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Types.Internal.Validation
( Validator,
SelectionValidator,
InputValidator,
BaseValidator,
InputSource (..),
OperationContext (..),
runValidator,
askType,
askTypeMember,
selectRequired,
selectKnown,
Constraint (..),
constraint,
asksScope,
selectWithDefaultValue,
startInput,
inField,
inputMessagePrefix,
checkUnused,
Prop (..),
constraintInputUnion,
ScopeKind (..),
setDirective,
inputValueSource,
askVariables,
Scope (..),
MissingRequired (..),
InputContext,
Unknown,
askFragments,
getOperationType,
selectType,
FragmentValidator,
askInterfaceTypes,
askTypeDefinitions,
withScope,
setPosition,
setSelection,
ValidatorContext (..),
)
where
import Control.Monad.Except (throwError)
import Data.Morpheus.Internal.Utils
( IsMap,
KeyOf (..),
member,
selectBy,
selectOr,
throwErrors,
)
import Data.Morpheus.Types.Internal.AST
( ANY,
FieldContent (..),
FieldDefinition (..),
FieldName,
IN,
Position (..),
Ref (..),
TRUE,
TypeName,
Value (..),
constraintInputUnion,
fromAny,
isNullable,
msg,
withPath,
)
import Data.Morpheus.Types.Internal.AST.TypeSystem
import Data.Morpheus.Types.Internal.Validation.Error
( KindViolation (..),
MissingRequired (..),
Unknown (..),
Unused (..),
)
import Data.Morpheus.Types.Internal.Validation.Internal
( askInterfaceTypes,
askType,
askTypeMember,
getOperationType,
)
import Data.Morpheus.Types.Internal.Validation.Validator
import Relude hiding (Constraint)
getUnused :: (KeyOf k b, IsMap k c, Foldable t) => c a -> t b -> [b]
getUnused :: forall k b (c :: * -> *) (t :: * -> *) a.
(KeyOf k b, IsMap k c, Foldable t) =>
c a -> t b -> [b]
getUnused c a
uses = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall k (m :: * -> *) a. IsMap k m => k -> m a -> Bool
`member` c a
uses) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. KeyOf k a => a -> k
keyOf) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
failOnUnused :: Unused a => [a] -> Validator s (OperationContext s1 s2) ()
failOnUnused :: forall a (s :: Stage) (s1 :: Stage) (s2 :: Stage).
Unused a =>
[a] -> Validator s (OperationContext s1 s2) ()
failOnUnused [] = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
failOnUnused (a
x : [a]
xs) = do
ValidatorContext s (OperationContext s1 s2)
ctx <- forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) GQLResult a -> Validator s ctx a
Validator forall r (m :: * -> *). MonadReader r m => m r
ask
forall e (m :: * -> *) b. MonadError e m => NonEmpty e -> m b
throwErrors forall a b. (a -> b) -> a -> b
$ (GQLError -> [PropName] -> GQLError
`withPath` Scope -> [PropName]
path (forall (s :: Stage) ctx. ValidatorContext s ctx -> Scope
scope ValidatorContext s (OperationContext s1 s2)
ctx)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c (s1 :: Stage) (s2 :: Stage).
Unused c =>
OperationContext s1 s2 -> c -> GQLError
unused (forall (s :: Stage) ctx. ValidatorContext s ctx -> ctx
localContext ValidatorContext s (OperationContext s1 s2)
ctx) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a
x forall a. a -> [a] -> NonEmpty a
:| [a]
xs)
checkUnused ::
( KeyOf k b,
IsMap k c,
Unused b,
Foldable t
) =>
c a ->
t b ->
Validator s (OperationContext s1 s2) ()
checkUnused :: forall k b (c :: * -> *) (t :: * -> *) a (s :: Stage) (s1 :: Stage)
(s2 :: Stage).
(KeyOf k b, IsMap k c, Unused b, Foldable t) =>
c a -> t b -> Validator s (OperationContext s1 s2) ()
checkUnused c a
uses = forall a (s :: Stage) (s1 :: Stage) (s2 :: Stage).
Unused a =>
[a] -> Validator s (OperationContext s1 s2) ()
failOnUnused forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k b (c :: * -> *) (t :: * -> *) a.
(KeyOf k b, IsMap k c, Foldable t) =>
c a -> t b -> [b]
getUnused c a
uses
constraint ::
KindViolation k inp =>
Constraint (k :: TypeCategory) ->
inp ->
TypeDefinition ANY s ->
Validator s ctx (TypeDefinition k s)
constraint :: forall (k :: TypeCategory) inp (s :: Stage) ctx.
KindViolation k inp =>
Constraint k
-> inp
-> TypeDefinition ANY s
-> Validator s ctx (TypeDefinition k s)
constraint Constraint k
IMPLEMENTABLE inp
_ TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataObject {FieldsDefinition OUT s
objectFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectFields, [TypeName]
objectImplements :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> [TypeName]
objectImplements :: [TypeName]
..}, Maybe Description
Directives s
TypeName
typeDirectives :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Directives s
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeDescription :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Maybe Description
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Description
..} =
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeDefinition {typeContent :: TypeContent TRUE k s
typeContent = DataObject {FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectFields :: FieldsDefinition OUT s
objectFields, [TypeName]
objectImplements :: [TypeName]
objectImplements :: [TypeName]
..}, Maybe Description
Directives s
TypeName
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Description
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Description
..}
constraint Constraint k
IMPLEMENTABLE inp
_ TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataInterface FieldsDefinition OUT s
fields, Maybe Description
Directives s
TypeName
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Description
typeDirectives :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Directives s
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeDescription :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Maybe Description
..} =
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeDefinition {typeContent :: TypeContent TRUE k s
typeContent = forall (s :: Stage) (a :: TypeCategory).
FieldsDefinition OUT s -> TypeContent ('IMPLEMENTABLE <=? a) a s
DataInterface FieldsDefinition OUT s
fields, Maybe Description
Directives s
TypeName
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Description
typeDirectives :: Directives s
typeName :: TypeName
typeDescription :: Maybe Description
..}
constraint Constraint k
INPUT inp
ctx TypeDefinition ANY s
x = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (forall (t :: TypeCategory) ctx (c :: TypeCategory -> *).
KindViolation t ctx =>
c t -> ctx -> GQLError
kindViolation Constraint 'IN
INPUT inp
ctx)) forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory)
(s :: Stage).
FromCategory a ANY k =>
a ANY s -> Maybe (a k s)
fromAny TypeDefinition ANY s
x)
constraint Constraint k
target inp
ctx TypeDefinition ANY s
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (forall (t :: TypeCategory) ctx (c :: TypeCategory -> *).
KindViolation t ctx =>
c t -> ctx -> GQLError
kindViolation Constraint k
target inp
ctx)
selectRequired ::
( IsMap FieldName c,
MissingRequired (c a) ctx
) =>
Ref FieldName ->
c a ->
Validator s ctx a
selectRequired :: forall (c :: * -> *) a ctx (s :: Stage).
(IsMap FieldName c, MissingRequired (c a) ctx) =>
Ref FieldName -> c a -> Validator s ctx a
selectRequired Ref FieldName
selector c a
container =
do
ValidatorContext {Scope
scope :: Scope
scope :: forall (s :: Stage) ctx. ValidatorContext s ctx -> Scope
scope, ctx
localContext :: ctx
localContext :: forall (s :: Stage) ctx. ValidatorContext s ctx -> ctx
localContext} <- forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) GQLResult a -> Validator s ctx a
Validator forall r (m :: * -> *). MonadReader r m => m r
ask
forall e (m :: * -> *) k (c :: * -> *) a.
(MonadError e m, IsMap k c, Monad m) =>
e -> k -> c a -> m a
selectBy
(forall c ctx.
MissingRequired c ctx =>
Scope -> ctx -> Ref FieldName -> c -> GQLError
missingRequired Scope
scope ctx
localContext Ref FieldName
selector c a
container)
(forall k a. KeyOf k a => a -> k
keyOf Ref FieldName
selector)
c a
container
selectWithDefaultValue ::
forall ctx c s 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 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
Value s -> Validator s ctx validValue
f
a -> Validator s ctx validValue
validateF
field :: FieldDefinition 'IN s
field@FieldDefinition
{ FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName :: FieldName
fieldName,
Maybe (FieldContent TRUE 'IN s)
fieldContent :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> Maybe (FieldContent TRUE cat s)
fieldContent :: Maybe (FieldContent TRUE 'IN s)
fieldContent
}
c a
values =
forall k (c :: * -> *) d a.
IsMap k c =>
d -> (a -> d) -> k -> c a -> d
selectOr
(Maybe (FieldContent TRUE 'IN s) -> Validator s ctx validValue
handleNull Maybe (FieldContent TRUE 'IN s)
fieldContent)
a -> Validator s ctx validValue
validateF
FieldName
fieldName
c a
values
where
handleNull ::
Maybe (FieldContent TRUE IN s) ->
Validator s ctx validValue
handleNull :: Maybe (FieldContent TRUE 'IN s) -> Validator s ctx validValue
handleNull (Just (DefaultInputValue Value s
value)) = Value s -> Validator s ctx validValue
f Value s
value
handleNull Maybe (FieldContent TRUE 'IN s)
Nothing
| forall a. Nullable a => a -> Bool
isNullable FieldDefinition 'IN s
field = Value s -> Validator s ctx validValue
f forall (stage :: Stage). Value stage
Null
| Bool
otherwise = Validator s ctx validValue
failSelection
failSelection :: Validator s ctx validValue
failSelection = do
ValidatorContext {Scope
scope :: Scope
scope :: forall (s :: Stage) ctx. ValidatorContext s ctx -> Scope
scope, ctx
localContext :: ctx
localContext :: forall (s :: Stage) ctx. ValidatorContext s ctx -> ctx
localContext} <- forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) GQLResult a -> Validator s ctx a
Validator forall r (m :: * -> *). MonadReader r m => m r
ask
Maybe Position
position <- forall (s :: Stage) ctx (m :: * -> *) a.
MonadReader (ValidatorContext s ctx) m =>
(Scope -> a) -> m a
asksScope Scope -> Maybe Position
position
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ forall c ctx.
MissingRequired c ctx =>
Scope -> ctx -> Ref FieldName -> c -> GQLError
missingRequired Scope
scope ctx
localContext (forall name. name -> Position -> Ref name
Ref FieldName
fieldName (forall a. a -> Maybe a -> a
fromMaybe (Int -> Int -> Position
Position Int
0 Int
0) Maybe Position
position)) c a
values
selectType ::
TypeName ->
Validator s ctx (TypeDefinition ANY s)
selectType :: forall (s :: Stage) ctx.
TypeName -> Validator s ctx (TypeDefinition ANY s)
selectType TypeName
name =
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s
schema forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError GQLError
err) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Stage).
TypeName -> Schema s -> Maybe (TypeDefinition ANY s)
lookupDataType TypeName
name
where
err :: GQLError
err = GQLError
"Unknown Type " forall a. Semigroup a => a -> a -> a
<> forall a. Msg a => a -> GQLError
msg TypeName
name forall a. Semigroup a => a -> a -> a
<> GQLError
"."
selectKnown ::
( IsMap k c,
Unknown sel ctx,
KeyOf k sel
) =>
sel ->
c a ->
Validator s ctx a
selectKnown :: 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 sel
selector c a
lib =
do
ValidatorContext {Scope
scope :: Scope
scope :: forall (s :: Stage) ctx. ValidatorContext s ctx -> Scope
scope, ctx
localContext :: ctx
localContext :: forall (s :: Stage) ctx. ValidatorContext s ctx -> ctx
localContext} <- forall (s :: Stage) ctx a.
ReaderT (ValidatorContext s ctx) GQLResult a -> Validator s ctx a
Validator forall r (m :: * -> *). MonadReader r m => m r
ask
forall e (m :: * -> *) k (c :: * -> *) a.
(MonadError e m, IsMap k c, Monad m) =>
e -> k -> c a -> m a
selectBy
(forall ref ctx. Unknown ref ctx => Scope -> ctx -> ref -> GQLError
unknown Scope
scope ctx
localContext sel
selector)
(forall k a. KeyOf k a => a -> k
keyOf sel
selector)
c a
lib