{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Validation.Query.Selection
( validateOperation,
validateFragmentSelection,
)
where
import Control.Monad.Except (throwError)
import Data.Mergeable
( toNonEmpty,
)
import Data.Morpheus.Error.Selection
( hasNoSubfields,
subfieldsNotSelected,
)
import Data.Morpheus.Ext.Empty (Empty (..))
import Data.Morpheus.Internal.Utils
( keyOf,
mergeConcat,
singleton,
startHistory,
throwErrors,
)
import Data.Morpheus.Types.Internal.AST
( Arguments,
DirectiveLocation (FIELD, FRAGMENT_SPREAD, INLINE_FRAGMENT, MUTATION, QUERY, SUBSCRIPTION),
Directives,
FieldDefinition (..),
FieldName,
FieldsDefinition,
Fragment (..),
FragmentName,
GQLError,
IMPLEMENTABLE,
OUT,
Operation (..),
OperationType (..),
RAW,
Ref (..),
Selection (..),
SelectionContent (..),
SelectionSet,
TRUE,
TypeContent (..),
TypeDefinition (..),
UnionTag (..),
VALID,
at,
isLeaf,
mkTypeRef,
msg,
possibleTypes,
toCategory,
typed,
)
import Data.Morpheus.Types.Internal.Validation
( FragmentValidator,
SelectionValidator,
askType,
getOperationType,
schema,
selectKnown,
setSelection,
withScope,
)
import Data.Morpheus.Validation.Internal.Arguments
( validateFieldArguments,
)
import Data.Morpheus.Validation.Internal.Directive
( shouldIncludeSelection,
validateDirectives,
)
import Data.Morpheus.Validation.Query.Fragment
( ValidateFragmentSelection,
selectFragmentType,
validateFragment,
validateSpread,
)
import Data.Morpheus.Validation.Query.UnionSelection
( validateInterfaceSelection,
validateUnionSelection,
)
import Relude hiding (empty, join)
selectionsWithoutTypename :: SelectionSet VALID -> [Selection VALID]
selectionsWithoutTypename :: SelectionSet VALID -> [Selection VALID]
selectionsWithoutTypename = forall a. (a -> Bool) -> [a] -> [a]
filter ((FieldName
"__typename" forall a. Eq a => a -> a -> Bool
/=) 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
singleTopLevelSelection :: Operation RAW -> SelectionSet VALID -> SelectionValidator ()
singleTopLevelSelection :: Operation RAW -> SelectionSet VALID -> SelectionValidator ()
singleTopLevelSelection Operation {operationType :: forall (s :: Stage). Operation s -> OperationType
operationType = OperationType
Subscription, Maybe FieldName
operationName :: forall (s :: Stage). Operation s -> Maybe FieldName
operationName :: Maybe FieldName
operationName} SelectionSet VALID
selSet =
case SelectionSet VALID -> [Selection VALID]
selectionsWithoutTypename SelectionSet VALID
selSet of
(Selection VALID
_ : (Selection VALID
x : [Selection VALID]
xs)) -> forall e (m :: * -> *) b. MonadError e m => NonEmpty e -> m b
throwErrors forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe FieldName -> Selection VALID -> GQLError
singleTopLevelSelectionError Maybe FieldName
operationName) (Selection VALID
x forall a. a -> [a] -> NonEmpty a
:| [Selection VALID]
xs)
[Selection VALID]
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
singleTopLevelSelection Operation RAW
_ SelectionSet VALID
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
singleTopLevelSelectionError :: Maybe FieldName -> Selection VALID -> GQLError
singleTopLevelSelectionError :: Maybe FieldName -> Selection VALID -> GQLError
singleTopLevelSelectionError Maybe FieldName
name Selection {Position
selectionPosition :: forall (s :: Stage). Selection s -> Position
selectionPosition :: Position
selectionPosition} =
( forall b a. b -> (a -> b) -> Maybe a -> b
maybe GQLError
"Anonymous Subscription" ((GQLError
"Subscription " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Msg a => a -> GQLError
msg) Maybe FieldName
name
forall a. Semigroup a => a -> a -> a
<> GQLError
" must select "
forall a. Semigroup a => a -> a -> a
<> GQLError
"only one top level field."
)
GQLError -> Position -> GQLError
`at` Position
selectionPosition
validateOperation ::
Operation RAW ->
SelectionValidator (Operation VALID)
validateOperation :: Operation RAW -> SelectionValidator (Operation VALID)
validateOperation
rawOperation :: Operation RAW
rawOperation@Operation
{ Maybe FieldName
operationName :: Maybe FieldName
operationName :: forall (s :: Stage). Operation s -> Maybe FieldName
operationName,
OperationType
operationType :: OperationType
operationType :: forall (s :: Stage). Operation s -> OperationType
operationType,
SelectionSet RAW
operationSelection :: forall (s :: Stage). Operation s -> SelectionSet s
operationSelection :: SelectionSet RAW
operationSelection,
Directives RAW
operationDirectives :: forall (s :: Stage). Operation s -> Directives s
operationDirectives :: Directives RAW
operationDirectives,
VariableDefinitions RAW
Position
operationArguments :: forall (s :: Stage). Operation s -> VariableDefinitions s
operationPosition :: forall (s :: Stage). Operation s -> Position
operationArguments :: VariableDefinitions RAW
operationPosition :: Position
..
} =
do
TypeDefinition OBJECT VALID
typeDef <- forall (a :: Stage).
Operation a -> SelectionValidator (TypeDefinition OBJECT VALID)
getOperationType Operation RAW
rawOperation
MergeMap 'False FieldName (Selection VALID)
selection <- forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
validateSelectionSet (forall (a :: TypeCategory -> Stage -> *) (k :: TypeCategory)
(k' :: TypeCategory) (s :: Stage).
ToCategory a k k' =>
a k s -> a k' s
toCategory TypeDefinition OBJECT VALID
typeDef) SelectionSet RAW
operationSelection
Operation RAW -> SelectionSet VALID -> SelectionValidator ()
singleTopLevelSelection Operation RAW
rawOperation MergeMap 'False FieldName (Selection VALID)
selection
Directives VALID
directives <-
forall ctx (schemaS :: Stage) (s :: Stage).
ArgumentsConstraints ctx schemaS s =>
DirectiveLocation
-> Directives s -> Validator schemaS ctx (Directives VALID)
validateDirectives
(OperationType -> DirectiveLocation
toDirectiveLocation OperationType
operationType)
Directives RAW
operationDirectives
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
Operation
{ Maybe FieldName
operationName :: Maybe FieldName
operationName :: Maybe FieldName
operationName,
OperationType
operationType :: OperationType
operationType :: OperationType
operationType,
operationArguments :: VariableDefinitions VALID
operationArguments = forall coll. Empty coll => coll
empty,
operationSelection :: SelectionSet VALID
operationSelection = MergeMap 'False FieldName (Selection VALID)
selection,
operationDirectives :: Directives VALID
operationDirectives = Directives VALID
directives,
Position
operationPosition :: Position
operationPosition :: Position
..
}
toDirectiveLocation :: OperationType -> DirectiveLocation
toDirectiveLocation :: OperationType -> DirectiveLocation
toDirectiveLocation OperationType
Subscription = DirectiveLocation
SUBSCRIPTION
toDirectiveLocation OperationType
Mutation = DirectiveLocation
MUTATION
toDirectiveLocation OperationType
Query = DirectiveLocation
QUERY
processSelectionDirectives ::
DirectiveLocation ->
Directives RAW ->
(Directives VALID -> FragmentValidator s (SelectionSet VALID)) ->
FragmentValidator s (Maybe (SelectionSet VALID))
processSelectionDirectives :: forall (s :: Stage).
DirectiveLocation
-> Directives RAW
-> (Directives VALID -> FragmentValidator s (SelectionSet VALID))
-> FragmentValidator s (Maybe (SelectionSet VALID))
processSelectionDirectives DirectiveLocation
location Directives RAW
rawDirectives Directives VALID -> FragmentValidator s (SelectionSet VALID)
sel = do
Directives VALID
directives <- forall ctx (schemaS :: Stage) (s :: Stage).
ArgumentsConstraints ctx schemaS s =>
DirectiveLocation
-> Directives s -> Validator schemaS ctx (Directives VALID)
validateDirectives DirectiveLocation
location Directives RAW
rawDirectives
Bool
include <- forall (schemaS :: Stage) ctx.
Directives VALID -> Validator schemaS ctx Bool
shouldIncludeSelection Directives VALID
directives
MergeMap 'False FieldName (Selection VALID)
selection <- Directives VALID -> FragmentValidator s (SelectionSet VALID)
sel Directives VALID
directives
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
if Bool
include
then forall a. a -> Maybe a
Just MergeMap 'False FieldName (Selection VALID)
selection
else forall a. Maybe a
Nothing
validateFragmentSelection :: (ValidateFragmentSelection s) => Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateFragmentSelection :: forall (s :: Stage).
ValidateFragmentSelection s =>
Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateFragmentSelection f :: Fragment RAW
f@Fragment {SelectionSet RAW
fragmentSelection :: forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentSelection :: SelectionSet RAW
fragmentSelection} = do
TypeDefinition IMPLEMENTABLE VALID
typeDef <- forall (s :: Stage).
Fragment RAW
-> FragmentValidator s (TypeDefinition IMPLEMENTABLE VALID)
selectFragmentType Fragment RAW
f
forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
validateSelectionSet TypeDefinition IMPLEMENTABLE VALID
typeDef SelectionSet RAW
fragmentSelection
getFields :: TypeDefinition IMPLEMENTABLE s -> FieldsDefinition OUT s
getFields :: forall (s :: Stage).
TypeDefinition IMPLEMENTABLE s -> FieldsDefinition OUT s
getFields 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}} = FieldsDefinition OUT s
objectFields
getFields TypeDefinition {typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent = DataInterface FieldsDefinition OUT s
fields} = FieldsDefinition OUT s
fields
validateSelectionSet ::
(ValidateFragmentSelection s) =>
TypeDefinition IMPLEMENTABLE VALID ->
SelectionSet RAW ->
FragmentValidator s (SelectionSet VALID)
validateSelectionSet :: forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
validateSelectionSet TypeDefinition IMPLEMENTABLE VALID
typeDef =
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition IMPLEMENTABLE VALID
-> Selection RAW
-> FragmentValidator s (Maybe (SelectionSet VALID))
validateSelection TypeDefinition IMPLEMENTABLE VALID
typeDef) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall e (f :: * -> *) a.
(IsString e, MonadError e f) =>
[a] -> f (NonEmpty a)
toNonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (m :: * -> *) a. HistoryT m a -> m a
startHistory forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a e.
(Monad m, Merge m a, MonadError e m) =>
NonEmpty a -> m a
mergeConcat
validateSelection :: ValidateFragmentSelection s => TypeDefinition IMPLEMENTABLE VALID -> Selection RAW -> FragmentValidator s (Maybe (SelectionSet VALID))
validateSelection :: forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition IMPLEMENTABLE VALID
-> Selection RAW
-> FragmentValidator s (Maybe (SelectionSet VALID))
validateSelection TypeDefinition IMPLEMENTABLE VALID
typeDef Selection {Maybe FieldName
Maybe FragmentName
Directives RAW
Arguments RAW
Position
FieldName
SelectionContent RAW
selectionOrigin :: forall (s :: Stage). Selection s -> Maybe FragmentName
selectionContent :: forall (s :: Stage). Selection s -> SelectionContent s
selectionDirectives :: forall (s :: Stage). Selection s -> Directives s
selectionArguments :: forall (s :: Stage). Selection s -> Arguments s
selectionName :: forall (s :: Stage). Selection s -> FieldName
selectionAlias :: forall (s :: Stage). Selection s -> Maybe FieldName
selectionOrigin :: Maybe FragmentName
selectionContent :: SelectionContent RAW
selectionDirectives :: Directives RAW
selectionArguments :: Arguments RAW
selectionName :: FieldName
selectionAlias :: Maybe FieldName
selectionPosition :: Position
selectionPosition :: forall (s :: Stage). Selection s -> Position
..} =
forall (s :: Stage) c (m :: * -> *) b.
MonadReader (ValidatorContext s c) m =>
(Scope -> Scope) -> m b -> m b
withScope (forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Ref FieldName -> Scope -> Scope
setSelection TypeDefinition IMPLEMENTABLE VALID
typeDef Ref FieldName
selectionRef) forall a b. (a -> b) -> a -> b
$
forall (s :: Stage).
DirectiveLocation
-> Directives RAW
-> (Directives VALID -> FragmentValidator s (SelectionSet VALID))
-> FragmentValidator s (Maybe (SelectionSet VALID))
processSelectionDirectives DirectiveLocation
FIELD Directives RAW
selectionDirectives Directives VALID
-> Validator
VALID
(OperationContext VALID s)
(MergeMap 'False FieldName (Selection VALID))
validateContent
where
selectionRef :: Ref FieldName
selectionRef = forall name. name -> Position -> Ref name
Ref FieldName
selectionName Position
selectionPosition
validateContent :: Directives VALID
-> Validator
VALID
(OperationContext VALID s)
(MergeMap 'False FieldName (Selection VALID))
validateContent Directives VALID
directives = do
(Arguments VALID
validArgs, SelectionContent VALID
content) <- forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition IMPLEMENTABLE VALID
-> Ref FieldName
-> Arguments RAW
-> SelectionContent RAW
-> FragmentValidator s (Arguments VALID, SelectionContent VALID)
validateSelectionContent TypeDefinition IMPLEMENTABLE VALID
typeDef Ref FieldName
selectionRef Arguments RAW
selectionArguments SelectionContent RAW
selectionContent
let selection :: Selection VALID
selection =
Selection
{ selectionArguments :: Arguments VALID
selectionArguments = Arguments VALID
validArgs,
selectionDirectives :: Directives VALID
selectionDirectives = Directives VALID
directives,
selectionContent :: SelectionContent VALID
selectionContent = SelectionContent VALID
content,
Maybe FieldName
Maybe FragmentName
Position
FieldName
selectionOrigin :: Maybe FragmentName
selectionName :: FieldName
selectionAlias :: Maybe FieldName
selectionOrigin :: Maybe FragmentName
selectionName :: FieldName
selectionAlias :: Maybe FieldName
selectionPosition :: Position
selectionPosition :: Position
..
}
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k (m :: * -> *) a. IsMap k m => k -> a -> m a
singleton (forall k a. KeyOf k a => a -> k
keyOf Selection VALID
selection) Selection VALID
selection
validateSelection TypeDefinition IMPLEMENTABLE VALID
typeDef (Spread Directives RAW
dirs Ref FragmentName
ref) =
forall (s :: Stage).
DirectiveLocation
-> Directives RAW
-> (Directives VALID -> FragmentValidator s (SelectionSet VALID))
-> FragmentValidator s (Maybe (SelectionSet VALID))
processSelectionDirectives DirectiveLocation
FRAGMENT_SPREAD Directives RAW
dirs forall a b. (a -> b) -> a -> b
$
forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$
forall (s :: Stage) (a :: TypeCategory).
ValidateFragmentSelection s =>
TypeDefinition a VALID
-> Ref FragmentName -> FragmentValidator s (SelectionSet VALID)
validateSpreadSelection TypeDefinition IMPLEMENTABLE VALID
typeDef Ref FragmentName
ref
validateSelection TypeDefinition IMPLEMENTABLE VALID
typeDef (InlineFragment fragment :: Fragment RAW
fragment@Fragment {Directives RAW
fragmentDirectives :: forall (stage :: Stage). Fragment stage -> Directives stage
fragmentDirectives :: Directives RAW
fragmentDirectives}) =
forall (s :: Stage).
DirectiveLocation
-> Directives RAW
-> (Directives VALID -> FragmentValidator s (SelectionSet VALID))
-> FragmentValidator s (Maybe (SelectionSet VALID))
processSelectionDirectives DirectiveLocation
INLINE_FRAGMENT Directives RAW
fragmentDirectives forall a b. (a -> b) -> a -> b
$
forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$
forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition IMPLEMENTABLE VALID
-> Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateInlineFragmentSelection TypeDefinition IMPLEMENTABLE VALID
typeDef Fragment RAW
fragment
validateSpreadSelection ::
ValidateFragmentSelection s =>
TypeDefinition a VALID ->
Ref FragmentName ->
FragmentValidator s (SelectionSet VALID)
validateSpreadSelection :: forall (s :: Stage) (a :: TypeCategory).
ValidateFragmentSelection s =>
TypeDefinition a VALID
-> Ref FragmentName -> FragmentValidator s (SelectionSet VALID)
validateSpreadSelection TypeDefinition a VALID
typeDef Ref FragmentName
ref = do
[TypeName]
types <- forall (a :: TypeCategory) (s :: Stage) (s' :: Stage).
TypeDefinition a s -> Schema s' -> [TypeName]
possibleTypes TypeDefinition a VALID
typeDef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s
schema
UnionTag -> SelectionSet VALID
unionTagSelection forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (s :: Stage).
ValidateFragmentSelection s =>
(Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> [TypeName] -> Ref FragmentName -> FragmentValidator s UnionTag
validateSpread forall (s :: Stage).
ValidateFragmentSelection s =>
Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateFragmentSelection [TypeName]
types Ref FragmentName
ref
validateInlineFragmentSelection ::
ValidateFragmentSelection s =>
TypeDefinition IMPLEMENTABLE VALID ->
Fragment RAW ->
FragmentValidator s (SelectionSet VALID)
validateInlineFragmentSelection :: forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition IMPLEMENTABLE VALID
-> Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateInlineFragmentSelection TypeDefinition IMPLEMENTABLE VALID
typeDef Fragment RAW
x = do
[TypeName]
types <- forall (a :: TypeCategory) (s :: Stage) (s' :: Stage).
TypeDefinition a s -> Schema s' -> [TypeName]
possibleTypes TypeDefinition IMPLEMENTABLE VALID
typeDef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall (s :: Stage) ctx. ValidatorContext s ctx -> Schema s
schema
forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentSelection forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (s :: Stage).
(Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> [TypeName]
-> Fragment RAW
-> FragmentValidator s (Fragment VALID)
validateFragment forall (s :: Stage).
ValidateFragmentSelection s =>
Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateFragmentSelection [TypeName]
types Fragment RAW
x
selectSelectionField ::
Ref FieldName ->
TypeDefinition IMPLEMENTABLE s ->
FragmentValidator s' (FieldDefinition OUT s)
selectSelectionField :: forall (s :: Stage) (s' :: Stage).
Ref FieldName
-> TypeDefinition IMPLEMENTABLE s
-> FragmentValidator s' (FieldDefinition OUT s)
selectSelectionField Ref FieldName
ref TypeDefinition IMPLEMENTABLE s
typeDef
| forall name. Ref name -> name
refName Ref FieldName
ref forall a. Eq a => a -> a -> Bool
== FieldName
"__typename" =
forall (f :: * -> *) a. Applicative f => a -> f a
pure
FieldDefinition
{ fieldDescription :: Maybe Description
fieldDescription = forall a. Maybe a
Nothing,
fieldName :: FieldName
fieldName = FieldName
"__typename",
fieldType :: TypeRef
fieldType = TypeName -> TypeRef
mkTypeRef TypeName
"String",
fieldContent :: Maybe (FieldContent TRUE OUT s)
fieldContent = forall a. Maybe a
Nothing,
fieldDirectives :: Directives s
fieldDirectives = forall coll. Empty coll => coll
empty
}
| Bool
otherwise = 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 Ref FieldName
ref (forall (s :: Stage).
TypeDefinition IMPLEMENTABLE s -> FieldsDefinition OUT s
getFields TypeDefinition IMPLEMENTABLE s
typeDef)
validateSelectionContent ::
forall s.
ValidateFragmentSelection s =>
TypeDefinition IMPLEMENTABLE VALID ->
Ref FieldName ->
Arguments RAW ->
SelectionContent RAW ->
FragmentValidator s (Arguments VALID, SelectionContent VALID)
validateSelectionContent :: forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition IMPLEMENTABLE VALID
-> Ref FieldName
-> Arguments RAW
-> SelectionContent RAW
-> FragmentValidator s (Arguments VALID, SelectionContent VALID)
validateSelectionContent TypeDefinition IMPLEMENTABLE VALID
typeDef Ref FieldName
ref Arguments RAW
selectionArguments SelectionContent RAW
content = do
FieldDefinition OUT VALID
fieldDef <- forall (s :: Stage) (s' :: Stage).
Ref FieldName
-> TypeDefinition IMPLEMENTABLE s
-> FragmentValidator s' (FieldDefinition OUT s)
selectSelectionField Ref FieldName
ref TypeDefinition IMPLEMENTABLE VALID
typeDef
TypeDefinition OUT VALID
fieldTypeDef <- forall (m :: * -> *) c (cat :: TypeCategory) (s :: Stage) ctx.
Constraints m c cat s ctx =>
Typed cat s TypeRef -> m (TypeDefinition cat s)
askType (forall (a :: TypeCategory -> Stage -> *) (c :: TypeCategory)
(s :: Stage) b.
(a c s -> b) -> a c s -> Typed c s b
typed forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType FieldDefinition OUT VALID
fieldDef)
Arguments VALID
validArgs <- forall (s :: Stage).
FieldDefinition OUT VALID
-> Arguments RAW -> FragmentValidator s (Arguments VALID)
validateFieldArguments FieldDefinition OUT VALID
fieldDef Arguments RAW
selectionArguments
SelectionContent VALID
validContent <- TypeDefinition OUT VALID
-> SelectionContent RAW
-> FragmentValidator s (SelectionContent VALID)
validateContent TypeDefinition OUT VALID
fieldTypeDef SelectionContent RAW
content
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Arguments VALID
validArgs, SelectionContent VALID
validContent)
where
validateContent :: TypeDefinition OUT VALID
-> SelectionContent RAW
-> FragmentValidator s (SelectionContent VALID)
validateContent TypeDefinition OUT VALID
fieldTypeDef SelectionContent RAW
SelectionField = forall (s' :: Stage) (s :: Stage).
Ref FieldName
-> TypeDefinition OUT VALID
-> FragmentValidator s' (SelectionContent s)
validateContentLeaf Ref FieldName
ref TypeDefinition OUT VALID
fieldTypeDef
validateContent TypeDefinition OUT VALID
fieldTypeDef (SelectionSet SelectionSet RAW
rawSelectionSet) = forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition OUT VALID
-> Ref FieldName
-> SelectionSet RAW
-> FragmentValidator s (SelectionContent VALID)
validateByTypeContent TypeDefinition OUT VALID
fieldTypeDef Ref FieldName
ref SelectionSet RAW
rawSelectionSet
validateContentLeaf ::
Ref FieldName ->
TypeDefinition OUT VALID ->
FragmentValidator s' (SelectionContent s)
validateContentLeaf :: forall (s' :: Stage) (s :: Stage).
Ref FieldName
-> TypeDefinition OUT VALID
-> FragmentValidator s' (SelectionContent s)
validateContentLeaf
(Ref FieldName
selectionName Position
selectionPosition)
TypeDefinition {TypeName
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
typeName :: TypeName
typeName, TypeContent TRUE OUT VALID
typeContent :: TypeContent TRUE OUT VALID
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent}
| forall (a :: TypeCategory) (s :: Stage).
TypeContent TRUE a s -> Bool
isLeaf TypeContent TRUE OUT VALID
typeContent = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (s :: Stage). SelectionContent s
SelectionField
| Bool
otherwise =
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ FieldName -> TypeName -> Position -> GQLError
subfieldsNotSelected FieldName
selectionName TypeName
typeName Position
selectionPosition
validateByTypeContent ::
forall s.
(ValidateFragmentSelection s) =>
TypeDefinition OUT VALID ->
Ref FieldName ->
SelectionSet RAW ->
FragmentValidator s (SelectionContent VALID)
validateByTypeContent :: forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition OUT VALID
-> Ref FieldName
-> SelectionSet RAW
-> FragmentValidator s (SelectionContent VALID)
validateByTypeContent
typeDef :: TypeDefinition OUT VALID
typeDef@TypeDefinition {TypeContent TRUE OUT VALID
typeContent :: TypeContent TRUE OUT VALID
typeContent :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeContent TRUE a s
typeContent, Maybe Description
Directives VALID
TypeName
typeDirectives :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Directives s
typeDescription :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Maybe Description
typeDirectives :: Directives VALID
typeName :: TypeName
typeDescription :: Maybe Description
typeName :: forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> TypeName
..}
Ref FieldName
currentSelectionRef =
forall (s :: Stage) c (m :: * -> *) b.
MonadReader (ValidatorContext s c) m =>
(Scope -> Scope) -> m b -> m b
withScope (forall (a :: TypeCategory) (s :: Stage).
TypeDefinition a s -> Ref FieldName -> Scope -> Scope
setSelection TypeDefinition OUT VALID
typeDef Ref FieldName
currentSelectionRef)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeContent TRUE OUT VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionContent VALID)
__validate TypeContent TRUE OUT VALID
typeContent
where
__validate ::
TypeContent TRUE OUT VALID ->
SelectionSet RAW ->
FragmentValidator s (SelectionContent VALID)
__validate :: TypeContent TRUE OUT VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionContent VALID)
__validate DataUnion {UnionTypeDefinition OUT VALID
unionMembers :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OUT a s -> UnionTypeDefinition OUT s
unionMembers :: UnionTypeDefinition OUT VALID
unionMembers} =
forall (s :: Stage).
ValidateFragmentSelection s =>
(Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> (TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID))
-> UnionTypeDefinition OUT VALID
-> SelectionSet RAW
-> FragmentValidator s (SelectionContent VALID)
validateUnionSelection
forall (s :: Stage).
ValidateFragmentSelection s =>
Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateFragmentSelection
forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
validateSelectionSet
UnionTypeDefinition OUT VALID
unionMembers
__validate DataObject {[TypeName]
FieldsDefinition OUT VALID
objectImplements :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> [TypeName]
objectFields :: FieldsDefinition OUT VALID
objectImplements :: [TypeName]
objectFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent OBJECT a s -> FieldsDefinition OUT s
..} =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (s :: Stage). SelectionSet s -> SelectionContent s
SelectionSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
validateSelectionSet (TypeDefinition {typeContent :: TypeContent TRUE IMPLEMENTABLE VALID
typeContent = DataObject {[TypeName]
FieldsDefinition OUT VALID
objectImplements :: [TypeName]
objectFields :: FieldsDefinition OUT VALID
objectImplements :: [TypeName]
objectFields :: FieldsDefinition OUT VALID
..}, Maybe Description
Directives VALID
TypeName
typeDirectives :: Directives VALID
typeDescription :: Maybe Description
typeDirectives :: Directives VALID
typeName :: TypeName
typeDescription :: Maybe Description
typeName :: TypeName
..})
__validate DataInterface {FieldsDefinition OUT VALID
interfaceFields :: forall (s :: Stage) (a :: TypeCategory).
CondTypeContent IMPLEMENTABLE a s -> FieldsDefinition OUT s
interfaceFields :: FieldsDefinition OUT VALID
..} =
forall (s :: Stage).
ValidateFragmentSelection s =>
(Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> (TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID))
-> TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW
-> FragmentValidator s (SelectionContent VALID)
validateInterfaceSelection
forall (s :: Stage).
ValidateFragmentSelection s =>
Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validateFragmentSelection
forall (s :: Stage).
ValidateFragmentSelection s =>
TypeDefinition IMPLEMENTABLE VALID
-> SelectionSet RAW -> FragmentValidator s (SelectionSet VALID)
validateSelectionSet
(TypeDefinition {typeContent :: TypeContent TRUE IMPLEMENTABLE VALID
typeContent = DataInterface {FieldsDefinition OUT VALID
interfaceFields :: FieldsDefinition OUT VALID
interfaceFields :: FieldsDefinition OUT VALID
..}, Maybe Description
Directives VALID
TypeName
typeDirectives :: Directives VALID
typeDescription :: Maybe Description
typeDirectives :: Directives VALID
typeName :: TypeName
typeDescription :: Maybe Description
typeName :: TypeName
..})
__validate TypeContent TRUE OUT VALID
_ =
forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
forall (s :: TypeCategory).
Ref FieldName -> TypeDefinition s VALID -> GQLError
hasNoSubfields
Ref FieldName
currentSelectionRef
TypeDefinition OUT VALID
typeDef