{- 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 DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeApplications #-}

-- | This module provides functions to execute a @GraphQL@ request.
module Language.GraphQL.Execute
    ( execute
    , module Language.GraphQL.Execute.Coerce
    ) where

import Conduit (mapMC, (.|))
import Control.Arrow (left)
import Control.Monad.Catch
     ( Exception(..)
     , Handler(..)
     , MonadCatch(..)
     , MonadThrow(..)
     , SomeException(..)
     , catches
     )
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Trans.Reader (ReaderT(..), ask, runReaderT)
import Control.Monad.Trans.Writer (WriterT(..), runWriterT)
import qualified Control.Monad.Trans.Writer as Writer
import Control.Monad (foldM)
import qualified Language.GraphQL.AST.Document as Full
import Data.Foldable (find)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe (fromMaybe)
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import qualified Data.Vector as Vector
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Typeable (cast)
import GHC.Records (HasField(..))
import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Execute.OrderedMap (OrderedMap)
import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
import qualified Language.GraphQL.Execute.Transform as Transform
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
import qualified Language.GraphQL.Type as Type
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(..)
    , ResolverException(..)
    , ResponseEventStream
    )
import Prelude hiding (null)
import Language.GraphQL.AST.Document (showVariableName)

newtype ExecutorT m a = ExecutorT
    { forall (m :: * -> *) a.
ExecutorT m a
-> ReaderT (HashMap Name (Type m)) (WriterT (Seq Error) m) a
runExecutorT :: ReaderT (HashMap Full.Name (Type m)) (WriterT (Seq Error) m) a
    }

instance Functor m => Functor (ExecutorT m) where
    fmap :: forall a b. (a -> b) -> ExecutorT m a -> ExecutorT m b
fmap a -> b
f = forall (m :: * -> *) a.
ReaderT (HashMap Name (Type m)) (WriterT (Seq Error) m) a
-> ExecutorT m a
ExecutorT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
ExecutorT m a
-> ReaderT (HashMap Name (Type m)) (WriterT (Seq Error) m) a
runExecutorT

instance Applicative m => Applicative (ExecutorT m) where
    pure :: forall a. a -> ExecutorT m a
pure = forall (m :: * -> *) a.
ReaderT (HashMap Name (Type m)) (WriterT (Seq Error) m) a
-> ExecutorT m a
ExecutorT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
    ExecutorT ReaderT (HashMap Name (Type m)) (WriterT (Seq Error) m) (a -> b)
f <*> :: forall a b. ExecutorT m (a -> b) -> ExecutorT m a -> ExecutorT m b
<*> ExecutorT ReaderT (HashMap Name (Type m)) (WriterT (Seq Error) m) a
x = forall (m :: * -> *) a.
ReaderT (HashMap Name (Type m)) (WriterT (Seq Error) m) a
-> ExecutorT m a
ExecutorT forall a b. (a -> b) -> a -> b
$ ReaderT (HashMap Name (Type m)) (WriterT (Seq Error) m) (a -> b)
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT (HashMap Name (Type m)) (WriterT (Seq Error) m) a
x

instance Monad m => Monad (ExecutorT m) where
    ExecutorT ReaderT (HashMap Name (Type m)) (WriterT (Seq Error) m) a
x >>= :: forall a b. ExecutorT m a -> (a -> ExecutorT m b) -> ExecutorT m b
>>= a -> ExecutorT m b
f = forall (m :: * -> *) a.
ReaderT (HashMap Name (Type m)) (WriterT (Seq Error) m) a
-> ExecutorT m a
ExecutorT forall a b. (a -> b) -> a -> b
$ ReaderT (HashMap Name (Type m)) (WriterT (Seq Error) m) a
x forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a.
ExecutorT m a
-> ReaderT (HashMap Name (Type m)) (WriterT (Seq Error) m) a
runExecutorT forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ExecutorT m b
f

instance MonadTrans ExecutorT where
    lift :: forall (m :: * -> *) a. Monad m => m a -> ExecutorT m a
lift = forall (m :: * -> *) a.
ReaderT (HashMap Name (Type m)) (WriterT (Seq Error) m) a
-> ExecutorT m a
ExecutorT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance MonadThrow m => MonadThrow (ExecutorT m) where
    throwM :: forall e a. Exception e => e -> ExecutorT m a
throwM = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM

instance MonadCatch m => MonadCatch (ExecutorT m) where
  catch :: forall e a.
Exception e =>
ExecutorT m a -> (e -> ExecutorT m a) -> ExecutorT m a
catch (ExecutorT ReaderT (HashMap Name (Type m)) (WriterT (Seq Error) m) a
stack) e -> ExecutorT m a
handler =
      forall (m :: * -> *) a.
ReaderT (HashMap Name (Type m)) (WriterT (Seq Error) m) a
-> ExecutorT m a
ExecutorT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch ReaderT (HashMap Name (Type m)) (WriterT (Seq Error) m) a
stack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
ExecutorT m a
-> ReaderT (HashMap Name (Type m)) (WriterT (Seq Error) m) a
runExecutorT forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> ExecutorT m a
handler

data GraphQLException = forall e. Exception e => GraphQLException e

instance Show GraphQLException where
    show :: GraphQLException -> String
show (GraphQLException e
e) = forall a. Show a => a -> String
show e
e

instance Exception GraphQLException

graphQLExceptionToException :: Exception e => e -> SomeException
graphQLExceptionToException :: forall e. Exception e => e -> SomeException
graphQLExceptionToException = forall e. Exception e => e -> SomeException
toException forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Exception e => e -> GraphQLException
GraphQLException

graphQLExceptionFromException :: Exception e => SomeException -> Maybe e
graphQLExceptionFromException :: forall e. Exception e => SomeException -> Maybe e
graphQLExceptionFromException SomeException
e = do
    GraphQLException e
graphqlException <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e
    forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
graphqlException

data ResultException = forall e. Exception e => ResultException e

instance Show ResultException where
    show :: ResultException -> String
show (ResultException e
e) = forall a. Show a => a -> String
show e
e

instance Exception ResultException where
    toException :: ResultException -> SomeException
toException = forall e. Exception e => e -> SomeException
graphQLExceptionToException
    fromException :: SomeException -> Maybe ResultException
fromException = forall e. Exception e => SomeException -> Maybe e
graphQLExceptionFromException

resultExceptionToException :: Exception e => e -> SomeException
resultExceptionToException :: forall e. Exception e => e -> SomeException
resultExceptionToException = forall e. Exception e => e -> SomeException
toException forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Exception e => e -> ResultException
ResultException

resultExceptionFromException :: Exception e => SomeException -> Maybe e
resultExceptionFromException :: forall e. Exception e => SomeException -> Maybe e
resultExceptionFromException SomeException
e = do
    ResultException e
resultException <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e
    forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
resultException

data FieldException = forall e. Exception e => FieldException Full.Location [Path] e

instance Show FieldException where
    show :: FieldException -> String
show (FieldException Location
_ [Path]
_ e
e) = forall e. Exception e => e -> String
displayException e
e

instance Exception FieldException where
    toException :: FieldException -> SomeException
toException = forall e. Exception e => e -> SomeException
graphQLExceptionToException
    fromException :: SomeException -> Maybe FieldException
fromException = forall e. Exception e => SomeException -> Maybe e
graphQLExceptionFromException

data ValueCompletionException = ValueCompletionException String Type.Value

instance Show ValueCompletionException where
    show :: ValueCompletionException -> String
show (ValueCompletionException String
typeRepresentation Value
found) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Value completion error. Expected type "
        , String
typeRepresentation
        , String
", found: "
        , forall a. Show a => a -> String
show Value
found
        , String
"."
        ]

instance Exception ValueCompletionException where
    toException :: ValueCompletionException -> SomeException
toException = forall e. Exception e => e -> SomeException
resultExceptionToException
    fromException :: SomeException -> Maybe ValueCompletionException
fromException = forall e. Exception e => SomeException -> Maybe e
resultExceptionFromException

data InputCoercionException =
    InputCoercionException String In.Type (Maybe (Full.Node Transform.Input))

instance Show InputCoercionException where
    show :: InputCoercionException -> String
