{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Morpheus.Validation.Query.Fragment
( validateFragments,
castFragmentType,
validateFragment,
selectFragmentType,
ValidateFragmentSelection,
validateSpread,
)
where
import Control.Monad.Except (throwError)
import Data.Morpheus.Error.Fragment
( cannotBeSpreadOnType,
)
import Data.Morpheus.Internal.Utils
( Empty (empty),
)
import Data.Morpheus.Types.Internal.AST
( Directives,
Fragment (..),
FragmentName,
Fragments,
IMPLEMENTABLE,
Position,
RAW,
Ref (..),
Selection (..),
SelectionSet,
Stage,
TypeDefinition,
TypeName,
UnionTag (..),
VALID,
)
import Data.Morpheus.Types.Internal.Validation
( Constraint (..),
FragmentValidator,
askFragments,
askTypeDefinitions,
constraint,
selectKnown,
)
import Relude hiding (empty)
class ValidateFragmentSelection (s :: Stage) where
validateFragmentSelection ::
Applicative m =>
(Fragment RAW -> m (SelectionSet VALID)) ->
Fragment s ->
m (SelectionSet VALID)
instance ValidateFragmentSelection VALID where
validateFragmentSelection :: forall (m :: * -> *).
Applicative m =>
(Fragment RAW -> m (SelectionSet VALID))
-> Fragment VALID -> m (SelectionSet VALID)
validateFragmentSelection Fragment RAW -> m (SelectionSet VALID)
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (stage :: Stage). Fragment stage -> SelectionSet stage
fragmentSelection
instance ValidateFragmentSelection RAW where
validateFragmentSelection :: forall (m :: * -> *).
Applicative m =>
(Fragment RAW -> m (SelectionSet VALID))
-> Fragment RAW -> m (SelectionSet VALID)
validateFragmentSelection Fragment RAW -> m (SelectionSet VALID)
f = Fragment RAW -> m (SelectionSet VALID)
f
validateSpread ::
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))
-> [TypeName] -> Ref FragmentName -> FragmentValidator s UnionTag
validateSpread Fragment RAW -> FragmentValidator s (SelectionSet VALID)
f [TypeName]
allowedTargets Ref FragmentName
ref = do
fragment :: Fragment s
fragment@Fragment {TypeName
fragmentType :: forall (stage :: Stage). Fragment stage -> TypeName
fragmentType :: TypeName
fragmentType, FragmentName
fragmentName :: forall (stage :: Stage). Fragment stage -> FragmentName
fragmentName :: FragmentName
fragmentName} <- forall (s :: Stage).
[TypeName] -> Ref FragmentName -> FragmentValidator s (Fragment s)
resolveSpread [TypeName]
allowedTargets Ref FragmentName
ref
TypeName -> SelectionSet VALID -> UnionTag
UnionTag TypeName
fragmentType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Selection VALID
s -> Selection VALID
s {selectionOrigin :: Maybe FragmentName
selectionOrigin = forall a. a -> Maybe a
Just FragmentName
fragmentName}) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (s :: Stage) (m :: * -> *).
(ValidateFragmentSelection s, Applicative m) =>
(Fragment RAW -> m (SelectionSet VALID))
-> Fragment s -> m (SelectionSet VALID)
validateFragmentSelection Fragment RAW -> FragmentValidator s (SelectionSet VALID)
f Fragment s
fragment
validateFragment ::
(Fragment RAW -> FragmentValidator s (SelectionSet VALID)) ->
[TypeName] ->
Fragment RAW ->
FragmentValidator s (Fragment VALID)
validateFragment :: forall (s :: Stage).
(Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> [TypeName]
-> Fragment RAW
-> FragmentValidator s (Fragment VALID)
validateFragment Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validate [TypeName]
allowedTypes fragment :: Fragment RAW
fragment@Fragment {Position
fragmentPosition :: forall (stage :: Stage). Fragment stage -> Position
fragmentPosition :: Position
fragmentPosition} =
forall (s :: Stage) (s1 :: Stage).
Maybe FragmentName
-> Position
-> [TypeName]
-> Fragment s
-> FragmentValidator s1 (Fragment s)
castFragmentType forall a. Maybe a
Nothing Position
fragmentPosition [TypeName]
allowedTypes Fragment RAW
fragment
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (s :: Stage).
(Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> Fragment RAW -> FragmentValidator s (Fragment VALID)
onlyValidateFrag Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validate
validateFragments ::
(Fragment RAW -> FragmentValidator RAW (SelectionSet VALID)) ->
FragmentValidator RAW (Fragments VALID)
validateFragments :: (Fragment RAW -> FragmentValidator RAW (SelectionSet VALID))
-> FragmentValidator RAW (Fragments VALID)
validateFragments Fragment RAW -> FragmentValidator RAW (SelectionSet VALID)
f = forall (s1 :: Stage) (s2 :: Stage) (s3 :: Stage) (m :: * -> *).
MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m =>
m (Fragments s3)
askFragments forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (s :: Stage).
(Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> Fragment RAW -> FragmentValidator s (Fragment VALID)
onlyValidateFrag Fragment RAW -> FragmentValidator RAW (SelectionSet VALID)
f)
onlyValidateFrag ::
(Fragment RAW -> FragmentValidator s (SelectionSet VALID)) ->
Fragment RAW ->
FragmentValidator s (Fragment VALID)
onlyValidateFrag :: forall (s :: Stage).
(Fragment RAW -> FragmentValidator s (SelectionSet VALID))
-> Fragment RAW -> FragmentValidator s (Fragment VALID)
onlyValidateFrag Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validate f :: Fragment RAW
f@Fragment {SelectionSet RAW
Directives RAW
Position
TypeName
FragmentName
fragmentDirectives :: forall (stage :: Stage). Fragment stage -> Directives stage
fragmentDirectives :: Directives RAW
fragmentSelection :: SelectionSet RAW
fragmentPosition :: Position
fragmentType :: TypeName
fragmentName :: FragmentName
fragmentPosition :: forall (stage :: Stage). Fragment stage -> Position
fragmentName :: forall (stage :: Stage). Fragment stage -> FragmentName
fragmentType :: forall (stage :: Stage). Fragment stage -> TypeName
fragmentSelection :: forall (stage :: Stage). Fragment stage -> SelectionSet stage
..} =
forall (stage :: Stage).
FragmentName
-> TypeName
-> Position
-> SelectionSet stage
-> Directives stage
-> Fragment stage
Fragment
FragmentName
fragmentName
TypeName
fragmentType
Position
fragmentPosition
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fragment RAW -> FragmentValidator s (SelectionSet VALID)
validate Fragment RAW
f
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (s :: Stage).
Directives RAW -> FragmentValidator s (Directives VALID)
validateFragmentDirectives Directives RAW
fragmentDirectives
validateFragmentDirectives :: Directives RAW -> FragmentValidator s (Directives VALID)
validateFragmentDirectives :: forall (s :: Stage).
Directives RAW -> FragmentValidator s (Directives VALID)
validateFragmentDirectives Directives RAW
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall coll. Empty coll => coll
empty
castFragmentType ::
Maybe FragmentName ->
Position ->
[TypeName] ->
Fragment s ->
FragmentValidator s1 (Fragment s)
castFragmentType :: forall (s :: Stage) (s1 :: Stage).
Maybe FragmentName
-> Position
-> [TypeName]
-> Fragment s
-> FragmentValidator s1 (Fragment s)
castFragmentType Maybe FragmentName
key Position
position [TypeName]
typeMembers fragment :: Fragment s
fragment@Fragment {TypeName
fragmentType :: TypeName
fragmentType :: forall (stage :: Stage). Fragment stage -> TypeName
fragmentType}
| TypeName
fragmentType forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` [TypeName]
typeMembers = forall (f :: * -> *) a. Applicative f => a -> f a
pure Fragment s
fragment
| Bool
otherwise = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Maybe FragmentName
-> TypeName -> Position -> [TypeName] -> GQLError
cannotBeSpreadOnType Maybe FragmentName
key TypeName
fragmentType Position
position [TypeName]
typeMembers
resolveSpread :: [TypeName] -> Ref FragmentName -> FragmentValidator s (Fragment s)
resolveSpread :: forall (s :: Stage).
[TypeName] -> Ref FragmentName -> FragmentValidator s (Fragment s)
resolveSpread [TypeName]
allowedTargets ref :: Ref FragmentName
ref@Ref {FragmentName
refName :: forall name. Ref name -> name
refName :: FragmentName
refName, Position
refPosition :: forall name. Ref name -> Position
refPosition :: Position
refPosition} =
forall (s1 :: Stage) (s2 :: Stage) (s3 :: Stage) (m :: * -> *).
MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m =>
m (Fragments s3)
askFragments
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 FragmentName
ref
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (s :: Stage) (s1 :: Stage).
Maybe FragmentName
-> Position
-> [TypeName]
-> Fragment s
-> FragmentValidator s1 (Fragment s)
castFragmentType (forall a. a -> Maybe a
Just FragmentName
refName) Position
refPosition [TypeName]
allowedTargets
selectFragmentType :: Fragment RAW -> FragmentValidator s (TypeDefinition IMPLEMENTABLE VALID)
selectFragmentType :: forall (s :: Stage).
Fragment RAW
-> FragmentValidator s (TypeDefinition IMPLEMENTABLE VALID)
selectFragmentType fr :: Fragment RAW
fr@Fragment {TypeName
fragmentType :: TypeName
fragmentType :: forall (stage :: Stage). Fragment stage -> TypeName
fragmentType, Position
fragmentPosition :: Position
fragmentPosition :: forall (stage :: Stage). Fragment stage -> Position
fragmentPosition} = do
TypeDefinition ANY VALID
typeDef <- forall (s :: Stage) ctx (m :: * -> *).
MonadReader (ValidatorContext s ctx) m =>
m (HashMap TypeName (TypeDefinition ANY s))
askTypeDefinitions forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 (forall name. name -> Position -> Ref name
Ref TypeName
fragmentType Position
fragmentPosition)
forall (k :: TypeCategory) inp (s :: Stage) ctx.
KindViolation k inp =>
Constraint k
-> inp
-> TypeDefinition ANY s
-> Validator s ctx (TypeDefinition k s)
constraint Constraint IMPLEMENTABLE
IMPLEMENTABLE Fragment RAW
fr TypeDefinition ANY VALID
typeDef