Copy subscription code

This commit is contained in:
Eugen Wissner 2021-08-31 14:03:15 +02:00
parent f808d0664f
commit c7e586a125
2 changed files with 144 additions and 58 deletions

View File

@ -38,7 +38,6 @@ library
Language.GraphQL.Error Language.GraphQL.Error
Language.GraphQL.Execute Language.GraphQL.Execute
Language.GraphQL.Execute.Coerce Language.GraphQL.Execute.Coerce
Language.GraphQL.Executor
Language.GraphQL.Execute.OrderedMap Language.GraphQL.Execute.OrderedMap
Language.GraphQL.Type Language.GraphQL.Type
Language.GraphQL.Type.In Language.GraphQL.Type.In
@ -52,6 +51,7 @@ library
Language.GraphQL.Execute.Internal Language.GraphQL.Execute.Internal
Language.GraphQL.Execute.Subscribe 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

@ -11,12 +11,14 @@
module Language.GraphQL.Executor module Language.GraphQL.Executor
( Error(..) ( Error(..)
, Operation(..) , Operation(..)
, QueryError(..) , Path(..)
, ResponseEventStream
, Response(..) , Response(..)
, Segment(..) , execute
, executeRequest
) where ) where
import Conduit (ConduitT, mapMC, (.|))
import Control.Arrow (left)
import Control.Monad.Catch import Control.Monad.Catch
( Exception(..) ( Exception(..)
, MonadCatch(..) , MonadCatch(..)
@ -54,6 +56,7 @@ import qualified Language.GraphQL.Type as Type
import qualified Language.GraphQL.Type.Internal as Type.Internal import qualified Language.GraphQL.Type.Internal as Type.Internal
import Language.GraphQL.Type.Schema (Schema, Type) import Language.GraphQL.Type.Schema (Schema, Type)
import qualified Language.GraphQL.Type.Schema as Schema import qualified Language.GraphQL.Type.Schema as Schema
import Language.GraphQL.Error (Error(..), Response(..), Path(..))
data Replacement m = Replacement data Replacement m = Replacement
{ variableValues :: Type.Subs { variableValues :: Type.Subs
@ -87,7 +90,7 @@ instance MonadCatch m => MonadCatch (TransformT m) where
TransformT $ catch stack $ runTransformT . handler TransformT $ catch stack $ runTransformT . handler
newtype ExecutorT m a = ExecutorT newtype ExecutorT m a = ExecutorT
{ runExecutorT :: ReaderT (HashMap Full.Name (Type m)) (WriterT [Error] m) a { runExecutorT :: ReaderT (HashMap Full.Name (Type m)) (WriterT (Seq Error) m) a
} }
instance Functor m => Functor (ExecutorT m) where instance Functor m => Functor (ExecutorT m) where
@ -161,19 +164,6 @@ instance Exception FieldException where
toException = graphQLExceptionToException toException = graphQLExceptionToException
fromException = graphQLExceptionFromException fromException = graphQLExceptionFromException
data Segment = Segment String | Index Int
data Error = Error
{ message :: String
, locations :: [Full.Location]
, path :: [Segment]
}
data Response a = Response
{ data' :: a
, errors :: [Error]
}
data QueryError data QueryError
= OperationNameRequired = OperationNameRequired
| OperationNotFound String | OperationNotFound String
@ -187,32 +177,33 @@ queryError :: QueryError -> Error
queryError OperationNameRequired = queryError OperationNameRequired =
Error{ message = "Operation name is required.", locations = [], path = [] } Error{ message = "Operation name is required.", locations = [], path = [] }
queryError (OperationNotFound operationName) = queryError (OperationNotFound operationName) =
let queryErrorMessage = concat let queryErrorMessage = Text.concat
[ "Operation \"" [ "Operation \""
, operationName , Text.pack operationName
, "\" not found." , "\" not found."
] ]
in Error{ message = queryErrorMessage, locations = [], path = [] } in Error{ message = queryErrorMessage, locations = [], path = [] }
queryError (CoercionError variableDefinition) = queryError (CoercionError variableDefinition) =
let Full.VariableDefinition variableName _ _ location = variableDefinition let Full.VariableDefinition variableName _ _ location = variableDefinition
queryErrorMessage = concat queryErrorMessage = Text.concat
[ "Failed to coerce the variable \"" [ "Failed to coerce the variable \""
, Text.unpack variableName , variableName
, "\"." , "\"."
] ]
in Error{ message = queryErrorMessage, locations = [location], path = [] } in Error{ message = queryErrorMessage, locations = [location], path = [] }
queryError (UnknownInputType variableDefinition) = queryError (UnknownInputType variableDefinition) =
let Full.VariableDefinition variableName variableTypeName _ location = variableDefinition let Full.VariableDefinition variableName variableTypeName _ location = variableDefinition
queryErrorMessage = concat queryErrorMessage = Text.concat
[ "Variable \"" [ "Variable \""
, Text.unpack variableName , variableName
, "\" has unknown type \"" , "\" has unknown type \""
, show variableTypeName , Text.pack $ show variableTypeName
, "\"." , "\"."
] ]
in Error{ message = queryErrorMessage, locations = [location], path = [] } in Error{ message = queryErrorMessage, locations = [location], path = [] }
data Operation m = Operation Full.OperationType (Seq (Selection m)) data Operation m
= Operation Full.OperationType (Seq (Selection m)) Full.Location
data Selection m data Selection m
= FieldSelection (Field m) = FieldSelection (Field m)
@ -252,12 +243,12 @@ document = foldr filterOperation ([], HashMap.empty)
filterOperation _ accumulator = accumulator -- Type system definitions. filterOperation _ accumulator = accumulator -- Type system definitions.
transform :: Monad m => Full.OperationDefinition -> TransformT m (Operation m) transform :: Monad m => Full.OperationDefinition -> TransformT m (Operation m)
transform (Full.OperationDefinition operationType _ _ _ selectionSet' _) = do transform (Full.OperationDefinition operationType _ _ _ selectionSet' operationLocation) = do
transformedSelections <- selectionSet selectionSet' transformedSelections <- selectionSet selectionSet'
pure $ Operation operationType transformedSelections pure $ Operation operationType transformedSelections operationLocation
transform (Full.SelectionSet selectionSet' _) = do transform (Full.SelectionSet selectionSet' operationLocation) = do
transformedSelections <- selectionSet selectionSet' transformedSelections <- selectionSet selectionSet'
pure $ Operation Full.Query transformedSelections pure $ Operation Full.Query transformedSelections operationLocation
selectionSet :: Monad m => Full.SelectionSet -> TransformT m (Seq (Selection m)) selectionSet :: Monad m => Full.SelectionSet -> TransformT m (Seq (Selection m))
selectionSet = selectionSetOpt . NonEmpty.toList selectionSet = selectionSetOpt . NonEmpty.toList
@ -413,24 +404,34 @@ node :: Monad m => Full.Node Full.Value -> TransformT m (Maybe (Full.Node Input)
node Full.Node{node = node', ..} = node Full.Node{node = node', ..} =
traverse Full.Node <$> input node' <*> pure location 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) executeRequest :: (MonadCatch m, Coerce.Serialize a, Coerce.VariableValue b)
=> Schema m => Schema m
-> Full.Document -> Full.Document
-> Maybe String -> Maybe String
-> HashMap Full.Name b -> HashMap Full.Name b
-> m (Response a) -> m (Either (ResponseEventStream m a) (Response a))
executeRequest schema sourceDocument operationName variableValues = do executeRequest schema sourceDocument operationName variableValues = do
operationAndVariables <- sequence buildOperation operationAndVariables <- sequence buildOperation
case operationAndVariables of case operationAndVariables of
Left queryError' -> pure Left queryError' -> pure
$ Right
$ Response Coerce.null $ pure $ queryError queryError' $ Response Coerce.null $ pure $ queryError queryError'
Right operation Right operation
| Operation Full.Query topSelections <- operation -> | Operation Full.Query topSelections _operationLocation <- operation ->
executeQuery topSelections schema Right <$> executeQuery topSelections schema
| Operation Full.Mutation topSelections <- operation -> | Operation Full.Mutation topSelections operationLocation <- operation ->
executeMutation topSelections schema Right <$> executeMutation topSelections schema operationLocation
| Operation Full.Subscription topSelections <- operation -> | Operation Full.Subscription topSelections operationLocation <- operation ->
subscribe topSelections schema either rightErrorResponse Left <$> subscribe topSelections schema operationLocation
where where
schemaTypes = Schema.types schema schemaTypes = Schema.types schema
(operationDefinitions, fragmentDefinitions') = document sourceDocument (operationDefinitions, fragmentDefinitions') = document sourceDocument
@ -450,6 +451,9 @@ executeRequest schema sourceDocument operationName variableValues = do
$ runTransformT $ runTransformT
$ transform operationDefinition $ 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 :: [Full.OperationDefinition] -> Maybe String -> Either QueryError Full.OperationDefinition
getOperation [operation] Nothing = Right operation getOperation [operation] Nothing = Right operation
getOperation operations (Just givenOperationName) getOperation operations (Just givenOperationName)
@ -470,36 +474,31 @@ 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 [] $ executeSelectionSet topSelections queryType Type.Null []
pure $ Response data' errors pure $ Response data' errors
executeMutation :: (MonadCatch m, Coerce.Serialize a) executeMutation :: (MonadCatch m, Coerce.Serialize a)
=> Seq (Selection m) => Seq (Selection m)
-> Schema m -> Schema m
-> Full.Location
-> m (Response a) -> m (Response a)
executeMutation topSelections schema executeMutation topSelections schema operationLocation
| Just mutationType <- Schema.mutation schema = do | Just mutationType <- Schema.mutation schema = do
(data', errors) <- runWriterT (data', errors) <- runWriterT
$ flip runReaderT (Schema.types schema) $ flip runReaderT (Schema.types schema)
$ runExecutorT $ runExecutorT
$ executeSelectionSet topSelections mutationType Type.Null [] $ executeSelectionSet topSelections mutationType Type.Null []
pure $ Response data' errors pure $ Response data' errors
| otherwise = pure $ Response Coerce.null | otherwise = pure
[Error "Schema doesn't define a mutation type." [] []] $ Response Coerce.null
$ Seq.singleton
-- TODO: Subscribe. $ Error "Schema doesn't support mutations." [operationLocation] []
subscribe :: (MonadCatch m, Coerce.Serialize a)
=> Seq (Selection m)
-> Schema m
-> m (Response a)
subscribe _operation _schema =
pure $ Response Coerce.null mempty
executeSelectionSet :: (MonadCatch m, Coerce.Serialize a) executeSelectionSet :: (MonadCatch m, Coerce.Serialize a)
=> Seq (Selection m) => Seq (Selection m)
-> Out.ObjectType m -> Out.ObjectType m
-> Type.Value -> Type.Value
-> [Segment] -> [Path]
-> ExecutorT m a -> ExecutorT m a
executeSelectionSet selections objectType objectValue errorPath = do executeSelectionSet selections objectType objectValue errorPath = do
let groupedFieldSet = collectFields objectType selections let groupedFieldSet = collectFields objectType selections
@ -512,15 +511,15 @@ executeSelectionSet selections objectType objectValue errorPath = do
go fields@(Field _ fieldName _ _ _ :| _) = go fields@(Field _ fieldName _ _ _ :| _) =
traverse (executeField' fields) $ HashMap.lookup fieldName resolvers traverse (executeField' fields) $ HashMap.lookup fieldName resolvers
fieldsSegment :: forall m. NonEmpty (Field m) -> Segment fieldsSegment :: forall m. NonEmpty (Field m) -> Path
fieldsSegment (Field alias fieldName _ _ _ :| _) = fieldsSegment (Field alias fieldName _ _ _ :| _) =
Segment (Text.unpack $ fromMaybe fieldName alias) Segment (fromMaybe fieldName alias)
executeField :: (MonadCatch m, Coerce.Serialize a) executeField :: (MonadCatch m, Coerce.Serialize a)
=> Type.Value => Type.Value
-> NonEmpty (Field m) -> NonEmpty (Field m)
-> Out.Resolver m -> Out.Resolver m
-> [Segment] -> [Path]
-> ExecutorT m a -> ExecutorT m a
executeField objectValue fields resolver errorPath = executeField objectValue fields resolver errorPath =
let Field _ fieldName inputArguments _ fieldLocation :| _ = fields let Field _ fieldName inputArguments _ fieldLocation :| _ = fields
@ -531,8 +530,8 @@ executeField objectValue fields resolver errorPath =
-> GraphQLException -> GraphQLException
-> ExecutorT m a -> ExecutorT m a
exceptionHandler fieldLocation e = exceptionHandler fieldLocation e =
let newError = Error (displayException e) [fieldLocation] errorPath let newError = Error (Text.pack $ displayException e) [fieldLocation] errorPath
in ExecutorT (lift $ tell [newError]) >> pure Coerce.null in ExecutorT (lift $ tell $ Seq.singleton newError) >> pure Coerce.null
go fieldName inputArguments = do go fieldName inputArguments = do
let (Out.Field _ fieldType argumentTypes, resolveFunction) = let (Out.Field _ fieldType argumentTypes, resolveFunction) =
resolverField resolver resolverField resolver
@ -577,7 +576,7 @@ resolveAbstractType abstractType values'
completeValue :: (MonadCatch m, Coerce.Serialize a) completeValue :: (MonadCatch m, Coerce.Serialize a)
=> Out.Type m => Out.Type m
-> NonEmpty (Field m) -> NonEmpty (Field m)
-> [Segment] -> [Path]
-> Type.Value -> Type.Value
-> ExecutorT m a -> ExecutorT m a
completeValue outputType _ _ Type.Null completeValue outputType _ _ Type.Null
@ -648,7 +647,7 @@ 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 Input)
-> ExecutorT m Type.Subs -> m Type.Subs
coerceArgumentValues argumentDefinitions argumentValues = coerceArgumentValues argumentDefinitions argumentValues =
HashMap.foldrWithKey c pure argumentDefinitions mempty HashMap.foldrWithKey c pure argumentDefinitions mempty
where where
@ -759,3 +758,90 @@ constValue (Full.ConstObject o) =
where where
constObjectField Full.ObjectField{value = value', ..} = constObjectField Full.ObjectField{value = value', ..} =
(name, constValue $ Full.node 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