Skip recursive fragments and marked fields

This commit is contained in:
Eugen Wissner 2021-08-25 10:16:23 +02:00
parent fef7c1ed98
commit db721a3f53

View File

@ -17,7 +17,8 @@ module Language.GraphQL.Executor
) where ) where
import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Reader (ReaderT(..), asks, runReader) import Control.Monad.Trans.Reader (ReaderT(..), local, runReader)
import qualified Control.Monad.Trans.Reader as Reader
import Control.Monad (foldM) import Control.Monad (foldM)
import qualified Language.GraphQL.AST.Document as Full import qualified Language.GraphQL.AST.Document as Full
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
@ -26,6 +27,8 @@ import Data.Foldable (find)
import Data.Functor.Identity (Identity) import Data.Functor.Identity (Identity)
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.Int (Int32) import Data.Int (Int32)
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty import qualified Data.List.NonEmpty as NonEmpty
@ -43,6 +46,7 @@ import qualified Language.GraphQL.Type.Schema as Schema
data Replacement = Replacement data Replacement = Replacement
{ variableValues :: Type.Subs { variableValues :: Type.Subs
, fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
, visitedFragments :: HashSet Full.Name
} }
newtype TransformT m a = TransformT newtype TransformT m a = TransformT
@ -83,6 +87,9 @@ data QueryError
| CoercionError Full.VariableDefinition | CoercionError Full.VariableDefinition
| UnknownInputType Full.VariableDefinition | UnknownInputType Full.VariableDefinition
asks :: forall a. (Replacement -> a) -> Transform a
asks = TransformT . Reader.asks
queryError :: QueryError -> Error queryError :: QueryError -> Error
queryError OperationNameRequired = queryError OperationNameRequired =
Error{ message = "Operation name is required.", locations = [], path = [] } Error{ message = "Operation name is required.", locations = [], path = [] }
@ -133,12 +140,11 @@ data Field = Field
(Maybe Full.Name) (Maybe Full.Name)
Full.Name Full.Name
[Argument] [Argument]
[Type.Directive]
SelectionSet SelectionSet
Full.Location Full.Location
data Fragment = Fragment data Fragment = Fragment
(Maybe Full.TypeCondition) [Type.Directive] SelectionSet Full.Location (Maybe Full.TypeCondition) SelectionSet Full.Location
data Value data Value
= Variable Full.Name = Variable Full.Name
@ -171,11 +177,11 @@ document = foldr filterOperation ([], HashMap.empty)
transform :: Full.OperationDefinition -> Transform Operation transform :: Full.OperationDefinition -> Transform Operation
transform (Full.OperationDefinition operationType _ _ _ selectionSet' _) = do transform (Full.OperationDefinition operationType _ _ _ selectionSet' _) = do
coercedVariableValues <- TransformT $ asks variableValues coercedVariableValues <- asks variableValues
transformedSelections <- selectionSet selectionSet' transformedSelections <- selectionSet selectionSet'
pure $ Operation operationType coercedVariableValues transformedSelections pure $ Operation operationType coercedVariableValues transformedSelections
transform (Full.SelectionSet selectionSet' _) = do transform (Full.SelectionSet selectionSet' _) = do
coercedVariableValues <- TransformT $ asks variableValues coercedVariableValues <- asks variableValues
transformedSelections <- selectionSet selectionSet' transformedSelections <- selectionSet selectionSet'
pure $ Operation Full.Query coercedVariableValues transformedSelections pure $ Operation Full.Query coercedVariableValues transformedSelections
@ -183,52 +189,61 @@ selectionSet :: Full.SelectionSet -> Transform SelectionSet
selectionSet = fmap catMaybes . traverse selection . NonEmpty.toList selectionSet = fmap catMaybes . traverse selection . NonEmpty.toList
selection :: Full.Selection -> Transform (Maybe Selection) selection :: Full.Selection -> Transform (Maybe Selection)
selection (Full.FieldSelection field') = Just . FieldSelection <$> field field' selection (Full.FieldSelection field') = fmap FieldSelection <$> field field'
selection (Full.FragmentSpreadSelection fragmentSpread') = selection (Full.FragmentSpreadSelection fragmentSpread') =
fmap FragmentSelection <$> fragmentSpread fragmentSpread' fmap FragmentSelection <$> fragmentSpread fragmentSpread'
selection (Full.InlineFragmentSelection inlineFragment') = selection (Full.InlineFragmentSelection inlineFragment') =
Just . FragmentSelection <$> inlineFragment inlineFragment' fmap FragmentSelection <$> inlineFragment inlineFragment'
inlineFragment :: Full.InlineFragment -> Transform Fragment directives :: [Full.Directive] -> Transform (Maybe [Type.Directive])
inlineFragment (Full.InlineFragment typeCondition directives selectionSet' location) = do directives = fmap Type.selection . traverse directive
inlineFragment :: Full.InlineFragment -> Transform (Maybe Fragment)
inlineFragment (Full.InlineFragment typeCondition directives' selectionSet' location) = do
transformedSelections <- selectionSet selectionSet' transformedSelections <- selectionSet selectionSet'
transformedDirectives <- traverse directive directives transformedDirectives <- directives directives'
pure $ Fragment pure $ transformedDirectives
typeCondition >> pure (Fragment typeCondition transformedSelections location)
transformedDirectives
transformedSelections
location
fragmentSpread :: Full.FragmentSpread -> Transform (Maybe Fragment) fragmentSpread :: Full.FragmentSpread -> Transform (Maybe Fragment)
fragmentSpread (Full.FragmentSpread spreadName directives location) = do fragmentSpread (Full.FragmentSpread spreadName directives' location) = do
transformedDirectives <- traverse directive directives transformedDirectives <- directives directives'
possibleFragmentDefinition <- TransformT visitedFragment <- asks $ HashSet.member spreadName . visitedFragments
$ asks possibleFragmentDefinition <- asks
$ HashMap.lookup spreadName $ HashMap.lookup spreadName
. fragmentDefinitions . fragmentDefinitions
case possibleFragmentDefinition of case transformedDirectives >> possibleFragmentDefinition of
Just (Full.FragmentDefinition _ typeCondition _ selections _) -> do Just (Full.FragmentDefinition _ typeCondition _ selections _)
transformedSelections <- selectionSet selections | visitedFragment -> pure Nothing
| otherwise -> do
transformedSelections <- TransformT
$ local fragmentInserter
$ runTransformT
$ selectionSet selections
pure $ Just $ Fragment pure $ Just $ Fragment
(Just typeCondition) (Just typeCondition)
transformedDirectives
transformedSelections transformedSelections
location location
Nothing -> Nothing ->
pure Nothing pure Nothing
where
fragmentInserter replacement@Replacement{ visitedFragments } = replacement
{ visitedFragments = HashSet.insert spreadName visitedFragments }
field :: Full.Field -> Transform Field field :: Full.Field -> Transform (Maybe Field)
field (Full.Field alias' name' arguments' directives selectionSet' location') = do field (Full.Field alias' name' arguments' directives' selectionSet' location') = do
transformedSelections <- catMaybes <$> traverse selection selectionSet' transformedSelections <- catMaybes <$> traverse selection selectionSet'
transformedDirectives <- traverse directive directives transformedDirectives <- directives directives'
pure $ Field let transformedField = Field
alias' alias'
name' name'
(argument <$> arguments') transformedArguments
transformedDirectives
transformedSelections transformedSelections
location' location'
pure $ transformedDirectives >> pure transformedField
where
transformedArguments = argument <$> arguments'
argument :: Full.Argument -> Argument argument :: Full.Argument -> Argument
argument (Full.Argument name' valueNode location') = argument (Full.Argument name' valueNode location') =
@ -246,8 +261,7 @@ directive (Full.Directive name' arguments _)
directiveValue :: Full.Value -> Transform Type.Value directiveValue :: Full.Value -> Transform Type.Value
directiveValue = \case directiveValue = \case
(Full.Variable name') -> TransformT (Full.Variable name') -> asks
$ asks
$ HashMap.lookupDefault Type.Null name' $ HashMap.lookupDefault Type.Null name'
. variableValues . variableValues
(Full.Int integer) -> pure $ Type.Int integer (Full.Int integer) -> pure $ Type.Int integer
@ -314,6 +328,7 @@ executeRequest schema sourceDocument operationName variableValues initialValue =
let replacement = Replacement let replacement = Replacement
{ variableValues = coercedVariableValues { variableValues = coercedVariableValues
, fragmentDefinitions = fragmentDefinitions' , fragmentDefinitions = fragmentDefinitions'
, visitedFragments = mempty
} }
pure pure
$ flip runReader replacement $ flip runReader replacement