From 500cff20eb21b28359400b99a4dfda4009229b95 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Sun, 10 May 2020 18:32:58 +0200 Subject: [PATCH] Separate Query and Mutation resolvers Fixes #33 . --- CHANGELOG.md | 9 +++++++- docs/tutorial/tutorial.lhs | 14 +++++++------ src/Language/GraphQL.hs | 11 +++++----- src/Language/GraphQL/Execute.hs | 36 ++++++++++++++++++++------------ src/Language/GraphQL/Schema.hs | 37 +++++++++++++++++++++------------ stack.yaml | 2 +- tests/Test/DirectiveSpec.hs | 18 +++++++++------- tests/Test/FragmentSpec.hs | 16 +++++++------- tests/Test/StarWars/Schema.hs | 7 +++++-- 9 files changed, 94 insertions(+), 56 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 80c39bc..70f26d0 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -17,7 +17,8 @@ and this project adheres to - Type system definition parser. - `Trans.argument`. - Schema extension parser. -- Contributing guidelines +- Contributing guidelines. +- `Schema.resolversToMap` (intended for to be used internally). ### Changed - Rename `AST.Definition` into `AST.Document.ExecutableDefinition`. @@ -31,6 +32,12 @@ and this project adheres to `symbol "@"` now. - Replace `MonadIO` with a plain `Monad`. Since the tests don't use IO, set the inner monad to `Identity`. +- `NonEmpty (Resolver m)` is now `HashMap Text (NonEmpty (Resolver m))`. Root + operation type can be any type, therefore a hashmap is needed. Since types + cannot be empty, we save the list of resolvers in the type as a non-empty + list. Currently only "Query" and "Mutation" are supported as types. For more + schema support is required. The executor checks now if the type in the query + matches the type of the provided root resolvers. ### Removed - `AST.Field`, `AST.InlineFragment` and `AST.FragmentSpread`. diff --git a/docs/tutorial/tutorial.lhs b/docs/tutorial/tutorial.lhs index a10f861..edaf7f2 100644 --- a/docs/tutorial/tutorial.lhs +++ b/docs/tutorial/tutorial.lhs @@ -17,6 +17,8 @@ Since this file is a literate haskell file, we start by importing some dependenc > import Control.Monad.IO.Class (liftIO) > import Data.Aeson (encode) > import Data.ByteString.Lazy.Char8 (putStrLn) +> import Data.HashMap.Strict (HashMap) +> import qualified Data.HashMap.Strict as HashMap > import Data.List.NonEmpty (NonEmpty(..)) > import Data.Text (Text) > import Data.Time (getCurrentTime) @@ -33,8 +35,8 @@ example from [graphql.js](https://github.com/graphql/graphql-js). First we build a GraphQL schema. -> schema1 :: NonEmpty (Schema.Resolver IO) -> schema1 = hello :| [] +> schema1 :: HashMap Text (NonEmpty (Schema.Resolver IO)) +> schema1 = HashMap.singleton "Query" $ hello :| [] > > hello :: Schema.Resolver IO > hello = Schema.scalar "hello" (return ("it's me" :: Text)) @@ -63,8 +65,8 @@ returning For this example, we're going to be using time. -> schema2 :: NonEmpty (Schema.Resolver IO) -> schema2 = time :| [] +> schema2 :: HashMap Text (NonEmpty (Schema.Resolver IO)) +> schema2 = HashMap.singleton "Query" $ time :| [] > > time :: Schema.Resolver IO > time = Schema.scalar "time" $ do @@ -122,8 +124,8 @@ This will fail Now that we have two resolvers, we can define a schema which uses them both. -> schema3 :: NonEmpty (Schema.Resolver IO) -> schema3 = hello :| [time] +> schema3 :: HashMap Text (NonEmpty (Schema.Resolver IO)) +> schema3 = HashMap.singleton "Query" $ hello :| [time] > > query3 :: Text > query3 = "query timeAndHello { time hello }" diff --git a/src/Language/GraphQL.hs b/src/Language/GraphQL.hs index 57c8bf1..73f9bdc 100644 --- a/src/Language/GraphQL.hs +++ b/src/Language/GraphQL.hs @@ -6,7 +6,8 @@ module Language.GraphQL import qualified Data.Aeson as Aeson import Data.List.NonEmpty (NonEmpty) -import qualified Data.Text as T +import Data.HashMap.Strict (HashMap) +import Data.Text (Text) import Language.GraphQL.Error import Language.GraphQL.Execute import Language.GraphQL.AST.Parser @@ -16,8 +17,8 @@ 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 - => NonEmpty (Schema.Resolver m) -- ^ Resolvers. - -> T.Text -- ^ Text representing a @GraphQL@ request document. + => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers. + -> Text -- ^ Text representing a @GraphQL@ request document. -> m Aeson.Value -- ^ Response. graphql = flip graphqlSubs mempty @@ -25,9 +26,9 @@ graphql = flip graphqlSubs mempty -- applied to the query and the query is then executed using to the given -- 'Schema.Resolver's. graphqlSubs :: Monad m - => NonEmpty (Schema.Resolver m) -- ^ Resolvers. + => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers. -> Schema.Subs -- ^ Variable substitution function. - -> T.Text -- ^ Text representing a @GraphQL@ request document. + -> Text -- ^ Text representing a @GraphQL@ request document. -> m Aeson.Value -- ^ Response. graphqlSubs schema f = either parseError (execute schema f) diff --git a/src/Language/GraphQL/Execute.hs b/src/Language/GraphQL/Execute.hs index de937ee..204d08c 100644 --- a/src/Language/GraphQL/Execute.hs +++ b/src/Language/GraphQL/Execute.hs @@ -7,9 +7,10 @@ module Language.GraphQL.Execute ) where import qualified Data.Aeson as Aeson -import Data.Foldable (toList) import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NE +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 @@ -24,12 +25,13 @@ 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 - => NonEmpty (Schema.Resolver m) -- ^ Resolvers. + => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers. -> Schema.Subs -- ^ Variable substitution function. -> Document -- @GraphQL@ document. -> m Aeson.Value execute schema subs doc = - maybe transformError (document schema Nothing) $ Transform.document subs doc + maybe transformError (document schema Nothing) + $ Transform.document subs doc where transformError = return $ singleError "Schema transformation error." @@ -40,23 +42,24 @@ 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 - => NonEmpty (Schema.Resolver m) -- ^ Resolvers + => HashMap Text (NonEmpty (Schema.Resolver 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) $ Transform.document subs doc + maybe transformError (document schema $ Just name) + $ Transform.document subs doc where transformError = return $ singleError "Schema transformation error." document :: Monad m - => NonEmpty (Schema.Resolver m) + => HashMap Text (NonEmpty (Schema.Resolver m)) -> Maybe Text -> AST.Core.Document -> m Aeson.Value document schema Nothing (op :| []) = operation schema op -document schema (Just name) operations = case NE.dropWhile matchingName operations of +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 @@ -67,10 +70,17 @@ document schema (Just name) operations = case NE.dropWhile matchingName operatio document _ _ _ = return $ singleError "Missing operation name." operation :: Monad m - => NonEmpty (Schema.Resolver m) + => HashMap Text (NonEmpty (Schema.Resolver m)) -> AST.Core.Operation -> m Aeson.Value -operation schema (AST.Core.Query _ flds) - = runCollectErrs (Schema.resolve (toList schema) flds) -operation schema (AST.Core.Mutation _ flds) - = runCollectErrs (Schema.resolve (toList schema) flds) +operation schema = schemaOperation + where + runResolver fields = runCollectErrs + . flip Schema.resolve fields + . Schema.resolversToMap + resolve fields queryType = maybe lookupError (runResolver fields) + $ HashMap.lookup queryType schema + 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" diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs index 8bde54d..c678e48 100644 --- a/src/Language/GraphQL/Schema.hs +++ b/src/Language/GraphQL/Schema.hs @@ -3,11 +3,12 @@ -- | This module provides a representation of a @GraphQL@ Schema in addition to -- functions for defining and manipulating schemas. module Language.GraphQL.Schema - ( Resolver + ( Resolver(..) , Subs , object - , scalar , resolve + , resolversToMap + , scalar , wrappedObject , wrappedScalar -- * AST Reexports @@ -18,7 +19,7 @@ module Language.GraphQL.Schema import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Trans.Reader (runReaderT) -import Data.Foldable (find, fold) +import Data.Foldable (fold, toList) import Data.Maybe (fromMaybe) import qualified Data.Aeson as Aeson import Data.HashMap.Strict (HashMap) @@ -38,6 +39,15 @@ data Resolver m = Resolver Text -- ^ Name (Field -> CollectErrsT m Aeson.Object) -- ^ Resolver +-- | Converts resolvers to a map. +resolversToMap + :: (Foldable f, Functor f) + => f (Resolver m) + -> HashMap Text (Field -> CollectErrsT m Aeson.Object) +resolversToMap = HashMap.fromList . toList . fmap toKV + where + toKV (Resolver name f) = (name, f) + -- | Contains variables for the query. The key of the map is a variable name, -- and the value is the variable value. type Subs = HashMap Name Value @@ -46,7 +56,8 @@ type Subs = HashMap Name Value object :: Monad m => Name -> ActionT m [Resolver m] -> Resolver m object name f = Resolver name $ resolveFieldValue f resolveRight where - resolveRight fld@(Field _ _ _ flds) resolver = withField (resolve resolver flds) fld + resolveRight fld@(Field _ _ _ flds) resolver + = withField (resolve (resolversToMap resolver) flds) fld -- | Like 'object' but can be null or a list of objects. wrappedObject :: @@ -57,7 +68,8 @@ wrappedObject :: wrappedObject name f = Resolver name $ resolveFieldValue f resolveRight where resolveRight fld@(Field _ _ _ sels) resolver - = withField (traverse (`resolve` sels) resolver) fld + = withField (traverse (resolveMap sels) resolver) fld + resolveMap = flip (resolve . resolversToMap) -- | A scalar represents a primitive value, like a string or an integer. scalar :: (Monad m, Aeson.ToJSON a) => Name -> ActionT m a -> Resolver m @@ -81,7 +93,7 @@ wrappedScalar name f = Resolver name $ resolveFieldValue f resolveRight resolveFieldValue :: Monad m => ActionT m a -> - (Field -> a -> CollectErrsT m (HashMap Text Aeson.Value)) -> + (Field -> a -> CollectErrsT m Aeson.Object) -> Field -> CollectErrsT m (HashMap Text Aeson.Value) resolveFieldValue f resolveRight fld@(Field _ _ args _) = do @@ -103,22 +115,21 @@ withField v fld -- 'Resolver' to each 'Field'. Resolves into a value containing the -- resolved 'Field', or a null value and error information. resolve :: Monad m - => [Resolver m] -> Seq Selection -> CollectErrsT m Aeson.Value + => HashMap Text (Field -> CollectErrsT m Aeson.Object) + -> Seq Selection + -> CollectErrsT m Aeson.Value resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers where - resolveTypeName (Resolver "__typename" f) = do + resolveTypeName f = do value <- f $ Field Nothing "__typename" mempty mempty return $ HashMap.lookupDefault "" "__typename" value - resolveTypeName _ = return "" tryResolvers (SelectionField fld@(Field _ name _ _)) - = maybe (errmsg fld) (tryResolver fld) $ find (compareResolvers name) resolvers + = fromMaybe (errmsg fld) $ HashMap.lookup name resolvers <*> Just fld tryResolvers (SelectionFragment (Fragment typeCondition selections')) = do - that <- traverse resolveTypeName (find (compareResolvers "__typename") resolvers) + that <- traverse resolveTypeName $ HashMap.lookup "__typename" resolvers if maybe True (Aeson.String typeCondition ==) that then fmap fold . traverse tryResolvers $ selections' else return mempty - compareResolvers name (Resolver name' _) = name == name' - tryResolver fld (Resolver _ resolver) = resolver fld errmsg fld@(Field _ name _ _) = do addErrMsg $ T.unwords ["field", name, "not resolved."] return $ HashMap.singleton (aliasOrName fld) Aeson.Null diff --git a/stack.yaml b/stack.yaml index 6fa5d59..ab90213 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-15.7 +resolver: lts-15.11 packages: - . diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs index 2224bc5..3b9da19 100644 --- a/tests/Test/DirectiveSpec.hs +++ b/tests/Test/DirectiveSpec.hs @@ -5,14 +5,18 @@ module Test.DirectiveSpec ) where import Data.Aeson (Value, object, (.=)) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap import Data.List.NonEmpty (NonEmpty(..)) +import Data.Text (Text) import Language.GraphQL import qualified Language.GraphQL.Schema as Schema import Test.Hspec (Spec, describe, it, shouldBe) import Text.RawString.QQ (r) -experimentalResolver :: Schema.Resolver IO -experimentalResolver = Schema.scalar "experimentalField" $ pure (5 :: Int) +experimentalResolver :: HashMap Text (NonEmpty (Schema.Resolver IO)) +experimentalResolver = HashMap.singleton "Query" + $ Schema.scalar "experimentalField" (pure (5 :: Int)) :| [] emptyObject :: Value emptyObject = object @@ -29,7 +33,7 @@ spec = } |] - actual <- graphql (experimentalResolver :| []) query + actual <- graphql experimentalResolver query actual `shouldBe` emptyObject it "should not skip fields if @skip is false" $ do @@ -44,7 +48,7 @@ spec = ] ] - actual <- graphql (experimentalResolver :| []) query + actual <- graphql experimentalResolver query actual `shouldBe` expected it "should skip fields if @include is false" $ do @@ -54,7 +58,7 @@ spec = } |] - actual <- graphql (experimentalResolver :| []) query + actual <- graphql experimentalResolver query actual `shouldBe` emptyObject it "should be able to @skip a fragment spread" $ do @@ -68,7 +72,7 @@ spec = } |] - actual <- graphql (experimentalResolver :| []) query + actual <- graphql experimentalResolver query actual `shouldBe` emptyObject it "should be able to @skip an inline fragment" $ do @@ -80,5 +84,5 @@ spec = } |] - actual <- graphql (experimentalResolver :| []) query + actual <- graphql experimentalResolver query actual `shouldBe` emptyObject diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs index de10d63..74293a9 100644 --- a/tests/Test/FragmentSpec.hs +++ b/tests/Test/FragmentSpec.hs @@ -51,7 +51,7 @@ spec :: Spec spec = do describe "Inline fragment executor" $ do it "chooses the first selection if the type matches" $ do - actual <- graphql (garment "Hat" :| []) inlineQuery + actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) inlineQuery let expected = object [ "data" .= object [ "garment" .= object @@ -62,7 +62,7 @@ spec = do in actual `shouldBe` expected it "chooses the last selection if the type matches" $ do - actual <- graphql (garment "Shirt" :| []) inlineQuery + actual <- graphql (HashMap.singleton "Query" $ garment "Shirt" :| []) inlineQuery let expected = object [ "data" .= object [ "garment" .= object @@ -83,7 +83,7 @@ spec = do }|] resolvers = Schema.object "garment" $ return [circumference, size] - actual <- graphql (resolvers :| []) query + actual <- graphql (HashMap.singleton "Query" $ resolvers :| []) query let expected = object [ "data" .= object [ "garment" .= object @@ -101,7 +101,7 @@ spec = do } }|] - actual <- graphql (size :| []) query + actual <- graphql (HashMap.singleton "Query" $ size :| []) query actual `shouldNotSatisfy` hasErrors describe "Fragment spread executor" $ do @@ -116,7 +116,7 @@ spec = do } |] - actual <- graphql (circumference :| []) query + actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query let expected = object [ "data" .= object [ "circumference" .= (60 :: Int) @@ -141,7 +141,7 @@ spec = do } |] - actual <- graphql (garment "Hat" :| []) query + actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query let expected = object [ "data" .= object [ "garment" .= object @@ -162,7 +162,7 @@ spec = do } |] - actual <- graphql (circumference :| []) query + actual <- graphql (HashMap.singleton "Query" $ circumference :| []) query actual `shouldSatisfy` hasErrors it "considers type condition" $ do @@ -187,5 +187,5 @@ spec = do ] ] ] - actual <- graphql (garment "Hat" :| []) query + actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query actual `shouldBe` expected diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs index 7986a30..cd25599 100644 --- a/tests/Test/StarWars/Schema.hs +++ b/tests/Test/StarWars/Schema.hs @@ -10,8 +10,11 @@ module Test.StarWars.Schema import Control.Monad.Trans.Except (throwE) import Control.Monad.Trans.Class (lift) import Data.Functor.Identity (Identity) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (catMaybes) +import Data.Text (Text) import qualified Language.GraphQL.Schema as Schema import Language.GraphQL.Trans import qualified Language.GraphQL.Type as Type @@ -19,8 +22,8 @@ import Test.StarWars.Data -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js -schema :: NonEmpty (Schema.Resolver Identity) -schema = hero :| [human, droid] +schema :: HashMap Text (NonEmpty (Schema.Resolver Identity)) +schema = HashMap.singleton "Query" $ hero :| [human, droid] hero :: Schema.Resolver Identity hero = Schema.object "hero" $ do