show (InputCoercionException String
argumentName Type
argumentType Maybe (Node Input)
Nothing) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Required argument \""
        , String
argumentName
        , String
"\" of type "
        , forall a. Show a => a -> String
show Type
argumentType
        , String
" not specified."
        ]
    show (InputCoercionException String
argumentName Type
argumentType (Just Node Input
givenValue)) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Argument \""
        , String
argumentName
        , String
"\" has invalid type. Expected type "
        , forall a. Show a => a -> String
show Type
argumentType
        , String
", found: "
        , forall a. Show a => a -> String
show Node Input
givenValue
        , String
"."
        ]

instance Exception InputCoercionException where
    toException :: InputCoercionException -> SomeException
toException = forall e. Exception e => e -> SomeException
graphQLExceptionToException
    fromException :: SomeException -> Maybe InputCoercionException
fromException = forall e. Exception e => SomeException -> Maybe e
graphQLExceptionFromException

newtype ResultCoercionException = ResultCoercionException String

instance Show ResultCoercionException where
    show :: ResultCoercionException -> String
show (ResultCoercionException String
typeRepresentation) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ String
"Unable to coerce result to "
        , String
typeRepresentation
        , String
"."
        ]

instance Exception ResultCoercionException where
    toException :: ResultCoercionException -> SomeException
toException = forall e. Exception e => e -> SomeException
resultExceptionToException
    fromException :: SomeException -> Maybe ResultCoercionException
fromException = forall e. Exception e => SomeException -> Maybe e
resultExceptionFromException

-- | Query error types.
data QueryError
    = OperationNameRequired
    | OperationNotFound String
    | CoercionError Full.VariableDefinition
    | UnknownInputType Full.VariableDefinition

tell :: Monad m => Seq Error -> ExecutorT m ()
tell :: forall (m :: * -> *). Monad m => Seq Error -> ExecutorT m ()
tell = forall (m :: * -> *) a.
ReaderT (HashMap Name (Type m)) (WriterT (Seq Error) m) a
-> ExecutorT m a
ExecutorT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
Writer.tell

operationNameErrorText :: Text
operationNameErrorText :: Name
operationNameErrorText = [Name] -> Name
Text.unlines
    [ Name
"Named operations must be provided with the name of the desired operation."
    , Name
"See https://spec.graphql.org/June2018/#sec-Language.Document description."
    ]

queryError :: QueryError -> Error
queryError :: QueryError -> Error
queryError QueryError
OperationNameRequired =
    let queryErrorMessage :: Name
queryErrorMessage = Name
"Operation name is required. " forall a. Semigroup a => a -> a -> a
<> Name
operationNameErrorText
    in Error{ $sel:message:Error :: Name
message = Name
queryErrorMessage, $sel:locations:Error :: [Location]
locations = [], $sel:path:Error :: [Path]
path = [] }
queryError (OperationNotFound String
operationName) =
    let queryErrorMessage :: Name
queryErrorMessage = [Name] -> Name
Text.unlines
            [ [Name] -> Name
Text.concat
              [ Name
"Operation \""
              , String -> Name
Text.pack String
operationName
              , Name
"\" is not found in the named operations you've provided. "
              ]
            , Name
operationNameErrorText
            ]
     in Error{ $sel:message:Error :: Name
message = Name
queryErrorMessage, $sel:locations:Error :: [Location]
locations = [], $sel:path:Error :: [Path]
path = [] }
queryError (CoercionError VariableDefinition
variableDefinition) =
    let (Full.VariableDefinition Name
_ Type
_ Maybe (Node ConstValue)
_ Location
location) = VariableDefinition
variableDefinition
        queryErrorMessage :: Name
queryErrorMessage = [Name] -> Name
Text.concat
            [ Name
"Failed to coerce the variable "
            , String -> Name
Text.pack forall a b. (a -> b) -> a -> b
$ VariableDefinition -> String
Full.showVariable VariableDefinition
variableDefinition
            , Name
"."
            ]
     in Error{ $sel:message:Error :: Name
message = Name
queryErrorMessage, $sel:locations:Error :: [Location]
locations = [Location
location], $sel:path:Error :: [Path]
path = [] }
queryError (UnknownInputType VariableDefinition
variableDefinition) =
    let Full.VariableDefinition Name
_ Type
variableTypeName Maybe (Node ConstValue)
_ Location
location = VariableDefinition
variableDefinition
        queryErrorMessage :: Name
queryErrorMessage = [Name] -> Name
Text.concat
            [ Name
"Variable "
            , String -> Name
Text.pack forall a b. (a -> b) -> a -> b
$ VariableDefinition -> String
showVariableName VariableDefinition
variableDefinition
            , Name
" has unknown type "
            , String -> Name
Text.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Type
variableTypeName
            , Name
"."
            ]
     in Error{ $sel:message:Error :: Name
message = Name
queryErrorMessage, $sel:locations:Error :: [Location]
locations = [Location
location], $sel:path:Error :: [Path]
path = [] }

-- | The substitution is applied to the document, and the resolvers are applied
-- to the resulting fields. The operation name can be used if the document
-- defines multiple root operations.
--
-- Returns the result of the query against the schema wrapped in a /data/
-- field, or errors wrapped in an /errors/ field.
execute :: (MonadCatch m, VariableValue a, 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 :: forall (m :: * -> *) a b.
(MonadCatch m, VariableValue a, Serialize b) =>
Schema m
-> Maybe Name
-> HashMap Name a
-> Document
-> m (Either (ResponseEventStream m b) (Response b))
execute Schema m
schema' Maybe Name
operationName HashMap Name a
subs Document
document' =
    forall (m :: * -> *) a b.
(MonadCatch m, Serialize a, VariableValue b) =>
Schema m
-> Document
-> Maybe String
-> HashMap Name b
-> m (Either (ResponseEventStream m a) (Response a))
executeRequest Schema m
schema' Document
document' (Name -> String
Text.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Name
operationName) HashMap Name a
subs

executeRequest :: (MonadCatch m, Serialize a, VariableValue b)
    => Schema m
    -> Full.Document
    -> Maybe String
    -> HashMap Full.Name b
    -> m (Either (ResponseEventStream m a) (Response a))
executeRequest :: forall (m :: * -> *) a b.
(MonadCatch m, Serialize a, VariableValue b) =>
Schema m
-> Document
-> Maybe String
-> HashMap Name b
-> m (Either (ResponseEventStream m a) (Response a))
executeRequest Schema m
schema Document
sourceDocument Maybe String
operationName HashMap Name b
variableValues = do
    Either QueryError (Operation m)
operationAndVariables <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence Either QueryError (m (Operation m))
buildOperation
    case Either QueryError (Operation m)
operationAndVariables of
        Left QueryError
queryError' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure
            forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right
            forall a b. (a -> b) -> a -> b
$ forall a. a -> Seq Error -> Response a
Response forall a. Serialize a => a
null forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ QueryError -> Error
queryError QueryError
queryError'
        Right Operation m
operation
            | Transform.Operation OperationType
Full.Query Seq (Selection m)
topSelections Location
_operationLocation <- Operation m
operation ->
                 forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Seq (Selection m) -> Schema m -> m (Response a)
executeQuery Seq (Selection m)
topSelections Schema m
schema
            | Transform.Operation OperationType
Full.Mutation Seq (Selection m)
topSelections Location
operationLocation <- Operation m
operation ->
                forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Seq (Selection m) -> Schema m -> Location -> m (Response a)
executeMutation Seq (Selection m)
topSelections Schema m
schema Location
operationLocation
            | Transform.Operation OperationType
Full.Subscription Seq (Selection m)
topSelections Location
operationLocation <- Operation m
operation ->
                forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall b a. Serialize b => Error -> Either a (Response b)
rightErrorResponse forall a b. a -> Either a b
Left forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Seq (Selection m)
-> Schema m
-> Location
-> m (Either Error (ResponseEventStream m a))
subscribe Seq (Selection m)
topSelections Schema m
schema Location
operationLocation
  where
    schemaTypes :: HashMap Name (Type m)
