{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Validation.Query.FragmentPreconditions ( checkFragmentPreconditions, ) where import Control.Monad.Except (throwError) import Data.Mergeable import Data.Morpheus.Error.Fragment ( cannotSpreadWithinItself, ) import Data.Morpheus.Internal.Graph ( Edges, Graph, Node, cycleChecking, ) import Data.Morpheus.Internal.Utils ( selectOr, ) import Data.Morpheus.Types.Internal.AST ( Fragment (..), FragmentName, Fragments, RAW, Ref (..), Selection (..), SelectionContent (..), SelectionSet, ) import Data.Morpheus.Types.Internal.Validation ( BaseValidator, askFragments, checkUnused, ) import Relude checkUnusedFragments :: SelectionSet RAW -> BaseValidator () checkUnusedFragments :: SelectionSet RAW -> BaseValidator () checkUnusedFragments SelectionSet RAW selectionSet = do Fragments RAW fragments <- Validator VALID (OperationContext RAW RAW) (Fragments RAW) forall (s1 :: Stage) (s2 :: Stage) (s3 :: Stage) (m :: * -> *). MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m => m (Fragments s3) askFragments HashMap FragmentName [Node FragmentName] usages <- Fragments RAW -> SelectionSet RAW -> BaseValidator (HashMap FragmentName [Node FragmentName]) usedFragments Fragments RAW fragments SelectionSet RAW selectionSet HashMap FragmentName [Node FragmentName] -> Fragments RAW -> Validator VALID (OperationContext RAW RAW) () 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 HashMap FragmentName [Node FragmentName] usages Fragments RAW fragments usedFragments :: Fragments RAW -> SelectionSet RAW -> BaseValidator (HashMap FragmentName [Node FragmentName]) usedFragments :: Fragments RAW -> SelectionSet RAW -> BaseValidator (HashMap FragmentName [Node FragmentName]) usedFragments Fragments RAW fragments = [(FragmentName, [Node FragmentName])] -> Validator VALID (OperationContext RAW RAW) (HashMap FragmentName [Node FragmentName]) forall k (m :: * -> *) v. (Eq k, Hashable k, Monad m, Semigroup v) => [(k, v)] -> m (HashMap k v) collect ([(FragmentName, [Node FragmentName])] -> Validator VALID (OperationContext RAW RAW) (HashMap FragmentName [Node FragmentName])) -> (MergeMap 'True FieldName (Selection RAW) -> [(FragmentName, [Node FragmentName])]) -> MergeMap 'True FieldName (Selection RAW) -> Validator VALID (OperationContext RAW RAW) (HashMap FragmentName [Node FragmentName]) forall b c a. (b -> c) -> (a -> b) -> a -> c . (Node FragmentName -> (FragmentName, [Node FragmentName])) -> [Node FragmentName] -> [(FragmentName, [Node FragmentName])] forall a b. (a -> b) -> [a] -> [b] map Node FragmentName -> (FragmentName, [Node FragmentName]) forall name. Ref name -> (name, [Ref name]) toEntry ([Node FragmentName] -> [(FragmentName, [Node FragmentName])]) -> (MergeMap 'True FieldName (Selection RAW) -> [Node FragmentName]) -> MergeMap 'True FieldName (Selection RAW) -> [(FragmentName, [Node FragmentName])] forall b c a. (b -> c) -> (a -> b) -> a -> c . (Selection RAW -> [Node FragmentName]) -> [Selection RAW] -> [Node FragmentName] forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap Selection RAW -> [Node FragmentName] findAllUses ([Selection RAW] -> [Node FragmentName]) -> (MergeMap 'True FieldName (Selection RAW) -> [Selection RAW]) -> MergeMap 'True FieldName (Selection RAW) -> [Node FragmentName] forall b c a. (b -> c) -> (a -> b) -> a -> c . MergeMap 'True FieldName (Selection RAW) -> [Selection RAW] forall (t :: * -> *) a. Foldable t => t a -> [a] toList where toEntry :: Ref name -> (name, [Ref name]) toEntry (Ref name x Position y) = (name x, [name -> Position -> Ref name forall name. name -> Position -> Ref name Ref name x Position y]) findUsesSelectionContent :: SelectionContent RAW -> [Node FragmentName] findUsesSelectionContent :: SelectionContent RAW -> [Node FragmentName] findUsesSelectionContent (SelectionSet SelectionSet RAW selectionSet) = (Selection RAW -> [Node FragmentName]) -> MergeMap 'True FieldName (Selection RAW) -> [Node FragmentName] forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap Selection RAW -> [Node FragmentName] findAllUses MergeMap 'True FieldName (Selection RAW) SelectionSet RAW selectionSet findUsesSelectionContent SelectionContent RAW SelectionField = [] findAllUses :: Selection RAW -> [Node FragmentName] findAllUses :: Selection RAW -> [Node FragmentName] findAllUses Selection {SelectionContent RAW selectionContent :: forall (s :: Stage). Selection s -> SelectionContent s selectionContent :: SelectionContent RAW selectionContent} = SelectionContent RAW -> [Node FragmentName] findUsesSelectionContent SelectionContent RAW selectionContent findAllUses (InlineFragment Fragment {SelectionSet RAW fragmentSelection :: forall (stage :: Stage). Fragment stage -> SelectionSet stage fragmentSelection :: SelectionSet RAW fragmentSelection}) = (Selection RAW -> [Node FragmentName]) -> MergeMap 'True FieldName (Selection RAW) -> [Node FragmentName] forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap Selection RAW -> [Node FragmentName] findAllUses MergeMap 'True FieldName (Selection RAW) SelectionSet RAW fragmentSelection findAllUses (Spread Directives RAW _ Ref {FragmentName refName :: forall name. Ref name -> name refName :: FragmentName refName, Position refPosition :: forall name. Ref name -> Position refPosition :: Position refPosition}) = [FragmentName -> Position -> Node FragmentName forall name. name -> Position -> Ref name Ref FragmentName refName Position refPosition] [Node FragmentName] -> [Node FragmentName] -> [Node FragmentName] forall a. Semigroup a => a -> a -> a <> [Node FragmentName] searchInFragment where searchInFragment :: [Node FragmentName] searchInFragment = [Node FragmentName] -> (Fragment RAW -> [Node FragmentName]) -> FragmentName -> Fragments RAW -> [Node FragmentName] forall k (c :: * -> *) d a. IsMap k c => d -> (a -> d) -> k -> c a -> d selectOr [] ((Selection RAW -> [Node FragmentName]) -> MergeMap 'True FieldName (Selection RAW) -> [Node FragmentName] forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap Selection RAW -> [Node FragmentName] findAllUses (MergeMap 'True FieldName (Selection RAW) -> [Node FragmentName]) -> (Fragment RAW -> MergeMap 'True FieldName (Selection RAW)) -> Fragment RAW -> [Node FragmentName] forall b c a. (b -> c) -> (a -> b) -> a -> c . Fragment RAW -> MergeMap 'True FieldName (Selection RAW) forall (stage :: Stage). Fragment stage -> SelectionSet stage fragmentSelection) FragmentName refName Fragments RAW fragments checkFragmentPreconditions :: SelectionSet RAW -> BaseValidator () checkFragmentPreconditions :: SelectionSet RAW -> BaseValidator () checkFragmentPreconditions SelectionSet RAW selection = (BaseValidator (Graph FragmentName) Validator VALID (OperationContext RAW RAW) (Graph FragmentName) exploreSpreads Validator VALID (OperationContext RAW RAW) (Graph FragmentName) -> (Graph FragmentName -> Validator VALID (OperationContext RAW RAW) ()) -> Validator VALID (OperationContext RAW RAW) () forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= (NonEmpty (Node FragmentName) -> Validator VALID (OperationContext RAW RAW) ()) -> Graph FragmentName -> Validator VALID (OperationContext RAW RAW) () forall (m :: * -> *) name. (Applicative m, Eq name) => (NonEmpty (Ref name) -> m ()) -> Graph name -> m () cycleChecking (GQLError -> Validator VALID (OperationContext RAW RAW) () forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (GQLError -> Validator VALID (OperationContext RAW RAW) ()) -> (NonEmpty (Node FragmentName) -> GQLError) -> NonEmpty (Node FragmentName) -> Validator VALID (OperationContext RAW RAW) () forall b c a. (b -> c) -> (a -> b) -> a -> c . NonEmpty (Node FragmentName) -> GQLError cannotSpreadWithinItself)) Validator VALID (OperationContext RAW RAW) () -> Validator VALID (OperationContext RAW RAW) () -> Validator VALID (OperationContext RAW RAW) () forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b *> SelectionSet RAW -> BaseValidator () checkUnusedFragments SelectionSet RAW selection exploreSpreads :: BaseValidator (Graph FragmentName) exploreSpreads :: BaseValidator (Graph FragmentName) exploreSpreads = (Fragment RAW -> Edges FragmentName) -> [Fragment RAW] -> Graph FragmentName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap Fragment RAW -> Edges FragmentName exploreFragmentSpreads ([Fragment RAW] -> Graph FragmentName) -> (Fragments RAW -> [Fragment RAW]) -> Fragments RAW -> Graph FragmentName forall b c a. (b -> c) -> (a -> b) -> a -> c . Fragments RAW -> [Fragment RAW] forall (t :: * -> *) a. Foldable t => t a -> [a] toList (Fragments RAW -> Graph FragmentName) -> Validator VALID (OperationContext RAW RAW) (Fragments RAW) -> Validator VALID (OperationContext RAW RAW) (Graph FragmentName) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Validator VALID (OperationContext RAW RAW) (Fragments RAW) forall (s1 :: Stage) (s2 :: Stage) (s3 :: Stage) (m :: * -> *). MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m => m (Fragments s3) askFragments exploreFragmentSpreads :: Fragment RAW -> Edges FragmentName exploreFragmentSpreads :: Fragment RAW -> Edges FragmentName exploreFragmentSpreads Fragment {FragmentName fragmentName :: forall (stage :: Stage). Fragment stage -> FragmentName fragmentName :: FragmentName fragmentName, SelectionSet RAW fragmentSelection :: SelectionSet RAW fragmentSelection :: forall (stage :: Stage). Fragment stage -> SelectionSet stage fragmentSelection, Position fragmentPosition :: forall (stage :: Stage). Fragment stage -> Position fragmentPosition :: Position fragmentPosition} = (FragmentName -> Position -> Node FragmentName forall name. name -> Position -> Ref name Ref FragmentName fragmentName Position fragmentPosition, (Selection RAW -> [Node FragmentName]) -> MergeMap 'True FieldName (Selection RAW) -> [Node FragmentName] forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap Selection RAW -> [Node FragmentName] forall a. ScanSpread a => a -> [Node FragmentName] scanSpread MergeMap 'True FieldName (Selection RAW) SelectionSet RAW fragmentSelection) class ScanSpread a where scanSpread :: a -> [Node FragmentName] instance ScanSpread (Selection RAW) where scanSpread :: Selection RAW -> [Node FragmentName] scanSpread Selection {SelectionContent RAW selectionContent :: SelectionContent RAW selectionContent :: forall (s :: Stage). Selection s -> SelectionContent s selectionContent} = SelectionContent RAW -> [Node FragmentName] forall a. ScanSpread a => a -> [Node FragmentName] scanSpread SelectionContent RAW selectionContent scanSpread (InlineFragment Fragment {SelectionSet RAW fragmentSelection :: SelectionSet RAW fragmentSelection :: forall (stage :: Stage). Fragment stage -> SelectionSet stage fragmentSelection}) = (Selection RAW -> [Node FragmentName]) -> MergeMap 'True FieldName (Selection RAW) -> [Node FragmentName] forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap Selection RAW -> [Node FragmentName] forall a. ScanSpread a => a -> [Node FragmentName] scanSpread MergeMap 'True FieldName (Selection RAW) SelectionSet RAW fragmentSelection scanSpread (Spread Directives RAW _ Ref {FragmentName refName :: FragmentName refName :: forall name. Ref name -> name refName, Position refPosition :: Position refPosition :: forall name. Ref name -> Position refPosition}) = [FragmentName -> Position -> Node FragmentName forall name. name -> Position -> Ref name Ref FragmentName refName Position refPosition] instance ScanSpread (SelectionContent RAW) where scanSpread :: SelectionContent RAW -> [Node FragmentName] scanSpread SelectionContent RAW SelectionField = [] scanSpread (SelectionSet SelectionSet RAW selectionSet) = (Selection RAW -> [Node FragmentName]) -> MergeMap 'True FieldName (Selection RAW) -> [Node FragmentName] forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap Selection RAW -> [Node FragmentName] forall a. ScanSpread a => a -> [Node FragmentName] scanSpread MergeMap 'True FieldName (Selection RAW) SelectionSet RAW selectionSet