Eugen Wissner
96bb061666
The intermediate representation was further modified so that the operation definitions contain location information. Probably I should introduce a data type that generalizes fields and operations, so it contains object type, location and the selection set, so the functions don't accept so many arguments.
426 lines
17 KiB
Haskell
426 lines
17 KiB
Haskell
{- This Source Code Form is subject to the terms of the Mozilla Public License,
|
|
v. 2.0. If a copy of the MPL was not distributed with this file, You can
|
|
obtain one at https://mozilla.org/MPL/2.0/. -}
|
|
|
|
{-# LANGUAGE ExplicitForAll #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
|
|
-- | After the document is parsed, before getting executed, the AST is
|
|
-- transformed into a similar, simpler AST. Performed transformations include:
|
|
--
|
|
-- * Replacing variables with their values.
|
|
-- * Inlining fragments. Some fragments can be completely eliminated and
|
|
-- replaced by the selection set they represent. Invalid (recursive and
|
|
-- non-existing) fragments are skipped. The most fragments are inlined, so the
|
|
-- executor doesn't have to perform additional lookups later.
|
|
-- * Evaluating directives (@\@include@ and @\@skip@).
|
|
--
|
|
-- This module is also responsible for smaller rewrites that touch only parts of
|
|
-- the original AST.
|
|
module Language.GraphQL.Execute.Transform
|
|
( Document(..)
|
|
, Field(..)
|
|
, Fragment(..)
|
|
, Input(..)
|
|
, Operation(..)
|
|
, QueryError(..)
|
|
, Selection(..)
|
|
, document
|
|
) where
|
|
|
|
import Control.Monad (foldM, unless)
|
|
import Control.Monad.Trans.Class (lift)
|
|
import Control.Monad.Trans.State (State, evalStateT, gets, modify)
|
|
import Data.Foldable (find)
|
|
import Data.Functor.Identity (Identity(..))
|
|
import Data.HashMap.Strict (HashMap)
|
|
import qualified Data.HashMap.Strict as HashMap
|
|
import Data.Int (Int32)
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.List.NonEmpty (NonEmpty(..))
|
|
import qualified Data.List.NonEmpty as NonEmpty
|
|
import Data.Sequence (Seq, (<|), (><))
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as Text
|
|
import qualified Language.GraphQL.AST as Full
|
|
import Language.GraphQL.AST (Name)
|
|
import qualified Language.GraphQL.Execute.Coerce as Coerce
|
|
import qualified Language.GraphQL.Type.Definition as Definition
|
|
import qualified Language.GraphQL.Type as Type
|
|
import qualified Language.GraphQL.Type.Internal as Type
|
|
import qualified Language.GraphQL.Type.Out as Out
|
|
import qualified Language.GraphQL.Type.Schema as Schema
|
|
|
|
-- | Associates a fragment name with a list of 'Field's.
|
|
data Replacement m = Replacement
|
|
{ fragments :: HashMap Full.Name (Fragment m)
|
|
, fragmentDefinitions :: FragmentDefinitions
|
|
, variableValues :: Type.Subs
|
|
, types :: HashMap Full.Name (Schema.Type m)
|
|
}
|
|
|
|
type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition
|
|
|
|
-- | Represents fragments and inline fragments.
|
|
data Fragment m
|
|
= Fragment (Type.CompositeType m) (Seq (Selection m))
|
|
|
|
-- | Single selection element.
|
|
data Selection m
|
|
= SelectionFragment (Fragment m)
|
|
| SelectionField (Field m)
|
|
|
|
-- | GraphQL has 3 operation types: queries, mutations and subscribtions.
|
|
data Operation m
|
|
= Query (Maybe Text) (Seq (Selection m)) Full.Location
|
|
| Mutation (Maybe Text) (Seq (Selection m)) Full.Location
|
|
| Subscription (Maybe Text) (Seq (Selection m)) Full.Location
|
|
|
|
-- | Single GraphQL field.
|
|
data Field m = Field
|
|
(Maybe Full.Name)
|
|
Full.Name
|
|
(HashMap Full.Name (Full.Node Input))
|
|
(Seq (Selection m))
|
|
Full.Location
|
|
|
|
-- | Contains the operation to be executed along with its root type.
|
|
data Document m = Document
|
|
(HashMap Full.Name (Schema.Type m)) (Out.ObjectType m) (Operation m)
|
|
|
|
data OperationDefinition = OperationDefinition
|
|
Full.OperationType
|
|
(Maybe Full.Name)
|
|
[Full.VariableDefinition]
|
|
[Full.Directive]
|
|
Full.SelectionSet
|
|
Full.Location
|
|
|
|
-- | Query error types.
|
|
data QueryError
|
|
= OperationNotFound Text
|
|
| OperationNameRequired
|
|
| CoercionError
|
|
| EmptyDocument
|
|
| UnsupportedRootOperation
|
|
|
|
instance Show QueryError where
|
|
show (OperationNotFound operationName) = unwords
|
|
["Operation", Text.unpack operationName, "couldn't be found in the document."]
|
|
show OperationNameRequired = "Missing operation name."
|
|
show CoercionError = "Coercion error."
|
|
show EmptyDocument =
|
|
"The document doesn't contain any executable operations."
|
|
show UnsupportedRootOperation =
|
|
"Root operation type couldn't be found in the schema."
|
|
|
|
data Input
|
|
= Int Int32
|
|
| Float Double
|
|
| String Text
|
|
| Boolean Bool
|
|
| Null
|
|
| Enum Name
|
|
| List [Type.Value]
|
|
| Object (HashMap Name Input)
|
|
| Variable Type.Value
|
|
deriving (Eq, Show)
|
|
|
|
getOperation
|
|
:: Maybe Full.Name
|
|
-> NonEmpty OperationDefinition
|
|
-> Either QueryError OperationDefinition
|
|
getOperation Nothing (operation' :| []) = pure operation'
|
|
getOperation Nothing _ = Left OperationNameRequired
|
|
getOperation (Just operationName) operations
|
|
| Just operation' <- find matchingName operations = pure operation'
|
|
| otherwise = Left $ OperationNotFound operationName
|
|
where
|
|
matchingName (OperationDefinition _ name _ _ _ _) =
|
|
name == Just operationName
|
|
|
|
coerceVariableValues :: Coerce.VariableValue a
|
|
=> forall m
|
|
. HashMap Full.Name (Schema.Type m)
|
|
-> OperationDefinition
|
|
-> HashMap.HashMap Full.Name a
|
|
-> Either QueryError Type.Subs
|
|
coerceVariableValues types operationDefinition variableValues =
|
|
let OperationDefinition _ _ variableDefinitions _ _ _ = operationDefinition
|
|
in maybe (Left CoercionError) Right
|
|
$ foldr forEach (Just HashMap.empty) variableDefinitions
|
|
where
|
|
forEach variableDefinition coercedValues = do
|
|
let Full.VariableDefinition variableName variableTypeName defaultValue _ =
|
|
variableDefinition
|
|
let defaultValue' = constValue . Full.node <$> defaultValue
|
|
variableType <- Type.lookupInputType variableTypeName types
|
|
|
|
Coerce.matchFieldValues
|
|
coerceVariableValue'
|
|
variableValues
|
|
variableName
|
|
variableType
|
|
defaultValue'
|
|
coercedValues
|
|
coerceVariableValue' variableType value'
|
|
= Coerce.coerceVariableValue variableType value'
|
|
>>= Coerce.coerceInputLiteral variableType
|
|
|
|
constValue :: Full.ConstValue -> Type.Value
|
|
constValue (Full.ConstInt i) = Type.Int i
|
|
constValue (Full.ConstFloat f) = Type.Float f
|
|
constValue (Full.ConstString x) = Type.String x
|
|
constValue (Full.ConstBoolean b) = Type.Boolean b
|
|
constValue Full.ConstNull = Type.Null
|
|
constValue (Full.ConstEnum e) = Type.Enum e
|
|
constValue (Full.ConstList list) = Type.List $ constValue . Full.node <$> list
|
|
constValue (Full.ConstObject o) =
|
|
Type.Object $ HashMap.fromList $ constObjectField <$> o
|
|
where
|
|
constObjectField Full.ObjectField{value = value', ..} =
|
|
(name, constValue $ Full.node value')
|
|
|
|
-- | Rewrites the original syntax tree into an intermediate representation used
|
|
-- for query execution.
|
|
document :: Coerce.VariableValue a
|
|
=> forall m
|
|
. Type.Schema m
|
|
-> Maybe Full.Name
|
|
-> HashMap Full.Name a
|
|
-> Full.Document
|
|
-> Either QueryError (Document m)
|
|
document schema operationName subs ast = do
|
|
let referencedTypes = Schema.types schema
|
|
|
|
(operations, fragmentTable) <- defragment ast
|
|
chosenOperation <- getOperation operationName operations
|
|
coercedValues <- coerceVariableValues referencedTypes chosenOperation subs
|
|
|
|
let replacement = Replacement
|
|
{ fragments = HashMap.empty
|
|
, fragmentDefinitions = fragmentTable
|
|
, variableValues = coercedValues
|
|
, types = referencedTypes
|
|
}
|
|
case chosenOperation of
|
|
OperationDefinition Full.Query _ _ _ _ _ ->
|
|
pure $ Document referencedTypes (Schema.query schema)
|
|
$ operation chosenOperation replacement
|
|
OperationDefinition Full.Mutation _ _ _ _ _
|
|
| Just mutationType <- Schema.mutation schema ->
|
|
pure $ Document referencedTypes mutationType
|
|
$ operation chosenOperation replacement
|
|
OperationDefinition Full.Subscription _ _ _ _ _
|
|
| Just subscriptionType <- Schema.subscription schema ->
|
|
pure $ Document referencedTypes subscriptionType
|
|
$ operation chosenOperation replacement
|
|
_ -> Left UnsupportedRootOperation
|
|
|
|
defragment
|
|
:: Full.Document
|
|
-> Either QueryError (NonEmpty OperationDefinition, FragmentDefinitions)
|
|
defragment ast =
|
|
let (operations, fragmentTable) = foldr defragment' ([], HashMap.empty) ast
|
|
nonEmptyOperations = NonEmpty.nonEmpty operations
|
|
emptyDocument = Left EmptyDocument
|
|
in (, fragmentTable) <$> maybe emptyDocument Right nonEmptyOperations
|
|
where
|
|
defragment' definition (operations, fragments')
|
|
| (Full.ExecutableDefinition executable) <- definition
|
|
, (Full.DefinitionOperation operation') <- executable =
|
|
(transform operation' : operations, fragments')
|
|
| (Full.ExecutableDefinition executable) <- definition
|
|
, (Full.DefinitionFragment fragment) <- executable
|
|
, (Full.FragmentDefinition name _ _ _ _) <- fragment =
|
|
(operations, HashMap.insert name fragment fragments')
|
|
defragment' _ acc = acc
|
|
transform = \case
|
|
Full.OperationDefinition type' name variables directives' selections location ->
|
|
OperationDefinition type' name variables directives' selections location
|
|
Full.SelectionSet selectionSet location ->
|
|
OperationDefinition Full.Query Nothing mempty mempty selectionSet location
|
|
|
|
-- * Operation
|
|
|
|
operation :: OperationDefinition -> Replacement m -> Operation m
|
|
operation operationDefinition replacement
|
|
= runIdentity
|
|
$ evalStateT (collectFragments >> transform operationDefinition) replacement
|
|
where
|
|
transform (OperationDefinition Full.Query name _ _ sels location) =
|
|
flip (Query name) location <$> appendSelection sels
|
|
transform (OperationDefinition Full.Mutation name _ _ sels location) =
|
|
flip (Mutation name) location <$> appendSelection sels
|
|
transform (OperationDefinition Full.Subscription name _ _ sels location) =
|
|
flip (Subscription name) location <$> appendSelection sels
|
|
|
|
-- * Selection
|
|
|
|
selection
|
|
:: Full.Selection
|
|
-> State (Replacement m) (Either (Seq (Selection m)) (Selection m))
|
|
selection (Full.FieldSelection fieldSelection) =
|
|
maybe (Left mempty) (Right . SelectionField) <$> field fieldSelection
|
|
selection (Full.FragmentSpreadSelection fragmentSelection)
|
|
= maybe (Left mempty) (Right . SelectionFragment)
|
|
<$> fragmentSpread fragmentSelection
|
|
selection (Full.InlineFragmentSelection fragmentSelection) =
|
|
inlineFragment fragmentSelection
|
|
|
|
field :: Full.Field -> State (Replacement m) (Maybe (Field m))
|
|
field (Full.Field alias name arguments' directives' selections location) = do
|
|
fieldArguments <- foldM go HashMap.empty arguments'
|
|
fieldSelections <- appendSelection selections
|
|
fieldDirectives <- Definition.selection <$> directives directives'
|
|
let field' = Field alias name fieldArguments fieldSelections location
|
|
pure $ field' <$ fieldDirectives
|
|
where
|
|
go arguments (Full.Argument name' (Full.Node value' _) location') = do
|
|
objectFieldValue <- input value'
|
|
case objectFieldValue of
|
|
Just fieldValue ->
|
|
let argumentNode = Full.Node fieldValue location'
|
|
in pure $ HashMap.insert name' argumentNode arguments
|
|
Nothing -> pure arguments
|
|
|
|
fragmentSpread
|
|
:: Full.FragmentSpread
|
|
-> State (Replacement m) (Maybe (Fragment m))
|
|
fragmentSpread (Full.FragmentSpread name directives' _) = do
|
|
spreadDirectives <- Definition.selection <$> directives directives'
|
|
fragments' <- gets fragments
|
|
|
|
fragmentDefinitions' <- gets fragmentDefinitions
|
|
case HashMap.lookup name fragments' of
|
|
Just definition -> lift $ pure $ definition <$ spreadDirectives
|
|
Nothing
|
|
| Just definition <- HashMap.lookup name fragmentDefinitions' -> do
|
|
fragDef <- fragmentDefinition definition
|
|
case fragDef of
|
|
Just fragment -> lift $ pure $ fragment <$ spreadDirectives
|
|
_ -> lift $ pure Nothing
|
|
| otherwise -> lift $ pure Nothing
|
|
|
|
inlineFragment
|
|
:: Full.InlineFragment
|
|
-> State (Replacement m) (Either (Seq (Selection m)) (Selection m))
|
|
inlineFragment (Full.InlineFragment type' directives' selections _) = do
|
|
fragmentDirectives <- Definition.selection <$> directives directives'
|
|
case fragmentDirectives of
|
|
Nothing -> pure $ Left mempty
|
|
_ -> do
|
|
fragmentSelectionSet <- appendSelection selections
|
|
|
|
case type' of
|
|
Nothing -> pure $ Left fragmentSelectionSet
|
|
Just typeName -> do
|
|
types' <- gets types
|
|
case Type.lookupTypeCondition typeName types' of
|
|
Just typeCondition -> pure $
|
|
selectionFragment typeCondition fragmentSelectionSet
|
|
Nothing -> pure $ Left mempty
|
|
where
|
|
selectionFragment typeName = Right
|
|
. SelectionFragment
|
|
. Fragment typeName
|
|
|
|
appendSelection :: Traversable t
|
|
=> t Full.Selection
|
|
-> State (Replacement m) (Seq (Selection m))
|
|
appendSelection = foldM go mempty
|
|
where
|
|
go acc sel = append acc <$> selection sel
|
|
append acc (Left list) = list >< acc
|
|
append acc (Right one) = one <| acc
|
|
|
|
directives :: [Full.Directive] -> State (Replacement m) [Definition.Directive]
|
|
directives = traverse directive
|
|
where
|
|
directive (Full.Directive directiveName directiveArguments _)
|
|
= Definition.Directive directiveName . Type.Arguments
|
|
<$> foldM go HashMap.empty directiveArguments
|
|
go arguments (Full.Argument name (Full.Node value' _) _) = do
|
|
substitutedValue <- value value'
|
|
return $ HashMap.insert name substitutedValue arguments
|
|
|
|
-- * Fragment replacement
|
|
|
|
-- | Extract fragment definitions into a single 'HashMap'.
|
|
collectFragments :: State (Replacement m) ()
|
|
collectFragments = do
|
|
fragDefs <- gets fragmentDefinitions
|
|
let nextValue = head $ HashMap.elems fragDefs
|
|
unless (HashMap.null fragDefs) $ do
|
|
_ <- fragmentDefinition nextValue
|
|
collectFragments
|
|
|
|
fragmentDefinition
|
|
:: Full.FragmentDefinition
|
|
-> State (Replacement m) (Maybe (Fragment m))
|
|
fragmentDefinition (Full.FragmentDefinition name type' _ selections _) = do
|
|
modify deleteFragmentDefinition
|
|
fragmentSelection <- appendSelection selections
|
|
types' <- gets types
|
|
|
|
case Type.lookupTypeCondition type' types' of
|
|
Just compositeType -> do
|
|
let newValue = Fragment compositeType fragmentSelection
|
|
modify $ insertFragment newValue
|
|
lift $ pure $ Just newValue
|
|
_ -> lift $ pure Nothing
|
|
where
|
|
deleteFragmentDefinition replacement@Replacement{..} =
|
|
let newDefinitions = HashMap.delete name fragmentDefinitions
|
|
in replacement{ fragmentDefinitions = newDefinitions }
|
|
insertFragment newValue replacement@Replacement{..} =
|
|
let newFragments = HashMap.insert name newValue fragments
|
|
in replacement{ fragments = newFragments }
|
|
|
|
value :: forall m. Full.Value -> State (Replacement m) Type.Value
|
|
value (Full.Variable name) =
|
|
gets (fromMaybe Type.Null . HashMap.lookup name . variableValues)
|
|
value (Full.Int int) = pure $ Type.Int int
|
|
value (Full.Float float) = pure $ Type.Float float
|
|
value (Full.String string) = pure $ Type.String string
|
|
value (Full.Boolean boolean) = pure $ Type.Boolean boolean
|
|
value Full.Null = pure Type.Null
|
|
value (Full.Enum enum) = pure $ Type.Enum enum
|
|
value (Full.List list) = Type.List <$> traverse (value . Full.node) list
|
|
value (Full.Object object) =
|
|
Type.Object . HashMap.fromList <$> traverse objectField object
|
|
where
|
|
objectField Full.ObjectField{value = value', ..} =
|
|
(name,) <$> value (Full.node value')
|
|
|
|
input :: forall m. Full.Value -> State (Replacement m) (Maybe Input)
|
|
input (Full.Variable name) =
|
|
gets (fmap Variable . HashMap.lookup name . variableValues)
|
|
input (Full.Int int) = pure $ pure $ Int int
|
|
input (Full.Float float) = pure $ pure $ Float float
|
|
input (Full.String string) = pure $ pure $ String string
|
|
input (Full.Boolean boolean) = pure $ pure $ Boolean boolean
|
|
input Full.Null = pure $ pure Null
|
|
input (Full.Enum enum) = pure $ pure $ Enum enum
|
|
input (Full.List list) = pure . List <$> traverse (value . Full.node) list
|
|
input (Full.Object object) = do
|
|
objectFields <- foldM objectField HashMap.empty object
|
|
pure $ pure $ Object objectFields
|
|
where
|
|
objectField resultMap Full.ObjectField{value = value', ..} =
|
|
inputField resultMap name $ Full.node value'
|
|
|
|
inputField :: forall m
|
|
. HashMap Full.Name Input
|
|
-> Full.Name
|
|
-> Full.Value
|
|
-> State (Replacement m) (HashMap Full.Name Input)
|
|
inputField resultMap name value' = do
|
|
objectFieldValue <- input value'
|
|
case objectFieldValue of
|
|
Just fieldValue -> pure $ HashMap.insert name fieldValue resultMap
|
|
Nothing -> pure resultMap
|