From b9594055d463192886c7ce1aef2c10c6f2c637c4 Mon Sep 17 00:00:00 2001 From: Thiago Rodrigues de Paula Date: Fri, 11 Jan 2019 23:27:42 +0100 Subject: [PATCH 1/3] Improve operation interpreting type safety --- src/GraphQL.hs | 45 +++++++++++------- src/GraphQL/Internal/Resolver.hs | 82 +++++++++++++++++++++----------- src/GraphQL/Resolver.hs | 10 ++-- 3 files changed, 88 insertions(+), 49 deletions(-) diff --git a/src/GraphQL.hs b/src/GraphQL.hs index cb0cb65..aedb858 100644 --- a/src/GraphQL.hs +++ b/src/GraphQL.hs @@ -1,7 +1,9 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} -- | Interface for GraphQL API. -- -- __Note__: This module is highly subject to change. We're still figuring @@ -27,7 +29,7 @@ import Protolude import Data.Attoparsec.Text (parseOnly, endOfInput) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NonEmpty -import GraphQL.API (HasObjectDefinition(..), SchemaError(..)) +import GraphQL.API (HasObjectDefinition(..), Object, SchemaError(..)) import GraphQL.Internal.Execution ( VariableValues , ExecutionError @@ -51,8 +53,13 @@ import GraphQL.Internal.Output ) import GraphQL.Internal.Schema (Schema) import qualified GraphQL.Internal.Schema as Schema -import GraphQL.Resolver (HasResolver(..), Result(..)) -import GraphQL.Value (Name, Value, pattern ValueObject) +import GraphQL.Resolver + ( HasResolver(..) + , OperationResolverConstraint + , Result(..) + , resolveOperation + ) +import GraphQL.Value (Name, Value) -- | Errors that can happen while processing a query document. data QueryError @@ -85,7 +92,10 @@ instance GraphQLError QueryError where -- | Execute a GraphQL query. executeQuery - :: forall api m. (HasResolver m api, Applicative m, HasObjectDefinition api) + :: forall api m fields typeName interfaces. + ( Object typeName interfaces fields ~ api + , OperationResolverConstraint m fields typeName interfaces + ) => Handler m api -- ^ Handler for the query. This links the query to the code you've written to handle it. -> QueryDocument VariableValue -- ^ A validated query document. Build one with 'compileQuery'. -> Maybe Name -- ^ An optional name. If 'Nothing', then executes the only operation in the query. If @Just "something"@, executes the query named @"something". @@ -94,17 +104,14 @@ executeQuery executeQuery handler document name variables = case getOperation document name variables of Left e -> pure (ExecutionFailure (singleError e)) - Right operation -> toResult <$> resolve @m @api handler (Just operation) + Right operation -> + toResult + <$> resolveOperation @m @fields @typeName @interfaces handler operation where - toResult (Result errors result) = - case result of - -- TODO: Prevent this at compile time. Particularly frustrating since - -- we *know* that api has an object definition. - ValueObject object -> - case NonEmpty.nonEmpty errors of - Nothing -> Success object - Just errs -> PartialSuccess object (map toError errs) - v -> ExecutionFailure (singleError (NonObjectResult v)) + toResult (Result errors object) = + case NonEmpty.nonEmpty errors of + Nothing -> Success object + Just errs -> PartialSuccess object (map toError errs) -- | Create a GraphQL schema. makeSchema :: forall api. HasObjectDefinition api => Either QueryError Schema @@ -114,7 +121,10 @@ makeSchema = first SchemaError (Schema.makeSchema <$> getDefinition @api) -- -- Compiles then executes a GraphQL query. interpretQuery - :: forall api m. (Applicative m, HasResolver m api, HasObjectDefinition api) + :: forall api m fields typeName interfaces. + ( Object typeName interfaces fields ~ api + , OperationResolverConstraint m fields typeName interfaces + ) => Handler m api -- ^ Handler for the query. This links the query to the code you've written to handle it. -> Text -- ^ The text of a query document. Will be parsed and then executed. -> Maybe Name -- ^ An optional name for the operation within document to run. If 'Nothing', execute the only operation in the document. If @Just "something"@, execute the query or mutation named @"something"@. @@ -129,7 +139,10 @@ interpretQuery handler query name variables = -- -- Anonymous queries have no name and take no variables. interpretAnonymousQuery - :: forall api m. (Applicative m, HasResolver m api, HasObjectDefinition api) + :: forall api m fields typeName interfaces. + ( Object typeName interfaces fields ~ api + , OperationResolverConstraint m fields typeName interfaces + ) => Handler m api -- ^ Handler for the anonymous query. -> Text -- ^ The text of the anonymous query. Should defined only a single, unnamed query operation. -> m Response -- ^ The result of running the query. diff --git a/src/GraphQL/Internal/Resolver.hs b/src/GraphQL/Internal/Resolver.hs index ca52f41..f20b9c5 100644 --- a/src/GraphQL/Internal/Resolver.hs +++ b/src/GraphQL/Internal/Resolver.hs @@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -18,9 +19,11 @@ module GraphQL.Internal.Resolver ( ResolverError(..) , HasResolver(..) + , OperationResolverConstraint , (:<>)(..) , Result(..) , unionValue + , resolveOperation ) where -- TODO (probably incomplete, the spec is large) @@ -147,6 +150,21 @@ class HasResolver m a where type Handler m a resolve :: Handler m a -> Maybe (SelectionSetByType Value) -> m (Result Value) +type OperationResolverConstraint m fields typeName interfaces = + ( RunFields m (RunFieldsType m fields) + , API.HasObjectDefinition (API.Object typeName interfaces fields) + , Monad m + ) + +resolveOperation + :: forall m fields typeName interfaces. + ( OperationResolverConstraint m fields typeName interfaces ) + => Handler m (API.Object typeName interfaces fields) + -> SelectionSetByType Value + -> m (Result GValue.Object) +resolveOperation handler ss = + resolveObject @m @fields @typeName @interfaces handler ss + -- | Called when the schema expects an input argument @name@ of type @a@ but -- @name@ has not been provided. valueMissing :: API.Defaultable a => Name -> Either ResolverError a @@ -357,6 +375,40 @@ instance forall m a b dispatchType. where nextHandler = pure (Result [FieldNotFoundError (getName field)] Nothing) +resolveObject + :: forall m fields typeName interfaces. + ( OperationResolverConstraint m fields typeName interfaces ) + => Handler m (API.Object typeName interfaces fields) + -> SelectionSetByType Value + -> m (Result GValue.Object) +resolveObject mHandler selectionSet = + case getSelectionSet of + Left err -> return (Result [err] (GValue.Object' OrderedMap.empty)) + Right ss -> do + -- Run the handler so the field resolvers have access to the object. + -- This (and other places, including field resolvers) is where user + -- code can do things like look up something in a database. + handler <- mHandler + r <- traverse (runFields @m @(RunFieldsType m fields) handler) ss + let (Result errs obj) = GValue.objectFromOrderedMap . OrderedMap.catMaybes <$> sequenceA r + pure (Result errs obj) + + where + getSelectionSet = do + defn <- first SchemaError $ API.getDefinition @(API.Object typeName interfaces fields) + -- Fields of a selection set may be behind "type conditions", due to + -- inline fragments or the use of fragment spreads. These type + -- conditions are represented in the schema by the name of a type + -- (e.g. "Dog"). To determine which type conditions (and thus which + -- fields) are relevant for this 1selection set, we need to look up the + -- actual types they refer to, as interfaces (say) match objects + -- differently than unions. + -- + -- See for + -- more details. + (SelectionSet ss') <- first ValidationError $ getSelectionSetForType defn selectionSet + pure ss' + instance forall typeName interfaces fields m. ( RunFields m (RunFieldsType m fields) , API.HasObjectDefinition (API.Object typeName interfaces fields) @@ -365,33 +417,9 @@ instance forall typeName interfaces fields m. type Handler m (API.Object typeName interfaces fields) = m (RunFieldsHandler m (RunFieldsType m fields)) resolve _ Nothing = throwE MissingSelectionSet - resolve mHandler (Just selectionSet) = - case getSelectionSet of - Left err -> throwE err - Right ss -> do - -- Run the handler so the field resolvers have access to the object. - -- This (and other places, including field resolvers) is where user - -- code can do things like look up something in a database. - handler <- mHandler - r <- traverse (runFields @m @(RunFieldsType m fields) handler) ss - let (Result errs obj) = GValue.objectFromOrderedMap . OrderedMap.catMaybes <$> sequenceA r - pure (Result errs (GValue.ValueObject obj)) - - where - getSelectionSet = do - defn <- first SchemaError $ API.getDefinition @(API.Object typeName interfaces fields) - -- Fields of a selection set may be behind "type conditions", due to - -- inline fragments or the use of fragment spreads. These type - -- conditions are represented in the schema by the name of a type - -- (e.g. "Dog"). To determine which type conditions (and thus which - -- fields) are relevant for this 1selection set, we need to look up the - -- actual types they refer to, as interfaces (say) match objects - -- differently than unions. - -- - -- See for - -- more details. - (SelectionSet ss') <- first ValidationError $ getSelectionSetForType defn selectionSet - pure ss' + resolve handler (Just ss) = do + result <- resolveObject @m @fields @typeName @interfaces handler ss + return $ GValue.ValueObject <$> result -- TODO(tom): we're getting to a point where it might make sense to -- split resolver into submodules (GraphQL.Resolver.Union etc.) diff --git a/src/GraphQL/Resolver.hs b/src/GraphQL/Resolver.hs index 9a779c9..cac277f 100644 --- a/src/GraphQL/Resolver.hs +++ b/src/GraphQL/Resolver.hs @@ -2,17 +2,15 @@ -- -- Contains everything you need to write handlers for your GraphQL schema. module GraphQL.Resolver - ( ResolverError(..) - , HasResolver(..) - , (:<>)(..) - , Result(..) - , unionValue + ( module Export ) where -import GraphQL.Internal.Resolver +import GraphQL.Internal.Resolver as Export ( ResolverError(..) , HasResolver(..) + , OperationResolverConstraint , (:<>)(..) , Result(..) , unionValue + , resolveOperation ) From 2e65ce5cfcf2f3314ac1beeb183a357051058524 Mon Sep 17 00:00:00 2001 From: Thiago Rodrigues de Paula Date: Fri, 11 Jan 2019 23:45:48 +0100 Subject: [PATCH 2/3] Fix WAI specs --- graphql-wai/src/GraphQL/Wai.hs | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/graphql-wai/src/GraphQL/Wai.hs b/graphql-wai/src/GraphQL/Wai.hs index 820d380..d6b996d 100644 --- a/graphql-wai/src/GraphQL/Wai.hs +++ b/graphql-wai/src/GraphQL/Wai.hs @@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} -- | Basic WAI handlers for graphql-api module GraphQL.Wai @@ -15,8 +16,8 @@ import Network.HTTP.Types.Header (hContentType) import Network.HTTP.Types.Status (status200, status400) import GraphQL (interpretAnonymousQuery) -import GraphQL.API (HasObjectDefinition) -import GraphQL.Resolver (HasResolver, Handler) +import GraphQL.API (HasObjectDefinition, Object) +import GraphQL.Resolver (HasResolver, Handler, OperationResolverConstraint) import GraphQL.Value (toValue) @@ -27,7 +28,12 @@ import GraphQL.Value (toValue) -- If you have a 'Cat' type and a corresponding 'catHandler' then you -- can use "toApplication @Cat catHandler". toApplication - :: forall r. (HasResolver IO r, HasObjectDefinition r) + :: forall r typeName interfaces fields. + ( HasResolver IO r + , r ~ Object typeName interfaces fields + , OperationResolverConstraint IO fields typeName interfaces + , HasObjectDefinition r + ) => Handler IO r -> Application toApplication handler = app where From 6397e4bb60ae4e8592ffe0830ee41bf7112f7630 Mon Sep 17 00:00:00 2001 From: Thiago Rodrigues de Paula Date: Fri, 11 Jan 2019 23:50:32 +0100 Subject: [PATCH 3/3] Adapt coverage numbers --- scripts/hpc-ratchet | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scripts/hpc-ratchet b/scripts/hpc-ratchet index 0ce8298..cec41f0 100755 --- a/scripts/hpc-ratchet +++ b/scripts/hpc-ratchet @@ -35,7 +35,7 @@ In a just world, this would be a separate config file, or command-line arguments Each item represents the number of "things" we are OK with not being covered. """ COVERAGE_TOLERANCE = { - ALTERNATIVES: 161, + ALTERNATIVES: 160, BOOLEANS: 8, EXPRESSIONS: 1412, LOCAL_DECLS: 13,