schemaTypes = forall (m :: * -> *). Schema m -> HashMap Name (Type m)
Schema.types Schema m
schema
    ([OperationDefinition]
operationDefinitions, HashMap Name FragmentDefinition
fragmentDefinitions') =
        Document
-> ([OperationDefinition], HashMap Name FragmentDefinition)
Transform.document Document
sourceDocument
    buildOperation :: Either QueryError (m (Operation m))
buildOperation = do
        OperationDefinition
operationDefinition <- [OperationDefinition]
-> Maybe String -> Either QueryError OperationDefinition
getOperation [OperationDefinition]
operationDefinitions Maybe String
operationName
        Subs
coercedVariableValues <- forall (m :: * -> *) b.
(Monad m, VariableValue b) =>
HashMap Name (Type m)
-> OperationDefinition -> HashMap Name b -> Either QueryError Subs
coerceVariableValues
            HashMap Name (Type m)
schemaTypes
            OperationDefinition
operationDefinition
            HashMap Name b
variableValues
        let replacement :: Replacement m
replacement = Transform.Replacement
                { variableValues :: Subs
variableValues = Subs
coercedVariableValues
                , fragmentDefinitions :: HashMap Name FragmentDefinition
fragmentDefinitions = HashMap Name FragmentDefinition
fragmentDefinitions'
                , visitedFragments :: HashSet Name
visitedFragments = forall a. Monoid a => a
mempty
                , types :: HashMap Name (Type m)
types = HashMap Name (Type m)
schemaTypes
                }
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Replacement m
replacement
            forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
TransformT m a -> ReaderT (Replacement m) m a
Transform.runTransformT
            forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Monad m =>
OperationDefinition -> TransformT m (Operation m)
Transform.transform OperationDefinition
operationDefinition

rightErrorResponse :: Serialize b => forall a. Error -> Either a (Response b)
rightErrorResponse :: forall b a. Serialize b => Error -> Either a (Response b)
rightErrorResponse = forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Seq Error -> Response a
Response forall a. Serialize a => a
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure

getOperation :: [Full.OperationDefinition] -> Maybe String -> Either QueryError Full.OperationDefinition
getOperation :: [OperationDefinition]
-> Maybe String -> Either QueryError OperationDefinition
getOperation [OperationDefinition
operation] Maybe String
Nothing = forall a b. b -> Either a b
Right OperationDefinition
operation
getOperation [OperationDefinition]
operations (Just String
givenOperationName)
    = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> QueryError
OperationNotFound String
givenOperationName) forall a b. b -> Either a b
Right
    forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find OperationDefinition -> Bool
findOperationByName [OperationDefinition]
operations
  where
    findOperationByName :: OperationDefinition -> Bool
findOperationByName (Full.OperationDefinition OperationType
_ (Just Name
operationName) [VariableDefinition]
_ [Directive]
_ SelectionSet
_ Location
_) =
        String
givenOperationName forall a. Eq a => a -> a -> Bool
== Name -> String
Text.unpack Name
operationName
    findOperationByName OperationDefinition
_ = Bool
False
getOperation [OperationDefinition]
_ Maybe String
_ = forall a b. a -> Either a b
Left QueryError
OperationNameRequired

executeQuery :: (MonadCatch m, Serialize a)
    => Seq (Transform.Selection m)
    -> Schema m
    -> m (Response a)
executeQuery :: forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Seq (Selection m) -> Schema m -> m (Response a)
executeQuery Seq (Selection m)
topSelections Schema m
schema = do
    let queryType :: ObjectType m
queryType = forall (m :: * -> *). Schema m -> ObjectType m
Schema.query Schema m
schema
    (a
data', Seq Error
errors) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT
        forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall (m :: * -> *). Schema m -> HashMap Name (Type m)
Schema.types Schema m
schema)
        forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
ExecutorT m a
-> ReaderT (HashMap Name (Type m)) (WriterT (Seq Error) m) a
runExecutorT
        forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Seq (Selection m)
-> ObjectType m -> Value -> [Path] -> ExecutorT m a
executeSelectionSet Seq (Selection m)
topSelections ObjectType m
queryType Value
Type.Null [])
        forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
FieldException -> ExecutorT m a
handleException
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Seq Error -> Response a
Response a
data' Seq Error
errors

handleException :: (MonadCatch m, Serialize a)
    => FieldException
    -> ExecutorT m a
handleException :: forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
FieldException -> ExecutorT m a
handleException (FieldException Location
fieldLocation [Path]
errorPath e
next) =
    let newError :: Error
newError = forall e. Exception e => e -> Location -> [Path] -> Error
constructError e
next Location
fieldLocation [Path]
errorPath
     in forall (m :: * -> *). Monad m => Seq Error -> ExecutorT m ()
tell (forall a. a -> Seq a
Seq.singleton Error
newError) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Serialize a => a
null

constructError :: Exception e => e -> Full.Location -> [Path] -> Error
constructError :: forall e. Exception e => e -> Location -> [Path] -> Error
constructError e
e Location
fieldLocation [Path]
errorPath = Error
    { $sel:message:Error :: Name
message = String -> Name
Text.pack (forall e. Exception e => e -> String
displayException e
e)
    , $sel:path:Error :: [Path]
path = forall a. [a] -> [a]
reverse [Path]
errorPath
    , $sel:locations:Error :: [Location]
locations = [Location
fieldLocation]
    }

executeMutation :: (MonadCatch m, Serialize a)
    => Seq (Transform.Selection m)
    -> Schema m
    -> Full.Location
    -> m (Response a)
executeMutation :: forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Seq (Selection m) -> Schema m -> Location -> m (Response a)
executeMutation Seq (Selection m)
topSelections Schema m
schema Location
operationLocation
    | Just ObjectType m
mutationType <- forall (m :: * -> *). Schema m -> Maybe (ObjectType m)
Schema.mutation Schema m
schema = do
        (a
data', Seq Error
errors) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT
            forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall (m :: * -> *). Schema m -> HashMap Name (Type m)
Schema.types Schema m
schema)
            forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
ExecutorT m a
-> ReaderT (HashMap Name (Type m)) (WriterT (Seq Error) m) a
runExecutorT
            forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Seq (Selection m)
-> ObjectType m -> Value -> [Path] -> ExecutorT m a
executeSelectionSet Seq (Selection m)
topSelections ObjectType m
mutationType Value
Type.Null [])
            forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
FieldException -> ExecutorT m a
handleException
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Seq Error -> Response a
Response a
data' Seq Error
errors
    | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure
        forall a b. (a -> b) -> a -> b
$ forall a. a -> Seq Error -> Response a
Response forall a. Serialize a => a
null
        forall a b. (a -> b) -> a -> b
$ forall a. a -> Seq a
Seq.singleton
        forall a b. (a -> b) -> a -> b
$ Name -> [Location] -> [Path] -> Error
Error Name
"Schema doesn't support mutations." [Location
operationLocation] []

executeSelectionSet :: (MonadCatch m, Serialize a)
    => Seq (Transform.Selection m)
    -> Out.ObjectType m
    -> Type.Value
    -> [Path]
    -> ExecutorT m a
executeSelectionSet :: forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Seq (Selection m)
-> ObjectType m -> Value -> [Path] -> ExecutorT m a
executeSelectionSet Seq (Selection m)
selections ObjectType m
objectType Value
objectValue [Path]
errorPath = do
    let groupedFieldSet :: OrderedMap (NonEmpty (Field m))
groupedFieldSet = forall (m :: * -> *).
Monad m =>
ObjectType m
-> Seq (Selection m) -> OrderedMap (NonEmpty (Field m))
collectFields ObjectType m
objectType Seq (Selection m)
selections
    OrderedMap a
resolvedValues <- forall (f :: * -> *) b a.
Applicative f =>
(a -> f (Maybe b)) -> OrderedMap a -> f (OrderedMap b)
OrderedMap.traverseMaybe forall {b}.
Serialize b =>
NonEmpty (Field m) -> ExecutorT m (Maybe b)
go OrderedMap (NonEmpty (Field m))
groupedFieldSet
    forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Type m -> Output a -> ExecutorT m a
coerceResult (forall (m :: * -> *). ObjectType m -> Type m
Out.NonNullObjectType ObjectType m
objectType) forall a b. (a -> b) -> a -> b
$ forall a. OrderedMap a -> Output a
Object OrderedMap a
resolvedValues
  where
    executeField' :: NonEmpty (Field m) -> Resolver m -> ExecutorT m a
