From a5c44f30facdaabd94ed25953a3bd88005efa868 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Thu, 14 May 2020 09:17:14 +0200 Subject: Add basic output object type support --- src/Language/GraphQL.hs | 7 ++- src/Language/GraphQL/Execute.hs | 75 +++++++++++++++++++++------------ src/Language/GraphQL/Schema.hs | 3 +- src/Language/GraphQL/Type/Definition.hs | 18 ++++++++ src/Language/GraphQL/Type/Schema.hs | 11 +++++ 5 files changed, 82 insertions(+), 32 deletions(-) create mode 100644 src/Language/GraphQL/Type/Definition.hs create mode 100644 src/Language/GraphQL/Type/Schema.hs (limited to 'src/Language') diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs index 73f9bdc..fff378d 100644 --- a/src/Language/GraphQL.hs +++ b/src/Language/GraphQL.hs @@ -5,19 +5,18 @@ module Language.GraphQL ) where import qualified Data.Aeson as Aeson -import Data.List.NonEmpty (NonEmpty) -import Data.HashMap.Strict (HashMap) import Data.Text (Text) import Language.GraphQL.Error import Language.GraphQL.Execute import Language.GraphQL.AST.Parser import qualified Language.GraphQL.Schema as Schema +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. graphql :: Monad m - => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers. + => Schema m -- ^ Resolvers. -> Text -- ^ Text representing a @GraphQL@ request document. -> m Aeson.Value -- ^ Response. graphql = flip graphqlSubs mempty @@ -26,7 +25,7 @@ graphql = flip graphqlSubs mempty -- applied to the query and the query is then executed using to the given -- 'Schema.Resolver's. graphqlSubs :: Monad m - => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers. + => Schema m -- ^ Resolvers. -> Schema.Subs -- ^ Variable substitution function. -> Text -- ^ Text representing a @GraphQL@ request document. -> m Aeson.Value -- ^ Response. diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index 204d08c..e1bacbc 100644 --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} -- | This module provides functions to execute a @GraphQL@ request. module Language.GraphQL.Execute @@ -7,10 +8,8 @@ module Language.GraphQL.Execute ) where import qualified Data.Aeson as Aeson +import Data.Foldable (find) 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.Text (Text) import qualified Data.Text as Text import Language.GraphQL.AST.Document @@ -18,6 +17,18 @@ import qualified Language.GraphQL.AST.Core as AST.Core import qualified Language.GraphQL.Execute.Transform as Transform import Language.GraphQL.Error import qualified Language.GraphQL.Schema as Schema +import Language.GraphQL.Type.Definition +import Language.GraphQL.Type.Schema + +-- | Query error types. +data QueryError + = OperationNotFound Text + | OperationNameRequired + +queryError :: QueryError -> Text +queryError (OperationNotFound operationName) = Text.unwords + ["Operation", operationName, "couldn't be found in the document."] +queryError OperationNameRequired = "Missing operation name." -- | The substitution is applied to the document, and the resolvers are applied -- to the resulting fields. @@ -25,7 +36,7 @@ import qualified Language.GraphQL.Schema as Schema -- Returns the result of the query against the schema wrapped in a /data/ -- field, or errors wrapped in an /errors/ field. execute :: Monad m - => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers. + => Schema m -- ^ Resolvers. -> Schema.Subs -- ^ Variable substitution function. -> Document -- @GraphQL@ document. -> m Aeson.Value @@ -42,45 +53,55 @@ execute schema subs doc = -- Returns the result of the query against the schema wrapped in a /data/ -- field, or errors wrapped in an /errors/ field. executeWithName :: Monad m - => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers + => Schema m -- ^ Resolvers -> Text -- ^ Operation name. -> Schema.Subs -- ^ Variable substitution function. -> Document -- ^ @GraphQL@ Document. -> m Aeson.Value -executeWithName schema name subs doc = - maybe transformError (document schema $ Just name) +executeWithName schema operationName subs doc = + maybe transformError (document schema $ Just operationName) $ Transform.document subs doc where transformError = return $ singleError "Schema transformation error." +getOperation + :: Maybe Text + -> AST.Core.Document + -> Either QueryError AST.Core.Operation +getOperation Nothing (operation' :| []) = pure operation' +getOperation Nothing _ = Left OperationNameRequired +getOperation (Just operationName) document' + | Just operation' <- find matchingName document' = pure operation' + | otherwise = Left $ OperationNotFound operationName + where + matchingName (AST.Core.Query (Just name') _) = operationName == name' + matchingName (AST.Core.Mutation (Just name') _) = operationName == name' + matchingName _ = False + document :: Monad m - => HashMap Text (NonEmpty (Schema.Resolver m)) + => Schema m -> Maybe Text -> AST.Core.Document -> m Aeson.Value -document schema Nothing (op :| []) = operation schema op -document schema (Just name) operations = case NonEmpty.dropWhile matchingName operations of - [] -> return $ singleError - $ Text.unwords ["Operation", name, "couldn't be found in the document."] - (op:_) -> operation schema op - where - matchingName (AST.Core.Query (Just name') _) = name == name' - matchingName (AST.Core.Mutation (Just name') _) = name == name' - matchingName _ = False -document _ _ _ = return $ singleError "Missing operation name." +document schema operationName document' = + case getOperation operationName document' of + Left error' -> pure $ singleError $ queryError error' + Right operation' -> operation schema operation' operation :: Monad m - => HashMap Text (NonEmpty (Schema.Resolver m)) + => Schema m -> AST.Core.Operation -> m Aeson.Value -operation schema = schemaOperation +operation = schemaOperation where - runResolver fields = runCollectErrs - . flip Schema.resolve fields - . Schema.resolversToMap - resolve fields queryType = maybe lookupError (runResolver fields) - $ HashMap.lookup queryType schema + resolve queryFields = runCollectErrs + . flip Schema.resolve queryFields + . fields lookupError = pure $ singleError "Root operation type couldn't be found in the schema." - schemaOperation (AST.Core.Query _ fields) = resolve fields "Query" - schemaOperation (AST.Core.Mutation _ fields) = resolve fields "Mutation" + schemaOperation Schema {query} (AST.Core.Query _ fields') = + resolve fields' query + schemaOperation Schema {mutation = Just mutation} (AST.Core.Mutation _ fields') = + resolve fields' mutation + schemaOperation Schema {mutation = Nothing} (AST.Core.Mutation _ _) = + lookupError diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs index 90a766c..e76b42e 100644 --- a/src/Language/GraphQL/Schema.hs +++ b/src/Language/GraphQL/Schema.hs @@ -3,7 +3,8 @@ -- | This module provides a representation of a @GraphQL@ Schema in addition to -- functions for defining and manipulating schemas. module Language.GraphQL.Schema - ( Resolver(..) + ( FieldResolver(..) + , Resolver(..) , Subs , object , resolve diff --git a/src/Language/GraphQL/Type/Definition.hs b/src/Language/GraphQL/Type/Definition.hs new file mode 100644 index 0000000..016eeb8 --- /dev/null +++ b/src/Language/GraphQL/Type/Definition.hs @@ -0,0 +1,18 @@ +module Language.GraphQL.Type.Definition + ( ObjectType(..) + ) where + +import Data.HashMap.Strict (HashMap) +import Data.Text (Text) +import Language.GraphQL.Schema + +type Fields m = HashMap Text (FieldResolver m) + +-- | 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 :: Text + , fields :: Fields m + } diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs new file mode 100644 index 0000000..f830c26 --- /dev/null +++ b/src/Language/GraphQL/Type/Schema.hs @@ -0,0 +1,11 @@ +module Language.GraphQL.Type.Schema + ( Schema(..) + ) where + +import Language.GraphQL.Type.Definition + +-- | Schema Definition +data Schema m = Schema + { query :: ObjectType m + , mutation :: Maybe (ObjectType m) + } -- cgit v1.2.3