From c311cb0070de2979111014e8e22a5f6fefee3ea3 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Thu, 13 May 2021 17:40:38 +0200 Subject: [PATCH] Add constructor with additional schema types --- CHANGELOG.md | 4 ++ src/Language/GraphQL/Type.hs | 2 +- src/Language/GraphQL/Type/Internal.hs | 33 +++++++------ src/Language/GraphQL/Type/Schema.hs | 46 +++++++++++++++--- tests/Language/GraphQL/ExecuteSpec.hs | 69 ++++++++++++++++++++++----- 5 files changed, 119 insertions(+), 35 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index b18668a..174e6dc 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,6 +10,10 @@ and this project adheres to ### Added - `Language.GraphQL.Execute.OrderedMap` is a map data structure, that preserves insertion order. +- `Language.GraphQL.Schema.schemaWithTypes` constructs a complete schema, + including an optional schema description and user-defined types not referenced + in the schema directly (for example interface implementations). +- `Language.GraphQL.Schema.description` returns the optional schema description. ### Fixed - Parser now accepts empty lists and objects. diff --git a/src/Language/GraphQL/Type.hs b/src/Language/GraphQL/Type.hs index 3ed8bb9..8a2a4d1 100644 --- a/src/Language/GraphQL/Type.hs +++ b/src/Language/GraphQL/Type.hs @@ -21,6 +21,6 @@ module Language.GraphQL.Type ) where import Language.GraphQL.Type.Definition -import Language.GraphQL.Type.Schema (Schema, schema) +import Language.GraphQL.Type.Schema (Schema, schema, schemaWithTypes) import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out diff --git a/src/Language/GraphQL/Type/Internal.hs b/src/Language/GraphQL/Type/Internal.hs index 2081b97..ce3b121 100644 --- a/src/Language/GraphQL/Type/Internal.hs +++ b/src/Language/GraphQL/Type/Internal.hs @@ -12,6 +12,7 @@ module Language.GraphQL.Type.Internal , Directives , Schema(..) , Type(..) + , description , directives , doesFragmentTypeApply , implementations @@ -55,41 +56,43 @@ type Directives = HashMap Full.Name Directive -- | 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. --- --- __Note:__ When the schema is constructed, by default only the types that --- are reachable by traversing the root types are included, other types must --- be explicitly referenced. data Schema m = Schema - (Out.ObjectType m) - (Maybe (Out.ObjectType m)) - (Maybe (Out.ObjectType m)) - Directives - (HashMap Full.Name (Type m)) + (Maybe Text) -- ^ Description. + (Out.ObjectType m) -- ^ Query. + (Maybe (Out.ObjectType m)) -- ^ Mutation. + (Maybe (Out.ObjectType m)) -- ^ Subscription. + Directives -- ^ Directives + (HashMap Full.Name (Type m)) -- ^ Types. + -- Interface implementations (used only for faster access). (HashMap Full.Name [Type m]) +-- | Schema description. +description :: forall m. Schema m -> Maybe Text +description (Schema description' _ _ _ _ _ _) = description' + -- | Schema query type. query :: forall m. Schema m -> Out.ObjectType m -query (Schema query' _ _ _ _ _) = query' +query (Schema _ query' _ _ _ _ _) = query' -- | Schema mutation type. mutation :: forall m. Schema m -> Maybe (Out.ObjectType m) -mutation (Schema _ mutation' _ _ _ _) = mutation' +mutation (Schema _ _ mutation' _ _ _ _) = mutation' -- | Schema subscription type. subscription :: forall m. Schema m -> Maybe (Out.ObjectType m) -subscription (Schema _ _ subscription' _ _ _) = subscription' +subscription (Schema _ _ _ subscription' _ _ _) = subscription' -- | Schema directive definitions. directives :: forall m. Schema m -> Directives -directives (Schema _ _ _ directives' _ _) = directives' +directives (Schema _ _ _ _ directives' _ _) = directives' -- | Types referenced by the schema. types :: forall m. Schema m -> HashMap Full.Name (Type m) -types (Schema _ _ _ _ types' _) = types' +types (Schema _ _ _ _ _ types' _) = types' -- | Interface implementations. implementations :: forall m. Schema m -> HashMap Full.Name [Type m] -implementations (Schema _ _ _ _ _ implementations') = implementations' +implementations (Schema _ _ _ _ _ _ implementations') = implementations' -- | These types may describe the parent context of a selection set. data CompositeType m diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs index dae8e18..ddddb4a 100644 --- a/src/Language/GraphQL/Type/Schema.hs +++ b/src/Language/GraphQL/Type/Schema.hs @@ -9,11 +9,13 @@ -- functions for defining and manipulating schemas. module Language.GraphQL.Type.Schema ( schema + , schemaWithTypes , module Language.GraphQL.Type.Internal ) where import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import Data.Text (Text) import Language.GraphQL.AST.DirectiveLocation (DirectiveLocation(..)) import qualified Language.GraphQL.AST.DirectiveLocation as DirectiveLocation import qualified Language.GraphQL.AST as Full @@ -22,6 +24,7 @@ import Language.GraphQL.Type.Internal , Directives , Schema , Type(..) + , description , directives , implementations , mutation @@ -35,17 +38,47 @@ import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out -- | Schema constructor. +-- +-- __Note:__ When the schema is constructed, by default only the types that +-- are reachable by traversing the root types are included, other types must +-- be explicitly referenced using 'schemaWithTypes' instead. schema :: forall m . Out.ObjectType m -- ^ Query type. -> Maybe (Out.ObjectType m) -- ^ Mutation type. -> Maybe (Out.ObjectType m) -- ^ Subscription type. -> Directives -- ^ Directive definitions. -> Schema m -- ^ Schema. -schema queryRoot mutationRoot subscriptionRoot directiveDefinitions = - Internal.Schema queryRoot mutationRoot subscriptionRoot +schema queryRoot mutationRoot subscriptionRoot = + schemaWithTypes Nothing queryRoot mutationRoot subscriptionRoot mempty + +-- | Constructs a complete schema, including user-defined types not referenced +-- in the schema directly (for example interface implementations). +schemaWithTypes :: forall m + . Maybe Text -- ^ Schema description + -> Out.ObjectType m -- ^ Query type. + -> Maybe (Out.ObjectType m) -- ^ Mutation type. + -> Maybe (Out.ObjectType m) -- ^ Subscription type. + -> [Type m] -- ^ Additional types. + -> Directives -- ^ Directive definitions. + -> Schema m -- ^ Schema. +schemaWithTypes description' queryRoot mutationRoot subscriptionRoot types' directiveDefinitions = + Internal.Schema description' queryRoot mutationRoot subscriptionRoot allDirectives collectedTypes collectedImplementations where - collectedTypes = collectReferencedTypes queryRoot mutationRoot subscriptionRoot + allTypes = foldr addTypeDefinition HashMap.empty types' + addTypeDefinition type'@(ScalarType (Definition.ScalarType typeName _)) accumulator = + HashMap.insert typeName type' accumulator + addTypeDefinition type'@(EnumType (Definition.EnumType typeName _ _)) accumulator = + HashMap.insert typeName type' accumulator + addTypeDefinition type'@(ObjectType (Out.ObjectType typeName _ _ _)) accumulator = + HashMap.insert typeName type' accumulator + addTypeDefinition type'@(InputObjectType (In.InputObjectType typeName _ _)) accumulator = + HashMap.insert typeName type' accumulator + addTypeDefinition type'@(InterfaceType (Out.InterfaceType typeName _ _ _)) accumulator = + HashMap.insert typeName type' accumulator + addTypeDefinition type'@(UnionType (Out.UnionType typeName _ _)) accumulator = + HashMap.insert typeName type' accumulator + collectedTypes = collectReferencedTypes queryRoot mutationRoot subscriptionRoot allTypes collectedImplementations = collectImplementations collectedTypes allDirectives = HashMap.union directiveDefinitions defaultDirectives defaultDirectives = HashMap.fromList @@ -98,11 +131,12 @@ collectReferencedTypes :: forall m -> Maybe (Out.ObjectType m) -> Maybe (Out.ObjectType m) -> HashMap Full.Name (Type m) -collectReferencedTypes queryRoot mutationRoot subscriptionRoot = - let queryTypes = traverseObjectType queryRoot HashMap.empty + -> HashMap Full.Name (Type m) +collectReferencedTypes queryRoot mutationRoot subscriptionRoot extraTypes = + let queryTypes = traverseObjectType queryRoot extraTypes mutationTypes = maybe queryTypes (`traverseObjectType` queryTypes) mutationRoot - in maybe mutationTypes (`traverseObjectType` queryTypes) subscriptionRoot + in maybe mutationTypes (`traverseObjectType` mutationTypes) subscriptionRoot where collect traverser typeName element foundTypes | HashMap.member typeName foundTypes = foundTypes diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs index 5035ec8..f5bfd33 100644 --- a/tests/Language/GraphQL/ExecuteSpec.hs +++ b/tests/Language/GraphQL/ExecuteSpec.hs @@ -18,21 +18,29 @@ import qualified Data.HashMap.Strict as HashMap import Language.GraphQL.AST (Document, Location(..), Name) import Language.GraphQL.AST.Parser (document) import Language.GraphQL.Error -import Language.GraphQL.Execute -import Language.GraphQL.Type as Type -import Language.GraphQL.Type.Out as Out +import Language.GraphQL.Execute (execute) +import qualified Language.GraphQL.Type.Schema as Schema +import Language.GraphQL.Type +import qualified Language.GraphQL.Type.Out as Out import Test.Hspec (Spec, context, describe, it, shouldBe) import Text.Megaparsec (parse) import Text.RawString.QQ (r) philosopherSchema :: Schema (Either SomeException) -philosopherSchema = schema queryType Nothing (Just subscriptionType) mempty +philosopherSchema = + schemaWithTypes Nothing queryType Nothing subscriptionRoot extraTypes mempty + where + subscriptionRoot = Just subscriptionType + extraTypes = + [ Schema.ObjectType bookType + , Schema.ObjectType bookCollectionType + ] queryType :: Out.ObjectType (Either SomeException) queryType = Out.ObjectType "Query" Nothing [] $ HashMap.singleton "philosopher" $ ValueResolver philosopherField - $ pure $ Type.Object mempty + $ pure $ Object mempty where philosopherField = Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty @@ -44,7 +52,7 @@ musicType = Out.ObjectType "Music" Nothing [] resolvers = [ ("instrument", ValueResolver instrumentField instrumentResolver) ] - instrumentResolver = pure $ Type.String "piano" + instrumentResolver = pure $ String "piano" instrumentField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty poetryType :: Out.ObjectType (Either SomeException) @@ -54,7 +62,7 @@ poetryType = Out.ObjectType "Poetry" Nothing [] resolvers = [ ("genre", ValueResolver genreField genreResolver) ] - genreResolver = pure $ Type.String "Futurism" + genreResolver = pure $ String "Futurism" genreField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty interestType :: Out.UnionType (Either SomeException) @@ -69,27 +77,62 @@ philosopherType = Out.ObjectType "Philosopher" Nothing [] , ("lastName", ValueResolver lastNameField lastNameResolver) , ("school", ValueResolver schoolField schoolResolver) , ("interest", ValueResolver interestField interestResolver) + , ("majorWork", ValueResolver majorWorkField majorWorkResolver) ] firstNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty - firstNameResolver = pure $ Type.String "Friedrich" + firstNameResolver = pure $ String "Friedrich" lastNameField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty - lastNameResolver = pure $ Type.String "Nietzsche" + lastNameResolver = pure $ String "Nietzsche" schoolField = Out.Field Nothing (Out.NonNullEnumType schoolType) HashMap.empty - schoolResolver = pure $ Type.Enum "EXISTENTIALISM" + schoolResolver = pure $ Enum "EXISTENTIALISM" interestField = Out.Field Nothing (Out.NonNullUnionType interestType) HashMap.empty interestResolver = pure - $ Type.Object + $ Object $ HashMap.fromList [("instrument", "piano")] + majorWorkField + = Out.Field Nothing (Out.NonNullInterfaceType workType) HashMap.empty + majorWorkResolver = pure + $ Object + $ HashMap.fromList + [ ("title", "Also sprach Zarathustra: Ein Buch für Alle und Keinen") + ] + +workType :: Out.InterfaceType (Either SomeException) +workType = Out.InterfaceType "Work" Nothing [] + $ HashMap.fromList fields + where + fields = [("title", titleField)] + titleField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty + +bookType :: Out.ObjectType (Either SomeException) +bookType = Out.ObjectType "Book" Nothing [workType] + $ HashMap.fromList resolvers + where + resolvers = + [ ("title", ValueResolver titleField titleResolver) + ] + titleField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty + titleResolver = pure "Also sprach Zarathustra: Ein Buch für Alle und Keinen" + +bookCollectionType :: Out.ObjectType (Either SomeException) +bookCollectionType = Out.ObjectType "Book" Nothing [workType] + $ HashMap.fromList resolvers + where + resolvers = + [ ("title", ValueResolver titleField titleResolver) + ] + titleField = Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty + titleResolver = pure "The Three Critiques" subscriptionType :: Out.ObjectType (Either SomeException) subscriptionType = Out.ObjectType "Subscription" Nothing [] $ HashMap.singleton "newQuote" - $ EventStreamResolver quoteField (pure $ Type.Object mempty) - $ pure $ yield $ Type.Object mempty + $ EventStreamResolver quoteField (pure $ Object mempty) + $ pure $ yield $ Object mempty where quoteField = Out.Field Nothing (Out.NonNullObjectType quoteType) HashMap.empty