From 4c19c88e98bea77ebccc786cd55b30e23ab6e897 Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Wed, 13 May 2020 16:21:48 +0200
Subject: [PATCH] Accept resolvers given by the user as is

---
 CHANGELOG.md                         |   7 +-
 src/Language/GraphQL/Schema.hs       | 129 +++++++++++++--------------
 src/Language/GraphQL/Trans.hs        |   3 +-
 tests/Language/GraphQL/SchemaSpec.hs |  31 +++++++
 tests/Test/DirectiveSpec.hs          |   2 +-
 tests/Test/FragmentSpec.hs           |  24 +++++
 tests/Test/QuerySpec.hs              |  40 +++++++++
 7 files changed, 166 insertions(+), 70 deletions(-)
 create mode 100644 tests/Language/GraphQL/SchemaSpec.hs
 create mode 100644 tests/Test/QuerySpec.hs

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 03b0831..0f2012c 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -7,6 +7,11 @@ and this project adheres to
 [Haskell Package Versioning Policy](https://pvp.haskell.org/).
 
 ## [Unreleased]
+### Changed
+- `Resolver` is now `Resolver Name FieldResolver` where `FieldResolver` can
+  contain a JSON value or another resolver, which is invoked during the
+  execution. `FieldResolver` is executed in `ActionT` and the current `Field` is
+  passed in the reader and not as an explicit argument.
 
 ## [0.7.0.0] - 2020-05-11
 ### Fixed
@@ -20,7 +25,7 @@ and this project adheres to
 - `Trans.argument`.
 - Schema extension parser.
 - Contributing guidelines.
-- `Schema.resolversToMap` (intended for to be used internally).
+- `Schema.resolversToMap` (intended to be used internally).
 
 ### Changed
 - Rename `AST.Definition` into `AST.Document.ExecutableDefinition`.
diff --git a/src/Language/GraphQL/Schema.hs b/src/Language/GraphQL/Schema.hs
index c678e48..90a766c 100644
--- a/src/Language/GraphQL/Schema.hs
+++ b/src/Language/GraphQL/Schema.hs
@@ -35,18 +35,19 @@ import qualified Language.GraphQL.Type as Type
 -- | Resolves a 'Field' into an @Aeson.@'Data.Aeson.Types.Object' with error
 --   information (if an error has occurred). @m@ is an arbitrary monad, usually
 --   'IO'.
-data Resolver m = Resolver
-    Text -- ^ Name
-    (Field -> CollectErrsT m Aeson.Object) -- ^ Resolver
+data Resolver m = Resolver Name (FieldResolver m)
+
+data FieldResolver m
+    = ValueResolver (ActionT m Aeson.Value)
+    | NestingResolver (ActionT m (Type.Wrapping (HashMap Name (FieldResolver m))))
 
 -- | Converts resolvers to a map.
-resolversToMap
-    :: (Foldable f, Functor f)
+resolversToMap :: (Foldable f, Functor f)
     => f (Resolver m)
-    -> HashMap Text (Field -> CollectErrsT m Aeson.Object)
+    -> HashMap Text (FieldResolver m)
 resolversToMap = HashMap.fromList . toList . fmap toKV
   where
-    toKV (Resolver name f) = (name, f)
+    toKV (Resolver name r) = (name, r)
 
 -- | Contains variables for the query. The key of the map is a variable name,
 --   and the value is the variable value.
@@ -54,85 +55,79 @@ type Subs = HashMap Name Value
 
 -- | Create a new 'Resolver' with the given 'Name' from the given 'Resolver's.
 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 (resolversToMap resolver) flds) fld
+object name = Resolver name
+    . NestingResolver
+    . fmap (Type.Named . resolversToMap)
 
 -- | Like 'object' but can be null or a list of objects.
-wrappedObject ::
-    Monad m =>
-    Name ->
-    ActionT m (Type.Wrapping [Resolver m]) ->
-    Resolver m
-wrappedObject name f = Resolver name $ resolveFieldValue f resolveRight
-  where
-    resolveRight fld@(Field _ _ _ sels) resolver
-        = withField (traverse (resolveMap sels) resolver) fld
-    resolveMap = flip (resolve . resolversToMap)
+wrappedObject :: Monad m
+    => Name
+    -> ActionT m (Type.Wrapping [Resolver m])
+    -> Resolver m
+wrappedObject name = Resolver name
+    . NestingResolver
+    . (fmap . fmap) 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
-scalar name f = Resolver name $ resolveFieldValue f resolveRight
-  where
-    resolveRight fld result = withField (return result) fld
+scalar name = Resolver name . ValueResolver . fmap Aeson.toJSON
 
 -- | Like 'scalar' but can be null or a list of scalars.
