From 1f7bd92d1105f44d5214c1210d4cefeb8bc1bd8e Mon Sep 17 00:00:00 2001
From: Dmitrii Skurikhin <dmitrii.sk@gmail.com>
Date: Tue, 4 Jan 2022 14:40:41 +0300
Subject: fix index position in error path

---
 tests/Language/GraphQL/ExecuteSpec.hs | 16 ++++++++
 tests/Schemas/HeroSchema.hs           | 70 +++++++++++++++++++++++++++++++++++
 2 files changed, 86 insertions(+)
 create mode 100644 tests/Schemas/HeroSchema.hs

(limited to 'tests')

diff --git a/tests/Language/GraphQL/ExecuteSpec.hs b/tests/Language/GraphQL/ExecuteSpec.hs
index 5eafb2e..f4e599a 100644
--- a/tests/Language/GraphQL/ExecuteSpec.hs
+++ b/tests/Language/GraphQL/ExecuteSpec.hs
@@ -4,6 +4,7 @@
 
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE QuasiQuotes #-}
+
 module Language.GraphQL.ExecuteSpec
     ( spec
     ) where
@@ -26,6 +27,9 @@ import qualified Language.GraphQL.Type.Out as Out
 import Prelude hiding (id)
 import Test.Hspec (Spec, context, describe, it, shouldBe)
 import Text.Megaparsec (parse)
+import Schemas.HeroSchema (heroSchema)
+import Data.Maybe (fromJust)
+import qualified Data.Sequence as Seq
 
 data PhilosopherException = PhilosopherException
     deriving Show
@@ -335,6 +339,18 @@ spec =
                         $ parse document "" "{ philosopher(id: \"1\") { firstLanguage } }"
                 in actual `shouldBe` expected
 
+            context "Error path" $ do
+                let executeHero :: Document -> Either SomeException EitherStreamOrValue
+                    executeHero = execute heroSchema Nothing (HashMap.empty :: HashMap Name Value)
+
+                it "at the beggining of the list" $
+                    let Right (Right actual) = either (pure . parseError) executeHero
+                            $ parse document "" "{ hero(id: \"1\") { friends { name } } }"
+                        Response _ errors' = actual
+                        Error _ _ path' = fromJust $ Seq.lookup 0 errors'
+                        expected = [Segment "hero", Segment "friends", Index 0, Segment "name"]
+                    in path' `shouldBe` expected
+
         context "Subscription" $
             it "subscribes" $
                 let data'' = Object
diff --git a/tests/Schemas/HeroSchema.hs b/tests/Schemas/HeroSchema.hs
new file mode 100644
index 0000000..71b7a10
--- /dev/null
+++ b/tests/Schemas/HeroSchema.hs
@@ -0,0 +1,70 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
+{-# LANGUAGE OverloadedStrings #-}
+
+module Schemas.HeroSchema (heroSchema) where
+
+import Control.Exception (Exception(..), SomeException)
+import Control.Monad.Catch (throwM)
+import Language.GraphQL.Error (ResolverException (..))
+import qualified Language.GraphQL.Type.In as In
+import qualified Language.GraphQL.Type as Type
+import Language.GraphQL.Type.Schema (schemaWithTypes)
+import qualified Data.HashMap.Strict as HashMap
+import Data.Typeable (cast)
+import qualified Language.GraphQL.Type.Out as Out
+
+data HeroException = HeroException
+    deriving Show
+
+instance Exception HeroException where
+    toException = toException. ResolverException
+    fromException e = do
+        ResolverException resolverException <- fromException e
+        cast resolverException
+
+heroSchema :: Type.Schema (Either SomeException)
+heroSchema =
+    schemaWithTypes Nothing queryType Nothing Nothing [] mempty
+
+type ObjectType = Out.ObjectType (Either SomeException)
+
+queryType :: ObjectType
+queryType = Out.ObjectType "Query" Nothing []
+    $ HashMap.fromList
+        [ ("hero", Out.ValueResolver heroField heroResolver)
+        ]
+  where
+    heroField = Out.Field Nothing (Out.NamedObjectType heroType)
+        $ HashMap.singleton "id"
+        $ In.Argument Nothing (In.NamedScalarType Type.id) Nothing
+    heroResolver = pure $ Type.Object mempty
+
+stringField :: Out.Field (Either SomeException)
+stringField = Out.Field Nothing (Out.NonNullScalarType Type.string) HashMap.empty
+
+heroType :: ObjectType
+heroType = Out.ObjectType "Hero" Nothing [] $ HashMap.fromList resolvers
+  where
+    resolvers =
+        [ ("id", Out.ValueResolver stringField (pure $ Type.String "4111"))
+        , ("name", Out.ValueResolver stringField (pure $ Type.String "R2D2"))
+        , ("friends", Out.ValueResolver friendsField (pure $ Type.List [luke]))
+        ]
+    friendsField = Out.Field Nothing (Out.ListType $ Out.NonNullObjectType lukeType) HashMap.empty
+    -- This list values are ignored because of current realisation (types and resolvers are the same entity)
+    -- The values from lukeType will be used
+    luke = Type.Object $ HashMap.fromList
+        [ ("id", "dfdfdf")
+        , ("name", "dfdfdff")
+        ]
+
+lukeType :: ObjectType
+lukeType = Out.ObjectType "Luke" Nothing [] $ HashMap.fromList resolvers
+  where
+    resolvers =
+        [ ("id", Out.ValueResolver stringField (pure $ Type.String "1000"))
+        , ("name", Out.ValueResolver stringField (throwM HeroException))
+        ]
-- 
cgit v1.2.3