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 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..9886f46 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 @@ -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/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 diff --git a/scripts/hpc-ratchet b/scripts/hpc-ratchet index df77fe3..c5620c4 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: 151, BOOLEANS: 8, - EXPRESSIONS: 1366, + EXPRESSIONS: 1351, LOCAL_DECLS: 10, - TOP_LEVEL_DECLS: 673, + TOP_LEVEL_DECLS: 670, } diff --git a/src/GraphQL/Internal/Resolver.hs b/src/GraphQL/Internal/Resolver.hs index f20b9c5..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 #-} @@ -24,6 +25,8 @@ module GraphQL.Internal.Resolver , Result(..) , unionValue , resolveOperation + , returns + , handlerError ) where -- TODO (probably incomplete, the spec is large) @@ -84,6 +87,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 +106,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 +153,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,45 +193,56 @@ 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 - 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 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..9d66f87 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) @@ -57,17 +57,17 @@ 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 $ - 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..d36e63c 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) + :<> returns ([ 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