-wrappedScalar ::
-    (Monad m, Aeson.ToJSON a) =>
-    Name ->
-    ActionT m (Type.Wrapping a) ->
-    Resolver m
-wrappedScalar name f = Resolver name $ resolveFieldValue f resolveRight
-  where
-    resolveRight fld (Type.Named result) = withField (return result) fld
-    resolveRight fld Type.Null
-        = return $ HashMap.singleton (aliasOrName fld) Aeson.Null
-    resolveRight fld (Type.List result) = withField (return result) fld
+wrappedScalar :: (Monad m, Aeson.ToJSON a)
+    => Name
+    -> ActionT m (Type.Wrapping a)
+    -> Resolver m
+wrappedScalar name = Resolver name . ValueResolver . fmap Aeson.toJSON
 
-resolveFieldValue ::
-    Monad m =>
-    ActionT m a ->
-    (Field -> a -> CollectErrsT m Aeson.Object) ->
-    Field ->
-    CollectErrsT m (HashMap Text Aeson.Value)
-resolveFieldValue f resolveRight fld@(Field _ _ args _) = do
-    result <- lift $ reader . runExceptT . runActionT $ f
-    either resolveLeft (resolveRight fld) result
-      where
-        reader = flip runReaderT $ Context {arguments=args}
-        resolveLeft err = do
-            _ <- addErrMsg err
-            return $ HashMap.singleton (aliasOrName fld) Aeson.Null
+resolveFieldValue :: Monad m => Field -> ActionT m a -> m (Either Text a)
+resolveFieldValue field@(Field _ _ args _) =
+    flip runReaderT (Context {arguments=args, info=field})
+    . runExceptT
+    . runActionT
 
--- | Helper function to facilitate error handling and result emitting.
-withField :: (Monad m, Aeson.ToJSON a)
-    => CollectErrsT m a -> Field -> CollectErrsT m (HashMap Text Aeson.Value)
-withField v fld
-    = HashMap.singleton (aliasOrName fld) . Aeson.toJSON <$> runAppendErrs v
+convert :: Type.Wrapping Aeson.Value -> Aeson.Value
+convert Type.Null = Aeson.Null
+convert (Type.Named value) = value
+convert (Type.List value) = Aeson.toJSON value
+
+withField :: Monad m => Field -> FieldResolver m -> CollectErrsT m Aeson.Object
+withField field (ValueResolver resolver) = do
+    answer <- lift $ resolveFieldValue field resolver
+    either (errmsg field) (pure . HashMap.singleton (aliasOrName field)) answer
+withField field@(Field _ _ _ seqSelection) (NestingResolver resolver) = do
+    answer <- lift $ resolveFieldValue field resolver
+    case answer of
+        Right result -> do
+            nestedFields <- traverse (`resolve` seqSelection) result
+            pure $ HashMap.singleton (aliasOrName field) $ convert nestedFields
+        Left errorMessage -> errmsg field errorMessage
+
+errmsg :: Monad m => Field -> Text -> CollectErrsT m (HashMap Text Aeson.Value)
+errmsg field errorMessage = do
+    addErrMsg errorMessage
+    pure $ HashMap.singleton (aliasOrName field) Aeson.Null
 
 -- | Takes a list of 'Resolver's and a list of 'Field's and applies each
 --   'Resolver' to each 'Field'. Resolves into a value containing the
 --   resolved 'Field', or a null value and error information.
 resolve :: Monad m
-    => HashMap Text (Field -> CollectErrsT m Aeson.Object)
+    => HashMap Text (FieldResolver m)
     -> Seq Selection
     -> CollectErrsT m Aeson.Value
 resolve resolvers = fmap (Aeson.toJSON . fold) . traverse tryResolvers
   where
-    resolveTypeName f = do
-        value <- f $ Field Nothing "__typename" mempty mempty
-        return $ HashMap.lookupDefault "" "__typename" value
+    lookupResolver = flip HashMap.lookup resolvers
     tryResolvers (SelectionField fld@(Field _ name _ _))
