graphql/src/Language/GraphQL/Execute/Transform.hs

420 lines
16 KiB
Haskell
Raw Normal View History

{- 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 #-}
2020-05-21 10:20:59 +02:00
{-# LANGUAGE LambdaCase #-}
2020-05-22 10:11:48 +02:00
{-# 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
2020-05-21 10:20:59 +02:00
( Document(..)
, Field(..)
, Fragment(..)
, Input(..)
, Operation(..)
, QueryError(..)
, Selection(..)
2020-05-21 10:20:59 +02:00
, document
2019-07-14 05:58:05 +02:00
) where
import Control.Monad (foldM, unless)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State (State, evalStateT, gets, modify)
2020-05-22 10:11:48 +02:00
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)
2020-05-22 10:11:48 +02:00
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Sequence (Seq, (<|), (><))
2020-05-22 10:11:48 +02:00
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Language.GraphQL.AST as Full
import Language.GraphQL.AST (Name)
2020-06-13 07:20:19 +02:00
import qualified Language.GraphQL.Execute.Coerce as Coerce
2020-07-06 19:10:34 +02:00
import qualified Language.GraphQL.Type.Definition as Definition
2020-06-13 07:20:19 +02:00
import qualified Language.GraphQL.Type as Type
import qualified Language.GraphQL.Type.Internal as Type
import qualified Language.GraphQL.Type.Out as Out
2020-09-28 07:06:15 +02:00
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
2020-06-13 07:20:19 +02:00
, variableValues :: Type.Subs
2020-09-28 07:06:15 +02:00
, 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))
| Mutation (Maybe Text) (Seq (Selection m))
2020-07-11 06:34:10 +02:00
| Subscription (Maybe Text) (Seq (Selection m))
-- | Single GraphQL field.
data Field m = Field
(Maybe Full.Name)
Full.Name
(HashMap Full.Name Input)
(Seq (Selection m))
Full.Location
-- | Contains the operation to be executed along with its root type.
data Document m = Document
2020-09-28 07:06:15 +02:00
(HashMap Full.Name (Schema.Type m)) (Out.ObjectType m) (Operation m)
2020-05-21 10:20:59 +02:00
data OperationDefinition = OperationDefinition
Full.OperationType
(Maybe Full.Name)
[Full.VariableDefinition]
[Full.Directive]
Full.SelectionSet
2020-05-22 10:11:48 +02:00
-- | Query error types.
data QueryError
= OperationNotFound Text
| OperationNameRequired
| CoercionError
| EmptyDocument
| UnsupportedRootOperation
2020-05-22 10:11:48 +02:00
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
2020-06-13 07:20:19 +02:00
| List [Type.Value]
| Object (HashMap Name Input)
2020-06-13 07:20:19 +02:00
| Variable Type.Value
deriving (Eq, Show)
2020-05-22 10:11:48 +02:00
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
2020-06-13 07:20:19 +02:00
coerceVariableValues :: Coerce.VariableValue a
=> forall m
2020-09-28 07:06:15 +02:00
. HashMap Full.Name (Schema.Type m)
2020-05-22 10:11:48 +02:00
-> OperationDefinition
-> HashMap.HashMap Full.Name a
2020-06-13 07:20:19 +02:00
-> Either QueryError Type.Subs
coerceVariableValues types operationDefinition variableValues =
let OperationDefinition _ _ variableDefinitions _ _ = operationDefinition
2020-05-22 10:11:48 +02:00
in maybe (Left CoercionError) Right
$ foldr forEach (Just HashMap.empty) variableDefinitions
2020-05-22 10:11:48 +02:00
where
forEach variableDefinition coercedValues = do
2020-09-19 18:18:26 +02:00
let Full.VariableDefinition variableName variableTypeName defaultValue _ =
2020-05-22 10:11:48 +02:00
variableDefinition
2020-10-04 18:51:21 +02:00
let defaultValue' = constValue . Full.node <$> defaultValue
variableType <- Type.lookupInputType variableTypeName types
2020-06-13 07:20:19 +02:00
Coerce.matchFieldValues
coerceVariableValue'
variableValues
variableName
variableType
defaultValue'
coercedValues
coerceVariableValue' variableType value'
2020-06-13 07:20:19 +02:00
= 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) =
2020-06-13 07:20:19 +02:00
Type.Object $ HashMap.fromList $ constObjectField <$> o
where
2020-10-04 18:51:21 +02:00
constObjectField Full.ObjectField{value = value', ..} =
(name, constValue $ Full.node value')
2020-05-22 10:11:48 +02:00
-- | Rewrites the original syntax tree into an intermediate representation used
-- for query execution.
2020-06-13 07:20:19 +02:00
document :: Coerce.VariableValue a
=> forall m
. Type.Schema m
2020-05-22 10:11:48 +02:00
-> Maybe Full.Name
-> HashMap Full.Name a
-> Full.Document
-> Either QueryError (Document m)
2020-05-22 10:11:48 +02:00
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 _ _ _ _ ->
2020-09-28 07:06:15 +02:00
pure $ Document referencedTypes (Schema.query schema)
$ operation chosenOperation replacement
OperationDefinition Full.Mutation _ _ _ _
2020-09-28 07:06:15 +02:00
| Just mutationType <- Schema.mutation schema ->
pure $ Document referencedTypes mutationType
$ operation chosenOperation replacement
OperationDefinition Full.Subscription _ _ _ _
2020-09-28 07:06:15 +02:00
| Just subscriptionType <- Schema.subscription schema ->
pure $ Document referencedTypes subscriptionType
$ operation chosenOperation replacement
_ -> Left UnsupportedRootOperation
2020-05-22 10:11:48 +02:00
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
2020-05-21 10:20:59 +02:00
, (Full.DefinitionOperation operation') <- executable =
(transform operation' : operations, fragments')
| (Full.ExecutableDefinition executable) <- definition
2020-05-21 10:20:59 +02:00
, (Full.DefinitionFragment fragment) <- executable
, (Full.FragmentDefinition name _ _ _ _) <- fragment =
2020-05-21 10:20:59 +02:00
(operations, HashMap.insert name fragment fragments')
defragment' _ acc = acc
2020-05-21 10:20:59 +02:00
transform = \case
Full.OperationDefinition type' name variables directives' selections _ ->
2020-05-21 10:20:59 +02:00
OperationDefinition type' name variables directives' selections
Full.SelectionSet selectionSet _ ->
2020-05-21 10:20:59 +02:00
OperationDefinition Full.Query Nothing mempty mempty selectionSet
-- * Operation
operation :: OperationDefinition -> Replacement m -> Operation m
operation operationDefinition replacement
= runIdentity
$ evalStateT (collectFragments >> transform operationDefinition) replacement
2020-05-21 10:20:59 +02:00
where
transform (OperationDefinition Full.Query name _ _ sels) =
Query name <$> appendSelection sels
2020-05-21 10:20:59 +02:00
transform (OperationDefinition Full.Mutation name _ _ sels) =
Mutation name <$> appendSelection sels
2020-07-11 06:34:10 +02:00
transform (OperationDefinition Full.Subscription name _ _ sels) =
Subscription name <$> appendSelection sels
-- * Selection
selection
:: Full.Selection
-> State (Replacement m) (Either (Seq (Selection m)) (Selection m))
2020-09-09 17:04:31 +02:00
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
2020-09-09 17:04:31 +02:00
fieldArguments <- foldM go HashMap.empty arguments'
fieldSelections <- appendSelection selections
fieldDirectives <- Definition.selection <$> directives directives'
let field' = Field alias name fieldArguments fieldSelections location
2020-09-09 17:04:31 +02:00
pure $ field' <$ fieldDirectives
where
2020-09-21 07:28:40 +02:00
go arguments (Full.Argument name' (Full.Node value' _) _) =
inputField arguments name' value'
2020-09-07 22:01:49 +02:00
fragmentSpread
:: Full.FragmentSpread
2020-09-09 17:04:31 +02:00
-> State (Replacement m) (Maybe (Fragment m))
fragmentSpread (Full.FragmentSpread name directives' _) = do
spreadDirectives <- Definition.selection <$> directives directives'
fragments' <- gets fragments
2020-09-09 17:04:31 +02:00
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
2020-09-07 22:01:49 +02:00
inlineFragment
:: Full.InlineFragment
-> State (Replacement m) (Either (Seq (Selection m)) (Selection m))
inlineFragment (Full.InlineFragment type' directives' selections _) = do
2020-07-06 19:10:34 +02:00
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
2020-07-06 19:10:34 +02:00
directives :: [Full.Directive] -> State (Replacement m) [Definition.Directive]
directives = traverse directive
where
directive (Full.Directive directiveName directiveArguments _)
2020-07-06 19:10:34 +02:00
= Definition.Directive directiveName . Type.Arguments
<$> foldM go HashMap.empty directiveArguments
2020-09-21 07:28:40 +02:00
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
2019-11-13 20:40:09 +01:00
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 }
2020-06-13 07:20:19 +02:00
value :: forall m. Full.Value -> State (Replacement m) Type.Value
value (Full.Variable name) =
2020-06-13 07:20:19 +02:00
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
2020-06-13 07:20:19 +02:00
value (Full.Object object) =
Type.Object . HashMap.fromList <$> traverse objectField object
where
2020-10-04 18:51:21 +02:00
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)
2020-06-13 07:20:19 +02:00
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
2020-06-13 07:20:19 +02:00
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
2020-10-04 18:51:21 +02:00
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