From 3acb52ef61dfd86a72d4d2ea8f0a42ef977e3789 Mon Sep 17 00:00:00 2001 From: Kevin Quick Date: Tue, 8 Oct 2019 11:51:38 -0700 Subject: [PATCH 1/6] Allow Handlers to return errors. Prior to this change, the graphql-api internals could generate errors but the user-supplied Handler could not. This adds the ability for the user-supplied Handler to also return an error. 1. Added a HandlerError constructor to the ResolverError to represent errors generated by the handler. 2. Updated the resolve to return a 'HandlerResult a' which is now a typedef for 'Either Text a'. This could not be done as a 'Union' type because the 'Left err' value should have a different effect on the results (null in 'data' and adding to 'errors'). 3. Updated all the HasResolver class instances for the change in #2. 4. Added 'returns' and 'handlerError' convenience functions for handlers to abstract the internals of the success/failure implementation. 5. Enhanced the tests (particularly ResolverSpec) for testing the generation of success and error results for different handler types. This change is *not* backward compatible---and cannot be because the handlers now need the ability to signal errors. However, all existing handlers which perforce return successful values can be updated rather simply using the new 'returns' helper for each handler field instead of the previous 'pure' function: miniCat name = pure (pure name :<> pure 32) becomes: miniCat name = pure (returns name :<> returns 32) And: handler :: Handler IO Query handler = pure $ \fooId -> do foo <- lookupFoo fooId -- note that fmap maps over the Maybe, so we still need -- have to wrap the result in a pure. sequence $ fmap (pure . viewFoo) foo becomes: handler :: Handler IO Query handler = pure $ \fooId -> do foo <- lookupFoo fooId returns $ viewFoo <$> foo The current reported package version of 0.3.0 should be changed to at least 0.4.0 to indicate a breaking, non-backward-compatible change. --- examples/InputObject.hs | 6 +-- examples/UnionExample.hs | 6 +-- src/GraphQL/Internal/Resolver.hs | 57 +++++++++++++++----- src/GraphQL/Resolver.hs | 2 + tests/EndToEndSpec.hs | 26 ++++----- tests/ResolverSpec.hs | 93 +++++++++++++++++++++++++------- 6 files changed, 139 insertions(+), 51 deletions(-) diff --git a/examples/InputObject.hs b/examples/InputObject.hs index 9ce811a..92253ba 100644 --- a/examples/InputObject.hs +++ b/examples/InputObject.hs @@ -11,7 +11,7 @@ import qualified Data.Aeson as Aeson import GraphQL import GraphQL.API -import GraphQL.Resolver (Handler) +import GraphQL.Resolver (Handler, returns) import GraphQL.Value (FromValue, toValue) data DogStuff = DogStuff { _toy :: Text, _likesTreats :: Bool } deriving (Show, Generic) @@ -30,8 +30,8 @@ root = pure description description :: DogStuff -> Handler IO Text description (DogStuff toy likesTreats) - | likesTreats = pure $ "likes treats and their favorite toy is a " <> toy - | otherwise = pure $ "their favorite toy is a " <> toy + | likesTreats = returns $ "likes treats and their favorite toy is a " <> toy + | otherwise = returns $ "their favorite toy is a " <> toy -- | Show input object usage -- diff --git a/examples/UnionExample.hs b/examples/UnionExample.hs index 8e011e0..c37a73b 100644 --- a/examples/UnionExample.hs +++ b/examples/UnionExample.hs @@ -6,7 +6,7 @@ import Protolude import qualified Data.Aeson as Aeson import GraphQL.API (Field, List, Object, Union) import GraphQL (interpretAnonymousQuery) -import GraphQL.Resolver (Handler, (:<>)(..), unionValue) +import GraphQL.Resolver (Handler, (:<>)(..), unionValue, returns) import GraphQL.Value (ToValue(..)) -- Slightly reduced example from the spec @@ -17,10 +17,10 @@ type CatOrDog = Object "Me" '[] '[Field "myPet" (Union "CatOrDog" '[MiniCat, Min type CatOrDogList = Object "CatOrDogList" '[] '[Field "pets" (List (Union "CatOrDog" '[MiniCat, MiniDog]))] miniCat :: Text -> Handler IO MiniCat -miniCat name = pure (pure name :<> pure 32) +miniCat name = pure (returns name :<> returns 32) miniDog :: Handler IO MiniDog -miniDog = pure (pure 100) +miniDog = pure (returns 100) catOrDog :: Handler IO CatOrDog catOrDog = pure $ do diff --git a/src/GraphQL/Internal/Resolver.hs b/src/GraphQL/Internal/Resolver.hs index f20b9c5..9ebac3f 100644 --- a/src/GraphQL/Internal/Resolver.hs +++ b/src/GraphQL/Internal/Resolver.hs @@ -24,6 +24,8 @@ module GraphQL.Internal.Resolver , Result(..) , unionValue , resolveOperation + , returns + , handlerError ) where -- TODO (probably incomplete, the spec is large) @@ -84,6 +86,8 @@ data ResolverError | SubSelectionOnLeaf (SelectionSetByType Value) -- | Tried to treat an object as a leaf. | MissingSelectionSet + -- | Error from handler + | HandlerError Text deriving (Show, Eq) instance GraphQLError ResolverError where @@ -101,6 +105,8 @@ instance GraphQLError ResolverError where "Tried to get values within leaf field: " <> show ss formatError MissingSelectionSet = "Tried to treat object as if it were leaf field." + formatError (HandlerError err) = + "Handler error: " <> err -- | Object field separation operator. -- @@ -146,6 +152,22 @@ instance Applicative Result where ok :: Value -> Result Value ok = pure + +-- | The result of a handler is either text errors generated by the +-- handler or a value. +type HandlerResult a = Either Text a + +-- | `returns` is a convenience function for a Handler that is +-- returning the expected value. +returns :: Applicative f => a -> f (HandlerResult a) +returns = pure . Right + +-- | `handlerError` is a convenience function for a Handler that has +-- encountered an error and is unable to return the expected value. +handlerError :: Applicative f => Text -> f (HandlerResult a) +handlerError = pure . Left + + class HasResolver m a where type Handler m a resolve :: Handler m a -> Maybe (SelectionSetByType Value) -> m (Result Value) @@ -170,24 +192,30 @@ resolveOperation handler ss = valueMissing :: API.Defaultable a => Name -> Either ResolverError a valueMissing name = maybe (Left (ValueMissing name)) Right (API.defaultFor name) +gotHandlerErr :: Text -> Result Value +gotHandlerErr err = Result [HandlerError err] GValue.ValueNull + +handlerResult :: (Applicative f, ToValue a) => f (HandlerResult a) -> f (Result Value) +handlerResult = fmap (either gotHandlerErr (ok . toValue)) + instance forall m. (Applicative m) => HasResolver m Int32 where - type Handler m Int32 = m Int32 - resolve handler Nothing = map (ok . toValue) handler + type Handler m Int32 = m (HandlerResult Int32) + resolve handler Nothing = handlerResult @m handler resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) instance forall m. (Applicative m) => HasResolver m Double where - type Handler m Double = m Double - resolve handler Nothing = map (ok . toValue) handler + type Handler m Double = m (HandlerResult Double) + resolve handler Nothing = handlerResult handler resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) instance forall m. (Applicative m) => HasResolver m Text where - type Handler m Text = m Text - resolve handler Nothing = map (ok . toValue) handler + type Handler m Text = m (HandlerResult Text) + resolve handler Nothing = handlerResult handler resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) instance forall m. (Applicative m) => HasResolver m Bool where - type Handler m Bool = m Bool - resolve handler Nothing = map (ok . toValue) handler + type Handler m Bool = m (HandlerResult Bool) + resolve handler Nothing = handlerResult handler resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) instance forall m hg. (Monad m, Applicative m, HasResolver m hg) => HasResolver m (API.List hg) where @@ -198,17 +226,20 @@ instance forall m hg. (Monad m, Applicative m, HasResolver m hg) => HasResolver map aggregateResults a instance forall m ksN enum. (Applicative m, API.GraphQLEnum enum) => HasResolver m (API.Enum ksN enum) where - type Handler m (API.Enum ksN enum) = m enum - resolve handler Nothing = map (ok . GValue.ValueEnum . API.enumToValue) handler + type Handler m (API.Enum ksN enum) = m (HandlerResult enum) + resolve handler Nothing = either gotHandlerErr (ok . GValue.ValueEnum . API.enumToValue) <$> handler resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) instance forall m hg. (HasResolver m hg, Monad m) => HasResolver m (Maybe hg) where - type Handler m (Maybe hg) = m (Maybe (Handler m hg)) + type Handler m (Maybe hg) = m (HandlerResult (Maybe (Handler m hg))) resolve handler selectionSet = do result <- handler case result of - Just x -> resolve @m @hg (x :: Handler m hg) selectionSet - Nothing -> (pure . ok) GValue.ValueNull + Right res -> + case res of + Just x -> resolve @m @hg (x :: Handler m hg) selectionSet + Nothing -> (pure . ok) GValue.ValueNull + Left err -> pure $ gotHandlerErr err -- TODO: A parametrized `Result` is really not a good way to handle the -- "result" for resolveField, but not sure what to use either. Tom liked the diff --git a/src/GraphQL/Resolver.hs b/src/GraphQL/Resolver.hs index cac277f..88c1cf8 100644 --- a/src/GraphQL/Resolver.hs +++ b/src/GraphQL/Resolver.hs @@ -13,4 +13,6 @@ import GraphQL.Internal.Resolver as Export , Result(..) , unionValue , resolveOperation + , returns + , handlerError ) diff --git a/tests/EndToEndSpec.hs b/tests/EndToEndSpec.hs index afd3b6f..70f3bdc 100644 --- a/tests/EndToEndSpec.hs +++ b/tests/EndToEndSpec.hs @@ -15,7 +15,7 @@ import qualified Data.Map as Map import GraphQL (makeSchema, compileQuery, executeQuery, interpretAnonymousQuery, interpretQuery) import GraphQL.API (Object, Field, List, Argument, (:>), Defaultable(..), HasAnnotatedInputType(..)) import GraphQL.Internal.Syntax.AST (Variable(..)) -import GraphQL.Resolver ((:<>)(..), Handler, unionValue) +import GraphQL.Resolver ((:<>)(..), Handler, unionValue, returns) import GraphQL.Value (ToValue(..), FromValue(..), makeName) import Test.Hspec import Text.RawString.QQ (r) @@ -64,10 +64,10 @@ catOrDogList = catHandler :: Text -> Maybe Text -> Int32 -> Handler IO Cat catHandler name nickName meowVolume = pure $ - pure name :<> - pure (pure <$> nickName) :<> - pure . const False :<> -- doesn't know any commands - pure meowVolume + returns name :<> + returns (returns <$> nickName) :<> + returns . const False :<> -- doesn't know any commands + returns meowVolume -- | Our server's internal representation of a 'Dog'. data ServerDog @@ -94,17 +94,17 @@ isHouseTrained dog (Just True) = houseTrainedElsewhere dog -- | Present 'ServerDog' for GraphQL. viewServerDog :: ServerDog -> Handler IO Dog viewServerDog dog@ServerDog{..} = pure $ - pure name :<> - pure (fmap pure nickname) :<> - pure barkVolume :<> - pure . doesKnowCommand dog :<> - pure . isHouseTrained dog :<> + returns name :<> + returns (fmap returns nickname) :<> + returns barkVolume :<> + returns . doesKnowCommand dog :<> + returns . isHouseTrained dog :<> viewServerHuman owner describeDog :: DogStuff -> Handler IO Text describeDog (DogStuff toy likesTreats) - | likesTreats = pure $ "likes treats and their favorite toy is a " <> toy - | otherwise = pure $ "their favorite toy is a " <> toy + | likesTreats = returns $ "likes treats and their favorite toy is a " <> toy + | otherwise = returns $ "their favorite toy is a " <> toy rootHandler :: ServerDog -> Handler IO QueryRoot rootHandler dog = pure $ viewServerDog dog :<> describeDog :<> catOrDog :<> catOrDogList @@ -127,7 +127,7 @@ newtype ServerHuman = ServerHuman Text deriving (Eq, Ord, Show, Generic) -- | Present a 'ServerHuman' as a GraphQL 'Human'. viewServerHuman :: ServerHuman -> Handler IO Human -viewServerHuman (ServerHuman name) = pure (pure name) +viewServerHuman (ServerHuman name) = pure (returns name) -- | It me. jml :: ServerHuman diff --git a/tests/ResolverSpec.hs b/tests/ResolverSpec.hs index d3bae1d..bd8dc85 100644 --- a/tests/ResolverSpec.hs +++ b/tests/ResolverSpec.hs @@ -7,7 +7,7 @@ import Protolude hiding (Enum) import Test.Hspec -import Data.Aeson (encode) +import Data.Aeson (encode, toJSON, object, (.=), Value(Null)) import GraphQL ( Response(..) , interpretAnonymousQuery @@ -17,28 +17,40 @@ import GraphQL.API , Field , Argument , Enum + , List , (:>) ) import GraphQL.Resolver ( Handler , ResolverError(..) , (:<>)(..) + , returns + , handlerError ) import GraphQL.Internal.Output (singleError) - +import qualified GraphQL.Value as GValue import EnumTests ( Mode(NormalFile) ) -- Test a custom error monad type TMonad = ExceptT Text IO type T = Object "T" '[] '[ Field "z" Int32 , Argument "x" Int32 :> Field "t" Int32 - , Argument "y" Int32 :> Field "q" Int32 + , Argument "y" Int32 :> Field "q" (Maybe Int32) + , Argument "d" Double :> Field "r" Double + , Field "l" (List Int32) + , Argument "n" Text :> Field "foo" (Maybe Foo) + , Field "bar" (Maybe Foo) ] tHandler :: Handler TMonad T -tHandler = - pure $ (pure 10) :<> (\tArg -> pure tArg) :<> (pure . (*2)) - +tHandler = pure $ + returns 10 + :<> (\x -> if x == 99 then handlerError "missed 99th value" else returns x) + :<> returns . Just . (returns . (*2)) + :<> (\dArg -> if dArg == 9.9 then handlerError "bad 9.9 value" else returns dArg) + :<> pure ([ returns 0, returns 7, handlerError "no number 9" ]) + :<> (\_nArg -> returns $ Just $ return $ returns "fred") + :<> returns Nothing -- https://github.com/jml/graphql-api/issues/119 -- Maybe X didn't descend into its argument. Now it does. @@ -56,40 +68,83 @@ lookupFoo :: Text -> IO (Maybe ServerFoo) lookupFoo _ = pure $ Just (ServerFoo "Mort") viewFoo :: ServerFoo -> Handler IO Foo -viewFoo ServerFoo { name=name } = pure $ pure $ name +viewFoo ServerFoo { name=name } = pure $ returns $ name handler :: Handler IO Query handler = pure $ \fooId -> do foo <- lookupFoo fooId - -- note that fmap maps over the Maybe, so we still need - -- have to wrap the result in a pure. - sequence $ fmap (pure . viewFoo) foo + returns $ viewFoo <$> foo -- Enum test type EnumQuery = Object "File" '[] '[ Field "mode" (Enum "modeEnumName" Mode) ] enumHandler :: Handler IO EnumQuery -enumHandler = pure $ pure NormalFile +enumHandler = pure $ returns NormalFile + +enumHandler2 :: Handler IO EnumQuery +enumHandler2 = pure $ handlerError "I forgot!" + -- /Enum test spec :: Spec spec = describe "TypeAPI" $ do describe "tTest" $ do - it "works in a simple case" $ do - Right (Success object) <- runExceptT (interpretAnonymousQuery @T tHandler "{ t(x: 12) }") - encode object `shouldBe` "{\"t\":12}" - it "complains about missing field" $ do + it "works in a simple Int32 case" $ do + Right (Success obj) <- runExceptT (interpretAnonymousQuery @T tHandler "{ t(x: 12) }") + encode obj `shouldBe` "{\"t\":12}" + it "works in a simple Double case" $ do + r <- runExceptT (interpretAnonymousQuery @T tHandler "{ r(d: 1.2) }") + case r of + Right (Success obj) -> encode obj `shouldBe` "{\"r\":1.2}" + _ -> r `shouldNotBe` r + it "works for value and error list elements" $ do + r <- runExceptT (interpretAnonymousQuery @T tHandler "{ l }") + case r of + Right (PartialSuccess obj err) -> do + encode obj `shouldBe` "{\"l\":[0,7,null]}" + err `shouldBe` (singleError (HandlerError "no number 9")) + _ -> r `shouldNotBe` r + it "works for Nullable present elements" $ do + r <- runExceptT (interpretAnonymousQuery @T tHandler "{ foo(n: \"flintstone\") { name } }") + case r of + Right (Success obj) -> do + encode obj `shouldBe` "{\"foo\":{\"name\":\"fred\"}}" + _ -> r `shouldNotBe` r + it "works for Nullable null elements" $ do + r <- runExceptT (interpretAnonymousQuery @T tHandler "{ bar { name } }") + case r of + Right (Success obj) -> do + encode obj `shouldBe` "{\"bar\":null}" + _ -> r `shouldNotBe` r + it "complains about a missing field" $ do Right (PartialSuccess _ errs) <- runExceptT (interpretAnonymousQuery @T tHandler "{ not_a_field }") errs `shouldBe` singleError (FieldNotFoundError "not_a_field") + it "complains about a handler throwing an exception" $ do + r <- runExceptT (interpretAnonymousQuery @T tHandler "{ t(x: 99) }") + case r of + Right (PartialSuccess v errs) -> do + -- n.b. this hasn't gone through the final JSON embedding, + -- so it's the individual components instead of the final + -- response of '{ "data": ..., "errors": ... }' + errs `shouldBe` (singleError (HandlerError "missed 99th value")) + toJSON (GValue.toValue v) `shouldBe` object [ "t" .= Null ] + _ -> r `shouldNotBe` r it "complains about missing argument" $ do Right (PartialSuccess _ errs) <- runExceptT (interpretAnonymousQuery @T tHandler "{ t }") errs `shouldBe` singleError (ValueMissing "x") describe "issue 119" $ do it "Just works" $ do - Success object <- interpretAnonymousQuery @Query handler "{ test(id: \"10\") { name } }" - encode object `shouldBe` "{\"test\":{\"name\":\"Mort\"}}" + Success obj <- interpretAnonymousQuery @Query handler "{ test(id: \"10\") { name } }" + encode obj `shouldBe` "{\"test\":{\"name\":\"Mort\"}}" describe "Parse, validate and execute queries against API" $ do it "API.Enum works" $ do - Success object <- interpretAnonymousQuery @EnumQuery enumHandler "{ mode }" - encode object `shouldBe` "{\"mode\":\"NormalFile\"}" + Success obj <- interpretAnonymousQuery @EnumQuery enumHandler "{ mode }" + encode obj `shouldBe` "{\"mode\":\"NormalFile\"}" + it "API.Enum handles errors" $ do + r <- interpretAnonymousQuery @EnumQuery enumHandler2 "{ mode }" + case r of + (PartialSuccess obj errs) -> do + encode obj `shouldBe` "{\"mode\":null}" + errs `shouldBe` (singleError $ HandlerError "I forgot!") + _ -> r `shouldNotBe` r From 84436b5b597080f924951012885992a460e66551 Mon Sep 17 00:00:00 2001 From: Kevin Quick Date: Tue, 8 Oct 2019 13:30:04 -0700 Subject: [PATCH 2/6] Update graphql-wai for new HandlerResult. --- graphql-wai/tests/Tests.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/graphql-wai/tests/Tests.hs b/graphql-wai/tests/Tests.hs index b27f689..c4dc5da 100644 --- a/graphql-wai/tests/Tests.hs +++ b/graphql-wai/tests/Tests.hs @@ -11,7 +11,7 @@ import GraphQL.Resolver type Cat = Object "Cat" '[] '[Field "name" Text] catHandler :: Handler IO Cat -catHandler = pure (pure "Felix") +catHandler = pure (returns "Felix") test1 :: Session () test1 = do From 312774fdee8d530a21a2e04e844dd9e34aed53c9 Mon Sep 17 00:00:00 2001 From: Kevin Quick Date: Tue, 8 Oct 2019 13:30:44 -0700 Subject: [PATCH 3/6] Update tutorial for new HandlerResult and describe handler error handling. --- docs/source/tutorial/Introduction.lhs | 31 +++++++++++++++++++++------ 1 file changed, 24 insertions(+), 7 deletions(-) diff --git a/docs/source/tutorial/Introduction.lhs b/docs/source/tutorial/Introduction.lhs index 1b609cd..9b4a9b8 100644 --- a/docs/source/tutorial/Introduction.lhs +++ b/docs/source/tutorial/Introduction.lhs @@ -16,7 +16,7 @@ import System.Random import GraphQL import GraphQL.API (Object, Field, Argument, (:>), Union) -import GraphQL.Resolver (Handler, (:<>)(..), unionValue) +import GraphQL.Resolver (Handler, (:<>)(..), unionValue, returns, handlerError) ``` ## A simple GraphQL service @@ -99,7 +99,7 @@ Here's a `Handler` for `Hello`: hello :: Handler IO Hello hello = pure greeting where - greeting who = pure ("Hello " <> who <> "!") + greeting who = returns ("Hello " <> who <> "!") ``` The type signature, `Handler IO Hello` shows that it's a `Handler` for @@ -115,7 +115,9 @@ to run actions in the base monad. The second layer of the handler, the implementation of `greeting`, produces the value of the `greeting` field. It is monadic so that it will only be -executed when the field was requested. +executed when the field was requested. It uses the 'returns' function to +return the value for the field in the monad (technically, the Applicative +context which is OK because a Monad is Applicative). Each field handler is a separate monadic action so we only perform the side effects for fields present in the query. @@ -124,6 +126,21 @@ This handler is in `Identity` because it doesn't do anything particularly monadic. It could be in `IO` or `STM` or `ExceptT Text IO` or whatever you would like. +### Errors in handlers + +It's possible that a handler will encounter an error as well (for example, the argument might be looked up in a database and the user might specify a non-existent user). To help support GraphQL-compliant errors, a handler can use the `handlerError` function with the error text. + +Here's a modified `Handler` for `Hello`: + +```haskell +helloFancy :: Handler IO Hello +helloFancy = pure greeting + where + greeting who = if who == "" + then handlerError "I need to know your name!" + else returns ("Hello " <> who <> "!") +``` + ### Running queries Defining a service isn't much point unless you can query. Here's how: @@ -174,15 +191,15 @@ And its handler: calculator :: Handler IO Calculator calculator = pure (add :<> subtract') where - add a b = pure (a + b) - subtract' a b = pure (a - b) + add a b = returns (a + b) + subtract' a b = returns (a - b) ``` This handler introduces a new operator, `:<>` (pronounced "birdface"), which is used to compose two existing handlers into a new handler. It's inspired by the operator for monoids, `<>`. -Note that we still need `pure` for each individual handler. +Note that we use `returns` for each individual handler. ## Nesting Objects @@ -238,7 +255,7 @@ We write nested handlers the same way we write the top-level handler: user :: Handler IO User user = pure name where - name = pure "Mort" + name = returns "Mort" query :: Handler IO Query query = pure user From 038cb983b873f16eea5d223ccbd767cac86db3c7 Mon Sep 17 00:00:00 2001 From: Kevin Quick Date: Tue, 8 Oct 2019 14:27:28 -0700 Subject: [PATCH 4/6] Update the hpc-ratchet coverage levels. --- scripts/hpc-ratchet | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/scripts/hpc-ratchet b/scripts/hpc-ratchet index df77fe3..13413f4 100755 --- a/scripts/hpc-ratchet +++ b/scripts/hpc-ratchet @@ -35,11 +35,11 @@ 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: 154, + ALTERNATIVES: 150, BOOLEANS: 8, - EXPRESSIONS: 1366, + EXPRESSIONS: 1347, LOCAL_DECLS: 10, - TOP_LEVEL_DECLS: 673, + TOP_LEVEL_DECLS: 670, } From f84ff3407d6993ba3549d2a139a830daf7606c32 Mon Sep 17 00:00:00 2001 From: Kevin Quick Date: Sat, 12 Oct 2019 18:02:46 -0700 Subject: [PATCH 5/6] Allow HandlerError on List return itself, not just List members. --- examples/UnionExample.hs | 8 ++++---- src/GraphQL/Internal/Resolver.hs | 11 +++++++---- tests/EndToEndSpec.hs | 8 ++++---- tests/ResolverSpec.hs | 2 +- 4 files changed, 16 insertions(+), 13 deletions(-) diff --git a/examples/UnionExample.hs b/examples/UnionExample.hs index c37a73b..9886f46 100644 --- a/examples/UnionExample.hs +++ b/examples/UnionExample.hs @@ -29,10 +29,10 @@ catOrDog = pure $ do catOrDogList :: Handler IO CatOrDogList catOrDogList = pure $ - pure [ unionValue @MiniCat (miniCat "Felix") - , unionValue @MiniCat (miniCat "Mini") - , unionValue @MiniDog miniDog - ] + returns [ unionValue @MiniCat (miniCat "Felix") + , unionValue @MiniCat (miniCat "Mini") + , unionValue @MiniDog miniDog + ] main :: IO () main = do diff --git a/src/GraphQL/Internal/Resolver.hs b/src/GraphQL/Internal/Resolver.hs index 9ebac3f..cbf772d 100644 --- a/src/GraphQL/Internal/Resolver.hs +++ b/src/GraphQL/Internal/Resolver.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} @@ -219,11 +220,13 @@ instance forall m. (Applicative m) => HasResolver m Bool where resolve _ (Just ss) = throwE (SubSelectionOnLeaf ss) instance forall m hg. (Monad m, Applicative m, HasResolver m hg) => HasResolver m (API.List hg) where - type Handler m (API.List hg) = m [Handler m hg] + type Handler m (API.List hg) = m (HandlerResult [Handler m hg]) resolve handler selectionSet = do - h <- handler - let a = traverse (flip (resolve @m @hg) selectionSet) h - map aggregateResults a + handler >>= \case + Right h -> + let a = traverse (flip (resolve @m @hg) selectionSet) h + in map aggregateResults a + Left err -> pure $ gotHandlerErr err instance forall m ksN enum. (Applicative m, API.GraphQLEnum enum) => HasResolver m (API.Enum ksN enum) where type Handler m (API.Enum ksN enum) = m (HandlerResult enum) diff --git a/tests/EndToEndSpec.hs b/tests/EndToEndSpec.hs index 70f3bdc..9d66f87 100644 --- a/tests/EndToEndSpec.hs +++ b/tests/EndToEndSpec.hs @@ -57,10 +57,10 @@ catOrDog = do catOrDogList :: Handler IO (List CatOrDog) catOrDogList = - pure [ unionValue @Cat (catHandler "Felix the Cat" (Just "felix") 42) - , unionValue @Cat (catHandler "Henry" Nothing 10) - , unionValue @Dog (viewServerDog mortgage) - ] + returns [ unionValue @Cat (catHandler "Felix the Cat" (Just "felix") 42) + , unionValue @Cat (catHandler "Henry" Nothing 10) + , unionValue @Dog (viewServerDog mortgage) + ] catHandler :: Text -> Maybe Text -> Int32 -> Handler IO Cat catHandler name nickName meowVolume = pure $ diff --git a/tests/ResolverSpec.hs b/tests/ResolverSpec.hs index bd8dc85..d36e63c 100644 --- a/tests/ResolverSpec.hs +++ b/tests/ResolverSpec.hs @@ -48,7 +48,7 @@ tHandler = pure $ :<> (\x -> if x == 99 then handlerError "missed 99th value" else returns x) :<> returns . Just . (returns . (*2)) :<> (\dArg -> if dArg == 9.9 then handlerError "bad 9.9 value" else returns dArg) - :<> pure ([ returns 0, returns 7, handlerError "no number 9" ]) + :<> returns ([ returns 0, returns 7, handlerError "no number 9" ]) :<> (\_nArg -> returns $ Just $ return $ returns "fred") :<> returns Nothing From f52d61cde661ea90c7938c81c8b2b55a7db7b976 Mon Sep 17 00:00:00 2001 From: Kevin Quick Date: Sun, 13 Oct 2019 17:42:54 -0700 Subject: [PATCH 6/6] Update hpc-ratchet expectations. --- scripts/hpc-ratchet | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/scripts/hpc-ratchet b/scripts/hpc-ratchet index 13413f4..c5620c4 100755 --- a/scripts/hpc-ratchet +++ b/scripts/hpc-ratchet @@ -35,9 +35,9 @@ 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: 150, + ALTERNATIVES: 151, BOOLEANS: 8, - EXPRESSIONS: 1347, + EXPRESSIONS: 1351, LOCAL_DECLS: 10, TOP_LEVEL_DECLS: 670, }