aboutsummaryrefslogtreecommitdiff
path: root/src/Language/GraphQL/Execute
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/GraphQL/Execute')
-rw-r--r--src/Language/GraphQL/Execute/Coerce.hs10
-rw-r--r--src/Language/GraphQL/Execute/Execution.hs135
-rw-r--r--src/Language/GraphQL/Execute/Internal.hs31
-rw-r--r--src/Language/GraphQL/Execute/OrderedMap.hs148
-rw-r--r--src/Language/GraphQL/Execute/Subscribe.hs78
-rw-r--r--src/Language/GraphQL/Execute/Transform.hs91
6 files changed, 369 insertions, 124 deletions
diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs
index 08a2fc0..f5ee204 100644
--- a/src/Language/GraphQL/Execute/Coerce.hs
+++ b/src/Language/GraphQL/Execute/Coerce.hs
@@ -19,7 +19,6 @@ import qualified Data.Aeson as Aeson
import Data.Int (Int32)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
-import Data.Map.Strict (Map)
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Data.Text.Lazy as Text.Lazy
@@ -27,6 +26,8 @@ import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified Data.Text.Lazy.Builder.Int as Text.Builder
import Data.Scientific (toBoundedInteger, toRealFloat)
import Language.GraphQL.AST (Name)
+import Language.GraphQL.Execute.OrderedMap (OrderedMap)
+import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
import qualified Language.GraphQL.Type as Type
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
@@ -209,7 +210,7 @@ data Output a
| Boolean Bool
| Enum Name
| List [a]
- | Object (Map Name a)
+ | Object (OrderedMap a)
deriving (Eq, Show)
instance forall a. IsString (Output a) where
@@ -229,6 +230,9 @@ instance Serialize Aeson.Value where
, Boolean boolean <- value = Just $ Aeson.Bool boolean
serialize _ (Enum enum) = Just $ Aeson.String enum
serialize _ (List list) = Just $ Aeson.toJSON list
- serialize _ (Object object) = Just $ Aeson.toJSON object
+ serialize _ (Object object) = Just
+ $ Aeson.object
+ $ OrderedMap.toList
+ $ Aeson.toJSON <$> object
serialize _ _ = Nothing
null = Aeson.Null
diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs
index 9d588ca..9ad4439 100644
--- a/src/Language/GraphQL/Execute/Execution.hs
+++ b/src/Language/GraphQL/Execute/Execution.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
@@ -13,16 +14,18 @@ import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (runReaderT)
import Control.Monad.Trans.State (gets)
import Data.List.NonEmpty (NonEmpty(..))
-import Data.Map.Strict (Map)
+import qualified Data.List.NonEmpty as NonEmpty
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
-import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Sequence (Seq(..))
import qualified Data.Text as Text
-import Language.GraphQL.AST (Name)
+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
@@ -34,15 +37,17 @@ resolveFieldValue :: MonadCatch m
=> Type.Value
-> Type.Subs
-> Type.Resolve m
+ -> Full.Location
-> CollectErrsT m Type.Value
-resolveFieldValue result args resolver =
+resolveFieldValue result args resolver location' =
catch (lift $ runReaderT resolver context) handleFieldError
where
handleFieldError :: MonadCatch m
=> ResolverException
-> CollectErrsT m Type.Value
- handleFieldError e =
- addErr (Error (Text.pack $ displayException e) [] []) >> pure Type.Null
+ handleFieldError e
+ = addError Type.Null
+ $ Error (Text.pack $ displayException e) [location'] []
context = Type.Context
{ Type.arguments = Type.Arguments args
, Type.values = result
@@ -51,21 +56,21 @@ resolveFieldValue result args resolver =
collectFields :: Monad m
=> Out.ObjectType m
-> Seq (Transform.Selection m)
- -> Map Name (NonEmpty (Transform.Field m))
-collectFields objectType = foldl forEach Map.empty
+ -> OrderedMap (NonEmpty (Transform.Field m))
+collectFields objectType = foldl forEach OrderedMap.empty
where
forEach groupedFields (Transform.SelectionField field) =
let responseKey = aliasOrName field
- in Map.insertWith (<>) responseKey (field :| []) groupedFields
+ 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 Map.unionWith (<>) groupedFields fragmentGroupedFieldSet
+ in groupedFields <> fragmentGroupedFieldSet
| otherwise = groupedFields
-aliasOrName :: forall m. Transform.Field m -> Name
-aliasOrName (Transform.Field alias name _ _) = fromMaybe name alias
+aliasOrName :: forall m. Transform.Field m -> Full.Name
+aliasOrName (Transform.Field alias name _ _ _) = fromMaybe name alias
resolveAbstractType :: Monad m
=> Internal.AbstractType m
@@ -95,11 +100,15 @@ executeField fieldResolver prev fields
where
executeField' fieldDefinition resolver = do
let Out.Field _ fieldType argumentDefinitions = fieldDefinition
- let (Transform.Field _ _ arguments' _ :| []) = fields
+ let Transform.Field _ _ arguments' _ location' = NonEmpty.head fields
case coerceArgumentValues argumentDefinitions arguments' of
- Nothing -> addErrMsg "Argument coercing failed."
- Just argumentValues -> do
- answer <- resolveFieldValue prev argumentValues resolver
+ 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)
@@ -110,55 +119,67 @@ completeValue :: (MonadCatch m, Serialize 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 . List
-completeValue outputType@(Out.ScalarBaseType _) _ (Type.Int int) =
- coerceResult outputType $ Int int
-completeValue outputType@(Out.ScalarBaseType _) _ (Type.Boolean boolean) =
- coerceResult outputType $ Boolean boolean
-completeValue outputType@(Out.ScalarBaseType _) _ (Type.Float float) =
- coerceResult outputType $ Float float
-completeValue outputType@(Out.ScalarBaseType _) _ (Type.String string) =
- coerceResult outputType $ String string
-completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) =
+ >>= 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 $ Enum enum
- else addErrMsg "Enum value completion failed."
-completeValue (Out.ObjectBaseType objectType) fields result =
- executeSelectionSet result objectType $ mergeSelectionSets fields
+ 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
+ Just objectType -> executeSelectionSet result objectType location
$ mergeSelectionSets fields
- Nothing -> addErrMsg "Interface value completion failed."
+ 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
- $ mergeSelectionSets fields
- Nothing -> addErrMsg "Union value completion failed."
-completeValue _ _ _ = addErrMsg "Value completion failed."
+ 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 =
+ 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 result
+coerceResult outputType parentLocation result
| Just serialized <- serialize outputType result = pure serialized
- | otherwise = addErrMsg "Result coercion failed."
+ | 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
@@ -166,29 +187,45 @@ coerceResult outputType result
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) selectionSet = do
+executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) objectLocation selectionSet = do
let fields = collectFields objectType selectionSet
- resolvedValues <- Map.traverseMaybeWithKey forEach fields
- coerceResult (Out.NonNullObjectType objectType) $ Object resolvedValues
+ resolvedValues <- OrderedMap.traverseMaybe forEach fields
+ coerceResult (Out.NonNullObjectType objectType) objectLocation
+ $ Object resolvedValues
where
- forEach _ fields@(field :| _) =
- let Transform.Field _ name _ _ = field
+ 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 Name In.Argument
- -> HashMap Name Transform.Input
- -> Maybe Type.Subs
-coerceArgumentValues argumentDefinitions argumentValues =
+ :: 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 variableName (In.Argument _ variableType defaultValue) =
- matchFieldValues coerceArgumentValue argumentValues variableName variableType defaultValue
+ 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) =
diff --git a/src/Language/GraphQL/Execute/Internal.hs b/src/Language/GraphQL/Execute/Internal.hs
new file mode 100644
index 0000000..046db45
--- /dev/null
+++ b/src/Language/GraphQL/Execute/Internal.hs
@@ -0,0 +1,31 @@
+{- 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 ExplicitForAll #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Language.GraphQL.Execute.Internal
+ ( addError
+ , singleError
+ ) where
+
+import Control.Monad.Trans.State (modify)
+import Control.Monad.Catch (MonadCatch)
+import Data.Sequence ((|>))
+import qualified Data.Text as Text
+import qualified Language.GraphQL.AST as Full
+import Language.GraphQL.Error (CollectErrsT, Error(..), Resolution(..))
+import Prelude hiding (null)
+
+addError :: MonadCatch m => forall a. a -> Error -> CollectErrsT m a
+addError returnValue error' = modify appender >> pure returnValue
+ where
+ appender :: Resolution m -> Resolution m
+ appender resolution@Resolution{ errors } = resolution
+ { errors = errors |> error'
+ }
+
+singleError :: [Full.Location] -> String -> Error
+singleError errorLocations message = Error (Text.pack message) errorLocations []
diff --git a/src/Language/GraphQL/Execute/OrderedMap.hs b/src/Language/GraphQL/Execute/OrderedMap.hs
new file mode 100644
index 0000000..e905cce
--- /dev/null
+++ b/src/Language/GraphQL/Execute/OrderedMap.hs
@@ -0,0 +1,148 @@
+{- 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 #-}
+
+-- | This module contains a map data structure, that preserves insertion order.
+-- Some definitions conflict with functions from prelude, so this module should
+-- probably be imported qualified.
+module Language.GraphQL.Execute.OrderedMap
+ ( OrderedMap
+ , elems
+ , empty
+ , insert
+ , foldlWithKey'
+ , keys
+ , lookup
+ , replace
+ , singleton
+ , size
+ , toList
+ , traverseMaybe
+ ) where
+
+import qualified Data.Foldable as Foldable
+import Data.HashMap.Strict (HashMap, (!))
+import qualified Data.HashMap.Strict as HashMap
+import Data.Text (Text)
+import Data.Vector (Vector)
+import qualified Data.Vector as Vector
+import Prelude hiding (filter, lookup)
+
+-- | This map associates values with the given text keys. Insertion order is
+-- preserved. When inserting a value with a key, that is already available in
+-- the map, the existing value isn't overridden, but combined with the new value
+-- using its 'Semigroup' instance.
+--
+-- Internally this map uses an array with keys to preserve the order and an
+-- unorded map with key-value pairs.
+data OrderedMap v = OrderedMap (Vector Text) (HashMap Text v)
+ deriving (Eq)
+
+instance Functor OrderedMap where
+ fmap f (OrderedMap vector hashMap) = OrderedMap vector $ fmap f hashMap
+
+instance Foldable OrderedMap where
+ foldr f = foldrWithKey $ const f
+ null (OrderedMap vector _) = Vector.null vector
+
+instance Semigroup v => Semigroup (OrderedMap v) where
+ (<>) = foldlWithKey'
+ $ \accumulator key value -> insert key value accumulator
+
+instance Semigroup v => Monoid (OrderedMap v) where
+ mempty = empty
+
+instance Traversable OrderedMap where
+ traverse f (OrderedMap vector hashMap) = OrderedMap vector
+ <$> traverse f hashMap
+
+instance Show v => Show (OrderedMap v) where
+ showsPrec precedence map' = showParen (precedence > 10)
+ $ showString "fromList " . shows (toList map')
+
+-- * Construction
+
+-- | Constructs a map with a single element.
+singleton :: forall v. Text -> v -> OrderedMap v
+singleton key value = OrderedMap (Vector.singleton key)
+ $ HashMap.singleton key value
+
+-- | Constructs an empty map.
+empty :: forall v. OrderedMap v
+empty = OrderedMap mempty mempty
+
+-- * Traversal
+
+-- | Reduces this map by applying a binary operator from right to left to all
+-- elements, using the given starting value.
+foldrWithKey :: forall v a. (Text -> v -> a -> a) -> a -> OrderedMap v -> a
+foldrWithKey f initial (OrderedMap vector hashMap) = foldr go initial vector
+ where
+ go key = f key (hashMap ! key)
+
+-- | Reduces this map by applying a binary operator from left to right to all
+-- elements, using the given starting value.
+foldlWithKey' :: forall v a. (a -> Text -> v -> a) -> a -> OrderedMap v -> a
+foldlWithKey' f initial (OrderedMap vector hashMap) =
+ Vector.foldl' go initial vector
+ where
+ go accumulator key = f accumulator key (hashMap ! key)
+
+-- | Traverse over the elements and collect the 'Just' results.
+traverseMaybe
+ :: Applicative f
+ => forall a
+ . (a -> f (Maybe b))
+ -> OrderedMap a
+ -> f (OrderedMap b)
+traverseMaybe f orderedMap = foldlWithKey' filter empty
+ <$> traverse f orderedMap
+ where
+ filter accumulator key (Just value) = replace key value accumulator
+ filter accumulator _ Nothing = accumulator
+
+-- * Lists
+
+-- | Converts this map to the list of key-value pairs.
+toList :: forall v. OrderedMap v -> [(Text, v)]
+toList = foldrWithKey ((.) (:) . (,)) []
+
+-- | Returns a list with all keys in this map.
+keys :: forall v. OrderedMap v -> [Text]
+keys (OrderedMap vector _) = Foldable.toList vector
+
+-- | Returns a list with all elements in this map.
+elems :: forall v. OrderedMap v -> [v]
+elems = fmap snd . toList
+
+-- * Basic interface
+
+-- | Associates the specified value with the specified key in this map. If this
+-- map previously contained a mapping for the key, the existing and new values
+-- are combined.
+insert :: Semigroup v => Text -> v -> OrderedMap v -> OrderedMap v
+insert key value (OrderedMap vector hashMap)
+ | Just available <- HashMap.lookup key hashMap = OrderedMap vector
+ $ HashMap.insert key (available <> value) hashMap
+ | otherwise = OrderedMap (Vector.snoc vector key)
+ $ HashMap.insert key value hashMap
+
+-- | Associates the specified value with the specified key in this map. If this
+-- map previously contained a mapping for the key, the existing value is
+-- replaced by the new one.
+replace :: Text -> v -> OrderedMap v -> OrderedMap v
+replace key value (OrderedMap vector hashMap)
+ | HashMap.member key hashMap = OrderedMap vector
+ $ HashMap.insert key value hashMap
+ | otherwise = OrderedMap (Vector.snoc vector key)
+ $ HashMap.insert key value hashMap
+
+-- | Gives the size of this map, i.e. number of elements in it.
+size :: forall v. OrderedMap v -> Int
+size (OrderedMap vector _) = Vector.length vector
+
+-- | Looks up a value in this map by key.
+lookup :: forall v. Text -> OrderedMap v -> Maybe v
+lookup key (OrderedMap _ hashMap) = HashMap.lookup key hashMap
diff --git a/src/Language/GraphQL/Execute/Subscribe.hs b/src/Language/GraphQL/Execute/Subscribe.hs
index 0bd274f..5d8d294 100644
--- a/src/Language/GraphQL/Execute/Subscribe.hs
+++ b/src/Language/GraphQL/Execute/Subscribe.hs
@@ -9,62 +9,78 @@ module Language.GraphQL.Execute.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.Map.Strict as Map
import qualified Data.List.NonEmpty as NonEmpty
import Data.Sequence (Seq(..))
-import Data.Text (Text)
-import qualified Data.Text as Text
-import Language.GraphQL.AST (Name)
+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
--- This is actually executeMutation, but we don't distinguish between queries
--- and mutations yet.
subscribe :: (MonadCatch m, Serialize a)
- => HashMap Name (Type m)
+ => HashMap Full.Name (Type m)
-> Out.ObjectType m
+ -> Full.Location
-> Seq (Transform.Selection m)
- -> m (Either Text (ResponseEventStream m a))
-subscribe types' objectType fields = do
- sourceStream <- createSourceEventStream types' objectType fields
- traverse (mapSourceToResponseEvent types' objectType fields) sourceStream
+ -> 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 Name (Type m)
+ => HashMap Full.Name (Type m)
-> Out.ObjectType m
+ -> Full.Location
-> Seq (Transform.Selection m)
-> Out.SourceEventStream m
-> m (ResponseEventStream m a)
-mapSourceToResponseEvent types' subscriptionType fields sourceStream = pure
+mapSourceToResponseEvent types' subscriptionType objectLocation fields sourceStream
+ = pure
$ sourceStream
- .| mapMC (executeSubscriptionEvent types' subscriptionType fields)
+ .| mapMC (executeSubscriptionEvent types' subscriptionType objectLocation fields)
createSourceEventStream :: MonadCatch m
- => HashMap Name (Type m)
+ => HashMap Full.Name (Type m)
-> Out.ObjectType m
+ -> Full.Location
-> Seq (Transform.Selection m)
- -> m (Either Text (Out.SourceEventStream m))
-createSourceEventStream _types subscriptionType@(Out.ObjectType _ _ _ fieldTypes) fields
- | [fieldGroup] <- Map.elems groupedFieldSet
- , Transform.Field _ fieldName arguments' _ <- NonEmpty.head fieldGroup
+ -> 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
- Nothing -> pure $ Left "Argument coercion failed."
- Just argumentValues ->
- resolveFieldEventStream Type.Null argumentValues resolver
- | otherwise = pure $ Left "Subscription contains more than one field."
+ 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
@@ -72,26 +88,26 @@ resolveFieldEventStream :: MonadCatch m
=> Type.Value
-> Type.Subs
-> Out.Subscribe m
- -> m (Either Text (Out.SourceEventStream m))
+ -> m (Either String (Out.SourceEventStream m))
resolveFieldEventStream result args resolver =
catch (Right <$> runReaderT resolver context) handleEventStreamError
where
handleEventStreamError :: MonadCatch m
=> ResolverException
- -> m (Either Text (Out.SourceEventStream m))
- handleEventStreamError = pure . Left . Text.pack . displayException
+ -> m (Either String (Out.SourceEventStream m))
+ handleEventStreamError = pure . Left . displayException
context = Type.Context
{ Type.arguments = Type.Arguments args
, Type.values = result
}
--- This is actually executeMutation, but we don't distinguish between queries
--- and mutations yet.
executeSubscriptionEvent :: (MonadCatch m, Serialize a)
- => HashMap Name (Type m)
+ => HashMap Full.Name (Type m)
-> Out.ObjectType m
+ -> Full.Location
-> Seq (Transform.Selection m)
-> Definition.Value
-> m (Response a)
-executeSubscriptionEvent types' objectType fields initialValue =
- runCollectErrs types' $ executeSelectionSet initialValue objectType fields
+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 010899b..117b708 100644
--- a/src/Language/GraphQL/Execute/Transform.hs
+++ b/src/Language/GraphQL/Execute/Transform.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 ExplicitForAll #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -25,7 +29,6 @@ module Language.GraphQL.Execute.Transform
, QueryError(..)
, Selection(..)
, document
- , queryError
) where
import Control.Monad (foldM, unless)
@@ -71,16 +74,18 @@ data Selection m
| SelectionField (Field m)
-- | GraphQL has 3 operation types: queries, mutations and subscribtions.
---
--- Currently only queries and mutations are supported.
data Operation m
- = Query (Maybe Text) (Seq (Selection m))
- | Mutation (Maybe Text) (Seq (Selection m))
- | Subscription (Maybe Text) (Seq (Selection 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
-- | Single GraphQL field.
data Field m = Field
- (Maybe Full.Name) Full.Name (HashMap Full.Name Input) (Seq (Selection m))
+ (Maybe Full.Name)
+ Full.Name
+ (HashMap Full.Name (Full.Node Input))
+ (Seq (Selection m))
+ Full.Location
-- | Contains the operation to be executed along with its root type.
data Document m = Document
@@ -92,16 +97,26 @@ data OperationDefinition = OperationDefinition
[Full.VariableDefinition]
[Full.Directive]
Full.SelectionSet
+ Full.Location
-- | Query error types.
data QueryError
= OperationNotFound Text
| OperationNameRequired
| CoercionError
- | TransformationError
| EmptyDocument
| UnsupportedRootOperation
+instance Show QueryError where
+ show (OperationNotFound operationName) = unwords
+ ["Operation", Text.unpack operationName, "couldn't be found in the document."]
+ show OperationNameRequired = "Missing operation name."
+ show CoercionError = "Coercion error."
+ show EmptyDocument =
+ "The document doesn't contain any executable operations."
+ show UnsupportedRootOperation =
+ "Root operation type couldn't be found in the schema."
+
data Input
= Int Int32
| Float Double
@@ -114,17 +129,6 @@ data Input
| Variable Type.Value
deriving (Eq, Show)
-queryError :: QueryError -> Text
-queryError (OperationNotFound operationName) = Text.unwords
- ["Operation", operationName, "couldn't be found in the document."]
-queryError OperationNameRequired = "Missing operation name."
-queryError CoercionError = "Coercion error."
-queryError TransformationError = "Schema transformation error."
-queryError EmptyDocument =
- "The document doesn't contain any executable operations."
-queryError UnsupportedRootOperation =
- "Root operation type couldn't be found in the schema."
-
getOperation
:: Maybe Full.Name
-> NonEmpty OperationDefinition
@@ -135,7 +139,7 @@ getOperation (Just operationName) operations
| Just operation' <- find matchingName operations = pure operation'
| otherwise = Left $ OperationNotFound operationName
where
- matchingName (OperationDefinition _ name _ _ _) =
+ matchingName (OperationDefinition _ name _ _ _ _) =
name == Just operationName
coerceVariableValues :: Coerce.VariableValue a
@@ -145,7 +149,7 @@ coerceVariableValues :: Coerce.VariableValue a
-> HashMap.HashMap Full.Name a
-> Either QueryError Type.Subs
coerceVariableValues types operationDefinition variableValues =
- let OperationDefinition _ _ variableDefinitions _ _ = operationDefinition
+ let OperationDefinition _ _ variableDefinitions _ _ _ = operationDefinition
in maybe (Left CoercionError) Right
$ foldr forEach (Just HashMap.empty) variableDefinitions
where
@@ -173,7 +177,7 @@ 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 l) = Type.List $ constValue <$> l
+constValue (Full.ConstList list) = Type.List $ constValue . Full.node <$> list
constValue (Full.ConstObject o) =
Type.Object $ HashMap.fromList $ constObjectField <$> o
where
@@ -203,14 +207,14 @@ document schema operationName subs ast = do
, types = referencedTypes
}
case chosenOperation of
- OperationDefinition Full.Query _ _ _ _ ->
+ OperationDefinition Full.Query _ _ _ _ _ ->
pure $ Document referencedTypes (Schema.query schema)
$ operation chosenOperation replacement
- OperationDefinition Full.Mutation _ _ _ _
+ OperationDefinition Full.Mutation _ _ _ _ _
| Just mutationType <- Schema.mutation schema ->
pure $ Document referencedTypes mutationType
$ operation chosenOperation replacement
- OperationDefinition Full.Subscription _ _ _ _
+ OperationDefinition Full.Subscription _ _ _ _ _
| Just subscriptionType <- Schema.subscription schema ->
pure $ Document referencedTypes subscriptionType
$ operation chosenOperation replacement
@@ -235,10 +239,10 @@ defragment ast =
(operations, HashMap.insert name fragment fragments')
defragment' _ acc = acc
transform = \case
- Full.OperationDefinition type' name variables directives' selections _ ->
- OperationDefinition type' name variables directives' selections
- Full.SelectionSet selectionSet _ ->
- OperationDefinition Full.Query Nothing mempty mempty selectionSet
+ 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
@@ -247,12 +251,12 @@ operation operationDefinition replacement
= runIdentity
$ evalStateT (collectFragments >> transform operationDefinition) replacement
where
- transform (OperationDefinition Full.Query name _ _ sels) =
- Query name <$> appendSelection sels
- transform (OperationDefinition Full.Mutation name _ _ sels) =
- Mutation name <$> appendSelection sels
- transform (OperationDefinition Full.Subscription name _ _ sels) =
- Subscription name <$> appendSelection sels
+ 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
@@ -268,15 +272,20 @@ selection (Full.InlineFragmentSelection fragmentSelection) =
inlineFragment fragmentSelection
field :: Full.Field -> State (Replacement m) (Maybe (Field m))
-field (Full.Field alias name arguments' directives' selections _) = do
+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
+ let field' = Field alias name fieldArguments fieldSelections location
pure $ field' <$ fieldDirectives
where
- go arguments (Full.Argument name' (Full.Node value' _) _) =
- inputField arguments name' value'
+ 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
@@ -380,7 +389,7 @@ 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 list
+value (Full.List list) = Type.List <$> traverse (value . Full.node) list
value (Full.Object object) =
Type.Object . HashMap.fromList <$> traverse objectField object
where
@@ -396,7 +405,7 @@ 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 list
+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
generated by cgit v1.2.3 (git 2.26.2) at 2026-10-02 08:52:01 +0000