executeField' NonEmpty (Field m)
fields Resolver m
resolver =
        forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Value
-> NonEmpty (Field m) -> Resolver m -> [Path] -> ExecutorT m a
executeField Value
objectValue NonEmpty (Field m)
fields Resolver m
resolver [Path]
errorPath
    Out.ObjectType Name
_ Maybe Name
_ [InterfaceType m]
_ HashMap Name (Resolver m)
resolvers = ObjectType m
objectType
    go :: NonEmpty (Field m) -> ExecutorT m (Maybe b)
go fields :: NonEmpty (Field m)
fields@(Transform.Field Maybe Name
_ Name
fieldName HashMap Name (Node Input)
_ Seq (Selection m)
_ Location
_ :| [Field m]
_) =
        forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall {m :: * -> *} {a}.
(MonadCatch m, Serialize a) =>
NonEmpty (Field m) -> Resolver m -> ExecutorT m a
executeField' NonEmpty (Field m)
fields) forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
fieldName HashMap Name (Resolver m)
resolvers

fieldsSegment :: forall m. NonEmpty (Transform.Field m) -> Path
fieldsSegment :: forall (m :: * -> *). NonEmpty (Field m) -> Path
fieldsSegment (Transform.Field Maybe Name
alias Name
fieldName HashMap Name (Node Input)
_ Seq (Selection m)
_ Location
_ :| [Field m]
_) =
    Name -> Path
Segment (forall a. a -> Maybe a -> a
fromMaybe Name
fieldName Maybe Name
alias)

viewResolver :: Out.Resolver m -> (Out.Field m, Out.Resolve m)
viewResolver :: forall (m :: * -> *). Resolver m -> (Field m, Resolve m)
viewResolver (Out.ValueResolver Field m
resolverField' Resolve m
resolveFunction) =
    (Field m
resolverField', Resolve m
resolveFunction)
viewResolver (Out.EventStreamResolver Field m
resolverField' Resolve m
resolveFunction Subscribe m
_) =
    (Field m
resolverField', Resolve m
resolveFunction)

executeField :: forall m a
    . (MonadCatch m, Serialize a)
    => Type.Value
    -> NonEmpty (Transform.Field m)
    -> Out.Resolver m
    -> [Path]
    -> ExecutorT m a
executeField :: forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Value
-> NonEmpty (Field m) -> Resolver m -> [Path] -> ExecutorT m a
executeField Value
objectValue NonEmpty (Field m)
fields (forall (m :: * -> *). Resolver m -> (Field m, Resolve m)
viewResolver -> (Field m, Resolve m)
resolverPair) [Path]
errorPath =
    let Transform.Field Maybe Name
_ Name
fieldName HashMap Name (Node Input)
inputArguments Seq (Selection m)
_ Location
fieldLocation :| [Field m]
_ = NonEmpty (Field m)
fields
     in forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, MonadCatch m) =>
m a -> f (Handler m a) -> m a
catches (forall {b}.
Serialize b =>
Name -> HashMap Name (Node Input) -> ExecutorT m b
go Name
fieldName HashMap Name (Node Input)
inputArguments)
        [ forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
FieldException -> ExecutorT m a
nullResultHandler
        , forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Location -> InputCoercionException -> ExecutorT m a
inputCoercionHandler Location
fieldLocation)
        , forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Location -> ResultException -> ExecutorT m a
resultHandler Location
fieldLocation)
        , forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Location -> ResolverException -> ExecutorT m a
resolverHandler Location
fieldLocation)
        ]
  where
    fieldErrorPath :: [Path]
fieldErrorPath = forall (m :: * -> *). NonEmpty (Field m) -> Path
fieldsSegment NonEmpty (Field m)
fields forall a. a -> [a] -> [a]
: [Path]
errorPath
    inputCoercionHandler :: (MonadCatch m, Serialize a)
        => Full.Location
        -> InputCoercionException
        -> ExecutorT m a
    inputCoercionHandler :: forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Location -> InputCoercionException -> ExecutorT m a
inputCoercionHandler Location
_ e :: InputCoercionException
e@(InputCoercionException String
_ Type
_ (Just Node Input
valueNode)) =
        let argumentLocation :: Location
argumentLocation = forall {k} (x :: k) r a. HasField x r a => r -> a
getField @"location" Node Input
valueNode
         in forall {m :: * -> *} {e} {a}.
(MonadThrow m, Serialize a, Exception e) =>
Location -> e -> ExecutorT m a
exceptionHandler Location
argumentLocation InputCoercionException
e
    inputCoercionHandler Location
fieldLocation InputCoercionException
e = forall {m :: * -> *} {e} {a}.
(MonadThrow m, Serialize a, Exception e) =>
Location -> e -> ExecutorT m a
exceptionHandler Location
fieldLocation InputCoercionException
e
    resultHandler :: (MonadCatch m, Serialize a)
        => Full.Location
        -> ResultException
        -> ExecutorT m a
    resultHandler :: forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Location -> ResultException -> ExecutorT m a
resultHandler = forall {m :: * -> *} {e} {a}.
(MonadThrow m, Serialize a, Exception e) =>
Location -> e -> ExecutorT m a
exceptionHandler
    resolverHandler :: (MonadCatch m, Serialize a)
        => Full.Location
        -> ResolverException
        -> ExecutorT m a
    resolverHandler :: forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Location -> ResolverException -> ExecutorT m a
resolverHandler = forall {m :: * -> *} {e} {a}.
(MonadThrow m, Serialize a, Exception e) =>
Location -> e -> ExecutorT m a
exceptionHandler
    nullResultHandler :: (MonadCatch m, Serialize a)
        => FieldException
        -> ExecutorT m a
    nullResultHandler :: forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
FieldException -> ExecutorT m a
nullResultHandler e :: FieldException
e@(FieldException Location
fieldLocation [Path]
errorPath' e
next) =
        let newError :: Error
newError = forall e. Exception e => e -> Location -> [Path] -> Error
constructError e
next Location
fieldLocation [Path]
errorPath'
         in if forall (m :: * -> *). Type m -> Bool
Out.isNonNullType Type m
fieldType
             then forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM FieldException
e
             else forall {m :: * -> *} {b}.
(Monad m, Serialize b) =>
Error -> ExecutorT m b
returnError Error
newError
    exceptionHandler :: Location -> e -> ExecutorT m a
exceptionHandler Location
errorLocation e
e =
        let newError :: Error
newError = forall e. Exception e => e -> Location -> [Path] -> Error
constructError e
e Location
errorLocation [Path]
fieldErrorPath
         in if forall (m :: * -> *). Type m -> Bool
Out.isNonNullType Type m
fieldType
             then forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ forall e. Exception e => Location -> [Path] -> e -> FieldException
FieldException Location
errorLocation [Path]
fieldErrorPath e
e
             else forall {m :: * -> *} {b}.
(Monad m, Serialize b) =>
Error -> ExecutorT m b
returnError Error
newError
    returnError :: Error -> ExecutorT m b
returnError Error
newError = forall (m :: * -> *). Monad m => Seq Error -> ExecutorT m ()
tell (forall a. a -> Seq a
Seq.singleton Error
newError) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Serialize a => a
null
    go :: Name -> HashMap Name (Node Input) -> ExecutorT m b
go Name
fieldName HashMap Name (Node Input)
inputArguments = do
        Subs
argumentValues <- forall (m :: * -> *).
MonadCatch m =>
HashMap Name Argument -> HashMap Name (Node Input) -> m Subs
coerceArgumentValues HashMap Name Argument
argumentTypes HashMap Name (Node Input)
inputArguments
        Value
resolvedValue <-
           forall (m :: * -> *).
MonadCatch m =>
Resolve m -> Value -> Name -> Subs -> ExecutorT m Value
resolveFieldValue Resolve m
resolveFunction Value
objectValue Name
fieldName Subs
argumentValues
        forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Type m -> NonEmpty (Field m) -> [Path] -> Value -> ExecutorT m a
