{-# 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 <- forall (s1 :: Stage) (s2 :: Stage) (s3 :: Stage) (m :: * -> *). MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m => m (Fragments s3) askFragments HashMap FragmentName [Ref FragmentName] usages <- Fragments RAW -> SelectionSet RAW -> BaseValidator (HashMap FragmentName [Ref FragmentName]) usedFragments Fragments RAW fragments SelectionSet RAW selectionSet 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 [Ref FragmentName] usages Fragments RAW fragments usedFragments :: Fragments RAW -> SelectionSet RAW -> BaseValidator (HashMap FragmentName [Node FragmentName]) usedFragments :: Fragments RAW -> SelectionSet RAW -> BaseValidator (HashMap FragmentName [Ref FragmentName]) usedFragments Fragments RAW fragments = forall k (m :: * -> *) v. (Eq k, Hashable k, Monad m, Semigroup v) => [(k, v)] -> m (HashMap k v) collect forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map forall {name}. Ref name -> (name, [Ref name]) toEntry forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap Selection RAW -> [Ref FragmentName] findAllUses forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) a. Foldable t => t a -> [a] toList where toEntry :: Ref name -> (name, [Ref name]) toEntry (Ref name x Position y) = (name x, [forall name. name -> Position -> Ref name Ref name x Position y]) findUsesSelectionContent :: SelectionContent RAW -> [Node FragmentName] findUsesSelectionContent :: SelectionContent RAW -> [Ref FragmentName] findUsesSelectionContent (SelectionSet SelectionSet RAW selectionSet) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap Selection RAW -> [Ref FragmentName] findAllUses SelectionSet RAW selectionSet findUsesSelectionContent SelectionContent RAW SelectionField = [] findAllUses :: Selection RAW -> [Node FragmentName] findAllUses :: Selection RAW -> [Ref FragmentName] findAllUses Selection {SelectionContent RAW selectionContent :: forall (s :: Stage). Selection s -> SelectionContent s selectionContent :: SelectionContent RAW selectionContent} = SelectionContent RAW -> [Ref FragmentName] findUsesSelectionContent SelectionContent RAW selectionContent findAllUses (InlineFragment Fragment {SelectionSet RAW fragmentSelection :: forall (stage :: Stage). Fragment stage -> SelectionSet stage fragmentSelection :: SelectionSet RAW fragmentSelection}) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap Selection RAW -> [Ref FragmentName] findAllUses 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}) = [forall name. name -> Position -> Ref name Ref FragmentName refName Position refPosition] forall a. Semigroup a => a -> a -> a <> [Ref FragmentName] searchInFragment where searchInFragment :: [Ref FragmentName] searchInFragment = forall k (c :: * -> *) d a. IsMap k c => d -> (a -> d) -> k -> c a -> d selectOr [] (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap Selection RAW -> [Ref FragmentName] findAllUses forall b c a. (b -> c) -> (a -> b) -> a -> c . 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) exploreSpreads forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= forall name (m :: * -> *). (Eq name, Monad m) => (NonEmpty (Ref name) -> m ()) -> Graph name -> m () cycleChecking (forall e (m :: * -> *) a. MonadError e m => e -> m a throwError forall b c a. (b -> c) -> (a -> b) -> a -> c . NonEmpty (Ref FragmentName) -> GQLError cannotSpreadWithinItself)) 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap Fragment RAW -> Edges FragmentName exploreFragmentSpreads forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: * -> *) a. Foldable t => t a -> [a] toList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> 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} = (forall name. name -> Position -> Ref name Ref FragmentName fragmentName Position fragmentPosition, forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap forall a. ScanSpread a => a -> [Ref FragmentName] scanSpread SelectionSet RAW fragmentSelection) class ScanSpread a where scanSpread :: a -> [Node FragmentName] instance ScanSpread (Selection RAW) where scanSpread :: Selection RAW -> [Ref FragmentName] scanSpread Selection {SelectionContent RAW selectionContent :: SelectionContent RAW selectionContent :: forall (s :: Stage). Selection s -> SelectionContent s selectionContent} = forall a. ScanSpread a => a -> [Ref FragmentName] scanSpread SelectionContent RAW selectionContent scanSpread (InlineFragment Fragment {SelectionSet RAW fragmentSelection :: SelectionSet RAW fragmentSelection :: forall (stage :: Stage). Fragment stage -> SelectionSet stage fragmentSelection}) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap forall a. ScanSpread a => a -> [Ref FragmentName] scanSpread 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}) = [forall name. name -> Position -> Ref name Ref FragmentName refName Position refPosition] instance ScanSpread (SelectionContent RAW) where scanSpread :: SelectionContent RAW -> [Ref FragmentName] scanSpread SelectionContent RAW SelectionField = [] scanSpread (SelectionSet SelectionSet RAW selectionSet) = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap forall a. ScanSpread a => a -> [Ref FragmentName] scanSpread SelectionSet RAW selectionSet