summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Language/GraphQL.hs4
-rw-r--r--src/Language/GraphQL/Error.hs1
-rw-r--r--src/Language/GraphQL/Execute.hs4
-rw-r--r--src/Language/GraphQL/Execute/Execution.hs127
-rw-r--r--src/Language/GraphQL/Schema.hs105
-rw-r--r--src/Language/GraphQL/Type/Out.hs13
-rw-r--r--src/Language/GraphQL/Type/Schema.hs23
7 files changed, 148 insertions, 129 deletions
diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs
index aef23f0..961253f 100644
--- a/src/Language/GraphQL.hs
+++ b/src/Language/GraphQL.hs
@@ -16,7 +16,7 @@ import Language.GraphQL.Type.Schema
import Text.Megaparsec (parse)
-- | If the text parses correctly as a @GraphQL@ query the query is
--- executed using the given 'Schema.Resolver's.
+-- executed using the given 'Schema'.
graphql :: Monad m
=> Schema m -- ^ Resolvers.
-> Text -- ^ Text representing a @GraphQL@ request document.
@@ -25,7 +25,7 @@ graphql = flip graphqlSubs (mempty :: Aeson.Object)
-- | If the text parses correctly as a @GraphQL@ query the substitution is
-- applied to the query and the query is then executed using to the given
--- 'Schema.Resolver's.
+-- 'Schema'.
graphqlSubs :: (Monad m, VariableValue a)
=> Schema m -- ^ Resolvers.
-> HashMap Name a -- ^ Variable substitution function.
diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs
index e41782d..59719b0 100644
--- a/src/Language/GraphQL/Error.hs
+++ b/src/Language/GraphQL/Error.hs
@@ -29,6 +29,7 @@ import Text.Megaparsec
, unPos
)
+-- | Executor context.
data Resolution m = Resolution
{ errors :: [Aeson.Value]
, types :: HashMap Name (Type m)
diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs
index ee009db..cfa935c 100644
--- a/src/Language/GraphQL/Execute.hs
+++ b/src/Language/GraphQL/Execute.hs
@@ -11,10 +11,10 @@ import Data.Sequence (Seq(..))
import Data.Text (Text)
import Language.GraphQL.AST.Document (Document, Name)
import Language.GraphQL.Execute.Coerce
+import Language.GraphQL.Execute.Execution
import qualified Language.GraphQL.Execute.Transform as Transform
import Language.GraphQL.Error
import Language.GraphQL.Type.Definition
-import qualified Language.GraphQL.Schema as Schema
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema
@@ -68,4 +68,4 @@ executeOperation :: Monad m
-> Seq (Transform.Selection m)
-> m Aeson.Value
executeOperation types' objectType fields =
- runCollectErrs types' $ Schema.resolve Null objectType fields
+ runCollectErrs types' $ executeSelectionSet Null objectType fields
diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs
index 117df30..140df81 100644
--- a/src/Language/GraphQL/Execute/Execution.hs
+++ b/src/Language/GraphQL/Execute/Execution.hs
@@ -1,20 +1,38 @@
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-}
+
module Language.GraphQL.Execute.Execution
- ( aliasOrName
- , collectFields
+ ( executeSelectionSet
) where
+import qualified Data.Aeson as Aeson
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Except (runExceptT)
+import Control.Monad.Trans.Reader (runReaderT)
+import Control.Monad.Trans.State (gets)
import Data.Map.Strict (Map)
+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 Data.Sequence (Seq(..))
+import Data.Text (Text)
+import qualified Data.Text as Text
import qualified Data.Sequence as Seq
import Language.GraphQL.AST.Document (Name)
+import Language.GraphQL.Error
import Language.GraphQL.Execute.Transform
+import Language.GraphQL.Trans
+import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema
+resolveFieldValue :: Monad m => Value -> Field m -> ActionT m a -> m (Either Text a)
+resolveFieldValue result (Field _ _ args _) =
+ flip runReaderT (Context {arguments=args, values=result})
+ . runExceptT
+ . runActionT
+
collectFields :: Monad m
=> Out.ObjectType m
-> Seq (Selection m)
@@ -34,6 +52,21 @@ collectFields objectType = foldl forEach Map.empty
aliasOrName :: forall m. Field m -> Name
aliasOrName (Field alias name _ _) = fromMaybe name alias
+resolveAbstractType :: Monad m
+ => AbstractType m
+ -> HashMap Name Value
+ -> CollectErrsT m (Maybe (Out.ObjectType m))
+resolveAbstractType abstractType values'
+ | Just (String typeName) <- HashMap.lookup "__typename" values' = do
+ types' <- gets types
+ case HashMap.lookup typeName types' of
+ Just (ObjectType objectType) ->
+ if instanceOf objectType abstractType
+ then pure $ Just objectType
+ else pure Nothing
+ _ -> pure Nothing
+ | otherwise = pure Nothing
+
doesFragmentTypeApply :: forall m
. CompositeType m
-> Out.ObjectType m
@@ -43,16 +76,88 @@ doesFragmentTypeApply (CompositeObjectType fragmentType) objectType =
Out.ObjectType objectName _ _ _ = objectType
in fragmentName == objectName
doesFragmentTypeApply (CompositeInterfaceType fragmentType) objectType =
+ instanceOf objectType $ AbstractInterfaceType fragmentType
+doesFragmentTypeApply (CompositeUnionType fragmentType) objectType =
+ instanceOf objectType $ AbstractUnionType fragmentType
+
+instanceOf :: forall m. Out.ObjectType m -> AbstractType m -> Bool
+instanceOf objectType (AbstractInterfaceType interfaceType) =
let Out.ObjectType _ _ interfaces _ = objectType
- in foldr instanceOf False interfaces
+ in foldr go False interfaces
where
- instanceOf (Out.InterfaceType that _ interfaces _) acc =
- let Out.InterfaceType this _ _ _ = fragmentType
- in acc || foldr instanceOf (this == that) interfaces
-doesFragmentTypeApply (CompositeUnionType fragmentType) objectType =
- let Out.UnionType _ _ members = fragmentType
- in foldr instanceOf False members
+ go (Out.InterfaceType that _ interfaces _) acc =
+ let Out.InterfaceType this _ _ _ = interfaceType
+ in acc || foldr go (this == that) interfaces
+instanceOf objectType (AbstractUnionType unionType) =
+ let Out.UnionType _ _ members = unionType
+ in foldr go False members
where
- instanceOf (Out.ObjectType that _ _ _) acc =
+ go (Out.ObjectType that _ _ _) acc =
let Out.ObjectType this _ _ _ = objectType
in acc || this == that
+
+executeField :: Monad m
+ => Value
+ -> Out.Resolver m
+ -> Field m
+ -> CollectErrsT m Aeson.Value
+executeField prev (Out.Resolver fieldDefinition resolver) field = do
+ let Out.Field _ fieldType _ = fieldDefinition
+ answer <- lift $ resolveFieldValue prev field resolver
+ case answer of
+ Right result -> completeValue fieldType field result
+ Left errorMessage -> errmsg errorMessage
+
+completeValue :: Monad m
+ => Out.Type m
+ -> Field m
+ -> Value
+ -> CollectErrsT m Aeson.Value
+completeValue _ _ Null = pure Aeson.Null
+completeValue _ _ (Int integer) = pure $ Aeson.toJSON integer
+completeValue _ _ (Boolean boolean') = pure $ Aeson.Bool boolean'
+completeValue _ _ (Float float') = pure $ Aeson.toJSON float'
+completeValue _ _ (Enum enum) = pure $ Aeson.String enum
+completeValue _ _ (String string') = pure $ Aeson.String string'
+completeValue (Out.ObjectBaseType objectType) (Field _ _ _ seqSelection) result =
+ executeSelectionSet result objectType seqSelection
+completeValue (Out.ListBaseType listType) selectionField (List list) =
+ Aeson.toJSON <$> traverse (completeValue listType selectionField) list
+completeValue (Out.InterfaceBaseType interfaceType) (Field _ _ _ seqSelection) result
+ | Object objectMap <- result = do
+ abstractType <- resolveAbstractType (AbstractInterfaceType interfaceType) objectMap
+ case abstractType of
+ Just objectType -> executeSelectionSet result objectType seqSelection
+ Nothing -> errmsg "Value completion failed."
+completeValue (Out.UnionBaseType unionType) (Field _ _ _ seqSelection) result
+ | Object objectMap <- result = do
+ abstractType <- resolveAbstractType (AbstractUnionType unionType) objectMap
+ case abstractType of
+ Just objectType -> executeSelectionSet result objectType seqSelection
+ Nothing -> errmsg "Value completion failed."
+completeValue _ _ _ = errmsg "Value completion failed."
+
+errmsg :: Monad m => Text -> CollectErrsT m Aeson.Value
+errmsg errorMessage = addErrMsg errorMessage >> pure Aeson.Null
+
+-- | Takes an 'Out.ObjectType' and a list of 'Selection's and applies each field
+-- to each 'Selection'. Resolves into a value containing the resolved
+-- 'Selection', or a null value and error information.
+executeSelectionSet :: Monad m
+ => Value
+ -> Out.ObjectType m
+ -> Seq (Selection m)
+ -> CollectErrsT m Aeson.Value
+executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do
+ resolvedValues <- Map.traverseMaybeWithKey forEach
+ $ collectFields objectType selectionSet
+ pure $ Aeson.toJSON resolvedValues
+ where
+ forEach _responseKey (field :<| _) =
+ tryResolvers field >>= lift . pure . pure
+ forEach _ _ = pure Nothing
+ lookupResolver = flip HashMap.lookup resolvers
+ tryResolvers fld@(Field _ name _ _)
+ | Just typeField <- lookupResolver name =
+ executeField result typeField fld
+ | otherwise = errmsg $ Text.unwords ["field", name, "not resolved."]
diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs
deleted file mode 100644
index 734f070..0000000
--- a/src/Language/GraphQL/Schema.hs
+++ /dev/null
@@ -1,105 +0,0 @@
-{-# LANGUAGE ExplicitForAll #-}
-{-# LANGUAGE OverloadedStrings #-}
-
--- | This module provides a representation of a @GraphQL@ Schema in addition to
--- functions for defining and manipulating schemas.
-module Language.GraphQL.Schema
- ( Resolver(..)
- , resolve
- ) where
-
-import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.Except (runExceptT)
-import Control.Monad.Trans.Reader (runReaderT)
-import qualified Data.Aeson as Aeson
-import qualified Data.HashMap.Strict as HashMap
-import qualified Data.Map.Strict as Map
-import Data.Sequence (Seq(..))
-import Data.Text (Text)
-import qualified Data.Text as Text
-import Language.GraphQL.AST.Document (Name)
-import Language.GraphQL.Error
-import Language.GraphQL.Execute.Execution
-import Language.GraphQL.Execute.Transform
-import Language.GraphQL.Trans
-import Language.GraphQL.Type.Definition
-import qualified Language.GraphQL.Type.Out as Out
-
--- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error
--- information (if an error has occurred). @m@ is an arbitrary monad, usually
--- 'IO'.
---
--- Resolving a field can result in a leaf value or an object, which is
--- represented as a list of nested resolvers, used to resolve the fields of that
--- object.
-data Resolver m = Resolver Name (ActionT m Value)
-
-resolveFieldValue :: Monad m => Value -> Field m -> ActionT m a -> m (Either Text a)
-resolveFieldValue result (Field _ _ args _) =
- flip runReaderT (Context {arguments=args, values=result})
- . runExceptT
- . runActionT
-
-executeField :: Monad m
- => Value
- -> Out.Field m
- -> Field m
- -> CollectErrsT m Aeson.Value
-executeField prev (Out.Field _ fieldType _ resolver) field = do
- answer <- lift $ resolveFieldValue prev field resolver
- case answer of
- Right result -> completeValue fieldType field result
- Left errorMessage -> errmsg errorMessage
-
-completeValue :: Monad m
- => Out.Type m
- -> Field m
- -> Value
- -> CollectErrsT m Aeson.Value
-completeValue _ _ Null = pure Aeson.Null
-completeValue _ _ (Int integer) = pure $ Aeson.toJSON integer
-completeValue _ _ (Boolean boolean') = pure $ Aeson.Bool boolean'
-completeValue _ _ (Float float') = pure $ Aeson.toJSON float'
-completeValue _ _ (Enum enum) = pure $ Aeson.String enum
-completeValue _ _ (String string') = pure $ Aeson.String string'
-completeValue (Out.ObjectBaseType objectType) (Field _ _ _ seqSelection) result =
- resolve result objectType seqSelection
-completeValue (Out.ListBaseType listType) selectionField (List list) =
- Aeson.toJSON <$> traverse (completeValue listType selectionField) list
-completeValue _ _ _ = errmsg "Value completion failed."
-
-errmsg :: Monad m => Text -> CollectErrsT m Aeson.Value
-errmsg errorMessage = addErrMsg errorMessage >> pure Aeson.Null
-
--- | Takes a list of 'Resolver's and a list of 'Field's and applies each
--- 'Resolver' to each 'Field'. Resolves into a value containing the
--- resolved 'Field', or a null value and error information.
-resolve :: Monad m -- executeSelectionSet
- => Value
- -> Out.ObjectType m
- -> Seq (Selection m)
- -> CollectErrsT m Aeson.Value
-resolve result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do
- resolvedValues <- Map.traverseMaybeWithKey forEach
- $ collectFields objectType selectionSet
- pure $ Aeson.toJSON resolvedValues
- where
- forEach _responseKey (field :<| _) =
- tryResolvers field >>= lift . pure . pure
- forEach _ _ = pure Nothing
- lookupResolver = flip HashMap.lookup resolvers
- tryResolvers fld@(Field _ name _ _)
- | Just typeField <- lookupResolver name =
- executeField result typeField fld
- | otherwise = errmsg $ Text.unwords ["field", name, "not resolved."]
- {-tryResolvers (Out.SelectionFragment (Out.Fragment typeCondition selections'))
- | Just (Out.Field _ _ _ resolver) <- lookupResolver "__typename" = do
- let fakeField = Out.Field Nothing "__typename" mempty mempty
- that <- lift $ resolveFieldValue result fakeField resolver
- case that of
- Right (String typeCondition')
- | (Out.CompositeObjectType (Out.ObjectType n _ _ _)) <- typeCondition
- , typeCondition' == n ->
- fmap fold . traverse tryResolvers $ selections'
- _ -> pure mempty
- | otherwise = fmap fold . traverse tryResolvers $ selections'-}
diff --git a/src/Language/GraphQL/Type/Out.hs b/src/Language/GraphQL/Type/Out.hs
index 4808d09..acd348c 100644
--- a/src/Language/GraphQL/Type/Out.hs
+++ b/src/Language/GraphQL/Type/Out.hs
@@ -10,6 +10,7 @@ module Language.GraphQL.Type.Out
( Field(..)
, InterfaceType(..)
, ObjectType(..)
+ , Resolver(..)
, Type(..)
, UnionType(..)
, isNonNullType
@@ -27,13 +28,22 @@ import Language.GraphQL.AST.Core
import Language.GraphQL.Trans
import Language.GraphQL.Type.Definition
import qualified Language.GraphQL.Type.In as In
+
+-- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error
+-- information (if an error has occurred). @m@ is an arbitrary monad, usually
+-- 'IO'.
--
+-- Resolving a field can result in a leaf value or an object, which is
+-- represented as a list of nested resolvers, used to resolve the fields of that
+-- object.
+data Resolver m = Resolver (Field m) (ActionT m Value)
+
-- | Object type definition.
--
-- Almost all of the GraphQL types you define will be object types. Object
-- types have a name, but most importantly describe their fields.
data ObjectType m = ObjectType
- Name (Maybe Text) [InterfaceType m] (HashMap Name (Field m))
+ Name (Maybe Text) [InterfaceType m] (HashMap Name (Resolver m))
-- | Interface Type Definition.
--
@@ -54,7 +64,6 @@ data Field m = Field
(Maybe Text) -- ^ Description.
(Type m) -- ^ Field type.
(HashMap Name In.Argument) -- ^ Arguments.
- (ActionT m Value) -- ^ Resolver.
-- | These types may be used as output types as the result of fields.
--
diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs
index b6055c5..ff7b5cc 100644
--- a/src/Language/GraphQL/Type/Schema.hs
+++ b/src/Language/GraphQL/Type/Schema.hs
@@ -1,8 +1,10 @@
{-# LANGUAGE ExplicitForAll #-}
--- | Schema Definition.
+-- | This module provides a representation of a @GraphQL@ Schema in addition to
+-- functions for defining and manipulating schemas.
module Language.GraphQL.Type.Schema
- ( CompositeType(..)
+ ( AbstractType(..)
+ , CompositeType(..)
, Schema(..)
, Type(..)
, collectReferencedTypes
@@ -30,6 +32,11 @@ data CompositeType m
| CompositeObjectType (Out.ObjectType m)
| CompositeInterfaceType (Out.InterfaceType m)
+-- | These types may describe the parent context of a selection set.
+data AbstractType m
+ = AbstractUnionType (Out.UnionType m)
+ | AbstractInterfaceType (Out.InterfaceType m)
+
-- | A Schema is created by supplying the root types of each type of operation,
-- query and mutation (optional). A schema definition is then supplied to the
-- validator and executor.
@@ -51,7 +58,7 @@ collectReferencedTypes schema =
collect traverser typeName element foundTypes
| HashMap.member typeName foundTypes = foundTypes
| otherwise = traverser $ HashMap.insert typeName element foundTypes
- visitFields (Out.Field _ outputType arguments _) foundTypes
+ visitFields (Out.Field _ outputType arguments) foundTypes
= traverseOutputType outputType
$ foldr visitArguments foundTypes arguments
visitArguments (In.Argument _ inputType _) = traverseInputType inputType
@@ -86,15 +93,17 @@ collectReferencedTypes schema =
let (Definition.EnumType typeName _ _) = enumType
in collect Prelude.id typeName (EnumType enumType)
traverseObjectType objectType foundTypes =
- let (Out.ObjectType typeName _ interfaces fields) = objectType
+ let (Out.ObjectType typeName _ interfaces resolvers) = objectType
element = ObjectType objectType
- traverser = polymorphicTypeTraverser interfaces fields
+ fields = extractObjectField <$> resolvers
+ traverser = polymorphicTraverser interfaces fields
in collect traverser typeName element foundTypes
traverseInterfaceType interfaceType foundTypes =
let (Out.InterfaceType typeName _ interfaces fields) = interfaceType
element = InterfaceType interfaceType
- traverser = polymorphicTypeTraverser interfaces fields
+ traverser = polymorphicTraverser interfaces fields
in collect traverser typeName element foundTypes
- polymorphicTypeTraverser interfaces fields
+ polymorphicTraverser interfaces fields
= flip (foldr visitFields) fields
. flip (foldr traverseInterfaceType) interfaces
+ extractObjectField (Out.Resolver field _) = field
generated by cgit v1.2.3 (git 2.26.2) at 2026-06-26 22:14:01 +0000