completeValue Type m
fieldType NonEmpty (Field m)
fields [Path]
fieldErrorPath Value
resolvedValue
    (Field m
resolverField, Resolve m
resolveFunction) = (Field m, Resolve m)
resolverPair
    Out.Field Maybe Name
_ Type m
fieldType HashMap Name Argument
argumentTypes = Field m
resolverField

resolveFieldValue :: MonadCatch m
    => Out.Resolve m
    -> Type.Value
    -> Full.Name
    -> Type.Subs
    -> ExecutorT m Type.Value
resolveFieldValue :: forall (m :: * -> *).
MonadCatch m =>
Resolve m -> Value -> Name -> Subs -> ExecutorT m Value
resolveFieldValue Resolve m
resolver Value
objectValue Name
_fieldName Subs
argumentValues =
    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Resolve m
resolver Context
context
  where
    context :: Context
context = Type.Context
        { arguments :: Arguments
Type.arguments = Subs -> Arguments
Type.Arguments Subs
argumentValues
        , values :: Value
Type.values = Value
objectValue
        }

resolveAbstractType :: Monad m
    => Type.Internal.AbstractType m
    -> Type.Subs
    -> ExecutorT m (Maybe (Out.ObjectType m))
resolveAbstractType :: forall (m :: * -> *).
Monad m =>
AbstractType m -> Subs -> ExecutorT m (Maybe (ObjectType m))
resolveAbstractType AbstractType m
abstractType Subs
values'
    | Just (Type.String Name
typeName) <- forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
"__typename" Subs
values' = do
        HashMap Name (Type m)
types' <- forall (m :: * -> *) a.
ReaderT (HashMap Name (Type m)) (WriterT (Seq Error) m) a
-> ExecutorT m a
ExecutorT forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
        case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
typeName HashMap Name (Type m)
types' of
            Just (Type.Internal.ObjectType ObjectType m
objectType) ->
                if forall (m :: * -> *). ObjectType m -> AbstractType m -> Bool
Type.Internal.instanceOf ObjectType m
objectType AbstractType m
abstractType
                    then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ObjectType m
objectType
                    else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
            Maybe (Type m)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
    | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

-- https://spec.graphql.org/October2021/#sec-Value-Completion
completeValue :: (MonadCatch m, Serialize a)
    => Out.Type m
    -> NonEmpty (Transform.Field m)
    -> [Path]
    -> Type.Value
    -> ExecutorT m a
completeValue :: forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Type m -> NonEmpty (Field m) -> [Path] -> Value -> ExecutorT m a
completeValue (forall (m :: * -> *). Type m -> Bool
Out.isNonNullType -> Bool
False) NonEmpty (Field m)
_ [Path]
_ Value
Type.Null =
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Serialize a => a
null
completeValue outputType :: Type m
outputType@(Out.ListBaseType Type m
listType) NonEmpty (Field m)
fields [Path]
errorPath (Type.List [Value]
list)
    = forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall {a}.
Serialize a =>
Vector a -> Value -> ExecutorT m (Vector a)
go forall a. Vector a
Vector.empty [Value]
list forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Type m -> Output a -> ExecutorT m a
coerceResult Type m
outputType forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Output a
List forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Vector a -> [a]
Vector.toList
  where
    go :: Vector a -> Value -> ExecutorT m (Vector a)
go Vector a
accumulator Value
listItem =
        let updatedPath :: [Path]
updatedPath = Int -> Path
Index (forall a. Vector a -> Int
Vector.length Vector a
accumulator) forall a. a -> [a] -> [a]
: [Path]
errorPath
         in forall a. Vector a -> a -> Vector a
Vector.snoc Vector a
accumulator
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Type m -> NonEmpty (Field m) -> [Path] -> Value -> ExecutorT m a
completeValue Type m
listType NonEmpty (Field m)
fields [Path]
updatedPath Value
listItem
completeValue outputType :: Type m
outputType@(Out.ScalarBaseType ScalarType
_) NonEmpty (Field m)
_ [Path]
_ (Type.Int Int32
int) =
    forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Type m -> Output a -> ExecutorT m a
coerceResult Type m
outputType forall a b. (a -> b) -> a -> b
$ forall a. Int32 -> Output a
Int Int32
int
completeValue outputType :: Type m
outputType@(Out.ScalarBaseType ScalarType
_) NonEmpty (Field m)
_ [Path]
_ (Type.Boolean Bool
boolean) =
    forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Type m -> Output a -> ExecutorT m a
coerceResult Type m
outputType forall a b. (a -> b) -> a -> b
$ forall a. Bool -> Output a
Boolean Bool
boolean
completeValue outputType :: Type m
outputType@(Out.ScalarBaseType ScalarType
_) NonEmpty (Field m)
_ [Path]
_ (Type.Float Double
float) =
    forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Type m -> Output a -> ExecutorT m a
coerceResult Type m
outputType forall a b. (a -> b) -> a -> b
$ forall a. Double -> Output a
Float Double
float
completeValue outputType :: Type m
outputType@(Out.ScalarBaseType ScalarType
_) NonEmpty (Field m)
_ [Path]
_ (Type.String Name
string) =
    forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Type m -> Output a -> ExecutorT m a
coerceResult Type m
outputType forall a b. (a -> b) -> a -> b
$ forall a. Name -> Output a
String Name
string
completeValue outputType :: Type m
outputType@(Out.EnumBaseType EnumType
enumType) NonEmpty (Field m)
_ [Path]
_ (Type.Enum Name
enum) =
    let Type.EnumType Name
_ Maybe Name
_ HashMap Name EnumValue
enumMembers = EnumType
enumType
     in if forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HashMap.member Name
enum HashMap Name EnumValue
enumMembers
        then forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Type m -> Output a -> ExecutorT m a
coerceResult Type m
outputType forall a b. (a -> b) -> a -> b
$ forall a. Name -> Output a
Enum Name
enum
        else forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
            forall a b. (a -> b) -> a -> b
$ String -> Value -> ValueCompletionException
ValueCompletionException (forall a. Show a => a -> String
show Type m
outputType)
            forall a b. (a -> b) -> a -> b
$ Name -> Value
Type.Enum Name
enum
completeValue (Out.ObjectBaseType ObjectType m
objectType) NonEmpty (Field m)
fields [Path]
errorPath Value
result
    = forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Seq (Selection m)
-> ObjectType m -> Value -> [Path] -> ExecutorT m a
executeSelectionSet (forall (m :: * -> *).
MonadCatch m =>
NonEmpty (Field m) -> Seq (Selection m)
mergeSelectionSets NonEmpty (Field m)
fields) ObjectType m
objectType Value
result [Path]
errorPath
completeValue outputType :: Type m
outputType@(Out.InterfaceBaseType InterfaceType m
interfaceType) NonEmpty (Field m)
fields [Path]
errorPath Value
result
    | Type.Object Subs
objectMap <- Value
result = do
        let abstractType :: AbstractType m
abstractType = forall (m :: * -> *). InterfaceType m -> AbstractType m
Type.Internal.AbstractInterfaceType InterfaceType m
interfaceType
        Maybe (ObjectType m)
concreteType <- forall (m :: * -> *).
Monad m =>
AbstractType m -> Subs -> ExecutorT m (Maybe (ObjectType m))
resolveAbstractType AbstractType m
abstractType Subs
objectMap
        case Maybe (ObjectType m)
concreteType of
            Just ObjectType m
objectType
                -> forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Seq (Selection m)
-> ObjectType m -> Value -> [Path] -> ExecutorT m a
executeSelectionSet (forall (m :: * -> *).
MonadCatch m =>
NonEmpty (Field m) -> Seq (Selection m)
mergeSelectionSets NonEmpty (Field m)
fields) ObjectType m
objectType Value
result
                forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). NonEmpty (Field m) -> Path
fieldsSegment NonEmpty (Field m)
fields forall a. a -> [a] -> [a]
: [Path]
errorPath
            Maybe (ObjectType m)
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
                forall a b. (a -> b) -> a -> b
$ String -> Value -> ValueCompletionException
ValueCompletionException (forall a. Show a => a -> String
show Type m
outputType) Value
result
completeValue outputType :: Type m
outputType@(Out.UnionBaseType UnionType m
unionType) NonEmpty (Field m)
fields [Path]
errorPath Value
result
    | Type.Object Subs
