{-# 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.Types.Internal.AST ( DirectiveLocation (..), 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 Data.Morpheus.Validation.Internal.Directive (validateDirectives) 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 :: DirectiveLocation -> (Fragment RAW -> FragmentValidator s (SelectionSet VALID)) -> [TypeName] -> Fragment RAW -> FragmentValidator s (Fragment VALID) validateFragment :: forall (s :: Stage). DirectiveLocation -> (Fragment RAW -> FragmentValidator s (SelectionSet VALID)) -> [TypeName] -> Fragment RAW -> FragmentValidator s (Fragment VALID) validateFragment DirectiveLocation loc 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). DirectiveLocation -> (Fragment RAW -> FragmentValidator s (SelectionSet VALID)) -> Fragment RAW -> FragmentValidator s (Fragment VALID) onlyValidateFrag DirectiveLocation loc 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). DirectiveLocation -> (Fragment RAW -> FragmentValidator s (SelectionSet VALID)) -> Fragment RAW -> FragmentValidator s (Fragment VALID) onlyValidateFrag DirectiveLocation LOCATION_FRAGMENT_DEFINITION Fragment RAW -> FragmentValidator RAW (SelectionSet VALID) f) onlyValidateFrag :: DirectiveLocation -> (Fragment RAW -> FragmentValidator s (SelectionSet VALID)) -> Fragment RAW -> FragmentValidator s (Fragment VALID) onlyValidateFrag :: forall (s :: Stage). DirectiveLocation -> (Fragment RAW -> FragmentValidator s (SelectionSet VALID)) -> Fragment RAW -> FragmentValidator s (Fragment VALID) onlyValidateFrag DirectiveLocation loc 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 ctx (schemaS :: Stage) (s :: Stage). ArgumentsConstraints ctx schemaS s => DirectiveLocation -> Directives s -> Validator schemaS ctx (Directives VALID) validateDirectives DirectiveLocation loc Directives RAW fragmentDirectives 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