Replace the old executor

This commit is contained in:
Eugen Wissner 2021-09-03 22:47:49 +02:00
parent 7b4c7e2b8c
commit b96d75f447
Signed by: belka
GPG Key ID: A27FDC1E8EE902C0
11 changed files with 480 additions and 2007 deletions

View File

@ -47,11 +47,8 @@ library
Language.GraphQL.Validate.Validation
Test.Hspec.GraphQL
other-modules:
Language.GraphQL.Execute.Execution
Language.GraphQL.Execute.Internal
Language.GraphQL.Execute.Subscribe
Language.GraphQL.Execute.Transform
Language.GraphQL.Executor
Language.GraphQL.Type.Definition
Language.GraphQL.Type.Internal
Language.GraphQL.Validate.Rules

View File

@ -1,6 +1,4 @@
{- 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 Safe #-}
-- | Target AST for parser.
module Language.GraphQL.AST

View File

@ -1,3 +1,7 @@
{- 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 DuplicateRecordFields #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RecordWildCards #-}

View File

@ -4,17 +4,13 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeApplications #-}
module Language.GraphQL.Execute
( Error(..)
, Operation(..)
, Path(..)
, Response(..)
( module Language.GraphQL.Execute.Coerce
, execute
) where
@ -29,32 +25,27 @@ import Control.Monad.Catch
, catches
)
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Reader (ReaderT(..), ask, local, runReaderT)
import Control.Monad.Trans.Writer (WriterT(..), runWriterT, tell)
import qualified Control.Monad.Trans.Reader as Reader
import Control.Monad.Trans.Reader (ReaderT(..), ask, runReaderT)
import Control.Monad.Trans.Writer (WriterT(..), runWriterT)
import qualified Control.Monad.Trans.Writer as Writer
import Control.Monad (foldM)
import qualified Language.GraphQL.AST.Document as Full
import Data.Bifunctor (first)
import Data.Foldable (find)
import Data.Functor ((<&>))
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 (intercalate)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (fromMaybe, isJust)
import Data.Sequence (Seq, (><))
import Data.Maybe (fromMaybe)
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Typeable (cast)
import GHC.Records (HasField(..))
import qualified Language.GraphQL.Execute.Coerce as Coerce
import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Execute.OrderedMap (OrderedMap)
import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
import qualified Language.GraphQL.Execute.Transform as Transform
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
import qualified Language.GraphQL.Type as Type
@ -65,40 +56,10 @@ import Language.GraphQL.Error
( Error(..)
, Response(..)
, Path(..)
, ResolverException(..)
, ResponseEventStream
)
import Numeric (showFloat)
data Replacement m = Replacement
{ variableValues :: Type.Subs
, fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
, visitedFragments :: HashSet Full.Name
, types :: HashMap Full.Name (Type m)
}
newtype TransformT m a = TransformT
{ runTransformT :: ReaderT (Replacement m) m a
}
instance Functor m => Functor (TransformT m) where
fmap f = TransformT . fmap f . runTransformT
instance Applicative m => Applicative (TransformT m) where
pure = TransformT . pure
TransformT f <*> TransformT x = TransformT $ f <*> x
instance Monad m => Monad (TransformT m) where
TransformT x >>= f = TransformT $ x >>= runTransformT . f
instance MonadTrans TransformT where
lift = TransformT . lift
instance MonadThrow m => MonadThrow (TransformT m) where
throwM = lift . throwM
instance MonadCatch m => MonadCatch (TransformT m) where
catch (TransformT stack) handler =
TransformT $ catch stack $ runTransformT . handler
import Prelude hiding (null)
newtype ExecutorT m a = ExecutorT
{ runExecutorT :: ReaderT (HashMap Full.Name (Type m)) (WriterT (Seq Error) m) a
@ -139,25 +100,27 @@ graphQLExceptionFromException e = do
GraphQLException graphqlException <- fromException e
cast graphqlException
data ResolverException = forall e. Exception e => ResolverException e
data ResultException = forall e. Exception e => ResultException e
instance Show ResolverException where
show (ResolverException e) = show e
instance Show ResultException where
show (ResultException e) = show e
instance Exception ResolverException where
instance Exception ResultException where
toException = graphQLExceptionToException
fromException = graphQLExceptionFromException
data FieldError
= ResultCoercionError
| NullResultError
resultExceptionToException :: Exception e => e -> SomeException
resultExceptionToException = toException . ResultException
instance Show FieldError where
show ResultCoercionError = "Result coercion failed."
show NullResultError = "Non-Nullable field resolver returned Null."
resultExceptionFromException :: Exception e => SomeException -> Maybe e
resultExceptionFromException e = do
ResultException resultException <- fromException e
cast resultException
newtype FieldException = FieldException FieldError
deriving Show
data FieldException = forall e. Exception e => FieldException Full.Location [Path] e
instance Show FieldException where
show (FieldException _ _ e) = displayException e
instance Exception FieldException where
toException = graphQLExceptionToException
@ -175,11 +138,11 @@ instance Show ValueCompletionException where
]
instance Exception ValueCompletionException where
toException = graphQLExceptionToException
fromException = graphQLExceptionFromException
toException = resultExceptionToException
fromException = resultExceptionFromException
data InputCoercionException =
InputCoercionException String In.Type (Maybe (Full.Node Input))
InputCoercionException String In.Type (Maybe (Full.Node Transform.Input))
instance Show InputCoercionException where
show (InputCoercionException argumentName argumentType Nothing) = concat
@ -203,14 +166,27 @@ instance Exception InputCoercionException where
toException = graphQLExceptionToException
fromException = graphQLExceptionFromException
newtype ResultCoercionException = ResultCoercionException String
instance Show ResultCoercionException where
show (ResultCoercionException typeRepresentation) = concat
[ "Unable to coerce result to "
, typeRepresentation
, "."
]
instance Exception ResultCoercionException where
toException = resultExceptionToException
fromException = resultExceptionFromException
data QueryError
= OperationNameRequired
| OperationNotFound String
| CoercionError Full.VariableDefinition
| UnknownInputType Full.VariableDefinition
asks :: Monad m => forall a. (Replacement m -> a) -> TransformT m a
asks = TransformT . Reader.asks
tell :: Monad m => Seq Error -> ExecutorT m ()
tell = ExecutorT . lift . Writer.tell
queryError :: QueryError -> Error
queryError OperationNameRequired =
@ -241,232 +217,7 @@ queryError (UnknownInputType variableDefinition) =
]
in Error{ message = queryErrorMessage, locations = [location], path = [] }
data Operation m
= Operation Full.OperationType (Seq (Selection m)) Full.Location
data Selection m
= FieldSelection (Field m)
| FragmentSelection (Fragment m)
data Field m = Field
(Maybe Full.Name)
Full.Name
(HashMap Full.Name (Full.Node Input))
(Seq (Selection m))
Full.Location
data Fragment m = Fragment
(Type.Internal.CompositeType m) (Seq (Selection m)) Full.Location
data Input
= Variable Type.Value
| Int Int32
| Float Double
| String Text
| Boolean Bool
| Null
| Enum Full.Name
| List [Input]
| Object (HashMap Full.Name Input)
deriving Eq
instance Show Input where
showList = mappend . showList'
where
showList' list = "[" ++ intercalate ", " (show <$> list) ++ "]"
show (Int integer) = show integer
show (Float float') = showFloat float' mempty
show (String text) = "\"" <> Text.foldr (mappend . Full.escape) "\"" text
show (Boolean boolean') = show boolean'
show Null = "null"
show (Enum name) = Text.unpack name
show (List list) = show list
show (Object fields) = unwords
[ "{"
, intercalate ", " (HashMap.foldrWithKey showObject [] fields)
, "}"
]
where
showObject key value accumulator =
concat [Text.unpack key, ": ", show value] : accumulator
show variableValue = show variableValue
document :: Full.Document
-> ([Full.OperationDefinition], HashMap Full.Name Full.FragmentDefinition)
document = foldr filterOperation ([], HashMap.empty)
where
filterOperation (Full.ExecutableDefinition executableDefinition) accumulator
| Full.DefinitionOperation operationDefinition' <- executableDefinition =
first (operationDefinition' :) accumulator
| Full.DefinitionFragment fragmentDefinition <- executableDefinition
, Full.FragmentDefinition fragmentName _ _ _ _ <- fragmentDefinition =
HashMap.insert fragmentName fragmentDefinition <$> accumulator
filterOperation _ accumulator = accumulator -- Type system definitions.
transform :: Monad m => Full.OperationDefinition -> TransformT m (Operation m)
transform (Full.OperationDefinition operationType _ _ _ selectionSet' operationLocation) = do
transformedSelections <- selectionSet selectionSet'
pure $ Operation operationType transformedSelections operationLocation
transform (Full.SelectionSet selectionSet' operationLocation) = do
transformedSelections <- selectionSet selectionSet'
pure $ Operation Full.Query transformedSelections operationLocation
selectionSet :: Monad m => Full.SelectionSet -> TransformT m (Seq (Selection m))
selectionSet = selectionSetOpt . NonEmpty.toList
selectionSetOpt :: Monad m => Full.SelectionSetOpt -> TransformT m (Seq (Selection m))
selectionSetOpt = foldM go Seq.empty
where
go accumulatedSelections currentSelection =
selection currentSelection <&> (accumulatedSelections ><)
selection :: Monad m => Full.Selection -> TransformT m (Seq (Selection m))
selection (Full.FieldSelection field') =
maybeToSelectionSet FieldSelection $ field field'
selection (Full.FragmentSpreadSelection fragmentSpread') =
maybeToSelectionSet FragmentSelection $ fragmentSpread fragmentSpread'
selection (Full.InlineFragmentSelection inlineFragment') =
either id (pure . FragmentSelection) <$> inlineFragment inlineFragment'
maybeToSelectionSet :: Monad m
=> forall a
. (a -> Selection m)
-> TransformT m (Maybe a)
-> TransformT m (Seq (Selection m))
maybeToSelectionSet selectionType = fmap (maybe Seq.empty $ pure . selectionType)
directives :: Monad m => [Full.Directive] -> TransformT m (Maybe [Type.Directive])
directives = fmap Type.selection . traverse directive
inlineFragment :: Monad m
=> Full.InlineFragment
-> TransformT m (Either (Seq (Selection m)) (Fragment m))
inlineFragment (Full.InlineFragment maybeCondition directives' selectionSet' location)
| Just typeCondition <- maybeCondition = do
transformedSelections <- selectionSet selectionSet'
transformedDirectives <- directives directives'
maybeFragmentType <- asks
$ Type.Internal.lookupTypeCondition typeCondition
. types
pure $ case transformedDirectives >> maybeFragmentType of
Just fragmentType -> Right
$ Fragment fragmentType transformedSelections location
Nothing -> Left Seq.empty
| otherwise = do
transformedSelections <- selectionSet selectionSet'
transformedDirectives <- directives directives'
pure $ if isJust transformedDirectives
then Left transformedSelections
else Left Seq.empty
fragmentSpread :: Monad m => Full.FragmentSpread -> TransformT m (Maybe (Fragment m))
fragmentSpread (Full.FragmentSpread spreadName directives' location) = do
transformedDirectives <- directives directives'
visitedFragment <- asks $ HashSet.member spreadName . visitedFragments
possibleFragmentDefinition <- asks
$ HashMap.lookup spreadName
. fragmentDefinitions
case transformedDirectives >> possibleFragmentDefinition of
Just (Full.FragmentDefinition _ typeCondition _ selections _)
| visitedFragment -> pure Nothing
| otherwise -> do
fragmentType <- asks
$ Type.Internal.lookupTypeCondition typeCondition
. types
traverse (traverseSelections selections) fragmentType
Nothing -> pure Nothing
where
traverseSelections selections typeCondition = do
transformedSelections <- TransformT
$ local fragmentInserter
$ runTransformT
$ selectionSet selections
pure $ Fragment typeCondition transformedSelections location
fragmentInserter replacement@Replacement{ visitedFragments } = replacement
{ visitedFragments = HashSet.insert spreadName visitedFragments }
field :: Monad m => Full.Field -> TransformT m (Maybe (Field m))
field (Full.Field alias' name' arguments' directives' selectionSet' location') = do
transformedSelections <- selectionSetOpt selectionSet'
transformedDirectives <- directives directives'
transformedArguments <- arguments arguments'
let transformedField = Field
alias'
name'
transformedArguments
transformedSelections
location'
pure $ transformedDirectives >> pure transformedField
arguments :: Monad m => [Full.Argument] -> TransformT m (HashMap Full.Name (Full.Node Input))
arguments = foldM go HashMap.empty
where
go accumulator (Full.Argument name' valueNode argumentLocation) = do
let replaceLocation = flip Full.Node argumentLocation . Full.node
argumentValue <- fmap replaceLocation <$> node valueNode
pure $ insertIfGiven name' argumentValue accumulator
directive :: Monad m => Full.Directive -> TransformT m Type.Directive
directive (Full.Directive name' arguments' _)
= Type.Directive name'
. Type.Arguments
<$> foldM go HashMap.empty arguments'
where
go accumulator (Full.Argument argumentName Full.Node{ node = node' } _) = do
transformedValue <- directiveValue node'
pure $ HashMap.insert argumentName transformedValue accumulator
directiveValue :: Monad m => Full.Value -> TransformT m Type.Value
directiveValue = \case
(Full.Variable name') -> asks
$ HashMap.lookupDefault Type.Null name'
. variableValues
(Full.Int integer) -> pure $ Type.Int integer
(Full.Float double) -> pure $ Type.Float double
(Full.String string) -> pure $ Type.String string
(Full.Boolean boolean) -> pure $ Type.Boolean boolean
Full.Null -> pure Type.Null
(Full.Enum enum) -> pure $ Type.Enum enum
(Full.List list) -> Type.List <$> traverse directiveNode list
(Full.Object objectFields) ->
Type.Object <$> foldM objectField HashMap.empty objectFields
where
directiveNode Full.Node{ node = node'} = directiveValue node'
objectField accumulator Full.ObjectField{ name, value } = do
transformedValue <- directiveNode value
pure $ HashMap.insert name transformedValue accumulator
input :: Monad m => Full.Value -> TransformT m (Maybe Input)
input (Full.Variable name') =
asks (HashMap.lookup name' . variableValues) <&> fmap Variable
input (Full.Int integer) = pure $ Just $ Int integer
input (Full.Float double) = pure $ Just $ Float double
input (Full.String string) = pure $ Just $ String string
input (Full.Boolean boolean) = pure $ Just $ Boolean boolean
input Full.Null = pure $ Just Null
input (Full.Enum enum) = pure $ Just $ Enum enum
input (Full.List list) = Just . List
<$> traverse (fmap (fromMaybe Null) . input . Full.node) list
input (Full.Object objectFields) = Just . Object
<$> foldM objectField HashMap.empty objectFields
where
objectField accumulator Full.ObjectField{..} = do
objectFieldValue <- fmap Full.node <$> node value
pure $ insertIfGiven name objectFieldValue accumulator
insertIfGiven :: forall a
. Full.Name
-> Maybe a
-> HashMap Full.Name a
-> HashMap Full.Name a
insertIfGiven name (Just v) = HashMap.insert name v
insertIfGiven _ _ = id
node :: Monad m => Full.Node Full.Value -> TransformT m (Maybe (Full.Node Input))
node Full.Node{node = node', ..} =
traverse Full.Node <$> input node' <*> pure location
execute :: (MonadCatch m, Coerce.VariableValue a, Coerce.Serialize b)
execute :: (MonadCatch m, VariableValue a, Serialize b)
=> Schema m -- ^ Resolvers.
-> Maybe Text -- ^ Operation name.
-> HashMap Full.Name a -- ^ Variable substitution function.
@ -475,7 +226,7 @@ execute :: (MonadCatch m, Coerce.VariableValue a, Coerce.Serialize b)
execute schema' operationName subs document' =
executeRequest schema' document' (Text.unpack <$> operationName) subs
executeRequest :: (MonadCatch m, Coerce.Serialize a, Coerce.VariableValue b)
executeRequest :: (MonadCatch m, Serialize a, VariableValue b)
=> Schema m
-> Full.Document
-> Maybe String
@ -486,35 +237,36 @@ executeRequest schema sourceDocument operationName variableValues = do
case operationAndVariables of
Left queryError' -> pure
$ Right
$ Response Coerce.null $ pure $ queryError queryError'
$ Response null $ pure $ queryError queryError'
Right operation
| Operation Full.Query topSelections _operationLocation <- operation ->
| Transform.Operation Full.Query topSelections _operationLocation <- operation ->
Right <$> executeQuery topSelections schema
| Operation Full.Mutation topSelections operationLocation <- operation ->
| Transform.Operation Full.Mutation topSelections operationLocation <- operation ->
Right <$> executeMutation topSelections schema operationLocation
| Operation Full.Subscription topSelections operationLocation <- operation ->
| Transform.Operation Full.Subscription topSelections operationLocation <- operation ->
either rightErrorResponse Left <$> subscribe topSelections schema operationLocation
where
schemaTypes = Schema.types schema
(operationDefinitions, fragmentDefinitions') = document sourceDocument
(operationDefinitions, fragmentDefinitions') =
Transform.document sourceDocument
buildOperation = do
operationDefinition <- getOperation operationDefinitions operationName
coercedVariableValues <- coerceVariableValues
schemaTypes
operationDefinition
variableValues
let replacement = Replacement
let replacement = Transform.Replacement
{ variableValues = coercedVariableValues
, fragmentDefinitions = fragmentDefinitions'
, visitedFragments = mempty
, types = schemaTypes
}
pure $ flip runReaderT replacement
$ runTransformT
$ transform operationDefinition
$ Transform.runTransformT
$ Transform.transform operationDefinition
rightErrorResponse :: Coerce.Serialize b => forall a. Error -> Either a (Response b)
rightErrorResponse = Right . Response Coerce.null . pure
rightErrorResponse :: Serialize b => forall a. Error -> Either a (Response b)
rightErrorResponse = Right . Response null . pure
getOperation :: [Full.OperationDefinition] -> Maybe String -> Either QueryError Full.OperationDefinition
getOperation [operation] Nothing = Right operation
@ -527,8 +279,8 @@ getOperation operations (Just givenOperationName)
findOperationByName _ = False
getOperation _ _ = Left OperationNameRequired
executeQuery :: (MonadCatch m, Coerce.Serialize a)
=> Seq (Selection m)
executeQuery :: (MonadCatch m, Serialize a)
=> Seq (Transform.Selection m)
-> Schema m
-> m (Response a)
executeQuery topSelections schema = do
@ -536,11 +288,26 @@ executeQuery topSelections schema = do
(data', errors) <- runWriterT
$ flip runReaderT (Schema.types schema)
$ runExecutorT
$ executeSelectionSet topSelections queryType Type.Null []
$ catch (executeSelectionSet topSelections queryType Type.Null [])
handleException
pure $ Response data' errors
executeMutation :: (MonadCatch m, Coerce.Serialize a)
=> Seq (Selection m)
handleException :: (MonadCatch m, Serialize a)
=> FieldException
-> ExecutorT m a
handleException (FieldException fieldLocation errorPath next) =
let newError = constructError next fieldLocation errorPath
in tell (Seq.singleton newError) >> pure null
constructError :: Exception e => e -> Full.Location -> [Path] -> Error
constructError e fieldLocation errorPath = Error
{ message = Text.pack (displayException e)
, path = reverse errorPath
, locations = [fieldLocation]
}
executeMutation :: (MonadCatch m, Serialize a)
=> Seq (Transform.Selection m)
-> Schema m
-> Full.Location
-> m (Response a)
@ -549,15 +316,16 @@ executeMutation topSelections schema operationLocation
(data', errors) <- runWriterT
$ flip runReaderT (Schema.types schema)
$ runExecutorT
$ executeSelectionSet topSelections mutationType Type.Null []
$ catch (executeSelectionSet topSelections mutationType Type.Null [])
handleException
pure $ Response data' errors
| otherwise = pure
$ Response Coerce.null
$ Response null
$ Seq.singleton
$ Error "Schema doesn't support mutations." [operationLocation] []
executeSelectionSet :: (MonadCatch m, Coerce.Serialize a)
=> Seq (Selection m)
executeSelectionSet :: (MonadCatch m, Serialize a)
=> Seq (Transform.Selection m)
-> Out.ObjectType m
-> Type.Value
-> [Path]
@ -565,62 +333,80 @@ executeSelectionSet :: (MonadCatch m, Coerce.Serialize a)
executeSelectionSet selections objectType objectValue errorPath = do
let groupedFieldSet = collectFields objectType selections
resolvedValues <- OrderedMap.traverseMaybe go groupedFieldSet
coerceResult (Out.NonNullObjectType objectType) $ Coerce.Object resolvedValues
coerceResult (Out.NonNullObjectType objectType) $ Object resolvedValues
where
executeField' fields resolver =
executeField objectValue fields resolver errorPath
Out.ObjectType _ _ _ resolvers = objectType
go fields@(Field _ fieldName _ _ _ :| _) =
go fields@(Transform.Field _ fieldName _ _ _ :| _) =
traverse (executeField' fields) $ HashMap.lookup fieldName resolvers
fieldsSegment :: forall m. NonEmpty (Field m) -> Path
fieldsSegment (Field alias fieldName _ _ _ :| _) =
fieldsSegment :: forall m. NonEmpty (Transform.Field m) -> Path
fieldsSegment (Transform.Field alias fieldName _ _ _ :| _) =
Segment (fromMaybe fieldName alias)
executeField :: (MonadCatch m, Coerce.Serialize a)
viewResolver :: Out.Resolver m -> (Out.Field m, Out.Resolve m)
viewResolver (Out.ValueResolver resolverField' resolveFunction) =
(resolverField', resolveFunction)
viewResolver (Out.EventStreamResolver resolverField' resolveFunction _) =
(resolverField', resolveFunction)
executeField :: forall m a
. (MonadCatch m, Serialize a)
=> Type.Value
-> NonEmpty (Field m)
-> NonEmpty (Transform.Field m)
-> Out.Resolver m
-> [Path]
-> ExecutorT m a
executeField objectValue fields resolver errorPath =
let Field _ fieldName inputArguments _ fieldLocation :| _ = fields
executeField objectValue fields (viewResolver -> resolverPair) errorPath =
let Transform.Field _ fieldName inputArguments _ fieldLocation :| _ = fields
in catches (go fieldName inputArguments)
[ Handler (inputCoercionHandler fieldLocation)
, Handler (graphqlExceptionHandler fieldLocation)
[ Handler nullResultHandler
, Handler (inputCoercionHandler fieldLocation)
, Handler (resultHandler fieldLocation)
, Handler (resolverHandler fieldLocation)
]
where
inputCoercionHandler :: (MonadCatch m, Coerce.Serialize a)
inputCoercionHandler :: (MonadCatch m, Serialize a)
=> Full.Location
-> InputCoercionException
-> ExecutorT m a
inputCoercionHandler _ e@(InputCoercionException _ _ (Just valueNode)) =
let argumentLocation = getField @"location" valueNode
in exceptionHandler argumentLocation $ displayException e
inputCoercionHandler fieldLocation e =
exceptionHandler fieldLocation $ displayException e
graphqlExceptionHandler :: (MonadCatch m, Coerce.Serialize a)
in exceptionHandler argumentLocation e
inputCoercionHandler fieldLocation e = exceptionHandler fieldLocation e
resultHandler :: (MonadCatch m, Serialize a)
=> Full.Location
-> GraphQLException
-> ResultException
-> ExecutorT m a
graphqlExceptionHandler fieldLocation e =
exceptionHandler fieldLocation $ displayException e
exceptionHandler errorLocation exceptionText =
let newError = Error (Text.pack exceptionText) [errorLocation]
$ reverse
$ fieldsSegment fields : errorPath
in ExecutorT (lift $ tell $ Seq.singleton newError) >> pure Coerce.null
resultHandler = exceptionHandler
resolverHandler :: (MonadCatch m, Serialize a)
=> Full.Location
-> ResolverException
-> ExecutorT m a
resolverHandler = exceptionHandler
nullResultHandler :: (MonadCatch m, Serialize a)
=> FieldException
-> ExecutorT m a
nullResultHandler e@(FieldException fieldLocation errorPath' next) =
let newError = constructError next fieldLocation errorPath'
in if Out.isNonNullType fieldType
then throwM e
else returnError newError
exceptionHandler errorLocation e =
let newPath = fieldsSegment fields : errorPath
newError = constructError e errorLocation newPath
in if Out.isNonNullType fieldType
then throwM $ FieldException errorLocation newPath e
else returnError newError
returnError newError = tell (Seq.singleton newError) >> pure null
go fieldName inputArguments = do
let (Out.Field _ fieldType argumentTypes, resolveFunction) =
resolverField resolver
argumentValues <- coerceArgumentValues argumentTypes inputArguments
resolvedValue <-
resolveFieldValue resolveFunction objectValue fieldName argumentValues
completeValue fieldType fields errorPath resolvedValue
resolverField (Out.ValueResolver resolverField' resolveFunction) =
(resolverField', resolveFunction)
resolverField (Out.EventStreamResolver resolverField' resolveFunction _) =
(resolverField', resolveFunction)
(resolverField, resolveFunction) = resolverPair
Out.Field _ fieldType argumentTypes = resolverField
resolveFieldValue :: MonadCatch m
=> Out.Resolve m
@ -651,34 +437,33 @@ resolveAbstractType abstractType values'
_ -> pure Nothing
| otherwise = pure Nothing
completeValue :: (MonadCatch m, Coerce.Serialize a)
completeValue :: (MonadCatch m, Serialize a)
=> Out.Type m
-> NonEmpty (Field m)
-> NonEmpty (Transform.Field m)
-> [Path]
-> Type.Value
-> ExecutorT m a
completeValue outputType _ _ Type.Null
| Out.isNonNullType outputType = throwFieldError NullResultError
| otherwise = pure Coerce.null
completeValue (Out.isNonNullType -> False) _ _ Type.Null =
pure null
completeValue outputType@(Out.ListBaseType listType) fields errorPath (Type.List list)
= foldM go (0, []) list >>= coerceResult outputType . Coerce.List . snd
= foldM go (0, []) list >>= coerceResult outputType . List . snd
where
go (index, accumulator) listItem = do
let updatedPath = Index index : errorPath
completedValue <- completeValue listType fields updatedPath listItem
pure (index + 1, completedValue : accumulator)
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Int int) =
coerceResult outputType $ Coerce.Int int
coerceResult outputType $ Int int
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Boolean boolean) =
coerceResult outputType $ Coerce.Boolean boolean
coerceResult outputType $ Boolean boolean
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Float float) =
coerceResult outputType $ Coerce.Float float
coerceResult outputType $ Float float
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.String string) =
coerceResult outputType $ Coerce.String string
coerceResult outputType $ String string
completeValue outputType@(Out.EnumBaseType enumType) _ _ (Type.Enum enum) =
let Type.EnumType _ _ enumMembers = enumType
in if HashMap.member enum enumMembers
then coerceResult outputType $ Coerce.Enum enum
then coerceResult outputType $ Enum enum
else throwM
$ ValueCompletionException (show outputType)
$ Type.Enum enum
@ -708,28 +493,25 @@ completeValue outputType@(Out.UnionBaseType unionType) fields errorPath result
completeValue outputType _ _ result =
throwM $ ValueCompletionException (show outputType) result
coerceResult :: (MonadCatch m, Coerce.Serialize a)
coerceResult :: (MonadCatch m, Serialize a)
=> Out.Type m
-> Coerce.Output a
-> Output a
-> ExecutorT m a
coerceResult outputType result
| Just serialized <- Coerce.serialize outputType result = pure serialized
| otherwise = throwFieldError ResultCoercionError
| Just serialized <- serialize outputType result = pure serialized
| otherwise = throwM $ ResultCoercionException $ show outputType
mergeSelectionSets :: MonadCatch m
=> NonEmpty (Field m)
-> Seq (Selection m)
=> NonEmpty (Transform.Field m)
-> Seq (Transform.Selection m)
mergeSelectionSets = foldr forEach mempty
where
forEach (Field _ _ _ fieldSelectionSet _) selectionSet' =
forEach (Transform.Field _ _ _ fieldSelectionSet _) selectionSet' =
selectionSet' <> fieldSelectionSet
throwFieldError :: MonadCatch m => FieldError -> m a
throwFieldError = throwM . FieldException
coerceArgumentValues :: MonadCatch m
=> HashMap Full.Name In.Argument
-> HashMap Full.Name (Full.Node Input)
-> HashMap Full.Name (Full.Node Transform.Input)
-> m Type.Subs
coerceArgumentValues argumentDefinitions argumentValues =
HashMap.foldrWithKey c pure argumentDefinitions mempty
@ -754,53 +536,53 @@ coerceArgumentValues argumentDefinitions argumentValues =
$ Just inputValue
| otherwise -> throwM
$ InputCoercionException (Text.unpack argumentName) variableType Nothing
matchFieldValues' = Coerce.matchFieldValues coerceArgumentValue
matchFieldValues' = matchFieldValues coerceArgumentValue
$ Full.node <$> argumentValues
coerceArgumentValue inputType (Int integer) =
Coerce.coerceInputLiteral inputType (Type.Int integer)
coerceArgumentValue inputType (Boolean boolean) =
Coerce.coerceInputLiteral inputType (Type.Boolean boolean)
coerceArgumentValue inputType (String string) =
Coerce.coerceInputLiteral inputType (Type.String string)
coerceArgumentValue inputType (Float float) =
Coerce.coerceInputLiteral inputType (Type.Float float)
coerceArgumentValue inputType (Enum enum) =
Coerce.coerceInputLiteral inputType (Type.Enum enum)
coerceArgumentValue inputType Null
coerceArgumentValue inputType (Transform.Int integer) =
coerceInputLiteral inputType (Type.Int integer)
coerceArgumentValue inputType (Transform.Boolean boolean) =
coerceInputLiteral inputType (Type.Boolean boolean)
coerceArgumentValue inputType (Transform.String string) =
coerceInputLiteral inputType (Type.String string)
coerceArgumentValue inputType (Transform.Float float) =
coerceInputLiteral inputType (Type.Float float)
coerceArgumentValue inputType (Transform.Enum enum) =
coerceInputLiteral inputType (Type.Enum enum)
coerceArgumentValue inputType Transform.Null
| In.isNonNullType inputType = Nothing
| otherwise = Coerce.coerceInputLiteral inputType Type.Null
coerceArgumentValue (In.ListBaseType inputType) (List list) =
| otherwise = coerceInputLiteral inputType Type.Null
coerceArgumentValue (In.ListBaseType inputType) (Transform.List list) =
let coerceItem = coerceArgumentValue inputType
in Type.List <$> traverse coerceItem list
coerceArgumentValue (In.InputObjectBaseType inputType) (Object object)
coerceArgumentValue (In.InputObjectBaseType inputType) (Transform.Object object)
| In.InputObjectType _ _ inputFields <- inputType =
let go = forEachField object
resultMap = HashMap.foldrWithKey go (pure mempty) inputFields
in Type.Object <$> resultMap
coerceArgumentValue _ (Variable variable) = pure variable
coerceArgumentValue _ (Transform.Variable variable) = pure variable
coerceArgumentValue _ _ = Nothing
forEachField object variableName (In.InputField _ variableType defaultValue) =
Coerce.matchFieldValues coerceArgumentValue object variableName variableType defaultValue
matchFieldValues coerceArgumentValue object variableName variableType defaultValue
collectFields :: Monad m
=> Out.ObjectType m
-> Seq (Selection m)
-> OrderedMap (NonEmpty (Field m))
-> Seq (Transform.Selection m)
-> OrderedMap (NonEmpty (Transform.Field m))
collectFields objectType = foldl forEach OrderedMap.empty
where
forEach groupedFields (FieldSelection fieldSelection) =
let Field maybeAlias fieldName _ _ _ = fieldSelection
forEach groupedFields (Transform.FieldSelection fieldSelection) =
let Transform.Field maybeAlias fieldName _ _ _ = fieldSelection
responseKey = fromMaybe fieldName maybeAlias
in OrderedMap.insert responseKey (fieldSelection :| []) groupedFields
forEach groupedFields (FragmentSelection selectionFragment)
| Fragment fragmentType fragmentSelectionSet _ <- selectionFragment
forEach groupedFields (Transform.FragmentSelection selectionFragment)
| Transform.Fragment fragmentType fragmentSelectionSet _ <- selectionFragment
, Type.Internal.doesFragmentTypeApply fragmentType objectType =
let fragmentGroupedFieldSet =
collectFields objectType fragmentSelectionSet
in groupedFields <> fragmentGroupedFieldSet
| otherwise = groupedFields
coerceVariableValues :: (Monad m, Coerce.VariableValue b)
coerceVariableValues :: (Monad m, VariableValue b)
=> HashMap Full.Name (Schema.Type m)
-> Full.OperationDefinition
-> HashMap Full.Name b
@ -818,7 +600,7 @@ coerceVariableValues types operationDefinition' variableValues
in case Type.Internal.lookupInputType variableTypeName types of
Just variableType ->
maybe (Left $ CoercionError variableDefinition) Right
$ Coerce.matchFieldValues
$ matchFieldValues
coerceVariableValue'
variableValues
variableName
@ -828,8 +610,8 @@ coerceVariableValues types operationDefinition' variableValues
Nothing -> Left $ UnknownInputType variableDefinition
forEach _ coercedValuesOrError = coercedValuesOrError
coerceVariableValue' variableType value'
= Coerce.coerceVariableValue variableType value'
>>= Coerce.coerceInputLiteral variableType
= coerceVariableValue variableType value'
>>= coerceInputLiteral variableType
constValue :: Full.ConstValue -> Type.Value
constValue (Full.ConstInt i) = Type.Int i
@ -845,8 +627,8 @@ constValue (Full.ConstObject o) =
constObjectField Full.ObjectField{value = value', ..} =
(name, constValue $ Full.node value')
subscribe :: (MonadCatch m, Coerce.Serialize a)
=> Seq (Selection m)
subscribe :: (MonadCatch m, Serialize a)
=> Seq (Transform.Selection m)
-> Schema m
-> Full.Location
-> m (Either Error (ResponseEventStream m a))
@ -861,10 +643,10 @@ subscribe fields schema objectLocation
| otherwise = pure $ Left
$ Error "Schema doesn't support subscriptions." [] []
mapSourceToResponseEvent :: (MonadCatch m, Coerce.Serialize a)
mapSourceToResponseEvent :: (MonadCatch m, Serialize a)
=> HashMap Full.Name (Type m)
-> Out.ObjectType m
-> Seq (Selection m)
-> Seq (Transform.Selection m)
-> Out.SourceEventStream m
-> m (ResponseEventStream m a)
mapSourceToResponseEvent types' subscriptionType fields sourceStream
@ -876,11 +658,12 @@ createSourceEventStream :: MonadCatch m
=> HashMap Full.Name (Type m)
-> Out.ObjectType m
-> Full.Location
-> Seq (Selection m)
-> Seq (Transform.Selection m)
-> m (Either Error (Out.SourceEventStream m))
createSourceEventStream _types subscriptionType objectLocation fields
| [fieldGroup] <- OrderedMap.elems groupedFieldSet
, Field _ fieldName arguments' _ errorLocation <- NonEmpty.head fieldGroup
, Transform.Field _ fieldName arguments' _ errorLocation <-
NonEmpty.head fieldGroup
, Out.ObjectType _ _ _ fieldTypes <- subscriptionType
, resolverT <- fieldTypes HashMap.! fieldName
, Out.EventStreamResolver fieldDefinition _ resolver <- resolverT
@ -889,16 +672,15 @@ createSourceEventStream _types subscriptionType objectLocation fields
Left _ -> pure
$ Left
$ Error "Argument coercion failed." [errorLocation] []
Right argumentValues -> left (singleError' [errorLocation])
Right argumentValues -> left (singleError [errorLocation])
<$> resolveFieldEventStream Type.Null argumentValues resolver
| otherwise = pure
$ Left
$ Error "Subscription contains more than one field." [objectLocation] []
where
groupedFieldSet = collectFields subscriptionType fields
singleError' :: [Full.Location] -> String -> Error
singleError' errorLocations message = Error (Text.pack message) errorLocations []
singleError :: [Full.Location] -> String -> Error
singleError errorLocations message = Error (Text.pack message) errorLocations []
resolveFieldEventStream :: MonadCatch m
=> Type.Value
@ -917,15 +699,16 @@ resolveFieldEventStream result args resolver =
, Type.values = result
}
executeSubscriptionEvent :: (MonadCatch m, Coerce.Serialize a)
executeSubscriptionEvent :: (MonadCatch m, Serialize a)
=> HashMap Full.Name (Type m)
-> Out.ObjectType m
-> Seq (Selection m)
-> Seq (Transform.Selection m)
-> Type.Value
-> m (Response a)
executeSubscriptionEvent types' objectType fields initialValue = do
(data', errors) <- runWriterT
$ flip runReaderT types'
$ runExecutorT
$ executeSelectionSet fields objectType initialValue []
$ catch (executeSelectionSet fields objectType initialValue [])
handleException
pure $ Response data' errors

View File

@ -1,253 +0,0 @@
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Language.GraphQL.Execute.Execution
( coerceArgumentValues
, collectFields
, executeSelectionSet
) where
import Control.Monad.Catch (Exception(..), MonadCatch(..))
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (runReaderT)
import Control.Monad.Trans.State (gets)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (fromMaybe)
import Data.Sequence (Seq(..))
import qualified Data.Text as Text
import qualified Language.GraphQL.AST as Full
import Language.GraphQL.Error
import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Execute.Internal
import Language.GraphQL.Execute.OrderedMap (OrderedMap)
import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
import qualified Language.GraphQL.Execute.Transform as Transform
import qualified Language.GraphQL.Type as Type
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
import qualified Language.GraphQL.Type.Internal as Internal
import Prelude hiding (null)
resolveFieldValue :: MonadCatch m
=> Type.Value
-> Type.Subs
-> Type.Resolve m
-> Full.Location
-> CollectErrsT m Type.Value
resolveFieldValue result args resolver location' =
catch (lift $ runReaderT resolver context) handleFieldError
where
handleFieldError :: MonadCatch m
=> ResolverException
-> CollectErrsT m Type.Value
handleFieldError e
= addError Type.Null
$ Error (Text.pack $ displayException e) [location'] []
context = Type.Context
{ Type.arguments = Type.Arguments args
, Type.values = result
}
collectFields :: Monad m
=> Out.ObjectType m
-> Seq (Transform.Selection m)
-> OrderedMap (NonEmpty (Transform.Field m))
collectFields objectType = foldl forEach OrderedMap.empty
where
forEach groupedFields (Transform.SelectionField field) =
let responseKey = aliasOrName field
in OrderedMap.insert responseKey (field :| []) groupedFields
forEach groupedFields (Transform.SelectionFragment selectionFragment)
| Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment
, Internal.doesFragmentTypeApply fragmentType objectType =
let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet
in groupedFields <> fragmentGroupedFieldSet
| otherwise = groupedFields
aliasOrName :: forall m. Transform.Field m -> Full.Name
aliasOrName (Transform.Field alias name _ _ _) = fromMaybe name alias
resolveAbstractType :: Monad m
=> Internal.AbstractType m
-> Type.Subs
-> CollectErrsT m (Maybe (Out.ObjectType m))
resolveAbstractType abstractType values'
| Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do
types' <- gets types
case HashMap.lookup typeName types' of
Just (Internal.ObjectType objectType) ->
if Internal.instanceOf objectType abstractType
then pure $ Just objectType
else pure Nothing
_ -> pure Nothing
| otherwise = pure Nothing
executeField :: (MonadCatch m, Serialize a)
=> Out.Resolver m
-> Type.Value
-> NonEmpty (Transform.Field m)
-> CollectErrsT m a
executeField fieldResolver prev fields
| Out.ValueResolver fieldDefinition resolver <- fieldResolver =
executeField' fieldDefinition resolver
| Out.EventStreamResolver fieldDefinition resolver _ <- fieldResolver =
executeField' fieldDefinition resolver
where
executeField' fieldDefinition resolver = do
let Out.Field _ fieldType argumentDefinitions = fieldDefinition
let Transform.Field _ _ arguments' _ location' = NonEmpty.head fields
case coerceArgumentValues argumentDefinitions arguments' of
Left [] ->
let errorMessage = "Not all required arguments are specified."
in addError null $ Error errorMessage [location'] []
Left errorLocations -> addError null
$ Error "Argument coercing failed." errorLocations []
Right argumentValues -> do
answer <- resolveFieldValue prev argumentValues resolver location'
completeValue fieldType fields answer
completeValue :: (MonadCatch m, Serialize a)
=> Out.Type m
-> NonEmpty (Transform.Field m)
-> Type.Value
-> CollectErrsT m a
completeValue (Out.isNonNullType -> False) _ Type.Null = pure null
completeValue outputType@(Out.ListBaseType listType) fields (Type.List list)
= traverse (completeValue listType fields) list
>>= coerceResult outputType (firstFieldLocation fields) . List
completeValue outputType@(Out.ScalarBaseType _) fields (Type.Int int) =
coerceResult outputType (firstFieldLocation fields) $ Int int
completeValue outputType@(Out.ScalarBaseType _) fields (Type.Boolean boolean) =
coerceResult outputType (firstFieldLocation fields) $ Boolean boolean
completeValue outputType@(Out.ScalarBaseType _) fields (Type.Float float) =
coerceResult outputType (firstFieldLocation fields) $ Float float
completeValue outputType@(Out.ScalarBaseType _) fields (Type.String string) =
coerceResult outputType (firstFieldLocation fields) $ String string
completeValue outputType@(Out.EnumBaseType enumType) fields (Type.Enum enum) =
let Type.EnumType _ _ enumMembers = enumType
location = firstFieldLocation fields
in if HashMap.member enum enumMembers
then coerceResult outputType location $ Enum enum
else addError null $ Error "Enum value completion failed." [location] []
completeValue (Out.ObjectBaseType objectType) fields result
= executeSelectionSet result objectType (firstFieldLocation fields)
$ mergeSelectionSets fields
completeValue (Out.InterfaceBaseType interfaceType) fields result
| Type.Object objectMap <- result = do
let abstractType = Internal.AbstractInterfaceType interfaceType
let location = firstFieldLocation fields
concreteType <- resolveAbstractType abstractType objectMap
case concreteType of
Just objectType -> executeSelectionSet result objectType location
$ mergeSelectionSets fields
Nothing -> addError null
$ Error "Interface value completion failed." [location] []
completeValue (Out.UnionBaseType unionType) fields result
| Type.Object objectMap <- result = do
let abstractType = Internal.AbstractUnionType unionType
let location = firstFieldLocation fields
concreteType <- resolveAbstractType abstractType objectMap
case concreteType of
Just objectType -> executeSelectionSet result objectType
location $ mergeSelectionSets fields
Nothing -> addError null
$ Error "Union value completion failed." [location] []
completeValue _ (Transform.Field _ _ _ _ location :| _) _ =
addError null $ Error "Value completion failed." [location] []
mergeSelectionSets :: MonadCatch m
=> NonEmpty (Transform.Field m)
-> Seq (Transform.Selection m)
mergeSelectionSets = foldr forEach mempty
where
forEach (Transform.Field _ _ _ fieldSelectionSet _) selectionSet =
selectionSet <> fieldSelectionSet
firstFieldLocation :: MonadCatch m => NonEmpty (Transform.Field m) -> Full.Location
firstFieldLocation (Transform.Field _ _ _ _ fieldLocation :| _) = fieldLocation
coerceResult :: (MonadCatch m, Serialize a)
=> Out.Type m
-> Full.Location
-> Output a
-> CollectErrsT m a
coerceResult outputType parentLocation result
| Just serialized <- serialize outputType result = pure serialized
| otherwise = addError null
$ Error "Result coercion failed." [parentLocation] []
-- | Takes an 'Out.ObjectType' and a list of 'Transform.Selection's and applies
-- each field to each 'Transform.Selection'. Resolves into a value containing
-- the resolved 'Transform.Selection', or a null value and error information.
executeSelectionSet :: (MonadCatch m, Serialize a)
=> Type.Value
-> Out.ObjectType m
-> Full.Location
-> Seq (Transform.Selection m)
-> CollectErrsT m a
executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) objectLocation selectionSet = do
let fields = collectFields objectType selectionSet
resolvedValues <- OrderedMap.traverseMaybe forEach fields
coerceResult (Out.NonNullObjectType objectType) objectLocation
$ Object resolvedValues
where
forEach fields@(field :| _) =
let Transform.Field _ name _ _ _ = field
in traverse (tryResolver fields) $ lookupResolver name
lookupResolver = flip HashMap.lookup resolvers
tryResolver fields resolver =
executeField resolver result fields >>= lift . pure
coerceArgumentValues
:: HashMap Full.Name In.Argument
-> HashMap Full.Name (Full.Node Transform.Input)
-> Either [Full.Location] Type.Subs
coerceArgumentValues argumentDefinitions argumentNodes =
HashMap.foldrWithKey forEach (pure mempty) argumentDefinitions
where
forEach argumentName (In.Argument _ variableType defaultValue) = \case
Right resultMap
| Just matchedValues
<- matchFieldValues' argumentName variableType defaultValue $ Just resultMap
-> Right matchedValues
| otherwise -> Left $ generateError argumentName []
Left errorLocations
| Just _
<- matchFieldValues' argumentName variableType defaultValue $ pure mempty
-> Left errorLocations
| otherwise -> Left $ generateError argumentName errorLocations
generateError argumentName errorLocations =
case HashMap.lookup argumentName argumentNodes of
Just (Full.Node _ errorLocation) -> [errorLocation]
Nothing -> errorLocations
matchFieldValues' = matchFieldValues coerceArgumentValue (Full.node <$> argumentNodes)
coerceArgumentValue inputType (Transform.Int integer) =
coerceInputLiteral inputType (Type.Int integer)
coerceArgumentValue inputType (Transform.Boolean boolean) =
coerceInputLiteral inputType (Type.Boolean boolean)
coerceArgumentValue inputType (Transform.String string) =
coerceInputLiteral inputType (Type.String string)
coerceArgumentValue inputType (Transform.Float float) =
coerceInputLiteral inputType (Type.Float float)
coerceArgumentValue inputType (Transform.Enum enum) =
coerceInputLiteral inputType (Type.Enum enum)
coerceArgumentValue inputType Transform.Null
| In.isNonNullType inputType = Nothing
| otherwise = coerceInputLiteral inputType Type.Null
coerceArgumentValue (In.ListBaseType inputType) (Transform.List list) =
let coerceItem = coerceInputLiteral inputType
in Type.List <$> traverse coerceItem list
coerceArgumentValue (In.InputObjectBaseType inputType) (Transform.Object object)
| In.InputObjectType _ _ inputFields <- inputType =
let go = forEachField object
resultMap = HashMap.foldrWithKey go (pure mempty) inputFields
in Type.Object <$> resultMap
coerceArgumentValue _ (Transform.Variable variable) = pure variable
coerceArgumentValue _ _ = Nothing
forEachField object variableName (In.InputField _ variableType defaultValue) =
matchFieldValues coerceArgumentValue object variableName variableType defaultValue

View File

@ -1,113 +0,0 @@
{- 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 OverloadedStrings #-}
module Language.GraphQL.Execute.Subscribe
( subscribe
) where
import Conduit
import Control.Arrow (left)
import Control.Monad.Catch (Exception(..), MonadCatch(..))
import Control.Monad.Trans.Reader (ReaderT(..), runReaderT)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.List.NonEmpty as NonEmpty
import Data.Sequence (Seq(..))
import qualified Language.GraphQL.AST as Full
import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Execute.Execution
import Language.GraphQL.Execute.Internal
import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
import qualified Language.GraphQL.Execute.Transform as Transform
import Language.GraphQL.Error
( Error(..)
, ResolverException
, Response
, ResponseEventStream
, runCollectErrs
)
import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type as Type
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema
subscribe :: (MonadCatch m, Serialize a)
=> HashMap Full.Name (Type m)
-> Out.ObjectType m
-> Full.Location
-> Seq (Transform.Selection m)
-> m (Either Error (ResponseEventStream m a))
subscribe types' objectType objectLocation fields = do
sourceStream <-
createSourceEventStream types' objectType objectLocation fields
let traverser =
mapSourceToResponseEvent types' objectType objectLocation fields
traverse traverser sourceStream
mapSourceToResponseEvent :: (MonadCatch m, Serialize a)
=> HashMap Full.Name (Type m)
-> Out.ObjectType m
-> Full.Location
-> Seq (Transform.Selection m)
-> Out.SourceEventStream m
-> m (ResponseEventStream m a)
mapSourceToResponseEvent types' subscriptionType objectLocation fields sourceStream
= pure
$ sourceStream
.| mapMC (executeSubscriptionEvent types' subscriptionType objectLocation fields)
createSourceEventStream :: MonadCatch m
=> HashMap Full.Name (Type m)
-> Out.ObjectType m
-> Full.Location
-> Seq (Transform.Selection m)
-> m (Either Error (Out.SourceEventStream m))
createSourceEventStream _types subscriptionType objectLocation fields
| [fieldGroup] <- OrderedMap.elems groupedFieldSet
, Transform.Field _ fieldName arguments' _ errorLocation <- NonEmpty.head fieldGroup
, Out.ObjectType _ _ _ fieldTypes <- subscriptionType
, resolverT <- fieldTypes HashMap.! fieldName
, Out.EventStreamResolver fieldDefinition _ resolver <- resolverT
, Out.Field _ _fieldType argumentDefinitions <- fieldDefinition =
case coerceArgumentValues argumentDefinitions arguments' of
Left _ -> pure
$ Left
$ Error "Argument coercion failed." [errorLocation] []
Right argumentValues -> left (singleError [errorLocation])
<$> resolveFieldEventStream Type.Null argumentValues resolver
| otherwise = pure
$ Left
$ Error "Subscription contains more than one field." [objectLocation] []
where
groupedFieldSet = collectFields subscriptionType fields
resolveFieldEventStream :: MonadCatch m
=> Type.Value
-> Type.Subs
-> Out.Subscribe m
-> m (Either String (Out.SourceEventStream m))
resolveFieldEventStream result args resolver =
catch (Right <$> runReaderT resolver context) handleEventStreamError
where
handleEventStreamError :: MonadCatch m
=> ResolverException
-> m (Either String (Out.SourceEventStream m))
handleEventStreamError = pure . Left . displayException
context = Type.Context
{ Type.arguments = Type.Arguments args
, Type.values = result
}
executeSubscriptionEvent :: (MonadCatch m, Serialize a)
=> HashMap Full.Name (Type m)
-> Out.ObjectType m
-> Full.Location
-> Seq (Transform.Selection m)
-> Definition.Value
-> m (Response a)
executeSubscriptionEvent types' objectType objectLocation fields initialValue
= runCollectErrs types'
$ executeSelectionSet initialValue objectType objectLocation fields

View File

@ -6,7 +6,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NamedFieldPuns #-}
-- | After the document is parsed, before getting executed, the AST is
-- transformed into a similar, simpler AST. Performed transformations include:
@ -21,65 +21,84 @@
-- This module is also responsible for smaller rewrites that touch only parts of
-- the original AST.
module Language.GraphQL.Execute.Transform
( Document(..)
, Field(..)
( Field(..)
, Fragment(..)
, Input(..)
, Operation(..)
, QueryError(..)
, Replacement(..)
, Selection(..)
, TransformT(..)
, document
, transform
) 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 Control.Monad (foldM)
import Control.Monad.Catch (MonadCatch(..), MonadThrow(..))
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Reader (ReaderT(..), local)
import qualified Control.Monad.Trans.Reader as Reader
import Data.Bifunctor (first)
import Data.Functor ((<&>))
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.Maybe (fromMaybe)
import Data.List.NonEmpty (NonEmpty(..))
import Data.List (intercalate)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Sequence (Seq, (<|), (><))
import Data.Maybe (fromMaybe, isJust)
import Data.Sequence (Seq, (><))
import qualified Data.Sequence as 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.AST.Document as Full
import Language.GraphQL.Type.Schema (Type)
import qualified Language.GraphQL.Type as Type
import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type.Internal as Type
import qualified Language.GraphQL.Type.Out as Out
import qualified Language.GraphQL.Type.Schema as Schema
import Numeric (showFloat)
-- | 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)
{ variableValues :: Type.Subs
, fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
, visitedFragments :: HashSet Full.Name
, types :: HashMap Full.Name (Type m)
}
type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition
newtype TransformT m a = TransformT
{ runTransformT :: ReaderT (Replacement m) m a
}
-- | Represents fragments and inline fragments.
data Fragment m
= Fragment (Type.CompositeType m) (Seq (Selection m))
instance Functor m => Functor (TransformT m) where
fmap f = TransformT . fmap f . runTransformT
-- | Single selection element.
data Selection m
= SelectionFragment (Fragment m)
| SelectionField (Field m)
instance Applicative m => Applicative (TransformT m) where
pure = TransformT . pure
TransformT f <*> TransformT x = TransformT $ f <*> x
instance Monad m => Monad (TransformT m) where
TransformT x >>= f = TransformT $ x >>= runTransformT . f
instance MonadTrans TransformT where
lift = TransformT . lift
instance MonadThrow m => MonadThrow (TransformT m) where
throwM = lift . throwM
instance MonadCatch m => MonadCatch (TransformT m) where
catch (TransformT stack) handler =
TransformT $ catch stack $ runTransformT . handler
asks :: Monad m => forall a. (Replacement m -> a) -> TransformT m a
asks = TransformT . Reader.asks
-- | 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
= Operation Full.OperationType (Seq (Selection m)) Full.Location
data Selection m
= FieldSelection (Field m)
| FragmentSelection (Fragment m)
-- | Single GraphQL field.
data Field m = Field
(Maybe Full.Name)
Full.Name
@ -87,339 +106,214 @@ data Field m = Field
(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 Fragment m = Fragment
(Type.CompositeType m) (Seq (Selection m)) Full.Location
data Input
= Int Int32
= Variable Type.Value
| Int Int32
| Float Double
| String Text
| Boolean Bool
| Null
| Enum Name
| List [Type.Value]
| Object (HashMap Name Input)
| Variable Type.Value
deriving (Eq, Show)
| Enum Full.Name
| List [Input]
| Object (HashMap Full.Name Input)
deriving Eq
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
instance Show Input where
showList = mappend . showList'
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
showList' list = "[" ++ intercalate ", " (show <$> list) ++ "]"
show (Int integer) = show integer
show (Float float') = showFloat float' mempty
show (String text) = "\"" <> Text.foldr (mappend . Full.escape) "\"" text
show (Boolean boolean') = show boolean'
show Null = "null"
show (Enum name) = Text.unpack name
show (List list) = show list
show (Object fields) = unwords
[ "{"
, intercalate ", " (HashMap.foldrWithKey showObject [] fields)
, "}"
]
where
forEach variableDefinition coercedValues = do
let Full.VariableDefinition variableName variableTypeName defaultValue _ =
variableDefinition
let defaultValue' = constValue . Full.node <$> defaultValue
variableType <- Type.lookupInputType variableTypeName types
showObject key value accumulator =
concat [Text.unpack key, ": ", show value] : accumulator
show variableValue = show variableValue
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
document :: Full.Document
-> ([Full.OperationDefinition], HashMap Full.Name Full.FragmentDefinition)
document = foldr filterOperation ([], HashMap.empty)
where
constObjectField Full.ObjectField{value = value', ..} =
(name, constValue $ Full.node value')
filterOperation (Full.ExecutableDefinition executableDefinition) accumulator
| Full.DefinitionOperation operationDefinition' <- executableDefinition =
first (operationDefinition' :) accumulator
| Full.DefinitionFragment fragmentDefinition <- executableDefinition
, Full.FragmentDefinition fragmentName _ _ _ _ <- fragmentDefinition =
HashMap.insert fragmentName fragmentDefinition <$> accumulator
filterOperation _ accumulator = accumulator -- Type system definitions.
-- | 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
transform :: Monad m => Full.OperationDefinition -> TransformT m (Operation m)
transform (Full.OperationDefinition operationType _ _ _ selectionSet' operationLocation) = do
transformedSelections <- selectionSet selectionSet'
pure $ Operation operationType transformedSelections operationLocation
transform (Full.SelectionSet selectionSet' operationLocation) = do
transformedSelections <- selectionSet selectionSet'
pure $ Operation Full.Query transformedSelections operationLocation
selectionSet :: Monad m => Full.SelectionSet -> TransformT m (Seq (Selection m))
selectionSet = selectionSetOpt . NonEmpty.toList
selectionSetOpt :: Monad m => Full.SelectionSetOpt -> TransformT m (Seq (Selection m))
selectionSetOpt = foldM go Seq.empty
where
go accumulatedSelections currentSelection =
selection currentSelection <&> (accumulatedSelections ><)
selection :: Monad m => Full.Selection -> TransformT m (Seq (Selection m))
selection (Full.FieldSelection field') =
maybeToSelectionSet FieldSelection $ field field'
selection (Full.FragmentSpreadSelection fragmentSpread') =
maybeToSelectionSet FragmentSelection $ fragmentSpread fragmentSpread'
selection (Full.InlineFragmentSelection inlineFragment') =
either id (pure . FragmentSelection) <$> inlineFragment inlineFragment'
maybeToSelectionSet :: Monad m
=> forall a
. (a -> Selection m)
-> TransformT m (Maybe a)
-> TransformT m (Seq (Selection m))
maybeToSelectionSet selectionType = fmap (maybe Seq.empty $ pure . selectionType)
directives :: Monad m => [Full.Directive] -> TransformT m (Maybe [Definition.Directive])
directives = fmap Type.selection . traverse directive
inlineFragment :: Monad m
=> Full.InlineFragment
-> TransformT m (Either (Seq (Selection m)) (Fragment m))
inlineFragment (Full.InlineFragment maybeCondition directives' selectionSet' location)
| Just typeCondition <- maybeCondition = do
transformedSelections <- selectionSet selectionSet'
transformedDirectives <- directives directives'
maybeFragmentType <- asks
$ Type.lookupTypeCondition typeCondition
. types
pure $ case transformedDirectives >> maybeFragmentType of
Just fragmentType -> Right
$ Fragment fragmentType transformedSelections location
Nothing -> Left Seq.empty
| otherwise = do
transformedSelections <- selectionSet selectionSet'
transformedDirectives <- directives directives'
pure $ if isJust transformedDirectives
then Left transformedSelections
else Left Seq.empty
fragmentSpread :: Monad m => Full.FragmentSpread -> TransformT m (Maybe (Fragment m))
fragmentSpread (Full.FragmentSpread spreadName directives' location) = do
transformedDirectives <- directives directives'
visitedFragment <- asks $ HashSet.member spreadName . visitedFragments
possibleFragmentDefinition <- asks
$ HashMap.lookup spreadName
. fragmentDefinitions
case transformedDirectives >> possibleFragmentDefinition of
Just (Full.FragmentDefinition _ typeCondition _ selections _)
| visitedFragment -> pure Nothing
| otherwise -> do
fragmentType <- asks
$ Type.lookupTypeCondition typeCondition
. types
traverse (traverseSelections selections) fragmentType
Nothing -> pure Nothing
where
traverseSelections selections typeCondition = do
transformedSelections <- TransformT
$ local fragmentInserter
$ runTransformT
$ selectionSet selections
pure $ Fragment typeCondition transformedSelections location
fragmentInserter replacement@Replacement{ visitedFragments } = replacement
{ visitedFragments = HashSet.insert spreadName visitedFragments }
field :: Monad m => Full.Field -> TransformT m (Maybe (Field m))
field (Full.Field alias' name' arguments' directives' selectionSet' location') = do
transformedSelections <- selectionSetOpt selectionSet'
transformedDirectives <- directives directives'
transformedArguments <- arguments arguments'
let transformedField = Field
alias'
name'
transformedArguments
transformedSelections
location'
pure $ transformedDirectives >> pure transformedField
arguments :: Monad m => [Full.Argument] -> TransformT m (HashMap Full.Name (Full.Node Input))
arguments = foldM go HashMap.empty
where
go accumulator (Full.Argument name' valueNode argumentLocation) = do
let replaceLocation = flip Full.Node argumentLocation . Full.node
argumentValue <- fmap replaceLocation <$> node valueNode
pure $ insertIfGiven name' argumentValue accumulator
directive :: Monad m => Full.Directive -> TransformT m Definition.Directive
directive (Full.Directive name' arguments' _)
= Definition.Directive name'
. Type.Arguments
<$> foldM go HashMap.empty arguments'
where
go accumulator (Full.Argument argumentName Full.Node{ node = node' } _) = do
transformedValue <- directiveValue node'
pure $ HashMap.insert argumentName transformedValue accumulator
directiveValue :: Monad m => Full.Value -> TransformT m Type.Value
directiveValue = \case
(Full.Variable name') -> asks
$ HashMap.lookupDefault Type.Null name'
. variableValues
(Full.Int integer) -> pure $ Type.Int integer
(Full.Float double) -> pure $ Type.Float double
(Full.String string) -> pure $ Type.String string
(Full.Boolean boolean) -> pure $ Type.Boolean boolean
Full.Null -> pure Type.Null
(Full.Enum enum) -> pure $ Type.Enum enum
(Full.List list) -> Type.List <$> traverse directiveNode list
(Full.Object objectFields) ->
Type.Object <$> foldM objectField HashMap.empty objectFields
where
directiveNode Full.Node{ node = node'} = directiveValue node'
objectField accumulator Full.ObjectField{ name, value } = do
transformedValue <- directiveNode value
pure $ HashMap.insert name transformedValue accumulator
input :: Monad m => Full.Value -> TransformT m (Maybe Input)
input (Full.Variable name') =
asks (HashMap.lookup name' . variableValues) <&> fmap Variable
input (Full.Int integer) = pure $ Just $ Int integer
input (Full.Float double) = pure $ Just $ Float double
input (Full.String string) = pure $ Just $ String string
input (Full.Boolean boolean) = pure $ Just $ Boolean boolean
input Full.Null = pure $ Just Null
input (Full.Enum enum) = pure $ Just $ Enum enum
input (Full.List list) = Just . List
<$> traverse (fmap (fromMaybe Null) . input . Full.node) list
input (Full.Object objectFields) = Just . Object
<$> foldM objectField HashMap.empty objectFields
where
objectField accumulator Full.ObjectField{..} = do
objectFieldValue <- fmap Full.node <$> node value
pure $ insertIfGiven name objectFieldValue accumulator
insertIfGiven :: forall a
. Full.Name
-> Maybe a
-> HashMap Full.Name a
-> Full.Document
-> Either QueryError (Document m)
document schema operationName subs ast = do
let referencedTypes = Schema.types schema
-> HashMap Full.Name a
insertIfGiven name (Just v) = HashMap.insert name v
insertIfGiven _ _ = id
(operations, fragmentTable) <- defragment ast
chosenOperation <- getOperation operationName operations
coercedValues <- coerceVariableValues referencedTypes chosenOperation subs
node :: Monad m => Full.Node Full.Value -> TransformT m (Maybe (Full.Node Input))
node Full.Node{node = node', ..} =
traverse Full.Node <$> input node' <*> pure location
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

View File

@ -1,847 +0,0 @@
{- 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 ExistentialQuantification #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Language.GraphQL.Executor
( Error(..)
, Operation(..)
, Path(..)
, ResponseEventStream
, Response(..)
, execute
) where
import Conduit (ConduitT, mapMC, (.|))
import Control.Arrow (left)
import Control.Monad.Catch
( Exception(..)
, MonadCatch(..)
, MonadThrow(..)
, SomeException(..)
)
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Reader (ReaderT(..), ask, local, runReaderT)
import Control.Monad.Trans.Writer (WriterT(..), runWriterT, tell)
import qualified Control.Monad.Trans.Reader as Reader
import Control.Monad (foldM)
import qualified Language.GraphQL.AST.Document as Full
import Data.Bifunctor (first)
import Data.Foldable (find)
import Data.Functor ((<&>))
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
import Data.Maybe (fromMaybe, isJust)
import Data.Sequence (Seq, (><))
import qualified Data.Sequence as Seq
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Typeable (cast)
import qualified Language.GraphQL.Execute.Coerce as Coerce
import Language.GraphQL.Execute.OrderedMap (OrderedMap)
import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
import qualified Language.GraphQL.Type as Type
import qualified Language.GraphQL.Type.Internal as Type.Internal
import Language.GraphQL.Type.Schema (Schema, Type)
import qualified Language.GraphQL.Type.Schema as Schema
import Language.GraphQL.Error (Error(..), Response(..), Path(..))
data Replacement m = Replacement
{ variableValues :: Type.Subs
, fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
, visitedFragments :: HashSet Full.Name
, types :: HashMap Full.Name (Type m)
}
newtype TransformT m a = TransformT
{ runTransformT :: ReaderT (Replacement m) m a
}
instance Functor m => Functor (TransformT m) where
fmap f = TransformT . fmap f . runTransformT
instance Applicative m => Applicative (TransformT m) where
pure = TransformT . pure
TransformT f <*> TransformT x = TransformT $ f <*> x
instance Monad m => Monad (TransformT m) where
TransformT x >>= f = TransformT $ x >>= runTransformT . f
instance MonadTrans TransformT where
lift = TransformT . lift
instance MonadThrow m => MonadThrow (TransformT m) where
throwM = lift . throwM
instance MonadCatch m => MonadCatch (TransformT m) where
catch (TransformT stack) handler =
TransformT $ catch stack $ runTransformT . handler
newtype ExecutorT m a = ExecutorT
{ runExecutorT :: ReaderT (HashMap Full.Name (Type m)) (WriterT (Seq Error) m) a
}
instance Functor m => Functor (ExecutorT m) where
fmap f = ExecutorT . fmap f . runExecutorT
instance Applicative m => Applicative (ExecutorT m) where
pure = ExecutorT . pure
ExecutorT f <*> ExecutorT x = ExecutorT $ f <*> x
instance Monad m => Monad (ExecutorT m) where
ExecutorT x >>= f = ExecutorT $ x >>= runExecutorT . f
instance MonadTrans ExecutorT where
lift = ExecutorT . lift . lift
instance MonadThrow m => MonadThrow (ExecutorT m) where
throwM = lift . throwM
instance MonadCatch m => MonadCatch (ExecutorT m) where
catch (ExecutorT stack) handler =
ExecutorT $ catch stack $ runExecutorT . handler
data GraphQLException = forall e. Exception e => GraphQLException e
instance Show GraphQLException where
show (GraphQLException e) = show e
instance Exception GraphQLException
graphQLExceptionToException :: Exception e => e -> SomeException
graphQLExceptionToException = toException . GraphQLException
graphQLExceptionFromException :: Exception e => SomeException -> Maybe e
graphQLExceptionFromException e = do
GraphQLException graphqlException <- fromException e
cast graphqlException
data ResolverException = forall e. Exception e => ResolverException e
instance Show ResolverException where
show (ResolverException e) = show e
instance Exception ResolverException where
toException = graphQLExceptionToException
fromException = graphQLExceptionFromException
data FieldError
= ArgumentTypeError
| MissingArgumentError
| EnumCompletionError
| InterfaceCompletionError
| UnionCompletionError
| ValueCompletionError
| ResultCoercionError
| NullResultError
instance Show FieldError where
show ArgumentTypeError = "Invalid argument type."
show MissingArgumentError = "Required argument not specified."
show EnumCompletionError = "Enum value completion failed."
show InterfaceCompletionError = "Interface value completion failed."
show UnionCompletionError = "Union value completion failed."
show ValueCompletionError = "Value completion failed."
show ResultCoercionError = "Result coercion failed."
show NullResultError = "Non-Nullable field resolver returned Null."
newtype FieldException = FieldException FieldError
deriving Show
instance Exception FieldException where
toException = graphQLExceptionToException
fromException = graphQLExceptionFromException
data QueryError
= OperationNameRequired
| OperationNotFound String
| CoercionError Full.VariableDefinition
| UnknownInputType Full.VariableDefinition
asks :: Monad m => forall a. (Replacement m -> a) -> TransformT m a
asks = TransformT . Reader.asks
queryError :: QueryError -> Error
queryError OperationNameRequired =
Error{ message = "Operation name is required.", locations = [], path = [] }
queryError (OperationNotFound operationName) =
let queryErrorMessage = Text.concat
[ "Operation \""
, Text.pack operationName
, "\" not found."
]
in Error{ message = queryErrorMessage, locations = [], path = [] }
queryError (CoercionError variableDefinition) =
let Full.VariableDefinition variableName _ _ location = variableDefinition
queryErrorMessage = Text.concat
[ "Failed to coerce the variable \""
, variableName
, "\"."
]
in Error{ message = queryErrorMessage, locations = [location], path = [] }
queryError (UnknownInputType variableDefinition) =
let Full.VariableDefinition variableName variableTypeName _ location = variableDefinition
queryErrorMessage = Text.concat
[ "Variable \""
, variableName
, "\" has unknown type \""
, Text.pack $ show variableTypeName
, "\"."
]
in Error{ message = queryErrorMessage, locations = [location], path = [] }
data Operation m
= Operation Full.OperationType (Seq (Selection m)) Full.Location
data Selection m
= FieldSelection (Field m)
| FragmentSelection (Fragment m)
data Field m = Field
(Maybe Full.Name)
Full.Name
(HashMap Full.Name (Full.Node Input))
(Seq (Selection m))
Full.Location
data Fragment m = Fragment
(Type.Internal.CompositeType m) (Seq (Selection m)) Full.Location
data Input
= Variable Type.Value
| Int Int32
| Float Double
| String Text
| Boolean Bool
| Null
| Enum Full.Name
| List [Input]
| Object (HashMap Full.Name Input)
document :: Full.Document
-> ([Full.OperationDefinition], HashMap Full.Name Full.FragmentDefinition)
document = foldr filterOperation ([], HashMap.empty)
where
filterOperation (Full.ExecutableDefinition executableDefinition) accumulator
| Full.DefinitionOperation operationDefinition' <- executableDefinition =
first (operationDefinition' :) accumulator
| Full.DefinitionFragment fragmentDefinition <- executableDefinition
, Full.FragmentDefinition fragmentName _ _ _ _ <- fragmentDefinition =
HashMap.insert fragmentName fragmentDefinition <$> accumulator
filterOperation _ accumulator = accumulator -- Type system definitions.
transform :: Monad m => Full.OperationDefinition -> TransformT m (Operation m)
transform (Full.OperationDefinition operationType _ _ _ selectionSet' operationLocation) = do
transformedSelections <- selectionSet selectionSet'
pure $ Operation operationType transformedSelections operationLocation
transform (Full.SelectionSet selectionSet' operationLocation) = do
transformedSelections <- selectionSet selectionSet'
pure $ Operation Full.Query transformedSelections operationLocation
selectionSet :: Monad m => Full.SelectionSet -> TransformT m (Seq (Selection m))
selectionSet = selectionSetOpt . NonEmpty.toList
selectionSetOpt :: Monad m => Full.SelectionSetOpt -> TransformT m (Seq (Selection m))
selectionSetOpt = foldM go Seq.empty
where
go accumulatedSelections currentSelection =
selection currentSelection <&> (accumulatedSelections ><)
selection :: Monad m => Full.Selection -> TransformT m (Seq (Selection m))
selection (Full.FieldSelection field') =
maybeToSelectionSet FieldSelection $ field field'
selection (Full.FragmentSpreadSelection fragmentSpread') =
maybeToSelectionSet FragmentSelection $ fragmentSpread fragmentSpread'
selection (Full.InlineFragmentSelection inlineFragment') =
either id (pure . FragmentSelection) <$> inlineFragment inlineFragment'
maybeToSelectionSet :: Monad m
=> forall a
. (a -> Selection m)
-> TransformT m (Maybe a)
-> TransformT m (Seq (Selection m))
maybeToSelectionSet selectionType = fmap (maybe Seq.empty $ pure . selectionType)
directives :: Monad m => [Full.Directive] -> TransformT m (Maybe [Type.Directive])
directives = fmap Type.selection . traverse directive
inlineFragment :: Monad m
=> Full.InlineFragment
-> TransformT m (Either (Seq (Selection m)) (Fragment m))
inlineFragment (Full.InlineFragment maybeCondition directives' selectionSet' location)
| Just typeCondition <- maybeCondition = do
transformedSelections <- selectionSet selectionSet'
transformedDirectives <- directives directives'
maybeFragmentType <- asks
$ Type.Internal.lookupTypeCondition typeCondition
. types
pure $ case transformedDirectives >> maybeFragmentType of
Just fragmentType -> Right
$ Fragment fragmentType transformedSelections location
Nothing -> Left Seq.empty
| otherwise = do
transformedSelections <- selectionSet selectionSet'
transformedDirectives <- directives directives'
pure $ if isJust transformedDirectives
then Left transformedSelections
else Left Seq.empty
fragmentSpread :: Monad m => Full.FragmentSpread -> TransformT m (Maybe (Fragment m))
fragmentSpread (Full.FragmentSpread spreadName directives' location) = do
transformedDirectives <- directives directives'
visitedFragment <- asks $ HashSet.member spreadName . visitedFragments
possibleFragmentDefinition <- asks
$ HashMap.lookup spreadName
. fragmentDefinitions
case transformedDirectives >> possibleFragmentDefinition of
Just (Full.FragmentDefinition _ typeCondition _ selections _)
| visitedFragment -> pure Nothing
| otherwise -> do
fragmentType <- asks
$ Type.Internal.lookupTypeCondition typeCondition
. types
traverse (traverseSelections selections) fragmentType
Nothing -> pure Nothing
where
traverseSelections selections typeCondition = do
transformedSelections <- TransformT
$ local fragmentInserter
$ runTransformT
$ selectionSet selections
pure $ Fragment typeCondition transformedSelections location
fragmentInserter replacement@Replacement{ visitedFragments } = replacement
{ visitedFragments = HashSet.insert spreadName visitedFragments }
field :: Monad m => Full.Field -> TransformT m (Maybe (Field m))
field (Full.Field alias' name' arguments' directives' selectionSet' location') = do
transformedSelections <- selectionSetOpt selectionSet'
transformedDirectives <- directives directives'
transformedArguments <- arguments arguments'
let transformedField = Field
alias'
name'
transformedArguments
transformedSelections
location'
pure $ transformedDirectives >> pure transformedField
arguments :: Monad m => [Full.Argument] -> TransformT m (HashMap Full.Name (Full.Node Input))
arguments = foldM go HashMap.empty
where
go accumulator (Full.Argument name' valueNode _) = do
argumentValue <- node valueNode
pure $ insertIfGiven name' argumentValue accumulator
directive :: Monad m => Full.Directive -> TransformT m Type.Directive
directive (Full.Directive name' arguments' _)
= Type.Directive name'
. Type.Arguments
<$> foldM go HashMap.empty arguments'
where
go accumulator (Full.Argument argumentName Full.Node{ node = node' } _) = do
transformedValue <- directiveValue node'
pure $ HashMap.insert argumentName transformedValue accumulator
directiveValue :: Monad m => Full.Value -> TransformT m Type.Value
directiveValue = \case
(Full.Variable name') -> asks
$ HashMap.lookupDefault Type.Null name'
. variableValues
(Full.Int integer) -> pure $ Type.Int integer
(Full.Float double) -> pure $ Type.Float double
(Full.String string) -> pure $ Type.String string
(Full.Boolean boolean) -> pure $ Type.Boolean boolean
Full.Null -> pure Type.Null
(Full.Enum enum) -> pure $ Type.Enum enum
(Full.List list) -> Type.List <$> traverse directiveNode list
(Full.Object objectFields) ->
Type.Object <$> foldM objectField HashMap.empty objectFields
where
directiveNode Full.Node{ node = node'} = directiveValue node'
objectField accumulator Full.ObjectField{ name, value } = do
transformedValue <- directiveNode value
pure $ HashMap.insert name transformedValue accumulator
input :: Monad m => Full.Value -> TransformT m (Maybe Input)
input (Full.Variable name') =
asks (HashMap.lookup name' . variableValues) <&> fmap Variable
input (Full.Int integer) = pure $ Just $ Int integer
input (Full.Float double) = pure $ Just $ Float double
input (Full.String string) = pure $ Just $ String string
input (Full.Boolean boolean) = pure $ Just $ Boolean boolean
input Full.Null = pure $ Just Null
input (Full.Enum enum) = pure $ Just $ Enum enum
input (Full.List list) = Just . List
<$> traverse (fmap (fromMaybe Null) . input . Full.node) list
input (Full.Object objectFields) = Just . Object
<$> foldM objectField HashMap.empty objectFields
where
objectField accumulator Full.ObjectField{..} = do
objectFieldValue <- fmap Full.node <$> node value
pure $ insertIfGiven name objectFieldValue accumulator
insertIfGiven :: forall a
. Full.Name
-> Maybe a
-> HashMap Full.Name a
-> HashMap Full.Name a
insertIfGiven name (Just v) = HashMap.insert name v
insertIfGiven _ _ = id
node :: Monad m => Full.Node Full.Value -> TransformT m (Maybe (Full.Node Input))
node Full.Node{node = node', ..} =
traverse Full.Node <$> input node' <*> pure location
execute :: (MonadCatch m, Coerce.VariableValue a, Coerce.Serialize b)
=> Schema m -- ^ Resolvers.
-> Maybe Text -- ^ Operation name.
-> HashMap Full.Name a -- ^ Variable substitution function.
-> Full.Document -- @GraphQL@ document.
-> m (Either (ResponseEventStream m b) (Response b))
execute schema' operationName subs document' =
executeRequest schema' document' (Text.unpack <$> operationName) subs
executeRequest :: (MonadCatch m, Coerce.Serialize a, Coerce.VariableValue b)
=> Schema m
-> Full.Document
-> Maybe String
-> HashMap Full.Name b
-> m (Either (ResponseEventStream m a) (Response a))
executeRequest schema sourceDocument operationName variableValues = do
operationAndVariables <- sequence buildOperation
case operationAndVariables of
Left queryError' -> pure
$ Right
$ Response Coerce.null $ pure $ queryError queryError'
Right operation
| Operation Full.Query topSelections _operationLocation <- operation ->
Right <$> executeQuery topSelections schema
| Operation Full.Mutation topSelections operationLocation <- operation ->
Right <$> executeMutation topSelections schema operationLocation
| Operation Full.Subscription topSelections operationLocation <- operation ->
either rightErrorResponse Left <$> subscribe topSelections schema operationLocation
where
schemaTypes = Schema.types schema
(operationDefinitions, fragmentDefinitions') = document sourceDocument
buildOperation = do
operationDefinition <- getOperation operationDefinitions operationName
coercedVariableValues <- coerceVariableValues
schemaTypes
operationDefinition
variableValues
let replacement = Replacement
{ variableValues = coercedVariableValues
, fragmentDefinitions = fragmentDefinitions'
, visitedFragments = mempty
, types = schemaTypes
}
pure $ flip runReaderT replacement
$ runTransformT
$ transform operationDefinition
rightErrorResponse :: Coerce.Serialize b => forall a. Error -> Either a (Response b)
rightErrorResponse = Right . Response Coerce.null . pure
getOperation :: [Full.OperationDefinition] -> Maybe String -> Either QueryError Full.OperationDefinition
getOperation [operation] Nothing = Right operation
getOperation operations (Just givenOperationName)
= maybe (Left $ OperationNotFound givenOperationName) Right
$ find findOperationByName operations
where
findOperationByName (Full.OperationDefinition _ (Just operationName) _ _ _ _) =
givenOperationName == Text.unpack operationName
findOperationByName _ = False
getOperation _ _ = Left OperationNameRequired
executeQuery :: (MonadCatch m, Coerce.Serialize a)
=> Seq (Selection m)
-> Schema m
-> m (Response a)
executeQuery topSelections schema = do
let queryType = Schema.query schema
(data', errors) <- runWriterT
$ flip runReaderT (Schema.types schema)
$ runExecutorT
$ executeSelectionSet topSelections queryType Type.Null []
pure $ Response data' errors
executeMutation :: (MonadCatch m, Coerce.Serialize a)
=> Seq (Selection m)
-> Schema m
-> Full.Location
-> m (Response a)
executeMutation topSelections schema operationLocation
| Just mutationType <- Schema.mutation schema = do
(data', errors) <- runWriterT
$ flip runReaderT (Schema.types schema)
$ runExecutorT
$ executeSelectionSet topSelections mutationType Type.Null []
pure $ Response data' errors
| otherwise = pure
$ Response Coerce.null
$ Seq.singleton
$ Error "Schema doesn't support mutations." [operationLocation] []
executeSelectionSet :: (MonadCatch m, Coerce.Serialize a)
=> Seq (Selection m)
-> Out.ObjectType m
-> Type.Value
-> [Path]
-> ExecutorT m a
executeSelectionSet selections objectType objectValue errorPath = do
let groupedFieldSet = collectFields objectType selections
resolvedValues <- OrderedMap.traverseMaybe go groupedFieldSet
coerceResult (Out.NonNullObjectType objectType) $ Coerce.Object resolvedValues
where
executeField' fields resolver =
executeField objectValue fields resolver errorPath
Out.ObjectType _ _ _ resolvers = objectType
go fields@(Field _ fieldName _ _ _ :| _) =
traverse (executeField' fields) $ HashMap.lookup fieldName resolvers
fieldsSegment :: forall m. NonEmpty (Field m) -> Path
fieldsSegment (Field alias fieldName _ _ _ :| _) =
Segment (fromMaybe fieldName alias)
executeField :: (MonadCatch m, Coerce.Serialize a)
=> Type.Value
-> NonEmpty (Field m)
-> Out.Resolver m
-> [Path]
-> ExecutorT m a
executeField objectValue fields resolver errorPath =
let Field _ fieldName inputArguments _ fieldLocation :| _ = fields
in catch (go fieldName inputArguments) $ exceptionHandler fieldLocation
where
exceptionHandler :: (MonadCatch m, Coerce.Serialize a)
=> Full.Location
-> GraphQLException
-> ExecutorT m a
exceptionHandler fieldLocation e =
let newError = Error (Text.pack $ displayException e) [fieldLocation] errorPath
in ExecutorT (lift $ tell $ Seq.singleton newError) >> pure Coerce.null
go fieldName inputArguments = do
let (Out.Field _ fieldType argumentTypes, resolveFunction) =
resolverField resolver
argumentValues <- coerceArgumentValues argumentTypes inputArguments
resolvedValue <-
resolveFieldValue resolveFunction objectValue fieldName argumentValues
completeValue fieldType fields errorPath resolvedValue
resolverField (Out.ValueResolver resolverField' resolveFunction) =
(resolverField', resolveFunction)
resolverField (Out.EventStreamResolver resolverField' resolveFunction _) =
(resolverField', resolveFunction)
resolveFieldValue :: MonadCatch m
=> Out.Resolve m
-> Type.Value
-> Full.Name
-> Type.Subs
-> ExecutorT m Type.Value
resolveFieldValue resolver objectValue _fieldName argumentValues =
lift $ runReaderT resolver context
where
context = Type.Context
{ Type.arguments = Type.Arguments argumentValues
, Type.values = objectValue
}
resolveAbstractType :: Monad m
=> Type.Internal.AbstractType m
-> Type.Subs
-> ExecutorT m (Maybe (Out.ObjectType m))
resolveAbstractType abstractType values'
| Just (Type.String typeName) <- HashMap.lookup "__typename" values' = do
types' <- ExecutorT ask
case HashMap.lookup typeName types' of
Just (Type.Internal.ObjectType objectType) ->
if Type.Internal.instanceOf objectType abstractType
then pure $ Just objectType
else pure Nothing
_ -> pure Nothing
| otherwise = pure Nothing
completeValue :: (MonadCatch m, Coerce.Serialize a)
=> Out.Type m
-> NonEmpty (Field m)
-> [Path]
-> Type.Value
-> ExecutorT m a
completeValue outputType _ _ Type.Null
| Out.isNonNullType outputType = throwFieldError NullResultError
| otherwise = pure Coerce.null
completeValue outputType@(Out.ListBaseType listType) fields errorPath (Type.List list)
= foldM go (0, []) list >>= coerceResult outputType . Coerce.List . snd
where
go (index, accumulator) listItem = do
let updatedPath = Index index : errorPath
completedValue <- completeValue listType fields updatedPath listItem
pure (index + 1, completedValue : accumulator)
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Int int) =
coerceResult outputType $ Coerce.Int int
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Boolean boolean) =
coerceResult outputType $ Coerce.Boolean boolean
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Float float) =
coerceResult outputType $ Coerce.Float float
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.String string) =
coerceResult outputType $ Coerce.String string
completeValue outputType@(Out.EnumBaseType enumType) _ _ (Type.Enum enum) =
let Type.EnumType _ _ enumMembers = enumType
in if HashMap.member enum enumMembers
then coerceResult outputType $ Coerce.Enum enum
else throwFieldError EnumCompletionError
completeValue (Out.ObjectBaseType objectType) fields errorPath result
= executeSelectionSet (mergeSelectionSets fields) objectType result
$ fieldsSegment fields : errorPath
completeValue (Out.InterfaceBaseType interfaceType) fields errorPath result
| Type.Object objectMap <- result = do
let abstractType = Type.Internal.AbstractInterfaceType interfaceType
concreteType <- resolveAbstractType abstractType objectMap
case concreteType of
Just objectType
-> executeSelectionSet (mergeSelectionSets fields) objectType result
$ fieldsSegment fields : errorPath
Nothing -> throwFieldError InterfaceCompletionError
completeValue (Out.UnionBaseType unionType) fields errorPath result
| Type.Object objectMap <- result = do
let abstractType = Type.Internal.AbstractUnionType unionType
concreteType <- resolveAbstractType abstractType objectMap
case concreteType of
Just objectType
-> executeSelectionSet (mergeSelectionSets fields) objectType result
$ fieldsSegment fields : errorPath
Nothing -> throwFieldError UnionCompletionError
completeValue _ _ _ _ = throwFieldError ValueCompletionError
coerceResult :: (MonadCatch m, Coerce.Serialize a)
=> Out.Type m
-> Coerce.Output a
-> ExecutorT m a
coerceResult outputType result
| Just serialized <- Coerce.serialize outputType result = pure serialized
| otherwise = throwFieldError ResultCoercionError
mergeSelectionSets :: MonadCatch m
=> NonEmpty (Field m)
-> Seq (Selection m)
mergeSelectionSets = foldr forEach mempty
where
forEach (Field _ _ _ fieldSelectionSet _) selectionSet' =
selectionSet' <> fieldSelectionSet
throwFieldError :: MonadCatch m => FieldError -> m a
throwFieldError = throwM . FieldException
coerceArgumentValues :: MonadCatch m
=> HashMap Full.Name In.Argument
-> HashMap Full.Name (Full.Node Input)
-> m Type.Subs
coerceArgumentValues argumentDefinitions argumentValues =
HashMap.foldrWithKey c pure argumentDefinitions mempty
where
c argumentName argumentType pure' resultMap =
forEach argumentName argumentType resultMap >>= pure'
forEach :: MonadCatch m
=> Full.Name
-> In.Argument
-> Type.Subs
-> m Type.Subs
forEach argumentName (In.Argument _ variableType defaultValue) resultMap = do
let matchedMap
= matchFieldValues' argumentName variableType defaultValue
$ Just resultMap
in case matchedMap of
Just matchedValues -> pure matchedValues
Nothing
| Just _ <- HashMap.lookup argumentName argumentValues ->
throwFieldError ArgumentTypeError
| otherwise -> throwFieldError MissingArgumentError
matchFieldValues' = Coerce.matchFieldValues coerceArgumentValue
$ Full.node <$> argumentValues
coerceArgumentValue inputType (Int integer) =
Coerce.coerceInputLiteral inputType (Type.Int integer)
coerceArgumentValue inputType (Boolean boolean) =
Coerce.coerceInputLiteral inputType (Type.Boolean boolean)
coerceArgumentValue inputType (String string) =
Coerce.coerceInputLiteral inputType (Type.String string)
coerceArgumentValue inputType (Float float) =
Coerce.coerceInputLiteral inputType (Type.Float float)
coerceArgumentValue inputType (Enum enum) =
Coerce.coerceInputLiteral inputType (Type.Enum enum)
coerceArgumentValue inputType Null
| In.isNonNullType inputType = Nothing
| otherwise = Coerce.coerceInputLiteral inputType Type.Null
coerceArgumentValue (In.ListBaseType inputType) (List list) =
let coerceItem = coerceArgumentValue inputType
in Type.List <$> traverse coerceItem list
coerceArgumentValue (In.InputObjectBaseType inputType) (Object object)
| In.InputObjectType _ _ inputFields <- inputType =
let go = forEachField object
resultMap = HashMap.foldrWithKey go (pure mempty) inputFields
in Type.Object <$> resultMap
coerceArgumentValue _ (Variable variable) = pure variable
coerceArgumentValue _ _ = Nothing
forEachField object variableName (In.InputField _ variableType defaultValue) =
Coerce.matchFieldValues coerceArgumentValue object variableName variableType defaultValue
collectFields :: Monad m
=> Out.ObjectType m
-> Seq (Selection m)
-> OrderedMap (NonEmpty (Field m))
collectFields objectType = foldl forEach OrderedMap.empty
where
forEach groupedFields (FieldSelection fieldSelection) =
let Field maybeAlias fieldName _ _ _ = fieldSelection
responseKey = fromMaybe fieldName maybeAlias
in OrderedMap.insert responseKey (fieldSelection :| []) groupedFields
forEach groupedFields (FragmentSelection selectionFragment)
| Fragment fragmentType fragmentSelectionSet _ <- selectionFragment
, Type.Internal.doesFragmentTypeApply fragmentType objectType =
let fragmentGroupedFieldSet =
collectFields objectType fragmentSelectionSet
in groupedFields <> fragmentGroupedFieldSet
| otherwise = groupedFields
coerceVariableValues :: (Monad m, Coerce.VariableValue b)
=> HashMap Full.Name (Schema.Type m)
-> Full.OperationDefinition
-> HashMap Full.Name b
-> Either QueryError Type.Subs
coerceVariableValues types operationDefinition' variableValues
| Full.OperationDefinition _ _ variableDefinitions _ _ _ <-
operationDefinition'
= foldr forEach (Right HashMap.empty) variableDefinitions
| otherwise = pure mempty
where
forEach variableDefinition (Right coercedValues) =
let Full.VariableDefinition variableName variableTypeName defaultValue _ =
variableDefinition
defaultValue' = constValue . Full.node <$> defaultValue
in case Type.Internal.lookupInputType variableTypeName types of
Just variableType ->
maybe (Left $ CoercionError variableDefinition) Right
$ Coerce.matchFieldValues
coerceVariableValue'
variableValues
variableName
variableType
defaultValue'
$ Just coercedValues
Nothing -> Left $ UnknownInputType variableDefinition
forEach _ coercedValuesOrError = coercedValuesOrError
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')
type ResponseEventStream m a = ConduitT () (Response a) m ()
subscribe :: (MonadCatch m, Coerce.Serialize a)
=> Seq (Selection m)
-> Schema m
-> Full.Location
-> m (Either Error (ResponseEventStream m a))
subscribe fields schema objectLocation
| Just objectType <- Schema.subscription schema = do
let types' = Schema.types schema
sourceStream <-
createSourceEventStream types' objectType objectLocation fields
let traverser =
mapSourceToResponseEvent types' objectType fields
traverse traverser sourceStream
| otherwise = pure $ Left
$ Error "Schema doesn't support subscriptions." [] []
mapSourceToResponseEvent :: (MonadCatch m, Coerce.Serialize a)
=> HashMap Full.Name (Type m)
-> Out.ObjectType m
-> Seq (Selection m)
-> Out.SourceEventStream m
-> m (ResponseEventStream m a)
mapSourceToResponseEvent types' subscriptionType fields sourceStream
= pure
$ sourceStream
.| mapMC (executeSubscriptionEvent types' subscriptionType fields)
createSourceEventStream :: MonadCatch m
=> HashMap Full.Name (Type m)
-> Out.ObjectType m
-> Full.Location
-> Seq (Selection m)
-> m (Either Error (Out.SourceEventStream m))
createSourceEventStream _types subscriptionType objectLocation fields
| [fieldGroup] <- OrderedMap.elems groupedFieldSet
, Field _ fieldName arguments' _ errorLocation <- NonEmpty.head fieldGroup
, Out.ObjectType _ _ _ fieldTypes <- subscriptionType
, resolverT <- fieldTypes HashMap.! fieldName
, Out.EventStreamResolver fieldDefinition _ resolver <- resolverT
, Out.Field _ _fieldType argumentDefinitions <- fieldDefinition =
case coerceArgumentValues argumentDefinitions arguments' of
Left _ -> pure
$ Left
$ Error "Argument coercion failed." [errorLocation] []
Right argumentValues -> left (singleError' [errorLocation])
<$> resolveFieldEventStream Type.Null argumentValues resolver
| otherwise = pure
$ Left
$ Error "Subscription contains more than one field." [objectLocation] []
where
groupedFieldSet = collectFields subscriptionType fields
singleError' :: [Full.Location] -> String -> Error
singleError' errorLocations message = Error (Text.pack message) errorLocations []
resolveFieldEventStream :: MonadCatch m
=> Type.Value
-> Type.Subs
-> Out.Subscribe m
-> m (Either String (Out.SourceEventStream m))
resolveFieldEventStream result args resolver =
catch (Right <$> runReaderT resolver context) handleEventStreamError
where
handleEventStreamError :: MonadCatch m
=> ResolverException
-> m (Either String (Out.SourceEventStream m))
handleEventStreamError = pure . Left . displayException
context = Type.Context
{ Type.arguments = Type.Arguments args
, Type.values = result
}
executeSubscriptionEvent :: (MonadCatch m, Coerce.Serialize a)
=> HashMap Full.Name (Type m)
-> Out.ObjectType m
-> Seq (Selection m)
-> Type.Value
-> m (Response a)
executeSubscriptionEvent types' objectType fields initialValue = do
(data', errors) <- runWriterT
$ flip runReaderT types'
$ runExecutorT
$ executeSelectionSet fields objectType initialValue []
pure $ Response data' errors

View File

@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Safe #-}
-- | Types that can be used as both input and output types.
module Language.GraphQL.Type.Definition

View File

@ -3,6 +3,7 @@
obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE ViewPatterns #-}
-- | Input types and values.

View File

@ -54,10 +54,11 @@ queryType = Out.ObjectType "Query" Nothing []
$ HashMap.fromList
[ ("philosopher", ValueResolver philosopherField philosopherResolver)
, ("genres", ValueResolver genresField genresResolver)
, ("count", ValueResolver countField countResolver)
]
where
philosopherField =
Out.Field Nothing (Out.NonNullObjectType philosopherType)
Out.Field Nothing (Out.NamedObjectType philosopherType)
$ HashMap.singleton "id"
$ In.Argument Nothing (In.NamedScalarType id) Nothing
philosopherResolver = pure $ Object mempty
@ -66,6 +67,10 @@ queryType = Out.ObjectType "Query" Nothing []
in Out.Field Nothing fieldType HashMap.empty
genresResolver :: Resolve (Either SomeException)
genresResolver = throwM PhilosopherException
countField =
let fieldType = Out.NonNullScalarType int
in Out.Field Nothing fieldType HashMap.empty
countResolver = pure ""
musicType :: Out.ObjectType (Either SomeException)
musicType = Out.ObjectType "Music" Nothing []
@ -230,9 +235,7 @@ spec =
it "errors on invalid output enum values" $
let data'' = Aeson.object
[ "philosopher" .= Aeson.object
[ "school" .= Aeson.Null
]
[ "philosopher" .= Aeson.Null
]
executionErrors = pure $ Error
{ message =
@ -247,9 +250,7 @@ spec =
it "gives location information for non-null unions" $
let data'' = Aeson.object
[ "philosopher" .= Aeson.object
[ "interest" .= Aeson.Null
]
[ "philosopher" .= Aeson.Null
]
executionErrors = pure $ Error
{ message =
@ -264,9 +265,7 @@ spec =
it "gives location information for invalid interfaces" $
let data'' = Aeson.object
[ "philosopher" .= Aeson.object
[ "majorWork" .= Aeson.Null
]
[ "philosopher" .= Aeson.Null
]
executionErrors = pure $ Error
{ message
@ -297,14 +296,12 @@ spec =
it "gives location information for failed result coercion" $
let data'' = Aeson.object
[ "philosopher" .= Aeson.object
[ "century" .= Aeson.Null
]
[ "philosopher" .= Aeson.Null
]
executionErrors = pure $ Error
{ message = "Result coercion failed."
{ message = "Unable to coerce result to !Int."
, locations = [Location 1 26]
, path = []
, path = [Segment "philosopher", Segment "century"]
}
expected = Response data'' executionErrors
Right (Right actual) = either (pure . parseError) execute'
@ -318,13 +315,24 @@ spec =
executionErrors = pure $ Error
{ message = "PhilosopherException"
, locations = [Location 1 3]
, path = []
, path = [Segment "genres"]
}
expected = Response data'' executionErrors
Right (Right actual) = either (pure . parseError) execute'
$ parse document "" "{ genres }"
in actual `shouldBe` expected
it "sets data to null if a root field isn't nullable" $
let executionErrors = pure $ Error
{ message = "Unable to coerce result to !Int."
, locations = [Location 1 3]
, path = [Segment "count"]
}
expected = Response Aeson.Null executionErrors
Right (Right actual) = either (pure . parseError) execute'
$ parse document "" "{ count }"
in actual `shouldBe` expected
context "Subscription" $
it "subscribes" $
let data'' = Aeson.object