objectMap <- Value
result = do
        let abstractType :: AbstractType m
abstractType = forall (m :: * -> *). UnionType m -> AbstractType m
Type.Internal.AbstractUnionType UnionType m
unionType
        Maybe (ObjectType m)
concreteType <- forall (m :: * -> *).
Monad m =>
AbstractType m -> Subs -> ExecutorT m (Maybe (ObjectType m))
resolveAbstractType AbstractType m
abstractType Subs
objectMap
        case Maybe (ObjectType m)
concreteType of
            Just ObjectType m
objectType
                -> forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Seq (Selection m)
-> ObjectType m -> Value -> [Path] -> ExecutorT m a
executeSelectionSet (forall (m :: * -> *).
MonadCatch m =>
NonEmpty (Field m) -> Seq (Selection m)
mergeSelectionSets NonEmpty (Field m)
fields) ObjectType m
objectType Value
result
                forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). NonEmpty (Field m) -> Path
fieldsSegment NonEmpty (Field m)
fields forall a. a -> [a] -> [a]
: [Path]
errorPath
            Maybe (ObjectType m)
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
                forall a b. (a -> b) -> a -> b
$ String -> Value -> ValueCompletionException
ValueCompletionException (forall a. Show a => a -> String
show Type m
outputType) Value
result
completeValue Type m
outputType NonEmpty (Field m)
_ [Path]
_ Value
result =
    forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> Value -> ValueCompletionException
ValueCompletionException (forall a. Show a => a -> String
show Type m
outputType) Value
result

coerceResult :: (MonadCatch m, Serialize a)
    => Out.Type m
    -> Output a
    -> ExecutorT m a
coerceResult :: forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Type m -> Output a -> ExecutorT m a
coerceResult Type m
outputType Output a
result
    | Just a
serialized <- forall a (m :: * -> *).
Serialize a =>
Type m -> Output a -> Maybe a
serialize Type m
outputType Output a
result = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
serialized
    | Bool
otherwise = forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ String -> ResultCoercionException
ResultCoercionException forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Type m
outputType

mergeSelectionSets :: MonadCatch m
    => NonEmpty (Transform.Field m)
    -> Seq (Transform.Selection m)
mergeSelectionSets :: forall (m :: * -> *).
MonadCatch m =>
NonEmpty (Field m) -> Seq (Selection m)
mergeSelectionSets = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {m :: * -> *}.
Field m -> Seq (Selection m) -> Seq (Selection m)
forEach forall a. Monoid a => a
mempty
  where
    forEach :: Field m -> Seq (Selection m) -> Seq (Selection m)
forEach (Transform.Field Maybe Name
_ Name
_ HashMap Name (Node Input)
_ Seq (Selection m)
fieldSelectionSet Location
_) Seq (Selection m)
selectionSet' =
        Seq (Selection m)
selectionSet' forall a. Semigroup a => a -> a -> a
<> Seq (Selection m)
fieldSelectionSet

coerceArgumentValues :: MonadCatch m
    => HashMap Full.Name In.Argument
    -> HashMap Full.Name (Full.Node Transform.Input)
    -> m Type.Subs
coerceArgumentValues :: forall (m :: * -> *).
MonadCatch m =>
HashMap Name Argument -> HashMap Name (Node Input) -> m Subs
coerceArgumentValues HashMap Name Argument
argumentDefinitions HashMap Name (Node Input)
argumentValues =
    forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
HashMap.foldrWithKey forall {m :: * -> *} {b}.
MonadCatch m =>
Name -> Argument -> (Subs -> m b) -> Subs -> m b
c forall (f :: * -> *) a. Applicative f => a -> f a
pure HashMap Name Argument
argumentDefinitions forall a. Monoid a => a
mempty
  where
    c :: Name -> Argument -> (Subs -> m b) -> Subs -> m b
c Name
argumentName Argument
argumentType Subs -> m b
pure' Subs
resultMap =
        forall (m :: * -> *).
MonadCatch m =>
Name -> Argument -> Subs -> m Subs
forEach Name
argumentName Argument
argumentType Subs
resultMap forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Subs -> m b
pure'
    forEach :: MonadCatch m
         => Full.Name
         -> In.Argument
         -> Type.Subs
         -> m Type.Subs
    forEach :: forall (m :: * -> *).
MonadCatch m =>
Name -> Argument -> Subs -> m Subs
forEach Name
argumentName (In.Argument Maybe Name
_ Type
variableType Maybe Value
defaultValue) Subs
resultMap = do
        let matchedMap :: Maybe Subs
matchedMap
                = Name -> Type -> Maybe Value -> Maybe Subs -> Maybe Subs
matchFieldValues' Name
argumentName Type
variableType Maybe Value
defaultValue
                forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Subs
resultMap
         in case Maybe Subs
matchedMap of
            Just Subs
matchedValues -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Subs
matchedValues
            Maybe Subs
Nothing
                | Just Node Input
inputValue <- forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
argumentName HashMap Name (Node Input)
argumentValues
                    -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
                    forall a b. (a -> b) -> a -> b
$ String -> Type -> Maybe (Node Input) -> InputCoercionException
InputCoercionException (Name -> String
Text.unpack Name
argumentName) Type
variableType
                    forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Node Input
inputValue
                | Bool
otherwise -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM
                    forall a b. (a -> b) -> a -> b
$ String -> Type -> Maybe (Node Input) -> InputCoercionException
InputCoercionException (Name -> String
Text.unpack Name
argumentName) Type
variableType forall a. Maybe a
Nothing
    matchFieldValues' :: Name -> Type -> Maybe Value -> Maybe Subs -> Maybe Subs
matchFieldValues' = forall a.
(Type -> a -> Maybe Value)
-> HashMap Name a
-> Name
-> Type
-> Maybe Value
-> Maybe Subs
-> Maybe Subs
matchFieldValues Type -> Input -> Maybe Value
coerceArgumentValue
        forall a b. (a -> b) -> a -> b
$ forall a. Node a -> a
Full.node forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap Name (Node Input)
argumentValues
    coerceArgumentValue :: Type -> Input -> Maybe Value
coerceArgumentValue Type
inputType (Transform.Int Int32
integer) =
        Type -> Value -> Maybe Value
coerceInputLiteral Type
inputType (Int32 -> Value
Type.Int Int32
integer)
    coerceArgumentValue Type
inputType (Transform.Boolean Bool
boolean) =
        Type -> Value -> Maybe Value
coerceInputLiteral Type
inputType (Bool -> Value
Type.Boolean Bool
boolean)
    coerceArgumentValue Type
inputType (Transform.String Name
string) =
        Type -> Value -> Maybe Value
coerceInputLiteral Type
inputType (Name -> Value
Type.String Name
string)
    coerceArgumentValue Type
inputType (Transform.Float Double
float) =
        Type -> Value -> Maybe Value
coerceInputLiteral Type
inputType (Double -> Value
Type.Float Double
float)
    coerceArgumentValue Type
inputType (Transform.Enum Name
enum) =
        Type -> Value -> Maybe Value
coerceInputLiteral Type
inputType (Name -> Value
Type.Enum Name
enum)
    coerceArgumentValue Type
inputType Input
Transform.Null
        | Type -> Bool
In.isNonNullType Type
inputType = forall a. Maybe a
Nothing
        | Bool
otherwise = Type -> Value -> Maybe Value
coerceInputLiteral Type
inputType Value
Type.Null
    coerceArgumentValue (In.ListBaseType Type
inputType) (Transform.List [Input]
list) =
        let coerceItem :: Input -> Maybe Value
coerceItem = Type -> Input -> Maybe Value
coerceArgumentValue Type
inputType
         in [Value] -> Value
Type.List forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Input -> Maybe Value
coerceItem [Input]
list
    coerceArgumentValue (In.InputObjectBaseType InputObjectType
inputType) (Transform.Object HashMap Name Input
object)
        | In.InputObjectType Name
_ Maybe Name
_ HashMap Name InputField
inputFields <- InputObjectType
inputType = 
            let go :: Name -> InputField -> Maybe Subs -> Maybe Subs
