Separate Query and Mutation resolvers

Fixes #33 .

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`.

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 :: HashMap Text (NonEmpty (Schema.Resolver IO))
-> schema1 = hello :| []
+> 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 :: HashMap Text (NonEmpty (Schema.Resolver IO))
-> schema2 = time :| []
+> 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 :: HashMap Text (NonEmpty (Schema.Resolver IO))
-> schema3 = hello :| [time]
+> schema3 = HashMap.singleton "Query" $ hello :| [time]
 >
 > query3 :: Text
 > query3 = "query timeAndHello { time hello }"

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.
+    => HashMap Text (NonEmpty (Schema.Resolver m)) -- ^ Resolvers.
-    -> T.Text -- ^ Text representing a @GraphQL@ request document.
+    -> 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)

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)
+operation schema = schemaOperation
-    = runCollectErrs (Schema.resolve (toList schema) flds)
+  where
-operation schema (AST.Core.Mutation _ flds)
+    runResolver fields = runCollectErrs
-    = runCollectErrs (Schema.resolve (toList schema) flds)
+        . 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"

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

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-15.7
+resolver: lts-15.11
 
 packages:
 - .

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 :: HashMap Text (NonEmpty (Schema.Resolver IO))
-experimentalResolver = Schema.scalar "experimentalField" $ pure (5 :: Int) 
+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

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

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 :: HashMap Text (NonEmpty (Schema.Resolver Identity))
-schema = hero :| [human, droid]
+schema = HashMap.singleton "Query" $ hero :| [human, droid]
 
 hero :: Schema.Resolver Identity
 hero = Schema.object "hero" $ do