summaryrefslogtreecommitdiff
path: root/src/Language/GraphQL
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/GraphQL')
-rw-r--r--src/Language/GraphQL/AST.hs4
-rw-r--r--src/Language/GraphQL/Error.hs4
-rw-r--r--src/Language/GraphQL/Execute.hs611
-rw-r--r--src/Language/GraphQL/Execute/Execution.hs253
-rw-r--r--src/Language/GraphQL/Execute/Subscribe.hs113
-rw-r--r--src/Language/GraphQL/Execute/Transform.hs610
-rw-r--r--src/Language/GraphQL/Executor.hs847
-rw-r--r--src/Language/GraphQL/Type/Definition.hs1
-rw-r--r--src/Language/GraphQL/Type/In.hs1
9 files changed, 456 insertions, 1988 deletions
diff --git a/src/Language/GraphQL/AST.hs b/src/Language/GraphQL/AST.hs
index c7ceee8..4cf9bfd 100644
--- a/src/Language/GraphQL/AST.hs
+++ b/src/Language/GraphQL/AST.hs
@@ -1,6 +1,4 @@
-{- This Source Code Form is subject to the terms of the Mozilla Public License,
- v. 2.0. If a copy of the MPL was not distributed with this file, You can
- obtain one at https://mozilla.org/MPL/2.0/. -}
+{-# LANGUAGE Safe #-}
-- | Target AST for parser.
module Language.GraphQL.AST
diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs
index 2061c20..43be778 100644
--- a/src/Language/GraphQL/Error.hs
+++ b/src/Language/GraphQL/Error.hs
@@ -1,3 +1,7 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+ v. 2.0. If a copy of the MPL was not distributed with this file, You can
+ obtain one at https://mozilla.org/MPL/2.0/. -}
+
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE RecordWildCards #-}
diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs
index 8741ab5..8eb22c2 100644
--- a/src/Language/GraphQL/Execute.hs
+++ b/src/Language/GraphQL/Execute.hs
@@ -4,17 +4,13 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeApplications #-}
module Language.GraphQL.Execute
- ( Error(..)
- , Operation(..)
- , Path(..)
- , Response(..)
+ ( module Language.GraphQL.Execute.Coerce
, execute
) where
@@ -29,32 +25,27 @@ import Control.Monad.Catch
, catches
)
import Control.Monad.Trans.Class (MonadTrans(..))
-import Control.Monad.Trans.Reader (ReaderT(..), ask, local, runReaderT)
-import Control.Monad.Trans.Writer (WriterT(..), runWriterT, tell)
-import qualified Control.Monad.Trans.Reader as Reader
+import Control.Monad.Trans.Reader (ReaderT(..), ask, runReaderT)
+import Control.Monad.Trans.Writer (WriterT(..), runWriterT)
+import qualified Control.Monad.Trans.Writer as Writer
import Control.Monad (foldM)
import qualified Language.GraphQL.AST.Document as Full
-import Data.Bifunctor (first)
import Data.Foldable (find)
-import Data.Functor ((<&>))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
-import Data.HashSet (HashSet)
-import qualified Data.HashSet as HashSet
-import Data.Int (Int32)
-import Data.List (intercalate)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
-import Data.Maybe (fromMaybe, isJust)
-import Data.Sequence (Seq, (><))
+import Data.Maybe (fromMaybe)
+import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Typeable (cast)
import GHC.Records (HasField(..))
-import qualified Language.GraphQL.Execute.Coerce as Coerce
+import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Execute.OrderedMap (OrderedMap)
import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
+import qualified Language.GraphQL.Execute.Transform as Transform
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
import qualified Language.GraphQL.Type as Type
@@ -64,41 +55,11 @@ import qualified Language.GraphQL.Type.Schema as Schema
import Language.GraphQL.Error
( Error(..)
, Response(..)
- , Path(..)
- , ResponseEventStream
- )
-import Numeric (showFloat)
-
-data Replacement m = Replacement
- { variableValues :: Type.Subs
- , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
- , visitedFragments :: HashSet Full.Name
- , types :: HashMap Full.Name (Type m)
- }
-
-newtype TransformT m a = TransformT
- { runTransformT :: ReaderT (Replacement m) m a
- }
-
-instance Functor m => Functor (TransformT m) where
- fmap f = TransformT . fmap f . runTransformT
-
-instance Applicative m => Applicative (TransformT m) where
- pure = TransformT . pure
- TransformT f <*> TransformT x = TransformT $ f <*> x
-
-instance Monad m => Monad (TransformT m) where
- TransformT x >>= f = TransformT $ x >>= runTransformT . f
-
-instance MonadTrans TransformT where
- lift = TransformT . lift
-
-instance MonadThrow m => MonadThrow (TransformT m) where
- throwM = lift . throwM
-
-instance MonadCatch m => MonadCatch (TransformT m) where
- catch (TransformT stack) handler =
- TransformT $ catch stack $ runTransformT . handler
+ , Path(..)
+ , ResolverException(..)
+ , ResponseEventStream
+ )
+import Prelude hiding (null)
newtype ExecutorT m a = ExecutorT
{ runExecutorT :: ReaderT (HashMap Full.Name (Type m)) (WriterT (Seq Error) m) a
@@ -139,29 +100,31 @@ graphQLExceptionFromException e = do
GraphQLException graphqlException <- fromException e
cast graphqlException
-data ResolverException = forall e. Exception e => ResolverException e
+data ResultException = forall e. Exception e => ResultException e
-instance Show ResolverException where
- show (ResolverException e) = show e
+instance Show ResultException where
+ show (ResultException e) = show e
-instance Exception ResolverException where
+instance Exception ResultException where
toException = graphQLExceptionToException
fromException = graphQLExceptionFromException
-data FieldError
- = ResultCoercionError
- | NullResultError
+resultExceptionToException :: Exception e => e -> SomeException
+resultExceptionToException = toException . ResultException
-instance Show FieldError where
- show ResultCoercionError = "Result coercion failed."
- show NullResultError = "Non-Nullable field resolver returned Null."
+resultExceptionFromException :: Exception e => SomeException -> Maybe e
+resultExceptionFromException e = do
+ ResultException resultException <- fromException e
+ cast resultException
-newtype FieldException = FieldException FieldError
- deriving Show
+data FieldException = forall e. Exception e => FieldException Full.Location [Path] e
+
+instance Show FieldException where
+ show (FieldException _ _ e) = displayException e
instance Exception FieldException where
- toException = graphQLExceptionToException
- fromException = graphQLExceptionFromException
+ toException = graphQLExceptionToException
+ fromException = graphQLExceptionFromException
data ValueCompletionException = ValueCompletionException String Type.Value
@@ -175,11 +138,11 @@ instance Show ValueCompletionException where
]
instance Exception ValueCompletionException where
- toException = graphQLExceptionToException
- fromException = graphQLExceptionFromException
+ toException = resultExceptionToException
+ fromException = resultExceptionFromException
data InputCoercionException =
- InputCoercionException String In.Type (Maybe (Full.Node Input))
+ InputCoercionException String In.Type (Maybe (Full.Node Transform.Input))
instance Show InputCoercionException where
show (InputCoercionException argumentName argumentType Nothing) = concat
@@ -203,14 +166,27 @@ instance Exception InputCoercionException where
toException = graphQLExceptionToException
fromException = graphQLExceptionFromException
+newtype ResultCoercionException = ResultCoercionException String
+
+instance Show ResultCoercionException where
+ show (ResultCoercionException typeRepresentation) = concat
+ [ "Unable to coerce result to "
+ , typeRepresentation
+ , "."
+ ]
+
+instance Exception ResultCoercionException where
+ toException = resultExceptionToException
+ fromException = resultExceptionFromException
+
data QueryError
- = OperationNameRequired
- | OperationNotFound String
- | CoercionError Full.VariableDefinition
- | UnknownInputType Full.VariableDefinition
+ = OperationNameRequired
+ | OperationNotFound String
+ | CoercionError Full.VariableDefinition
+ | UnknownInputType Full.VariableDefinition
-asks :: Monad m => forall a. (Replacement m -> a) -> TransformT m a
-asks = TransformT . Reader.asks
+tell :: Monad m => Seq Error -> ExecutorT m ()
+tell = ExecutorT . lift . Writer.tell
queryError :: QueryError -> Error
queryError OperationNameRequired =
@@ -241,232 +217,7 @@ queryError (UnknownInputType variableDefinition) =
]
in Error{ message = queryErrorMessage, locations = [location], path = [] }
-data Operation m
- = Operation Full.OperationType (Seq (Selection m)) Full.Location
-
-data Selection m
- = FieldSelection (Field m)
- | FragmentSelection (Fragment m)
-
-data Field m = Field
- (Maybe Full.Name)
- Full.Name
- (HashMap Full.Name (Full.Node Input))
- (Seq (Selection m))
- Full.Location
-
-data Fragment m = Fragment
- (Type.Internal.CompositeType m) (Seq (Selection m)) Full.Location
-
-data Input
- = Variable Type.Value
- | Int Int32
- | Float Double
- | String Text
- | Boolean Bool
- | Null
- | Enum Full.Name
- | List [Input]
- | Object (HashMap Full.Name Input)
- deriving Eq
-
-instance Show Input where
- showList = mappend . showList'
- where
- showList' list = "[" ++ intercalate ", " (show <$> list) ++ "]"
- show (Int integer) = show integer
- show (Float float') = showFloat float' mempty
- show (String text) = "\"" <> Text.foldr (mappend . Full.escape) "\"" text
- show (Boolean boolean') = show boolean'
- show Null = "null"
- show (Enum name) = Text.unpack name
- show (List list) = show list
- show (Object fields) = unwords
- [ "{"
- , intercalate ", " (HashMap.foldrWithKey showObject [] fields)
- , "}"
- ]
- where
- showObject key value accumulator =
- concat [Text.unpack key, ": ", show value] : accumulator
- show variableValue = show variableValue
-
-document :: Full.Document
- -> ([Full.OperationDefinition], HashMap Full.Name Full.FragmentDefinition)
-document = foldr filterOperation ([], HashMap.empty)
- where
- filterOperation (Full.ExecutableDefinition executableDefinition) accumulator
- | Full.DefinitionOperation operationDefinition' <- executableDefinition =
- first (operationDefinition' :) accumulator
- | Full.DefinitionFragment fragmentDefinition <- executableDefinition
- , Full.FragmentDefinition fragmentName _ _ _ _ <- fragmentDefinition =
- HashMap.insert fragmentName fragmentDefinition <$> accumulator
- filterOperation _ accumulator = accumulator -- Type system definitions.
-
-transform :: Monad m => Full.OperationDefinition -> TransformT m (Operation m)
-transform (Full.OperationDefinition operationType _ _ _ selectionSet' operationLocation) = do
- transformedSelections <- selectionSet selectionSet'
- pure $ Operation operationType transformedSelections operationLocation
-transform (Full.SelectionSet selectionSet' operationLocation) = do
- transformedSelections <- selectionSet selectionSet'
- pure $ Operation Full.Query transformedSelections operationLocation
-
-selectionSet :: Monad m => Full.SelectionSet -> TransformT m (Seq (Selection m))
-selectionSet = selectionSetOpt . NonEmpty.toList
-
-selectionSetOpt :: Monad m => Full.SelectionSetOpt -> TransformT m (Seq (Selection m))
-selectionSetOpt = foldM go Seq.empty
- where
- go accumulatedSelections currentSelection =
- selection currentSelection <&> (accumulatedSelections ><)
-
-selection :: Monad m => Full.Selection -> TransformT m (Seq (Selection m))
-selection (Full.FieldSelection field') =
- maybeToSelectionSet FieldSelection $ field field'
-selection (Full.FragmentSpreadSelection fragmentSpread') =
- maybeToSelectionSet FragmentSelection $ fragmentSpread fragmentSpread'
-selection (Full.InlineFragmentSelection inlineFragment') =
- either id (pure . FragmentSelection) <$> inlineFragment inlineFragment'
-
-maybeToSelectionSet :: Monad m
- => forall a
- . (a -> Selection m)
- -> TransformT m (Maybe a)
- -> TransformT m (Seq (Selection m))
-maybeToSelectionSet selectionType = fmap (maybe Seq.empty $ pure . selectionType)
-
-directives :: Monad m => [Full.Directive] -> TransformT m (Maybe [Type.Directive])
-directives = fmap Type.selection . traverse directive
-
-inlineFragment :: Monad m
- => Full.InlineFragment
- -> TransformT m (Either (Seq (Selection m)) (Fragment m))
-inlineFragment (Full.InlineFragment maybeCondition directives' selectionSet' location)
- | Just typeCondition <- maybeCondition = do
- transformedSelections <- selectionSet selectionSet'
- transformedDirectives <- directives directives'
- maybeFragmentType <- asks
- $ Type.Internal.lookupTypeCondition typeCondition
- . types
- pure $ case transformedDirectives >> maybeFragmentType of
- Just fragmentType -> Right
- $ Fragment fragmentType transformedSelections location
- Nothing -> Left Seq.empty
- | otherwise = do
- transformedSelections <- selectionSet selectionSet'
- transformedDirectives <- directives directives'
- pure $ if isJust transformedDirectives
- then Left transformedSelections
- else Left Seq.empty
-
-fragmentSpread :: Monad m => Full.FragmentSpread -> TransformT m (Maybe (Fragment m))
-fragmentSpread (Full.FragmentSpread spreadName directives' location) = do
- transformedDirectives <- directives directives'
- visitedFragment <- asks $ HashSet.member spreadName . visitedFragments
- possibleFragmentDefinition <- asks
- $ HashMap.lookup spreadName
- . fragmentDefinitions
- case transformedDirectives >> possibleFragmentDefinition of
- Just (Full.FragmentDefinition _ typeCondition _ selections _)
- | visitedFragment -> pure Nothing
- | otherwise -> do
- fragmentType <- asks
- $ Type.Internal.lookupTypeCondition typeCondition
- . types
- traverse (traverseSelections selections) fragmentType
- Nothing -> pure Nothing
- where
- traverseSelections selections typeCondition = do
- transformedSelections <- TransformT
- $ local fragmentInserter
- $ runTransformT
- $ selectionSet selections
- pure $ Fragment typeCondition transformedSelections location
- fragmentInserter replacement@Replacement{ visitedFragments } = replacement
- { visitedFragments = HashSet.insert spreadName visitedFragments }
-
-field :: Monad m => Full.Field -> TransformT m (Maybe (Field m))
-field (Full.Field alias' name' arguments' directives' selectionSet' location') = do
- transformedSelections <- selectionSetOpt selectionSet'
- transformedDirectives <- directives directives'
- transformedArguments <- arguments arguments'
- let transformedField = Field
- alias'
- name'
- transformedArguments
- transformedSelections
- location'
- pure $ transformedDirectives >> pure transformedField
-
-arguments :: Monad m => [Full.Argument] -> TransformT m (HashMap Full.Name (Full.Node Input))
-arguments = foldM go HashMap.empty
- where
- go accumulator (Full.Argument name' valueNode argumentLocation) = do
- let replaceLocation = flip Full.Node argumentLocation . Full.node
- argumentValue <- fmap replaceLocation <$> node valueNode
- pure $ insertIfGiven name' argumentValue accumulator
-
-directive :: Monad m => Full.Directive -> TransformT m Type.Directive
-directive (Full.Directive name' arguments' _)
- = Type.Directive name'
- . Type.Arguments
- <$> foldM go HashMap.empty arguments'
- where
- go accumulator (Full.Argument argumentName Full.Node{ node = node' } _) = do
- transformedValue <- directiveValue node'
- pure $ HashMap.insert argumentName transformedValue accumulator
-
-directiveValue :: Monad m => Full.Value -> TransformT m Type.Value
-directiveValue = \case
- (Full.Variable name') -> asks
- $ HashMap.lookupDefault Type.Null name'
- . variableValues
- (Full.Int integer) -> pure $ Type.Int integer
- (Full.Float double) -> pure $ Type.Float double
- (Full.String string) -> pure $ Type.String string
- (Full.Boolean boolean) -> pure $ Type.Boolean boolean
- Full.Null -> pure Type.Null
- (Full.Enum enum) -> pure $ Type.Enum enum
- (Full.List list) -> Type.List <$> traverse directiveNode list
- (Full.Object objectFields) ->
- Type.Object <$> foldM objectField HashMap.empty objectFields
- where
- directiveNode Full.Node{ node = node'} = directiveValue node'
- objectField accumulator Full.ObjectField{ name, value } = do
- transformedValue <- directiveNode value
- pure $ HashMap.insert name transformedValue accumulator
-
-input :: Monad m => Full.Value -> TransformT m (Maybe Input)
-input (Full.Variable name') =
- asks (HashMap.lookup name' . variableValues) <&> fmap Variable
-input (Full.Int integer) = pure $ Just $ Int integer
-input (Full.Float double) = pure $ Just $ Float double
-input (Full.String string) = pure $ Just $ String string
-input (Full.Boolean boolean) = pure $ Just $ Boolean boolean
-input Full.Null = pure $ Just Null
-input (Full.Enum enum) = pure $ Just $ Enum enum
-input (Full.List list) = Just . List
- <$> traverse (fmap (fromMaybe Null) . input . Full.node) list
-input (Full.Object objectFields) = Just . Object
- <$> foldM objectField HashMap.empty objectFields
- where
- objectField accumulator Full.ObjectField{..} = do
- objectFieldValue <- fmap Full.node <$> node value
- pure $ insertIfGiven name objectFieldValue accumulator
-
-insertIfGiven :: forall a
- . Full.Name
- -> Maybe a
- -> HashMap Full.Name a
- -> HashMap Full.Name a
-insertIfGiven name (Just v) = HashMap.insert name v
-insertIfGiven _ _ = id
-
-node :: Monad m => Full.Node Full.Value -> TransformT m (Maybe (Full.Node Input))
-node Full.Node{node = node', ..} =
- traverse Full.Node <$> input node' <*> pure location
-
-execute :: (MonadCatch m, Coerce.VariableValue a, Coerce.Serialize b)
+execute :: (MonadCatch m, VariableValue a, Serialize b)
=> Schema m -- ^ Resolvers.
-> Maybe Text -- ^ Operation name.
-> HashMap Full.Name a -- ^ Variable substitution function.
@@ -475,7 +226,7 @@ execute :: (MonadCatch m, Coerce.VariableValue a, Coerce.Serialize b)
execute schema' operationName subs document' =
executeRequest schema' document' (Text.unpack <$> operationName) subs
-executeRequest :: (MonadCatch m, Coerce.Serialize a, Coerce.VariableValue b)
+executeRequest :: (MonadCatch m, Serialize a, VariableValue b)
=> Schema m
-> Full.Document
-> Maybe String
@@ -486,35 +237,36 @@ executeRequest schema sourceDocument operationName variableValues = do
case operationAndVariables of
Left queryError' -> pure
$ Right
- $ Response Coerce.null $ pure $ queryError queryError'
+ $ Response null $ pure $ queryError queryError'
Right operation
- | Operation Full.Query topSelections _operationLocation <- operation ->
+ | Transform.Operation Full.Query topSelections _operationLocation <- operation ->
Right <$> executeQuery topSelections schema
- | Operation Full.Mutation topSelections operationLocation <- operation ->
+ | Transform.Operation Full.Mutation topSelections operationLocation <- operation ->
Right <$> executeMutation topSelections schema operationLocation
- | Operation Full.Subscription topSelections operationLocation <- operation ->
+ | Transform.Operation Full.Subscription topSelections operationLocation <- operation ->
either rightErrorResponse Left <$> subscribe topSelections schema operationLocation
where
schemaTypes = Schema.types schema
- (operationDefinitions, fragmentDefinitions') = document sourceDocument
+ (operationDefinitions, fragmentDefinitions') =
+ Transform.document sourceDocument
buildOperation = do
operationDefinition <- getOperation operationDefinitions operationName
coercedVariableValues <- coerceVariableValues
schemaTypes
operationDefinition
variableValues
- let replacement = Replacement
+ let replacement = Transform.Replacement
{ variableValues = coercedVariableValues
, fragmentDefinitions = fragmentDefinitions'
, visitedFragments = mempty
, types = schemaTypes
}
pure $ flip runReaderT replacement
- $ runTransformT
- $ transform operationDefinition
+ $ Transform.runTransformT
+ $ Transform.transform operationDefinition
-rightErrorResponse :: Coerce.Serialize b => forall a. Error -> Either a (Response b)
-rightErrorResponse = Right . Response Coerce.null . pure
+rightErrorResponse :: Serialize b => forall a. Error -> Either a (Response b)
+rightErrorResponse = Right . Response null . pure
getOperation :: [Full.OperationDefinition] -> Maybe String -> Either QueryError Full.OperationDefinition
getOperation [operation] Nothing = Right operation
@@ -527,8 +279,8 @@ getOperation operations (Just givenOperationName)
findOperationByName _ = False
getOperation _ _ = Left OperationNameRequired
-executeQuery :: (MonadCatch m, Coerce.Serialize a)
- => Seq (Selection m)
+executeQuery :: (MonadCatch m, Serialize a)
+ => Seq (Transform.Selection m)
-> Schema m
-> m (Response a)
executeQuery topSelections schema = do
@@ -536,11 +288,26 @@ executeQuery topSelections schema = do
(data', errors) <- runWriterT
$ flip runReaderT (Schema.types schema)
$ runExecutorT
- $ executeSelectionSet topSelections queryType Type.Null []
+ $ catch (executeSelectionSet topSelections queryType Type.Null [])
+ handleException
pure $ Response data' errors
-executeMutation :: (MonadCatch m, Coerce.Serialize a)
- => Seq (Selection m)
+handleException :: (MonadCatch m, Serialize a)
+ => FieldException
+ -> ExecutorT m a
+handleException (FieldException fieldLocation errorPath next) =
+ let newError = constructError next fieldLocation errorPath
+ in tell (Seq.singleton newError) >> pure null
+
+constructError :: Exception e => e -> Full.Location -> [Path] -> Error
+constructError e fieldLocation errorPath = Error
+ { message = Text.pack (displayException e)
+ , path = reverse errorPath
+ , locations = [fieldLocation]
+ }
+
+executeMutation :: (MonadCatch m, Serialize a)
+ => Seq (Transform.Selection m)
-> Schema m
-> Full.Location
-> m (Response a)
@@ -549,15 +316,16 @@ executeMutation topSelections schema operationLocation
(data', errors) <- runWriterT
$ flip runReaderT (Schema.types schema)
$ runExecutorT
- $ executeSelectionSet topSelections mutationType Type.Null []
+ $ catch (executeSelectionSet topSelections mutationType Type.Null [])
+ handleException
pure $ Response data' errors
| otherwise = pure
- $ Response Coerce.null
+ $ Response null
$ Seq.singleton
$ Error "Schema doesn't support mutations." [operationLocation] []
-executeSelectionSet :: (MonadCatch m, Coerce.Serialize a)
- => Seq (Selection m)
+executeSelectionSet :: (MonadCatch m, Serialize a)
+ => Seq (Transform.Selection m)
-> Out.ObjectType m
-> Type.Value
-> [Path]
@@ -565,62 +333,80 @@ executeSelectionSet :: (MonadCatch m, Coerce.Serialize a)
executeSelectionSet selections objectType objectValue errorPath = do
let groupedFieldSet = collectFields objectType selections
resolvedValues <- OrderedMap.traverseMaybe go groupedFieldSet
- coerceResult (Out.NonNullObjectType objectType) $ Coerce.Object resolvedValues
+ coerceResult (Out.NonNullObjectType objectType) $ Object resolvedValues
where
executeField' fields resolver =
executeField objectValue fields resolver errorPath
Out.ObjectType _ _ _ resolvers = objectType
- go fields@(Field _ fieldName _ _ _ :| _) =
+ go fields@(Transform.Field _ fieldName _ _ _ :| _) =
traverse (executeField' fields) $ HashMap.lookup fieldName resolvers
-fieldsSegment :: forall m. NonEmpty (Field m) -> Path
-fieldsSegment (Field alias fieldName _ _ _ :| _) =
+fieldsSegment :: forall m. NonEmpty (Transform.Field m) -> Path
+fieldsSegment (Transform.Field alias fieldName _ _ _ :| _) =
Segment (fromMaybe fieldName alias)
-executeField :: (MonadCatch m, Coerce.Serialize a)
+viewResolver :: Out.Resolver m -> (Out.Field m, Out.Resolve m)
+viewResolver (Out.ValueResolver resolverField' resolveFunction) =
+ (resolverField', resolveFunction)
+viewResolver (Out.EventStreamResolver resolverField' resolveFunction _) =
+ (resolverField', resolveFunction)
+
+executeField :: forall m a
+ . (MonadCatch m, Serialize a)
=> Type.Value
- -> NonEmpty (Field m)
+ -> NonEmpty (Transform.Field m)
-> Out.Resolver m
-> [Path]
-> ExecutorT m a
-executeField objectValue fields resolver errorPath =
- let Field _ fieldName inputArguments _ fieldLocation :| _ = fields
+executeField objectValue fields (viewResolver -> resolverPair) errorPath =
+ let Transform.Field _ fieldName inputArguments _ fieldLocation :| _ = fields
in catches (go fieldName inputArguments)
- [ Handler (inputCoercionHandler fieldLocation)
- , Handler (graphqlExceptionHandler fieldLocation)
+ [ Handler nullResultHandler
+ , Handler (inputCoercionHandler fieldLocation)
+ , Handler (resultHandler fieldLocation)
+ , Handler (resolverHandler fieldLocation)
]
where
- inputCoercionHandler :: (MonadCatch m, Coerce.Serialize a)
+ inputCoercionHandler :: (MonadCatch m, Serialize a)
=> Full.Location
-> InputCoercionException
-> ExecutorT m a
inputCoercionHandler _ e@(InputCoercionException _ _ (Just valueNode)) =
let argumentLocation = getField @"location" valueNode
- in exceptionHandler argumentLocation $ displayException e
- inputCoercionHandler fieldLocation e =
- exceptionHandler fieldLocation $ displayException e
- graphqlExceptionHandler :: (MonadCatch m, Coerce.Serialize a)
+ in exceptionHandler argumentLocation e
+ inputCoercionHandler fieldLocation e = exceptionHandler fieldLocation e
+ resultHandler :: (MonadCatch m, Serialize a)
=> Full.Location
- -> GraphQLException
+ -> ResultException
-> ExecutorT m a
- graphqlExceptionHandler fieldLocation e =
- exceptionHandler fieldLocation $ displayException e
- exceptionHandler errorLocation exceptionText =
- let newError = Error (Text.pack exceptionText) [errorLocation]
- $ reverse
- $ fieldsSegment fields : errorPath
- in ExecutorT (lift $ tell $ Seq.singleton newError) >> pure Coerce.null
+ resultHandler = exceptionHandler
+ resolverHandler :: (MonadCatch m, Serialize a)
+ => Full.Location
+ -> ResolverException
+ -> ExecutorT m a
+ resolverHandler = exceptionHandler
+ nullResultHandler :: (MonadCatch m, Serialize a)
+ => FieldException
+ -> ExecutorT m a
+ nullResultHandler e@(FieldException fieldLocation errorPath' next) =
+ let newError = constructError next fieldLocation errorPath'
+ in if Out.isNonNullType fieldType
+ then throwM e
+ else returnError newError
+ exceptionHandler errorLocation e =
+ let newPath = fieldsSegment fields : errorPath
+ newError = constructError e errorLocation newPath
+ in if Out.isNonNullType fieldType
+ then throwM $ FieldException errorLocation newPath e
+ else returnError newError
+ returnError newError = tell (Seq.singleton newError) >> pure null
go fieldName inputArguments = do
- let (Out.Field _ fieldType argumentTypes, resolveFunction) =
- resolverField resolver
argumentValues <- coerceArgumentValues argumentTypes inputArguments
resolvedValue <-
- resolveFieldValue resolveFunction objectValue fieldName argumentValues
+ resolveFieldValue resolveFunction objectValue fieldName argumentValues
completeValue fieldType fields errorPath resolvedValue
- resolverField (Out.ValueResolver resolverField' resolveFunction) =
- (resolverField', resolveFunction)
- resolverField (Out.EventStreamResolver resolverField' resolveFunction _) =
- (resolverField', resolveFunction)
+ (resolverField, resolveFunction) = resolverPair
+ Out.Field _ fieldType argumentTypes = resolverField
resolveFieldValue :: MonadCatch m
=> Out.Resolve m
@@ -651,34 +437,33 @@ resolveAbstractType abstractType values'
_ -> pure Nothing
| otherwise = pure Nothing
-completeValue :: (MonadCatch m, Coerce.Serialize a)
+completeValue :: (MonadCatch m, Serialize a)
=> Out.Type m
- -> NonEmpty (Field m)
+ -> NonEmpty (Transform.Field m)
-> [Path]
-> Type.Value
-> ExecutorT m a
-completeValue outputType _ _ Type.Null
- | Out.isNonNullType outputType = throwFieldError NullResultError
- | otherwise = pure Coerce.null
+completeValue (Out.isNonNullType -> False) _ _ Type.Null =
+ pure null
completeValue outputType@(Out.ListBaseType listType) fields errorPath (Type.List list)
- = foldM go (0, []) list >>= coerceResult outputType . Coerce.List . snd
+ = foldM go (0, []) list >>= coerceResult outputType . List . snd
where
go (index, accumulator) listItem = do
let updatedPath = Index index : errorPath
completedValue <- completeValue listType fields updatedPath listItem
pure (index + 1, completedValue : accumulator)
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Int int) =
- coerceResult outputType $ Coerce.Int int
+ coerceResult outputType $ Int int
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Boolean boolean) =
- coerceResult outputType $ Coerce.Boolean boolean
+ coerceResult outputType $ Boolean boolean
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.Float float) =
- coerceResult outputType $ Coerce.Float float
+ coerceResult outputType $ Float float
completeValue outputType@(Out.ScalarBaseType _) _ _ (Type.String string) =
- coerceResult outputType $ Coerce.String string
+ coerceResult outputType $ String string
completeValue outputType@(Out.EnumBaseType enumType) _ _ (Type.Enum enum) =
let Type.EnumType _ _ enumMembers = enumType
in if HashMap.member enum enumMembers
- then coerceResult outputType $ Coerce.Enum enum
+ then coerceResult outputType $ Enum enum
else throwM
$ ValueCompletionException (show outputType)
$ Type.Enum enum
@@ -708,28 +493,25 @@ completeValue outputType@(Out.UnionBaseType unionType) fields errorPath result
completeValue outputType _ _ result =
throwM $ ValueCompletionException (show outputType) result
-coerceResult :: (MonadCatch m, Coerce.Serialize a)
+coerceResult :: (MonadCatch m, Serialize a)
=> Out.Type m
- -> Coerce.Output a
+ -> Output a
-> ExecutorT m a
coerceResult outputType result
- | Just serialized <- Coerce.serialize outputType result = pure serialized
- | otherwise = throwFieldError ResultCoercionError
+ | Just serialized <- serialize outputType result = pure serialized
+ | otherwise = throwM $ ResultCoercionException $ show outputType
mergeSelectionSets :: MonadCatch m
- => NonEmpty (Field m)
- -> Seq (Selection m)
+ => NonEmpty (Transform.Field m)
+ -> Seq (Transform.Selection m)
mergeSelectionSets = foldr forEach mempty
where
- forEach (Field _ _ _ fieldSelectionSet _) selectionSet' =
+ forEach (Transform.Field _ _ _ fieldSelectionSet _) selectionSet' =
selectionSet' <> fieldSelectionSet
-throwFieldError :: MonadCatch m => FieldError -> m a
-throwFieldError = throwM . FieldException
-
coerceArgumentValues :: MonadCatch m
=> HashMap Full.Name In.Argument
- -> HashMap Full.Name (Full.Node Input)
+ -> HashMap Full.Name (Full.Node Transform.Input)
-> m Type.Subs
coerceArgumentValues argumentDefinitions argumentValues =
HashMap.foldrWithKey c pure argumentDefinitions mempty
@@ -754,53 +536,53 @@ coerceArgumentValues argumentDefinitions argumentValues =
$ Just inputValue
| otherwise -> throwM
$ InputCoercionException (Text.unpack argumentName) variableType Nothing
- matchFieldValues' = Coerce.matchFieldValues coerceArgumentValue
+ matchFieldValues' = matchFieldValues coerceArgumentValue
$ Full.node <$> argumentValues
- coerceArgumentValue inputType (Int integer) =
- Coerce.coerceInputLiteral inputType (Type.Int integer)
- coerceArgumentValue inputType (Boolean boolean) =
- Coerce.coerceInputLiteral inputType (Type.Boolean boolean)
- coerceArgumentValue inputType (String string) =
- Coerce.coerceInputLiteral inputType (Type.String string)
- coerceArgumentValue inputType (Float float) =
- Coerce.coerceInputLiteral inputType (Type.Float float)
- coerceArgumentValue inputType (Enum enum) =
- Coerce.coerceInputLiteral inputType (Type.Enum enum)
- coerceArgumentValue inputType Null
+ coerceArgumentValue inputType (Transform.Int integer) =
+ coerceInputLiteral inputType (Type.Int integer)
+ coerceArgumentValue inputType (Transform.Boolean boolean) =
+ coerceInputLiteral inputType (Type.Boolean boolean)
+ coerceArgumentValue inputType (Transform.String string) =
+ coerceInputLiteral inputType (Type.String string)
+ coerceArgumentValue inputType (Transform.Float float) =
+ coerceInputLiteral inputType (Type.Float float)
+ coerceArgumentValue inputType (Transform.Enum enum) =
+ coerceInputLiteral inputType (Type.Enum enum)
+ coerceArgumentValue inputType Transform.Null
| In.isNonNullType inputType = Nothing
- | otherwise = Coerce.coerceInputLiteral inputType Type.Null
- coerceArgumentValue (In.ListBaseType inputType) (List list) =
+ | otherwise = coerceInputLiteral inputType Type.Null
+ coerceArgumentValue (In.ListBaseType inputType) (Transform.List list) =
let coerceItem = coerceArgumentValue inputType
in Type.List <$> traverse coerceItem list
- coerceArgumentValue (In.InputObjectBaseType inputType) (Object object)
+ coerceArgumentValue (In.InputObjectBaseType inputType) (Transform.Object object)
| In.InputObjectType _ _ inputFields <- inputType =
let go = forEachField object
resultMap = HashMap.foldrWithKey go (pure mempty) inputFields
in Type.Object <$> resultMap
- coerceArgumentValue _ (Variable variable) = pure variable
+ coerceArgumentValue _ (Transform.Variable variable) = pure variable
coerceArgumentValue _ _ = Nothing
forEachField object variableName (In.InputField _ variableType defaultValue) =
- Coerce.matchFieldValues coerceArgumentValue object variableName variableType defaultValue
+ matchFieldValues coerceArgumentValue object variableName variableType defaultValue
collectFields :: Monad m
=> Out.ObjectType m
- -> Seq (Selection m)
- -> OrderedMap (NonEmpty (Field m))
+ -> Seq (Transform.Selection m)
+ -> OrderedMap (NonEmpty (Transform.Field m))
collectFields objectType = foldl forEach OrderedMap.empty
where
- forEach groupedFields (FieldSelection fieldSelection) =
- let Field maybeAlias fieldName _ _ _ = fieldSelection
+ forEach groupedFields (Transform.FieldSelection fieldSelection) =
+ let Transform.Field maybeAlias fieldName _ _ _ = fieldSelection
responseKey = fromMaybe fieldName maybeAlias
in OrderedMap.insert responseKey (fieldSelection :| []) groupedFields
- forEach groupedFields (FragmentSelection selectionFragment)
- | Fragment fragmentType fragmentSelectionSet _ <- selectionFragment
+ forEach groupedFields (Transform.FragmentSelection selectionFragment)
+ | Transform.Fragment fragmentType fragmentSelectionSet _ <- selectionFragment
, Type.Internal.doesFragmentTypeApply fragmentType objectType =
let fragmentGroupedFieldSet =
collectFields objectType fragmentSelectionSet
in groupedFields <> fragmentGroupedFieldSet
| otherwise = groupedFields
-coerceVariableValues :: (Monad m, Coerce.VariableValue b)
+coerceVariableValues :: (Monad m, VariableValue b)
=> HashMap Full.Name (Schema.Type m)
-> Full.OperationDefinition
-> HashMap Full.Name b
@@ -818,7 +600,7 @@ coerceVariableValues types operationDefinition' variableValues
in case Type.Internal.lookupInputType variableTypeName types of
Just variableType ->
maybe (Left $ CoercionError variableDefinition) Right
- $ Coerce.matchFieldValues
+ $ matchFieldValues
coerceVariableValue'
variableValues
variableName
@@ -828,8 +610,8 @@ coerceVariableValues types operationDefinition' variableValues
Nothing -> Left $ UnknownInputType variableDefinition
forEach _ coercedValuesOrError = coercedValuesOrError
coerceVariableValue' variableType value'
- = Coerce.coerceVariableValue variableType value'
- >>= Coerce.coerceInputLiteral variableType
+ = coerceVariableValue variableType value'
+ >>= coerceInputLiteral variableType
constValue :: Full.ConstValue -> Type.Value
constValue (Full.ConstInt i) = Type.Int i
@@ -845,8 +627,8 @@ constValue (Full.ConstObject o) =
constObjectField Full.ObjectField{value = value', ..} =
(name, constValue $ Full.node value')
-subscribe :: (MonadCatch m, Coerce.Serialize a)
- => Seq (Selection m)
+subscribe :: (MonadCatch m, Serialize a)
+ => Seq (Transform.Selection m)
-> Schema m
-> Full.Location
-> m (Either Error (ResponseEventStream m a))
@@ -861,10 +643,10 @@ subscribe fields schema objectLocation
| otherwise = pure $ Left
$ Error "Schema doesn't support subscriptions." [] []
-mapSourceToResponseEvent :: (MonadCatch m, Coerce.Serialize a)
+mapSourceToResponseEvent :: (MonadCatch m, Serialize a)
=> HashMap Full.Name (Type m)
-> Out.ObjectType m
- -> Seq (Selection m)
+ -> Seq (Transform.Selection m)
-> Out.SourceEventStream m
-> m (ResponseEventStream m a)
mapSourceToResponseEvent types' subscriptionType fields sourceStream
@@ -876,11 +658,12 @@ createSourceEventStream :: MonadCatch m
=> HashMap Full.Name (Type m)
-> Out.ObjectType m
-> Full.Location
- -> Seq (Selection m)
+ -> Seq (Transform.Selection m)
-> m (Either Error (Out.SourceEventStream m))
createSourceEventStream _types subscriptionType objectLocation fields
| [fieldGroup] <- OrderedMap.elems groupedFieldSet
- , Field _ fieldName arguments' _ errorLocation <- NonEmpty.head fieldGroup
+ , Transform.Field _ fieldName arguments' _ errorLocation <-
+ NonEmpty.head fieldGroup
, Out.ObjectType _ _ _ fieldTypes <- subscriptionType
, resolverT <- fieldTypes HashMap.! fieldName
, Out.EventStreamResolver fieldDefinition _ resolver <- resolverT
@@ -889,16 +672,15 @@ createSourceEventStream _types subscriptionType objectLocation fields
Left _ -> pure
$ Left
$ Error "Argument coercion failed." [errorLocation] []
- Right argumentValues -> left (singleError' [errorLocation])
+ Right argumentValues -> left (singleError [errorLocation])
<$> resolveFieldEventStream Type.Null argumentValues resolver
| otherwise = pure
$ Left
$ Error "Subscription contains more than one field." [objectLocation] []
where
groupedFieldSet = collectFields subscriptionType fields
-
-singleError' :: [Full.Location] -> String -> Error
-singleError' errorLocations message = Error (Text.pack message) errorLocations []
+ singleError :: [Full.Location] -> String -> Error
+ singleError errorLocations message = Error (Text.pack message) errorLocations []
resolveFieldEventStream :: MonadCatch m
=> Type.Value
@@ -917,15 +699,16 @@ resolveFieldEventStream result args resolver =
, Type.values = result
}
-executeSubscriptionEvent :: (MonadCatch m, Coerce.Serialize a)
+executeSubscriptionEvent :: (MonadCatch m, Serialize a)
=> HashMap Full.Name (Type m)
-> Out.ObjectType m
- -> Seq (Selection m)
+ -> Seq (Transform.Selection m)
-> Type.Value
-> m (Response a)
executeSubscriptionEvent types' objectType fields initialValue = do
(data', errors) <- runWriterT
$ flip runReaderT types'
$ runExecutorT
- $ executeSelectionSet fields objectType initialValue []
+ $ catch (executeSelectionSet fields objectType initialValue [])
+ handleException
pure $ Response data' errors
diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs
deleted file mode 100644
index 9ad4439..0000000
--- a/src/Language/GraphQL/Execute/Execution.hs
+++ /dev/null
@@ -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
diff --git a/src/Language/GraphQL/Execute/Subscribe.hs b/src/Language/GraphQL/Execute/Subscribe.hs
deleted file mode 100644
index 5d8d294..0000000
--- a/src/Language/GraphQL/Execute/Subscribe.hs
+++ /dev/null
@@ -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
diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs
index 117b708..b2bd643 100644
--- a/src/Language/GraphQL/Execute/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.hs
@@ -6,7 +6,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE NamedFieldPuns #-}
-- | After the document is parsed, before getting executed, the AST is
-- transformed into a similar, simpler AST. Performed transformations include:
@@ -21,65 +21,84 @@
-- This module is also responsible for smaller rewrites that touch only parts of
-- the original AST.
module Language.GraphQL.Execute.Transform
- ( Document(..)
- , Field(..)
+ ( Field(..)
, Fragment(..)
, Input(..)
, Operation(..)
- , QueryError(..)
+ , Replacement(..)
, Selection(..)
+ , TransformT(..)
, document
+ , transform
) where
-import Control.Monad (foldM, unless)
-import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.State (State, evalStateT, gets, modify)
-import Data.Foldable (find)
-import Data.Functor.Identity (Identity(..))
+import Control.Monad (foldM)
+import Control.Monad.Catch (MonadCatch(..), MonadThrow(..))
+import Control.Monad.Trans.Class (MonadTrans(..))
+import Control.Monad.Trans.Reader (ReaderT(..), local)
+import qualified Control.Monad.Trans.Reader as Reader
+import Data.Bifunctor (first)
+import Data.Functor ((<&>))
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
+import Data.HashSet (HashSet)
+import qualified Data.HashSet as HashSet
import Data.Int (Int32)
-import Data.Maybe (fromMaybe)
-import Data.List.NonEmpty (NonEmpty(..))
+import Data.List (intercalate)
import qualified Data.List.NonEmpty as NonEmpty
-import Data.Sequence (Seq, (<|), (><))
+import Data.Maybe (fromMaybe, isJust)
+import Data.Sequence (Seq, (><))
+import qualified Data.Sequence as Seq
import Data.Text (Text)
import qualified Data.Text as Text
-import qualified Language.GraphQL.AST as Full
-import Language.GraphQL.AST (Name)
-import qualified Language.GraphQL.Execute.Coerce as Coerce
-import qualified Language.GraphQL.Type.Definition as Definition
+import qualified Language.GraphQL.AST.Document as Full
+import Language.GraphQL.Type.Schema (Type)
import qualified Language.GraphQL.Type as Type
+import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type.Internal as Type
-import qualified Language.GraphQL.Type.Out as Out
-import qualified Language.GraphQL.Type.Schema as Schema
+import Numeric (showFloat)
--- | Associates a fragment name with a list of 'Field's.
data Replacement m = Replacement
- { fragments :: HashMap Full.Name (Fragment m)
- , fragmentDefinitions :: FragmentDefinitions
- , variableValues :: Type.Subs
- , types :: HashMap Full.Name (Schema.Type m)
+ { variableValues :: Type.Subs
+ , fragmentDefinitions :: HashMap Full.Name Full.FragmentDefinition
+ , visitedFragments :: HashSet Full.Name
+ , types :: HashMap Full.Name (Type m)
}
-type FragmentDefinitions = HashMap Full.Name Full.FragmentDefinition
+newtype TransformT m a = TransformT
+ { runTransformT :: ReaderT (Replacement m) m a
+ }
--- | Represents fragments and inline fragments.
-data Fragment m
- = Fragment (Type.CompositeType m) (Seq (Selection m))
+instance Functor m => Functor (TransformT m) where
+ fmap f = TransformT . fmap f . runTransformT
--- | Single selection element.
-data Selection m
- = SelectionFragment (Fragment m)
- | SelectionField (Field m)
+instance Applicative m => Applicative (TransformT m) where
+ pure = TransformT . pure
+ TransformT f <*> TransformT x = TransformT $ f <*> x
+
+instance Monad m => Monad (TransformT m) where
+ TransformT x >>= f = TransformT $ x >>= runTransformT . f
+
+instance MonadTrans TransformT where
+ lift = TransformT . lift
+
+instance MonadThrow m => MonadThrow (TransformT m) where
+ throwM = lift . throwM
+
+instance MonadCatch m => MonadCatch (TransformT m) where
+ catch (TransformT stack) handler =
+ TransformT $ catch stack $ runTransformT . handler
+
+asks :: Monad m => forall a. (Replacement m -> a) -> TransformT m a
+asks = TransformT . Reader.asks
--- | GraphQL has 3 operation types: queries, mutations and subscribtions.
data Operation m
- = Query (Maybe Text) (Seq (Selection m)) Full.Location
- | Mutation (Maybe Text) (Seq (Selection m)) Full.Location
- | Subscription (Maybe Text) (Seq (Selection m)) Full.Location
+ = Operation Full.OperationType (Seq (Selection m)) Full.Location
+
+data Selection m
+ = FieldSelection (Field m)
+ | FragmentSelection (Fragment m)
--- | Single GraphQL field.
data Field m = Field
(Maybe Full.Name)
Full.Name
@@ -87,339 +106,214 @@ data Field m = Field
(Seq (Selection m))
Full.Location
--- | Contains the operation to be executed along with its root type.
-data Document m = Document
- (HashMap Full.Name (Schema.Type m)) (Out.ObjectType m) (Operation m)
-
-data OperationDefinition = OperationDefinition
- Full.OperationType
- (Maybe Full.Name)
- [Full.VariableDefinition]
- [Full.Directive]
- Full.SelectionSet
- Full.Location
-
--- | Query error types.
-data QueryError
- = OperationNotFound Text
- | OperationNameRequired
- | CoercionError
- | EmptyDocument
- | UnsupportedRootOperation
-
-instance Show QueryError where
- show (OperationNotFound operationName) = unwords
- ["Operation", Text.unpack operationName, "couldn't be found in the document."]
- show OperationNameRequired = "Missing operation name."
- show CoercionError = "Coercion error."
- show EmptyDocument =
- "The document doesn't contain any executable operations."
- show UnsupportedRootOperation =
- "Root operation type couldn't be found in the schema."
+data Fragment m = Fragment
+ (Type.CompositeType m) (Seq (Selection m)) Full.Location
data Input
- = Int Int32
+ = Variable Type.Value
+ | Int Int32
| Float Double
| String Text
| Boolean Bool
| Null
- | Enum Name
- | List [Type.Value]
- | Object (HashMap Name Input)
- | Variable Type.Value
- deriving (Eq, Show)
-
-getOperation
- :: Maybe Full.Name
- -> NonEmpty OperationDefinition
- -> Either QueryError OperationDefinition
-getOperation Nothing (operation' :| []) = pure operation'
-getOperation Nothing _ = Left OperationNameRequired
-getOperation (Just operationName) operations
- | Just operation' <- find matchingName operations = pure operation'
- | otherwise = Left $ OperationNotFound operationName
- where
- matchingName (OperationDefinition _ name _ _ _ _) =
- name == Just operationName
-
-coerceVariableValues :: Coerce.VariableValue a
- => forall m
- . HashMap Full.Name (Schema.Type m)
- -> OperationDefinition
- -> HashMap.HashMap Full.Name a
- -> Either QueryError Type.Subs
-coerceVariableValues types operationDefinition variableValues =
- let OperationDefinition _ _ variableDefinitions _ _ _ = operationDefinition
- in maybe (Left CoercionError) Right
- $ foldr forEach (Just HashMap.empty) variableDefinitions
+ | 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
- forEach variableDefinition coercedValues = do
- let Full.VariableDefinition variableName variableTypeName defaultValue _ =
- variableDefinition
- let defaultValue' = constValue . Full.node <$> defaultValue
- variableType <- Type.lookupInputType variableTypeName types
-
- Coerce.matchFieldValues
- coerceVariableValue'
- variableValues
- variableName
- variableType
- defaultValue'
- coercedValues
- coerceVariableValue' variableType value'
- = Coerce.coerceVariableValue variableType value'
- >>= Coerce.coerceInputLiteral variableType
-
-constValue :: Full.ConstValue -> Type.Value
-constValue (Full.ConstInt i) = Type.Int i
-constValue (Full.ConstFloat f) = Type.Float f
-constValue (Full.ConstString x) = Type.String x
-constValue (Full.ConstBoolean b) = Type.Boolean b
-constValue Full.ConstNull = Type.Null
-constValue (Full.ConstEnum e) = Type.Enum e
-constValue (Full.ConstList list) = Type.List $ constValue . Full.node <$> list
-constValue (Full.ConstObject o) =
- Type.Object $ HashMap.fromList $ constObjectField <$> o
+ 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
- constObjectField Full.ObjectField{value = value', ..} =
- (name, constValue $ Full.node value')
-
--- | Rewrites the original syntax tree into an intermediate representation used
--- for query execution.
-document :: Coerce.VariableValue a
- => forall m
- . Type.Schema m
- -> Maybe Full.Name
- -> HashMap Full.Name a
- -> Full.Document
- -> Either QueryError (Document m)
-document schema operationName subs ast = do
- let referencedTypes = Schema.types schema
-
- (operations, fragmentTable) <- defragment ast
- chosenOperation <- getOperation operationName operations
- coercedValues <- coerceVariableValues referencedTypes chosenOperation subs
-
- let replacement = Replacement
- { fragments = HashMap.empty
- , fragmentDefinitions = fragmentTable
- , variableValues = coercedValues
- , types = referencedTypes
- }
- case chosenOperation of
- OperationDefinition Full.Query _ _ _ _ _ ->
- 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
+ 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
- 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
+ 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
- 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
+ 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 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
+ 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
- selectionFragment typeName = Right
- . SelectionFragment
- . Fragment typeName
-
-appendSelection :: Traversable t
- => t Full.Selection
- -> State (Replacement m) (Seq (Selection m))
-appendSelection = foldM go mempty
+ 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
- go acc sel = append acc <$> selection sel
- append acc (Left list) = list >< acc
- append acc (Right one) = one <| acc
+ 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
-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
diff --git a/src/Language/GraphQL/Executor.hs b/src/Language/GraphQL/Executor.hs
deleted file mode 100644
index 39428d5..0000000
--- a/src/Language/GraphQL/Executor.hs
+++ /dev/null
@@ -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
diff --git a/src/Language/GraphQL/Type/Definition.hs b/src/Language/GraphQL/Type/Definition.hs
index 076b38e..cbfeeeb 100644
--- a/src/Language/GraphQL/Type/Definition.hs
+++ b/src/Language/GraphQL/Type/Definition.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE Safe #-}
-- | Types that can be used as both input and output types.
module Language.GraphQL.Type.Definition
diff --git a/src/Language/GraphQL/Type/In.hs b/src/Language/GraphQL/Type/In.hs
index d42599b..376ed6f 100644
--- a/src/Language/GraphQL/Type/In.hs
+++ b/src/Language/GraphQL/Type/In.hs
@@ -3,6 +3,7 @@
obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE Safe #-}
{-# LANGUAGE ViewPatterns #-}
-- | Input types and values.
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-26 21:18:14 +0000