-        = fromMaybe (errmsg fld) $ HashMap.lookup name resolvers <*> Just fld
-    tryResolvers (SelectionFragment (Fragment typeCondition selections')) = do
-        that <- traverse resolveTypeName $ HashMap.lookup "__typename" resolvers
-        if maybe True (Aeson.String typeCondition ==) that
-            then fmap fold . traverse tryResolvers $ selections'
-            else return mempty
-    errmsg fld@(Field _ name _ _) = do
-        addErrMsg $ T.unwords ["field", name, "not resolved."]
-        return $ HashMap.singleton (aliasOrName fld) Aeson.Null
+        | (Just resolver) <- lookupResolver name = withField fld resolver
+        | otherwise = errmsg fld $ T.unwords ["field", name, "not resolved."]
+    tryResolvers (SelectionFragment (Fragment typeCondition selections'))
+        | Just (ValueResolver resolver) <- lookupResolver "__typename" = do
+            let fakeField = Field Nothing "__typename" mempty mempty
+            that <- lift $ resolveFieldValue fakeField resolver
+            if Right (Aeson.String typeCondition) == that
+                then fmap fold . traverse tryResolvers $ selections'
+                else pure mempty
+        | otherwise = fmap fold . traverse tryResolvers $ selections'
 
 aliasOrName :: Field -> Text
 aliasOrName (Field alias name _ _) = fromMaybe name alias
diff --git a/src/Language/GraphQL/Trans.hs b/src/Language/GraphQL/Trans.hs
index 09c012b..f09a8a0 100644
--- a/src/Language/GraphQL/Trans.hs
+++ b/src/Language/GraphQL/Trans.hs
@@ -18,8 +18,9 @@ import Language.GraphQL.AST.Core
 import Prelude hiding (lookup)
 
 -- | Resolution context holds resolver arguments.
-newtype Context = Context
+data Context = Context
     { arguments :: Arguments
+    , info :: Field
     }
 
 -- | Monad transformer stack used by the resolvers to provide error handling
diff --git a/tests/Language/GraphQL/SchemaSpec.hs b/tests/Language/GraphQL/SchemaSpec.hs
new file mode 100644
index 0000000..6804150
--- /dev/null
+++ b/tests/Language/GraphQL/SchemaSpec.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Language.GraphQL.SchemaSpec
+    ( spec
+    ) where
+
+import qualified Data.Aeson as Aeson
+import qualified Data.Aeson.Types as Aeson
+import qualified Data.Sequence as Sequence
+import Data.Text (Text)
+import Language.GraphQL.AST.Core
+import Language.GraphQL.Error
+import Language.GraphQL.Schema
+import Test.Hspec (Spec, describe, it, shouldBe)
+
+spec :: Spec
+spec =
+    describe "resolve" $
+        it "ignores invalid __typename" $ do
+            let resolver = object "__typename" $ pure
+                    [ scalar "field" $ pure ("T" :: Text)
+                    ]
+                schema = resolversToMap [resolver]
+                fields = Sequence.singleton
+                    $ SelectionFragment
+                    $ Fragment "T" Sequence.empty
+                expected = Aeson.object
+                    [ ("data" , Aeson.emptyObject)
+                    ]
+
+            actual <- runCollectErrs (resolve schema fields)
+            actual `shouldBe` expected
diff --git a/tests/Test/DirectiveSpec.hs b/tests/Test/DirectiveSpec.hs
index 3b9da19..b4cf364 100644
--- a/tests/Test/DirectiveSpec.hs
+++ b/tests/Test/DirectiveSpec.hs
@@ -4,7 +4,7 @@ module Test.DirectiveSpec
     ( spec
     ) where
 
-import Data.Aeson (Value, object, (.=))
+import Data.Aeson (Value(..), object, (.=))
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
 import Data.List.NonEmpty (NonEmpty(..))
diff --git a/tests/Test/FragmentSpec.hs b/tests/Test/FragmentSpec.hs
index 74293a9..99c0715 100644
--- a/tests/Test/FragmentSpec.hs
+++ b/tests/Test/FragmentSpec.hs
@@ -189,3 +189,27 @@ spec = do
                     ]
             actual <- graphql (HashMap.singleton "Query" $ garment "Hat" :| []) query
             actual `shouldBe` expected
+
+        it "test1" $ do
+            let query = [r|
+              {
+                garment {
+                  circumference
+                }
+              }
+            |]
+                expected = object
+                    [ "data" .= object
+                        [ "garment" .= object
+                            [ "circumference" .= (60 :: Int)
+                            ]
+                        ]
+                    ]
+            actual <- graphql schema query
+            actual `shouldBe` expected
+          where
+            schema = HashMap.singleton "Query" $ garment' :| []
+            garment' = Schema.object "garment" $ return
+                [ circumference'
+                ]
+            circumference' = Schema.scalar "circumference" $ pure (60 :: Int)
diff --git a/tests/Test/QuerySpec.hs b/tests/Test/QuerySpec.hs
new file mode 100644
index 0000000..95608b0
--- /dev/null
+++ b/tests/Test/QuerySpec.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Test.QuerySpec
+    ( spec
+    ) where
+
+import Data.Aeson ((.=), object)
+import qualified Data.HashMap.Strict as HashMap
+import Data.List.NonEmpty (NonEmpty(..))
+import Language.GraphQL
+import qualified Language.GraphQL.Schema as Schema
+import Test.Hspec (Spec, describe, it, shouldBe)
+import Text.RawString.QQ (r)
+
+spec :: Spec
+spec =
+    describe "Query executor" $
+        it "returns objects from the root resolvers" $ do
+            let query = [r|
+              {
+                garment {
+                  circumference
+                }
+              }
+            |]
+                expected = object
+                    [ "data" .= object
+                        [ "garment" .= object
+                            [ "circumference" .= (60 :: Int)
+                            ]
+                        ]
+                    ]
+            actual <- graphql schema query
+            actual `shouldBe` expected
+          where
+            schema = HashMap.singleton "Query" $ garment' :| []
+            garment' = Schema.object "garment" $ return
+                [ circumference'
+                ]
+            circumference' = Schema.scalar "circumference" $ pure (60 :: Int)