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 Language.GraphQL.Validate.Validation
Test.Hspec.GraphQL Test.Hspec.GraphQL
other-modules: other-modules:
Language.GraphQL.Execute.Execution
Language.GraphQL.Execute.Internal Language.GraphQL.Execute.Internal
Language.GraphQL.Execute.Subscribe
Language.GraphQL.Execute.Transform Language.GraphQL.Execute.Transform
Language.GraphQL.Executor
Language.GraphQL.Type.Definition Language.GraphQL.Type.Definition
Language.GraphQL.Type.Internal Language.GraphQL.Type.Internal
Language.GraphQL.Validate.Rules Language.GraphQL.Validate.Rules

View File

@ -1,6 +1,4 @@
{- This Source Code Form is subject to the terms of the Mozilla Public License, {-# LANGUAGE Safe #-}
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/. -}
-- | Target AST for parser. -- | Target AST for parser.
module Language.GraphQL.AST 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 DuplicateRecordFields #-}
{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}

View File

@ -4,17 +4,13 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
module Language.GraphQL.Execute module Language.GraphQL.Execute
( Error(..) ( module Language.GraphQL.Execute.Coerce
, Operation(..)
, Path(..)
, Response(..)
, execute , execute
) where ) where
@ -29,32 +25,27 @@ import Control.Monad.Catch
, catches , catches
) )
import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Reader (ReaderT(..), ask, local, runReaderT) import Control.Monad.Trans.Reader (ReaderT(..), ask, runReaderT)
import Control.Monad.Trans.Writer (WriterT(..), runWriterT, tell) import Control.Monad.Trans.Writer (WriterT(..), runWriterT)
import qualified Control.Monad.Trans.Reader as Reader import qualified Control.Monad.Trans.Writer as Writer
import Control.Monad (foldM) import Control.Monad (foldM)
import qualified Language.GraphQL.AST.Document as Full import qualified Language.GraphQL.AST.Document as Full
import Data.Bifunctor (first)
import Data.Foldable (find) import Data.Foldable (find)
import Data.Functor ((<&>))
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.Int (Int32)
import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty(..)) import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (fromMaybe, isJust) import Data.Maybe (fromMaybe)
import Data.Sequence (Seq, (><)) import Data.Sequence (Seq)
import qualified Data.Sequence as Seq import qualified Data.Sequence as Seq
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.Typeable (cast) import Data.Typeable (cast)
import GHC.Records (HasField(..)) import GHC.Records (HasField(..))
import qualified Language.GraphQL.Execute.Coerce as Coerce import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Execute.OrderedMap (OrderedMap) import Language.GraphQL.Execute.OrderedMap (OrderedMap)
import qualified Language.GraphQL.Execute.OrderedMap as 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.In as In
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out
import qualified Language.GraphQL.Type as Type import qualified Language.GraphQL.Type as Type
@ -65,40 +56,10 @@ import Language.GraphQL.Error
( Error(..) ( Error(..)
, Response(..) , Response(..)
, Path(..) , Path(..)
, ResolverException(..)
, ResponseEventStream , ResponseEventStream
) )
import Numeric (showFloat) import Prelude hiding (null)
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 newtype ExecutorT m a = ExecutorT
{ runExecutorT :: ReaderT (HashMap Full.Name (Type m)) (WriterT (Seq Error) m) a { runExecutorT :: ReaderT (HashMap Full.Name (Type m)) (WriterT (Seq Error) m) a
@ -139,25 +100,27 @@ graphQLExceptionFromException e = do
GraphQLException graphqlException <- fromException e GraphQLException graphqlException <- fromException e
cast graphqlException cast graphqlException
data ResolverException = forall e. Exception e => ResolverException e data ResultException = forall e. Exception e => ResultException e
instance Show ResolverException where instance Show ResultException where
show (ResolverException e) = show e show (ResultException e) = show e
instance Exception ResolverException where instance Exception ResultException where
toException = graphQLExceptionToException toException = graphQLExceptionToException
fromException = graphQLExceptionFromException fromException = graphQLExceptionFromException
data FieldError resultExceptionToException :: Exception e => e -> SomeException
= ResultCoercionError resultExceptionToException = toException . ResultException
| NullResultError
instance Show FieldError where resultExceptionFromException :: Exception e => SomeException -> Maybe e
show ResultCoercionError = "Result coercion failed." resultExceptionFromException e = do
show NullResultError = "Non-Nullable field resolver returned Null." ResultException resultException <- fromException e
cast resultException
newtype FieldException = FieldException FieldError data FieldException = forall e. Exception e => FieldException Full.Location [Path] e
deriving Show
instance Show FieldException where
show (FieldException _ _ e) = displayException e
instance Exception FieldException where instance Exception FieldException where
toException = graphQLExceptionToException toException = graphQLExceptionToException
@ -175,11 +138,11 @@ instance Show ValueCompletionException where
] ]
instance Exception ValueCompletionException where instance Exception ValueCompletionException where
toException = graphQLExceptionToException toException = resultExceptionToException
fromException = graphQLExceptionFromException fromException = resultExceptionFromException
data InputCoercionException = data InputCoercionException =
InputCoercionException String In.Type (Maybe (Full.Node Input)) InputCoercionException String In.Type (Maybe (Full.Node Transform.Input))
instance Show InputCoercionException where instance Show InputCoercionException where
show (InputCoercionException argumentName argumentType Nothing) = concat show (InputCoercionException argumentName argumentType Nothing) = concat
@ -203,14 +166,27 @@ instance Exception InputCoercionException where
toException = graphQLExceptionToException toException = graphQLExceptionToException
fromException = graphQLExceptionFromException 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 data QueryError
= OperationNameRequired = OperationNameRequired
| OperationNotFound String | OperationNotFound String
| CoercionError Full.VariableDefinition | CoercionError Full.VariableDefinition
| UnknownInputType Full.VariableDefinition | UnknownInputType Full.VariableDefinition
asks :: Monad m => forall a. (Replacement m -> a) -> TransformT m a tell :: Monad m => Seq Error -> ExecutorT m ()
asks = TransformT . Reader.asks tell = ExecutorT . lift . Writer.tell
queryError :: QueryError -> Error queryError :: QueryError -> Error
queryError OperationNameRequired = queryError OperationNameRequired =
@ -241,232 +217,7 @@ queryError (UnknownInputType variableDefinition) =
] ]
in Error{ message = queryErrorMessage, locations = [location], path = [] } in Error{ message = queryErrorMessage, locations = [location], path = [] }
data Operation m execute :: (MonadCatch m, VariableValue a, Serialize b)
= 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)
=> Schema m -- ^ Resolvers. => Schema m -- ^ Resolvers.
-> Maybe Text -- ^ Operation name. -> Maybe Text -- ^ Operation name.
-> HashMap Full.Name a -- ^ Variable substitution function. -> 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' = execute schema' operationName subs document' =
executeRequest schema' document' (Text.unpack <$> operationName) subs 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 => Schema m
-> Full.Document -> Full.Document
-> Maybe String -> Maybe String
@ -486,35 +237,36 @@ executeRequest schema sourceDocument operationName variableValues = do
case operationAndVariables of case operationAndVariables of
Left queryError' -> pure Left queryError' -> pure
$ Right $ Right
$ Response Coerce.null $ pure $ queryError queryError' $ Response null $ pure $ queryError queryError'
Right operation Right operation
| Operation Full.Query topSelections _operationLocation <- operation -> | Transform.Operation Full.Query topSelections _operationLocation <- operation ->
Right <$> executeQuery topSelections schema Right <$> executeQuery topSelections schema
| Operation Full.Mutation topSelections operationLocation <- operation -> | Transform.Operation Full.Mutation topSelections operationLocation <- operation ->
Right <$> executeMutation topSelections schema operationLocation 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 either rightErrorResponse Left <$> subscribe topSelections schema operationLocation
where where
schemaTypes = Schema.types schema schemaTypes = Schema.types schema
(operationDefinitions, fragmentDefinitions') = document sourceDocument (operationDefinitions, fragmentDefinitions') =
Transform.document sourceDocument
buildOperation = do buildOperation = do
operationDefinition <- getOperation operationDefinitions operationName operationDefinition <- getOperation operationDefinitions operationName
coercedVariableValues <- coerceVariableValues coercedVariableValues <- coerceVariableValues
schemaTypes schemaTypes
operationDefinition operationDefinition
variableValues variableValues
let replacement = Replacement let replacement = Transform.Replacement
{ variableValues = coercedVariableValues { variableValues = coercedVariableValues
, fragmentDefinitions = fragmentDefinitions' , fragmentDefinitions = fragmentDefinitions'
, visitedFragments = mempty , visitedFragments = mempty
, types = schemaTypes , types = schemaTypes
} }
pure $ flip runReaderT replacement pure $ flip runReaderT replacement
$ runTransformT $ Transform.runTransformT
$ transform operationDefinition $ Transform.transform operationDefinition
rightErrorResponse :: Coerce.Serialize b => forall a. Error -> Either a (Response b) rightErrorResponse :: Serialize b => forall a. Error -> Either a (Response b)
rightErrorResponse = Right . Response Coerce.null . pure rightErrorResponse = Right . Response null . pure
getOperation :: [Full.OperationDefinition] -> Maybe String -> Either QueryError Full.OperationDefinition getOperation :: [Full.OperationDefinition] -> Maybe String -> Either QueryError Full.OperationDefinition
getOperation [operation] Nothing = Right operation getOperation [operation] Nothing = Right operation
@ -527,8 +279,8 @@ getOperation operations (Just givenOperationName)
findOperationByName _ = False findOperationByName _ = False
getOperation _ _ = Left OperationNameRequired getOperation _ _ = Left OperationNameRequired
executeQuery :: (MonadCatch m, Coerce.Serialize a) executeQuery :: (MonadCatch m, Serialize a)
=> Seq (Selection m) => Seq (Transform.Selection m)
-> Schema m -> Schema m
-> m (Response a) -> m (Response a)
executeQuery topSelections schema = do executeQuery topSelections schema = do
@ -536,11 +288,26 @@ executeQuery topSelections schema = do
(data', errors) <- runWriterT (data', errors) <- runWriterT
$ flip runReaderT (Schema.types schema) $ flip runReaderT (Schema.types schema)
$ runExecutorT $ runExecutorT
$ executeSelectionSet topSelections queryType Type.Null [] $ catch (executeSelectionSet topSelections queryType Type.Null [])
handleException
pure $ Response data' errors pure $ Response data' errors
executeMutation :: (MonadCatch m, Coerce.Serialize a) handleException :: (MonadCatch m, Serialize a)
=> Seq (Selection m) => 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 -> Schema m
-> Full.Location -> Full.Location
-> m (Response a) -> m (Response a)
@ -549,15 +316,16 @@ executeMutation topSelections schema operationLocation
(data', errors) <- runWriterT (data', errors) <- runWriterT
$ flip runReaderT (Schema.types schema) $ flip runReaderT (Schema.types schema)
$ runExecutorT $ runExecutorT
$ executeSelectionSet topSelections mutationType Type.Null [] $ catch (executeSelectionSet topSelections mutationType Type.Null [])
handleException
pure $ Response data' errors pure $ Response data' errors
| otherwise = pure | otherwise = pure
$ Response Coerce.null $ Response null
$ Seq.singleton $ Seq.singleton
$ Error "Schema doesn't support mutations." [operationLocation] [] $ Error "Schema doesn't support mutations." [operationLocation] []
executeSelectionSet :: (MonadCatch m, Coerce.Serialize a) executeSelectionSet :: (MonadCatch m, Serialize a)
=> Seq (Selection m) => Seq (Transform.Selection m)
-> Out.ObjectType m -> Out.ObjectType m
-> Type.Value -> Type.Value
-> [Path] -> [Path]
@ -565,62 +333,80 @@ executeSelectionSet :: (MonadCatch m, Coerce.Serialize a)
executeSelectionSet selections objectType objectValue errorPath = do executeSelectionSet selections objectType objectValue errorPath = do
let groupedFieldSet = collectFields objectType selections let groupedFieldSet = collectFields objectType selections
resolvedValues <- OrderedMap.traverseMaybe go groupedFieldSet resolvedValues <- OrderedMap.traverseMaybe go groupedFieldSet
coerceResult (Out.NonNullObjectType objectType) $ Coerce.Object resolvedValues coerceResult (Out.NonNullObjectType objectType) $ Object resolvedValues
where where
executeField' fields resolver = executeField' fields resolver =
executeField objectValue fields resolver errorPath executeField objectValue fields resolver errorPath
Out.ObjectType _ _ _ resolvers = objectType Out.ObjectType _ _ _ resolvers = objectType
go fields@(Field _ fieldName _ _ _ :| _) = go fields@(Transform.Field _ fieldName _ _ _ :| _) =
traverse (executeField' fields) $ HashMap.lookup fieldName resolvers traverse (executeField' fields) $ HashMap.lookup fieldName resolvers
fieldsSegment :: forall m. NonEmpty (Field m) -> Path fieldsSegment :: forall m. NonEmpty (Transform.Field m) -> Path
fieldsSegment (Field alias fieldName _ _ _ :| _) = fieldsSegment (Transform.Field alias fieldName _ _ _ :| _) =
Segment (fromMaybe fieldName alias) 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 => Type.Value
-> NonEmpty (Field m) -> NonEmpty (Transform.Field m)
-> Out.Resolver m -> Out.Resolver m
-> [Path] -> [Path]
-> ExecutorT m a -> ExecutorT m a
executeField objectValue fields resolver errorPath = executeField objectValue fields (viewResolver -> resolverPair) errorPath =
let Field _ fieldName inputArguments _ fieldLocation :| _ = fields let Transform.Field _ fieldName inputArguments _ fieldLocation :| _ = fields
in catches (go fieldName inputArguments) in catches (go fieldName inputArguments)
[ Handler (inputCoercionHandler fieldLocation) [ Handler nullResultHandler
, Handler (graphqlExceptionHandler fieldLocation) , Handler (inputCoercionHandler fieldLocation)
, Handler (resultHandler fieldLocation)
, Handler (resolverHandler fieldLocation)
] ]
where where
inputCoercionHandler :: (MonadCatch m, Coerce.Serialize a) inputCoercionHandler :: (MonadCatch m, Serialize a)
=> Full.Location => Full.Location
-> InputCoercionException -> InputCoercionException
-> ExecutorT m a -> ExecutorT m a
inputCoercionHandler _ e@(InputCoercionException _ _ (Just valueNode)) = inputCoercionHandler _ e@(InputCoercionException _ _ (Just valueNode)) =
let argumentLocation = getField @"location" valueNode let argumentLocation = getField @"location" valueNode
in exceptionHandler argumentLocation $ displayException e in exceptionHandler argumentLocation e
inputCoercionHandler fieldLocation e = inputCoercionHandler fieldLocation e = exceptionHandler fieldLocation e
exceptionHandler fieldLocation $ displayException e resultHandler :: (MonadCatch m, Serialize a)
graphqlExceptionHandler :: (MonadCatch m, Coerce.Serialize a)
=> Full.Location => Full.Location
-> GraphQLException -> ResultException
-> ExecutorT m a -> ExecutorT m a
graphqlExceptionHandler fieldLocation e = resultHandler = exceptionHandler
exceptionHandler fieldLocation $ displayException e resolverHandler :: (MonadCatch m, Serialize a)
exceptionHandler errorLocation exceptionText = => Full.Location
let newError = Error (Text.pack exceptionText) [errorLocation] -> ResolverException
$ reverse -> ExecutorT m a
$ fieldsSegment fields : errorPath resolverHandler = exceptionHandler
in ExecutorT (lift $ tell $ Seq.singleton newError) >> pure Coerce.null 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 go fieldName inputArguments = do
let (Out.Field _ fieldType argumentTypes, resolveFunction) =
resolverField resolver
argumentValues <- coerceArgumentValues argumentTypes inputArguments argumentValues <- coerceArgumentValues argumentTypes inputArguments
resolvedValue <- resolvedValue <-
resolveFieldValue resolveFunction objectValue fieldName argumentValues resolveFieldValue resolveFunction objectValue fieldName argumentValues
completeValue fieldType fields errorPath resolvedValue completeValue fieldType fields errorPath resolvedValue
resolverField (Out.ValueResolver resolverField' resolveFunction) = (resolverField, resolveFunction) = resolverPair
(resolverField', resolveFunction) Out.Field _ fieldType argumentTypes = resolverField
resolverField (Out.EventStreamResolver resolverField' resolveFunction _) =
(resolverField', resolveFunction)
resolveFieldValue :: MonadCatch m resolveFieldValue :: MonadCatch m
=> Out.Resolve m => Out.Resolve m
@ -651,34 +437,33 @@ resolveAbstractType abstractType values'
_ -> pure Nothing _ -> pure Nothing
| otherwise = pure Nothing | otherwise = pure Nothing
completeValue :: (MonadCatch m, Coerce.Serialize a) completeValue :: (MonadCatch m, Serialize a)
=> Out.Type m => Out.Type m
-> NonEmpty (Field m) -> NonEmpty (Transform.Field m)
-> [Path] -> [Path]
-> Type.Value -> Type.Value
-> ExecutorT m a -> ExecutorT m a
completeValue outputType _ _ Type.Null completeValue (Out.isNonNullType -> False) _ _ Type.Null =
| Out.isNonNullType outputType = throwFieldError NullResultError pure null
| otherwise = pure Coerce.null
completeValue outputType@(Out.ListBaseType listType) fields errorPath (Type.List list) 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 where
go (index, accumulator) listItem = do go (index, accumulator) listItem = do
let updatedPath = Index index : errorPath let updatedPath = Index index : errorPath
completedValue <- completeValue listType fields updatedPath listItem completedValue <- completeValue listType fields updatedPath listItem
pure (index + 1, completedValue : accumulator) pure (index + 1, completedValue : accumulator)
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Int int) = completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Int int) =
coerceResult outputType $ Coerce.Int int coerceResult outputType $ Int int
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Boolean boolean) = completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Boolean boolean) =
coerceResult outputType $ Coerce.Boolean boolean coerceResult outputType $ Boolean boolean
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Float float) = completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Float float) =
coerceResult outputType $ Coerce.Float float coerceResult outputType $ Float float
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.String string) = completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.String string) =
coerceResult outputType $ Coerce.String string coerceResult outputType $ String string
completeValue outputType@(Out.EnumBaseType enumType) _ _ (Type.Enum enum) = completeValue outputType@(Out.EnumBaseType enumType) _ _ (Type.Enum enum) =
let Type.EnumType _ _ enumMembers = enumType let Type.EnumType _ _ enumMembers = enumType
in if HashMap.member enum enumMembers in if HashMap.member enum enumMembers
then coerceResult outputType $ Coerce.Enum enum then coerceResult outputType $ Enum enum
else throwM else throwM
$ ValueCompletionException (show outputType) $ ValueCompletionException (show outputType)
$ Type.Enum enum $ Type.Enum enum
@ -708,28 +493,25 @@ completeValue outputType@(Out.UnionBaseType unionType) fields errorPath result
completeValue outputType _ _ result = completeValue outputType _ _ result =
throwM $ ValueCompletionException (show outputType) result throwM $ ValueCompletionException (show outputType) result
coerceResult :: (MonadCatch m, Coerce.Serialize a) coerceResult :: (MonadCatch m, Serialize a)
=> Out.Type m => Out.Type m
-> Coerce.Output a -> Output a
-> ExecutorT m a -> ExecutorT m a
coerceResult outputType result coerceResult outputType result
| Just serialized <- Coerce.serialize outputType result = pure serialized | Just serialized <- serialize outputType result = pure serialized
| otherwise = throwFieldError ResultCoercionError | otherwise = throwM $ ResultCoercionException $ show outputType
mergeSelectionSets :: MonadCatch m mergeSelectionSets :: MonadCatch m
=> NonEmpty (Field m) => NonEmpty (Transform.Field m)
-> Seq (Selection m) -> Seq (Transform.Selection m)
mergeSelectionSets = foldr forEach mempty mergeSelectionSets = foldr forEach mempty
where where
forEach (Field _ _ _ fieldSelectionSet _) selectionSet' = forEach (Transform.Field _ _ _ fieldSelectionSet _) selectionSet' =
selectionSet' <> fieldSelectionSet selectionSet' <> fieldSelectionSet
throwFieldError :: MonadCatch m => FieldError -> m a
throwFieldError = throwM . FieldException
coerceArgumentValues :: MonadCatch m coerceArgumentValues :: MonadCatch m
=> HashMap Full.Name In.Argument => HashMap Full.Name In.Argument
-> HashMap Full.Name (Full.Node Input) -> HashMap Full.Name (Full.Node Transform.Input)
-> m Type.Subs -> m Type.Subs
coerceArgumentValues argumentDefinitions argumentValues = coerceArgumentValues argumentDefinitions argumentValues =
HashMap.foldrWithKey c pure argumentDefinitions mempty HashMap.foldrWithKey c pure argumentDefinitions mempty
@ -754,53 +536,53 @@ coerceArgumentValues argumentDefinitions argumentValues =
$ Just inputValue $ Just inputValue
| otherwise -> throwM | otherwise -> throwM
$ InputCoercionException (Text.unpack argumentName) variableType Nothing $ InputCoercionException (Text.unpack argumentName) variableType Nothing
matchFieldValues' = Coerce.matchFieldValues coerceArgumentValue matchFieldValues' = matchFieldValues coerceArgumentValue
$ Full.node <$> argumentValues $ Full.node <$> argumentValues
coerceArgumentValue inputType (Int integer) = coerceArgumentValue inputType (Transform.Int integer) =
Coerce.coerceInputLiteral inputType (Type.Int integer) coerceInputLiteral inputType (Type.Int integer)
coerceArgumentValue inputType (Boolean boolean) = coerceArgumentValue inputType (Transform.Boolean boolean) =
Coerce.coerceInputLiteral inputType (Type.Boolean boolean) coerceInputLiteral inputType (Type.Boolean boolean)
coerceArgumentValue inputType (String string) = coerceArgumentValue inputType (Transform.String string) =
Coerce.coerceInputLiteral inputType (Type.String string) coerceInputLiteral inputType (Type.String string)
coerceArgumentValue inputType (Float float) = coerceArgumentValue inputType (Transform.Float float) =
Coerce.coerceInputLiteral inputType (Type.Float float) coerceInputLiteral inputType (Type.Float float)
coerceArgumentValue inputType (Enum enum) = coerceArgumentValue inputType (Transform.Enum enum) =
Coerce.coerceInputLiteral inputType (Type.Enum enum) coerceInputLiteral inputType (Type.Enum enum)
coerceArgumentValue inputType Null coerceArgumentValue inputType Transform.Null
| In.isNonNullType inputType = Nothing | In.isNonNullType inputType = Nothing
| otherwise = Coerce.coerceInputLiteral inputType Type.Null | otherwise = coerceInputLiteral inputType Type.Null
coerceArgumentValue (In.ListBaseType inputType) (List list) = coerceArgumentValue (In.ListBaseType inputType) (Transform.List list) =
let coerceItem = coerceArgumentValue inputType let coerceItem = coerceArgumentValue inputType
in Type.List <$> traverse coerceItem list in Type.List <$> traverse coerceItem list
coerceArgumentValue (In.InputObjectBaseType inputType) (Object object) coerceArgumentValue (In.InputObjectBaseType inputType) (Transform.Object object)
| In.InputObjectType _ _ inputFields <- inputType = | In.InputObjectType _ _ inputFields <- inputType =
let go = forEachField object let go = forEachField object
resultMap = HashMap.foldrWithKey go (pure mempty) inputFields resultMap = HashMap.foldrWithKey go (pure mempty) inputFields
in Type.Object <$> resultMap in Type.Object <$> resultMap
coerceArgumentValue _ (Variable variable) = pure variable coerceArgumentValue _ (Transform.Variable variable) = pure variable
coerceArgumentValue _ _ = Nothing coerceArgumentValue _ _ = Nothing
forEachField object variableName (In.InputField _ variableType defaultValue) = forEachField object variableName (In.InputField _ variableType defaultValue) =
Coerce.matchFieldValues coerceArgumentValue object variableName variableType defaultValue matchFieldValues coerceArgumentValue object variableName variableType defaultValue
collectFields :: Monad m collectFields :: Monad m
=> Out.ObjectType m => Out.ObjectType m
-> Seq (Selection m) -> Seq (Transform.Selection m)
-> OrderedMap (NonEmpty (Field m)) -> OrderedMap (NonEmpty (Transform.Field m))
collectFields objectType = foldl forEach OrderedMap.empty collectFields objectType = foldl forEach OrderedMap.empty
where where
forEach groupedFields (FieldSelection fieldSelection) = forEach groupedFields (Transform.FieldSelection fieldSelection) =
let Field maybeAlias fieldName _ _ _ = fieldSelection let Transform.Field maybeAlias fieldName _ _ _ = fieldSelection
responseKey = fromMaybe fieldName maybeAlias responseKey = fromMaybe fieldName maybeAlias
in OrderedMap.insert responseKey (fieldSelection :| []) groupedFields in OrderedMap.insert responseKey (fieldSelection :| []) groupedFields
forEach groupedFields (FragmentSelection selectionFragment) forEach groupedFields (Transform.FragmentSelection selectionFragment)
| Fragment fragmentType fragmentSelectionSet _ <- selectionFragment | Transform.Fragment fragmentType fragmentSelectionSet _ <- selectionFragment
, Type.Internal.doesFragmentTypeApply fragmentType objectType = , Type.Internal.doesFragmentTypeApply fragmentType objectType =
let fragmentGroupedFieldSet = let fragmentGroupedFieldSet =
collectFields objectType fragmentSelectionSet collectFields objectType fragmentSelectionSet
in groupedFields <> fragmentGroupedFieldSet in groupedFields <> fragmentGroupedFieldSet
| otherwise = groupedFields | otherwise = groupedFields
coerceVariableValues :: (Monad m, Coerce.VariableValue b) coerceVariableValues :: (Monad m, VariableValue b)
=> HashMap Full.Name (Schema.Type m) => HashMap Full.Name (Schema.Type m)
-> Full.OperationDefinition -> Full.OperationDefinition
-> HashMap Full.Name b -> HashMap Full.Name b
@ -818,7 +600,7 @@ coerceVariableValues types operationDefinition' variableValues
in case Type.Internal.lookupInputType variableTypeName types of in case Type.Internal.lookupInputType variableTypeName types of
Just variableType -> Just variableType ->
maybe (Left $ CoercionError variableDefinition) Right maybe (Left $ CoercionError variableDefinition) Right
$ Coerce.matchFieldValues $ matchFieldValues
coerceVariableValue' coerceVariableValue'
variableValues variableValues
variableName variableName
@ -828,8 +610,8 @@ coerceVariableValues types operationDefinition' variableValues
Nothing -> Left $ UnknownInputType variableDefinition Nothing -> Left $ UnknownInputType variableDefinition
forEach _ coercedValuesOrError = coercedValuesOrError forEach _ coercedValuesOrError = coercedValuesOrError
coerceVariableValue' variableType value' coerceVariableValue' variableType value'
= Coerce.coerceVariableValue variableType value' = coerceVariableValue variableType value'
>>= Coerce.coerceInputLiteral variableType >>= coerceInputLiteral variableType
constValue :: Full.ConstValue -> Type.Value constValue :: Full.ConstValue -> Type.Value
constValue (Full.ConstInt i) = Type.Int i constValue (Full.ConstInt i) = Type.Int i
@ -845,8 +627,8 @@ constValue (Full.ConstObject o) =
constObjectField Full.ObjectField{value = value', ..} = constObjectField Full.ObjectField{value = value', ..} =
(name, constValue $ Full.node value') (name, constValue $ Full.node value')
subscribe :: (MonadCatch m, Coerce.Serialize a) subscribe :: (MonadCatch m, Serialize a)
=> Seq (Selection m) => Seq (Transform.Selection m)
-> Schema m -> Schema m
-> Full.Location -> Full.Location
-> m (Either Error (ResponseEventStream m a)) -> m (Either Error (ResponseEventStream m a))
@ -861,10 +643,10 @@ subscribe fields schema objectLocation
| otherwise = pure $ Left | otherwise = pure $ Left
$ Error "Schema doesn't support subscriptions." [] [] $ Error "Schema doesn't support subscriptions." [] []
mapSourceToResponseEvent :: (MonadCatch m, Coerce.Serialize a) mapSourceToResponseEvent :: (MonadCatch m, Serialize a)
=> HashMap Full.Name (Type m) => HashMap Full.Name (Type m)
-> Out.ObjectType m -> Out.ObjectType m
-> Seq (Selection m) -> Seq (Transform.Selection m)
-> Out.SourceEventStream m -> Out.SourceEventStream m
-> m (ResponseEventStream m a) -> m (ResponseEventStream m a)
mapSourceToResponseEvent types' subscriptionType fields sourceStream mapSourceToResponseEvent types' subscriptionType fields sourceStream
@ -876,11 +658,12 @@ createSourceEventStream :: MonadCatch m
=> HashMap Full.Name (Type m) => HashMap Full.Name (Type m)
-> Out.ObjectType m -> Out.ObjectType m
-> Full.Location -> Full.Location
-> Seq (Selection m) -> Seq (Transform.Selection m)
-> m (Either Error (Out.SourceEventStream m)) -> m (Either Error (Out.SourceEventStream m))
createSourceEventStream _types subscriptionType objectLocation fields createSourceEventStream _types subscriptionType objectLocation fields
| [fieldGroup] <- OrderedMap.elems groupedFieldSet | [fieldGroup] <- OrderedMap.elems groupedFieldSet
, Field _ fieldName arguments' _ errorLocation <- NonEmpty.head fieldGroup , Transform.Field _ fieldName arguments' _ errorLocation <-
NonEmpty.head fieldGroup
, Out.ObjectType _ _ _ fieldTypes <- subscriptionType , Out.ObjectType _ _ _ fieldTypes <- subscriptionType
, resolverT <- fieldTypes HashMap.! fieldName , resolverT <- fieldTypes HashMap.! fieldName
, Out.EventStreamResolver fieldDefinition _ resolver <- resolverT , Out.EventStreamResolver fieldDefinition _ resolver <- resolverT
@ -889,16 +672,15 @@ createSourceEventStream _types subscriptionType objectLocation fields
Left _ -> pure Left _ -> pure
$ Left $ Left
$ Error "Argument coercion failed." [errorLocation] [] $ Error "Argument coercion failed." [errorLocation] []
Right argumentValues -> left (singleError' [errorLocation]) Right argumentValues -> left (singleError [errorLocation])
<$> resolveFieldEventStream Type.Null argumentValues resolver <$> resolveFieldEventStream Type.Null argumentValues resolver
| otherwise = pure | otherwise = pure
$ Left $ Left
$ Error "Subscription contains more than one field." [objectLocation] [] $ Error "Subscription contains more than one field." [objectLocation] []
where where
groupedFieldSet = collectFields subscriptionType fields groupedFieldSet = collectFields subscriptionType fields
singleError :: [Full.Location] -> String -> Error
singleError' :: [Full.Location] -> String -> Error singleError errorLocations message = Error (Text.pack message) errorLocations []
singleError' errorLocations message = Error (Text.pack message) errorLocations []
resolveFieldEventStream :: MonadCatch m resolveFieldEventStream :: MonadCatch m
=> Type.Value => Type.Value
@ -917,15 +699,16 @@ resolveFieldEventStream result args resolver =
, Type.values = result , Type.values = result
} }
executeSubscriptionEvent :: (MonadCatch m, Coerce.Serialize a) executeSubscriptionEvent :: (MonadCatch m, Serialize a)
=> HashMap Full.Name (Type m) => HashMap Full.Name (Type m)
-> Out.ObjectType m -> Out.ObjectType m
-> Seq (Selection m) -> Seq (Transform.Selection m)
-> Type.Value -> Type.Value
-> m (Response a) -> m (Response a)
executeSubscriptionEvent types' objectType fields initialValue = do executeSubscriptionEvent types' objectType fields initialValue = do
(data', errors) <- runWriterT (data', errors) <- runWriterT
$ flip runReaderT types' $ flip runReaderT types'
$ runExecutorT $ runExecutorT
$ executeSelectionSet fields objectType initialValue [] $ catch (executeSelectionSet fields objectType initialValue [])
handleException
pure $ Response data' errors 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 LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE NamedFieldPuns #-}
-- | After the document is parsed, before getting executed, the AST is -- | After the document is parsed, before getting executed, the AST is
-- transformed into a similar, simpler AST. Performed transformations include: -- 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 -- This module is also responsible for smaller rewrites that touch only parts of
-- the original AST. -- the original AST.
module Language.GraphQL.Execute.Transform module Language.GraphQL.Execute.Transform
( Document(..) ( Field(..)
, Field(..)
, Fragment(..) , Fragment(..)
, Input(..) , Input(..)
, Operation(..) , Operation(..)
, QueryError(..) , Replacement(..)
, Selection(..) , Selection(..)
, TransformT(..)
, document , document
, transform
) where ) where
import Control.Monad (foldM, unless) import Control.Monad (foldM)
import Control.Monad.Trans.Class (lift) import Control.Monad.Catch (MonadCatch(..), MonadThrow(..))
import Control.Monad.Trans.State (State, evalStateT, gets, modify) import Control.Monad.Trans.Class (MonadTrans(..))
import Data.Foldable (find) import Control.Monad.Trans.Reader (ReaderT(..), local)
import Data.Functor.Identity (Identity(..)) import qualified Control.Monad.Trans.Reader as Reader
import Data.Bifunctor (first)
import Data.Functor ((<&>))
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.HashSet (HashSet)
import qualified Data.HashSet as HashSet
import Data.Int (Int32) import Data.Int (Int32)
import Data.Maybe (fromMaybe) import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty 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 Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Language.GraphQL.AST as Full import qualified Language.GraphQL.AST.Document as Full
import Language.GraphQL.AST (Name) import Language.GraphQL.Type.Schema (Type)
import qualified Language.GraphQL.Execute.Coerce as Coerce
import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type as Type import qualified Language.GraphQL.Type as Type
import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type.Internal as Type import qualified Language.GraphQL.Type.Internal as Type
import qualified Language.GraphQL.Type.Out as Out import Numeric (showFloat)
import qualified Language.GraphQL.Type.Schema as Schema
-- | Associates a fragment name with a list of 'Field's.
data Replacement m = Replacement data Replacement m = Replacement
{ fragments :: HashMap Full.Name (Fragment m) { variableValues :: Type.Subs
, fragmentDefinitions :: FragmentDefinitions , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
, variableValues :: Type.Subs , visitedFragments :: HashSet Full.Name
, types :: HashMap Full.Name (Schema.Type m) , 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. instance Functor m => Functor (TransformT m) where
data Fragment m fmap f = TransformT . fmap f . runTransformT
= Fragment (Type.CompositeType m) (Seq (Selection m))
-- | Single selection element. instance Applicative m => Applicative (TransformT m) where
data Selection m pure = TransformT . pure
= SelectionFragment (Fragment m) TransformT f <*> TransformT x = TransformT $ f <*> x
| SelectionField (Field m)
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 data Operation m
= Query (Maybe Text) (Seq (Selection m)) Full.Location = Operation Full.OperationType (Seq (Selection m)) Full.Location
| Mutation (Maybe Text) (Seq (Selection m)) Full.Location
| Subscription (Maybe Text) (Seq (Selection m)) Full.Location data Selection m
= FieldSelection (Field m)
| FragmentSelection (Fragment m)
-- | Single GraphQL field.
data Field m = Field data Field m = Field
(Maybe Full.Name) (Maybe Full.Name)
Full.Name Full.Name
@ -87,339 +106,214 @@ data Field m = Field
(Seq (Selection m)) (Seq (Selection m))
Full.Location Full.Location
-- | Contains the operation to be executed along with its root type. data Fragment m = Fragment
data Document m = Document (Type.CompositeType m) (Seq (Selection m)) Full.Location
(HashMap Full.Name (Schema.Type m)) (Out.ObjectType m) (Operation m)
data OperationDefinition = OperationDefinition
Full.OperationType
(Maybe Full.Name)
[Full.VariableDefinition]
[Full.Directive]
Full.SelectionSet
Full.Location
-- | Query error types.
data QueryError
= OperationNotFound Text
| OperationNameRequired
| CoercionError
| EmptyDocument
| UnsupportedRootOperation
instance Show QueryError where
show (OperationNotFound operationName) = unwords
["Operation", Text.unpack operationName, "couldn't be found in the document."]
show OperationNameRequired = "Missing operation name."
show CoercionError = "Coercion error."
show EmptyDocument =
"The document doesn't contain any executable operations."
show UnsupportedRootOperation =
"Root operation type couldn't be found in the schema."
data Input data Input
= Int Int32 = Variable Type.Value
| Int Int32
| Float Double | Float Double
| String Text | String Text
| Boolean Bool | Boolean Bool
| Null | Null
| Enum Name | Enum Full.Name
| List [Type.Value] | List [Input]
| Object (HashMap Name Input) | Object (HashMap Full.Name Input)
| Variable Type.Value deriving Eq
deriving (Eq, Show)
getOperation instance Show Input where
:: Maybe Full.Name showList = mappend . showList'
-> NonEmpty OperationDefinition
-> Either QueryError OperationDefinition
getOperation Nothing (operation' :| []) = pure operation'
getOperation Nothing _ = Left OperationNameRequired
getOperation (Just operationName) operations
| Just operation' <- find matchingName operations = pure operation'
| otherwise = Left $ OperationNotFound operationName
where where
matchingName (OperationDefinition _ name _ _ _ _) = showList' list = "[" ++ intercalate ", " (show <$> list) ++ "]"
name == Just operationName show (Int integer) = show integer
show (Float float') = showFloat float' mempty
coerceVariableValues :: Coerce.VariableValue a show (String text) = "\"" <> Text.foldr (mappend . Full.escape) "\"" text
=> forall m show (Boolean boolean') = show boolean'
. HashMap Full.Name (Schema.Type m) show Null = "null"
-> OperationDefinition show (Enum name) = Text.unpack name
-> HashMap.HashMap Full.Name a show (List list) = show list
-> Either QueryError Type.Subs show (Object fields) = unwords
coerceVariableValues types operationDefinition variableValues = [ "{"
let OperationDefinition _ _ variableDefinitions _ _ _ = operationDefinition , intercalate ", " (HashMap.foldrWithKey showObject [] fields)
in maybe (Left CoercionError) Right , "}"
$ foldr forEach (Just HashMap.empty) variableDefinitions ]
where where
forEach variableDefinition coercedValues = do showObject key value accumulator =
let Full.VariableDefinition variableName variableTypeName defaultValue _ = concat [Text.unpack key, ": ", show value] : accumulator
variableDefinition show variableValue = show variableValue
let defaultValue' = constValue . Full.node <$> defaultValue
variableType <- Type.lookupInputType variableTypeName types
Coerce.matchFieldValues document :: Full.Document
coerceVariableValue' -> ([Full.OperationDefinition], HashMap Full.Name Full.FragmentDefinition)
variableValues document = foldr filterOperation ([], HashMap.empty)
variableName
variableType
defaultValue'
coercedValues
coerceVariableValue' variableType value'
= Coerce.coerceVariableValue variableType value'
>>= Coerce.coerceInputLiteral variableType
constValue :: Full.ConstValue -> Type.Value
constValue (Full.ConstInt i) = Type.Int i
constValue (Full.ConstFloat f) = Type.Float f
constValue (Full.ConstString x) = Type.String x
constValue (Full.ConstBoolean b) = Type.Boolean b
constValue Full.ConstNull = Type.Null
constValue (Full.ConstEnum e) = Type.Enum e
constValue (Full.ConstList list) = Type.List $ constValue . Full.node <$> list
constValue (Full.ConstObject o) =
Type.Object $ HashMap.fromList $ constObjectField <$> o
where where
constObjectField Full.ObjectField{value = value', ..} = filterOperation (Full.ExecutableDefinition executableDefinition) accumulator
(name, constValue $ Full.node value') | 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 transform :: Monad m => Full.OperationDefinition -> TransformT m (Operation m)
-- for query execution. transform (Full.OperationDefinition operationType _ _ _ selectionSet' operationLocation) = do
document :: Coerce.VariableValue a transformedSelections <- selectionSet selectionSet'
=> forall m pure $ Operation operationType transformedSelections operationLocation
. Type.Schema m transform (Full.SelectionSet selectionSet' operationLocation) = do
-> Maybe Full.Name 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 -> HashMap Full.Name a
-> Full.Document -> HashMap Full.Name a
-> Either QueryError (Document m) insertIfGiven name (Just v) = HashMap.insert name v
document schema operationName subs ast = do insertIfGiven _ _ = id
let referencedTypes = Schema.types schema
(operations, fragmentTable) <- defragment ast node :: Monad m => Full.Node Full.Value -> TransformT m (Maybe (Full.Node Input))
chosenOperation <- getOperation operationName operations node Full.Node{node = node', ..} =
coercedValues <- coerceVariableValues referencedTypes chosenOperation subs 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 OverloadedStrings #-}
{-# LANGUAGE Safe #-}
-- | Types that can be used as both input and output types. -- | Types that can be used as both input and output types.
module Language.GraphQL.Type.Definition module Language.GraphQL.Type.Definition

View File

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

View File

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