Merge pull request #224 from kquick/master

Allow Handlers to return errors.

Author: teh

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

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

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

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

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,
 }
 
 

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

src/GraphQL/Resolver.hs

@@ -13,4 +13,6 @@ import GraphQL.Internal.Resolver as Export
   , Result(..)
   , unionValue
   , resolveOperation
+  , returns
+  , handlerError
   )

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