go = HashMap Name Input
-> Name -> InputField -> Maybe Subs -> Maybe Subs
forEachField HashMap Name Input
object
                resultMap :: Maybe Subs
resultMap = forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
HashMap.foldrWithKey Name -> InputField -> Maybe Subs -> Maybe Subs
go (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty) HashMap Name InputField
inputFields
             in Subs -> Value
Type.Object forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Subs
resultMap
    coerceArgumentValue Type
_ (Transform.Variable Value
variable) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
variable
    coerceArgumentValue Type
_ Input
_ = forall a. Maybe a
Nothing
    forEachField :: HashMap Name Input
-> Name -> InputField -> Maybe Subs -> Maybe Subs
forEachField HashMap Name Input
object Name
variableName (In.InputField Maybe Name
_ Type
variableType Maybe Value
defaultValue) =
        forall a.
(Type -> a -> Maybe Value)
-> HashMap Name a
-> Name
-> Type
-> Maybe Value
-> Maybe Subs
-> Maybe Subs
matchFieldValues Type -> Input -> Maybe Value
coerceArgumentValue HashMap Name Input
object Name
variableName Type
variableType Maybe Value
defaultValue

collectFields :: Monad m
    => Out.ObjectType m
    -> Seq (Transform.Selection m)
    -> OrderedMap (NonEmpty (Transform.Field m))
collectFields :: forall (m :: * -> *).
Monad m =>
ObjectType m
-> Seq (Selection m) -> OrderedMap (NonEmpty (Field m))
collectFields ObjectType m
objectType = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl OrderedMap (NonEmpty (Field m))
-> Selection m -> OrderedMap (NonEmpty (Field m))
forEach forall v. OrderedMap v
OrderedMap.empty
  where
    forEach :: OrderedMap (NonEmpty (Field m))
-> Selection m -> OrderedMap (NonEmpty (Field m))
forEach OrderedMap (NonEmpty (Field m))
groupedFields (Transform.FieldSelection Field m
fieldSelection) =
        let Transform.Field Maybe Name
maybeAlias Name
fieldName HashMap Name (Node Input)
_ Seq (Selection m)
_ Location
_ = Field m
fieldSelection
            responseKey :: Name
responseKey = forall a. a -> Maybe a -> a
fromMaybe Name
fieldName Maybe Name
maybeAlias
         in forall v. Semigroup v => Name -> v -> OrderedMap v -> OrderedMap v
OrderedMap.insert Name
responseKey (Field m
fieldSelection forall a. a -> [a] -> NonEmpty a
:| []) OrderedMap (NonEmpty (Field m))
groupedFields
    forEach OrderedMap (NonEmpty (Field m))
groupedFields (Transform.FragmentSelection Fragment m
selectionFragment)
        | Transform.Fragment CompositeType m
fragmentType Seq (Selection m)
fragmentSelectionSet Location
_ <- Fragment m
selectionFragment
        , forall (m :: * -> *). CompositeType m -> ObjectType m -> Bool
Type.Internal.doesFragmentTypeApply CompositeType m
fragmentType ObjectType m
objectType =
            let fragmentGroupedFieldSet :: OrderedMap (NonEmpty (Field m))
fragmentGroupedFieldSet =
                    forall (m :: * -> *).
Monad m =>
ObjectType m
-> Seq (Selection m) -> OrderedMap (NonEmpty (Field m))
collectFields ObjectType m
objectType Seq (Selection m)
fragmentSelectionSet
             in OrderedMap (NonEmpty (Field m))
groupedFields forall a. Semigroup a => a -> a -> a
<> OrderedMap (NonEmpty (Field m))
fragmentGroupedFieldSet
        | Bool
otherwise = OrderedMap (NonEmpty (Field m))
groupedFields

coerceVariableValues :: (Monad m, VariableValue b)
    => HashMap Full.Name (Schema.Type m)
    -> Full.OperationDefinition
    -> HashMap Full.Name b
    -> Either QueryError Type.Subs
coerceVariableValues :: forall (m :: * -> *) b.
(Monad m, VariableValue b) =>
HashMap Name (Type m)
-> OperationDefinition -> HashMap Name b -> Either QueryError Subs
coerceVariableValues HashMap Name (Type m)
types OperationDefinition
operationDefinition' HashMap Name b
variableValues
    | Full.OperationDefinition OperationType
_ Maybe Name
_ [VariableDefinition]
variableDefinitions [Directive]
_ SelectionSet
_ Location
_ <-
        OperationDefinition
operationDefinition'
    = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr VariableDefinition
-> Either QueryError Subs -> Either QueryError Subs
forEach (forall a b. b -> Either a b
Right forall k v. HashMap k v
HashMap.empty) [VariableDefinition]
variableDefinitions
    | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Monoid a => a
mempty
  where
    forEach :: VariableDefinition
-> Either QueryError Subs -> Either QueryError Subs
forEach VariableDefinition
variableDefinition (Right Subs
coercedValues) =
        let Full.VariableDefinition Name
variableName Type
variableTypeName Maybe (Node ConstValue)
defaultValue Location
_ =
                VariableDefinition
variableDefinition
            defaultValue' :: Maybe Value
defaultValue' = ConstValue -> Value
constValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Node a -> a
Full.node forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Node ConstValue)
defaultValue
         in case forall (m :: * -> *). Type -> HashMap Name (Type m) -> Maybe Type
Type.Internal.lookupInputType Type
variableTypeName HashMap Name (Type m)
types of
            Just Type
variableType ->
                forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ VariableDefinition -> QueryError
CoercionError VariableDefinition
variableDefinition) forall a b. b -> Either a b
Right
                    forall a b. (a -> b) -> a -> b
$ forall a.
(Type -> a -> Maybe Value)
-> HashMap Name a
-> Name
-> Type
-> Maybe Value
-> Maybe Subs
-> Maybe Subs
matchFieldValues
                        forall {a}. VariableValue a => Type -> a -> Maybe Value
coerceVariableValue'
                        HashMap Name b
variableValues
                        Name
variableName
                        Type
variableType
                        Maybe Value
defaultValue'
                    forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Subs
coercedValues
            Maybe Type
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ VariableDefinition -> QueryError
UnknownInputType VariableDefinition
variableDefinition
    forEach VariableDefinition
_ Either QueryError Subs
coercedValuesOrError = Either QueryError Subs
coercedValuesOrError
    coerceVariableValue' :: Type -> a -> Maybe Value
coerceVariableValue' Type
variableType a
value'
        = forall {a}. VariableValue a => Type -> a -> Maybe Value
coerceVariableValue Type
variableType a
value'
        forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> Value -> Maybe Value
coerceInputLiteral Type
variableType

constValue :: Full.ConstValue -> Type.Value
constValue :: ConstValue -> Value
constValue (Full.ConstInt Int32
i) = Int32 -> Value
Type.Int Int32
i
constValue (Full.ConstFloat Double
f) = Double -> Value
Type.Float Double
f
constValue (Full.ConstString Name
x) = Name -> Value
Type.String Name
x
constValue (Full.ConstBoolean Bool
b) = Bool -> Value
Type.Boolean Bool
b
constValue ConstValue
Full.ConstNull = Value
Type.Null
constValue (Full.ConstEnum Name
e) = Name -> Value
Type.Enum Name
e
constValue (Full.ConstList [Node ConstValue]
list) = [Value] -> Value
Type.List forall a b. (a -> b) -> a -> b
$ ConstValue -> Value
constValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Node a -> a
Full.node forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Node ConstValue]
list
constValue (Full.ConstObject [ObjectField ConstValue]
o) =
    Subs -> Value
Type.Object forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList forall a b. (a -> b) -> a -> b
$ ObjectField ConstValue -> (Name, Value)
constObjectField forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ObjectField ConstValue]
o
  where
    constObjectField :: ObjectField ConstValue -> (Name, Value)
