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