constObjectField Full.ObjectField{$sel:value:ObjectField :: forall a. ObjectField a -> Node a
value = Node ConstValue
value', Name
Location
$sel:location:ObjectField :: forall a. ObjectField a -> Location
$sel:name:ObjectField :: forall a. ObjectField a -> Name
location :: Location
name :: Name
..} =
        (Name
name, ConstValue -> Value
constValue forall a b. (a -> b) -> a -> b
$ forall a. Node a -> a
Full.node Node ConstValue
value')

subscribe :: (MonadCatch m, Serialize a)
    => Seq (Transform.Selection m)
    -> Schema m
    -> Full.Location
    -> m (Either Error (ResponseEventStream m a))
subscribe :: forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Seq (Selection m)
-> Schema m
-> Location
-> m (Either Error (ResponseEventStream m a))
subscribe Seq (Selection m)
fields Schema m
schema Location
objectLocation
    | Just ObjectType m
objectType <- forall (m :: * -> *). Schema m -> Maybe (ObjectType m)
Schema.subscription Schema m
schema = do
        let types' :: HashMap Name (Type m)
types' = forall (m :: * -> *). Schema m -> HashMap Name (Type m)
Schema.types Schema m
schema
        Either Error (SourceEventStream m)
sourceStream <-
            forall (m :: * -> *).
MonadCatch m =>
HashMap Name (Type m)
-> ObjectType m
-> Location
-> Seq (Selection m)
-> m (Either Error (SourceEventStream m))
createSourceEventStream HashMap Name (Type m)
types' ObjectType m
objectType Location
objectLocation Seq (Selection m)
fields
        let traverser :: SourceEventStream m -> m (ResponseEventStream m a)
traverser =
                forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
HashMap Name (Type m)
-> ObjectType m
-> Seq (Selection m)
-> SourceEventStream m
-> m (ResponseEventStream m a)
mapSourceToResponseEvent HashMap Name (Type m)
types' ObjectType m
objectType Seq (Selection m)
fields
        forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse SourceEventStream m -> m (ResponseEventStream m a)
traverser Either Error (SourceEventStream m)
sourceStream
    | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left
        forall a b. (a -> b) -> a -> b
$ Name -> [Location] -> [Path] -> Error
Error Name
"Schema doesn't support subscriptions." [] []

mapSourceToResponseEvent :: (MonadCatch m, Serialize a)
    => HashMap Full.Name (Type m)
    -> Out.ObjectType m
    -> Seq (Transform.Selection m)
    -> Out.SourceEventStream m
    -> m (ResponseEventStream m a)
mapSourceToResponseEvent :: forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
HashMap Name (Type m)
-> ObjectType m
-> Seq (Selection m)
-> SourceEventStream m
-> m (ResponseEventStream m a)
mapSourceToResponseEvent HashMap Name (Type m)
types' ObjectType m
subscriptionType Seq (Selection m)
fields SourceEventStream m
sourceStream
    = forall (f :: * -> *) a. Applicative f => a -> f a
pure
    forall a b. (a -> b) -> a -> b
$ SourceEventStream m
sourceStream
    forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
mapMC (forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
HashMap Name (Type m)
-> ObjectType m -> Seq (Selection m) -> Value -> m (Response a)
executeSubscriptionEvent HashMap Name (Type m)
types' ObjectType m
subscriptionType Seq (Selection m)
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 :: forall (m :: * -> *).
MonadCatch m =>
HashMap Name (Type m)
-> ObjectType m
-> Location
-> Seq (Selection m)
-> m (Either Error (SourceEventStream m))
createSourceEventStream HashMap Name (Type m)
_types ObjectType m
subscriptionType Location
objectLocation Seq (Selection m)
fields
    | [NonEmpty (Field m)
fieldGroup] <- forall v. OrderedMap v -> [v]
OrderedMap.elems OrderedMap (NonEmpty (Field m))
groupedFieldSet
    , Transform.Field Maybe Name
_ Name
fieldName HashMap Name (Node Input)
arguments' Seq (Selection m)
_ Location
errorLocation <-
        forall a. NonEmpty a -> a
NonEmpty.head NonEmpty (Field m)
fieldGroup
    , Out.ObjectType Name
_ Maybe Name
_ [InterfaceType m]
_ HashMap Name (Resolver m)
fieldTypes <- ObjectType m
subscriptionType
    , Resolver m
resolverT <- HashMap Name (Resolver m)
fieldTypes forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
HashMap.! Name
fieldName
    , Out.EventStreamResolver Field m
fieldDefinition Resolve m
_ Subscribe m
resolver <- Resolver m
resolverT
    , Out.Field Maybe Name
_ Type m
_fieldType HashMap Name Argument
argumentDefinitions <- Field m
fieldDefinition =
        case forall (m :: * -> *).
MonadCatch m =>
HashMap Name Argument -> HashMap Name (Node Input) -> m Subs
coerceArgumentValues HashMap Name Argument
argumentDefinitions HashMap Name (Node Input)
arguments' of
            Left SomeException
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure
                forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left
                forall a b. (a -> b) -> a -> b
$ Name -> [Location] -> [Path] -> Error
Error Name
"Argument coercion failed." [Location
errorLocation] []
            Right  Subs
argumentValues -> forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ([Location] -> String -> Error
singleError [Location
errorLocation])
                forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadCatch m =>
Value
-> Subs -> Subscribe m -> m (Either String (SourceEventStream m))
resolveFieldEventStream Value
Type.Null Subs
argumentValues Subscribe m
resolver
    | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure
        forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left
        forall a b. (a -> b) -> a -> b
$ Name -> [Location] -> [Path] -> Error
Error Name
"Subscription contains more than one field." [Location
objectLocation] []
  where
    groupedFieldSet :: OrderedMap (NonEmpty (Field m))
groupedFieldSet = forall (m :: * -> *).
Monad m =>
ObjectType m
-> Seq (Selection m) -> OrderedMap (NonEmpty (Field m))
collectFields ObjectType m
subscriptionType Seq (Selection m)
fields
    singleError :: [Full.Location] -> String -> Error
    singleError :: [Location] -> String -> Error
singleError [Location]
errorLocations String
message = Name -> [Location] -> [Path] -> Error
Error (String -> Name
Text.pack String
message) [Location]
errorLocations []

resolveFieldEventStream :: MonadCatch m
    => Type.Value
    -> Type.Subs
    -> Out.Subscribe m
    -> m (Either String (Out.SourceEventStream m))
resolveFieldEventStream :: forall (m :: * -> *).
MonadCatch m =>
Value
-> Subs -> Subscribe m -> m (Either String (SourceEventStream m))
resolveFieldEventStream Value
result Subs
args Subscribe m
resolver =
    forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Subscribe m
resolver Context
context) forall (m :: * -> *).
MonadCatch m =>
ResolverException -> m (Either String (SourceEventStream m))
handleEventStreamError
  where
    handleEventStreamError :: MonadCatch m
        => ResolverException
        -> m (Either String (Out.SourceEventStream m))
    handleEventStreamError :: forall (m :: * -> *).
MonadCatch m =>
ResolverException -> m (Either String (SourceEventStream m))
handleEventStreamError = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Exception e => e -> String
displayException
    context :: Context
context = Type.Context
        { arguments :: Arguments
Type.arguments = Subs -> Arguments
Type.Arguments Subs
args
        , values :: Value
Type.values = Value
result
        }

executeSubscriptionEvent :: (MonadCatch m, Serialize a)
    => HashMap Full.Name (Type m)
    -> Out.ObjectType m
    -> Seq (Transform.Selection m)
    -> Type.Value
    -> m (Response a)
executeSubscriptionEvent :: forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
HashMap Name (Type m)
-> ObjectType m -> Seq (Selection m) -> Value -> m (Response a)
executeSubscriptionEvent HashMap Name (Type m)
types' ObjectType m
objectType Seq (Selection m)
fields Value
initialValue = do
    (a
data', Seq Error
errors) <- forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT
        forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT HashMap Name (Type m)
types'
        forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
ExecutorT m a
-> ReaderT (HashMap Name (Type m)) (WriterT (Seq Error) m) a
runExecutorT
        forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch (forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
Seq (Selection m)
-> ObjectType m -> Value -> [Path] -> ExecutorT m a
executeSelectionSet Seq (Selection m)
fields ObjectType m
objectType Value
initialValue [])
        forall (m :: * -> *) a.
(MonadCatch m, Serialize a) =>
FieldException -> ExecutorT m a
handleException
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Seq Error -> Response a
Response a
data' Seq Error
errors