Handle errors using custom types

Fixes #32.
This commit is contained in:
Eugen Wissner 2020-07-05 14:36:00 +02:00
parent b5157e141e
commit a6f9cec413
7 changed files with 119 additions and 97 deletions

View File

@ -9,6 +9,9 @@ and this project adheres to
## [Unreleased] ## [Unreleased]
## Added ## Added
- `AST` reexports `AST.Parser`. - `AST` reexports `AST.Parser`.
- `Execute` reexports `Execute.Coerce`.
- `Error.Error` is an error representation with a message and source location.
- `Error.Response` represents a result of running a GraphQL query.
## Changed ## Changed
- `Trans.ActionT` has become to `Type.Out.ResolverT`. Since `Type.Out.Resolver` - `Trans.ActionT` has become to `Type.Out.ResolverT`. Since `Type.Out.Resolver`
@ -18,10 +21,15 @@ and this project adheres to
- `AST.Core` contained only `Arguments` which was moved to `Type.Definition`. - `AST.Core` contained only `Arguments` which was moved to `Type.Definition`.
`AST` provides now only functionality related to parsing and encoding, as it `AST` provides now only functionality related to parsing and encoding, as it
should be. should be.
- `Execute.execute` takes an additional argument, a possible operation name.
- `Error` module was changed to work with dedicated types for errors and the
response instead of JSON.
## Removed ## Removed
- `Type.Out.Resolver`: It is an unneeded layer of complexity. Resolvers are a - `Type.Out.Resolver`: It is an unneeded layer of complexity. Resolvers are a
part of the fields and are called `Trans.ResolverT`. part of the fields and are called `Trans.ResolverT`.
- `Execute.executeWithName`. `Execute.execute` takes the operation name and
completely replaces `executeWithName`.
## [0.8.0.0] - 2020-06-20 ## [0.8.0.0] - 2020-06-20
### Fixed ### Fixed

View File

@ -1,3 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-- | This module provides the functions to parse and execute @GraphQL@ queries. -- | This module provides the functions to parse and execute @GraphQL@ queries.
module Language.GraphQL module Language.GraphQL
( graphql ( graphql
@ -5,13 +8,11 @@ module Language.GraphQL
) where ) where
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap) import qualified Data.Sequence as Seq
import Data.Text (Text) import Data.Text (Text)
import Language.GraphQL.AST.Document import Language.GraphQL.AST
import Language.GraphQL.AST.Parser
import Language.GraphQL.Error import Language.GraphQL.Error
import Language.GraphQL.Execute import Language.GraphQL.Execute
import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Type.Schema import Language.GraphQL.Type.Schema
import Text.Megaparsec (parse) import Text.Megaparsec (parse)
@ -21,16 +22,32 @@ graphql :: Monad m
=> Schema m -- ^ Resolvers. => Schema m -- ^ Resolvers.
-> Text -- ^ Text representing a @GraphQL@ request document. -> Text -- ^ Text representing a @GraphQL@ request document.
-> m Aeson.Value -- ^ Response. -> m Aeson.Value -- ^ Response.
graphql = flip graphqlSubs (mempty :: Aeson.Object) graphql schema = graphqlSubs schema mempty mempty
-- | If the text parses correctly as a @GraphQL@ query the substitution is -- | If the text parses correctly as a @GraphQL@ query the substitution is
-- applied to the query and the query is then executed using to the given -- applied to the query and the query is then executed using to the given
-- 'Schema'. -- 'Schema'.
graphqlSubs :: (Monad m, VariableValue a) graphqlSubs :: Monad m
=> Schema m -- ^ Resolvers. => Schema m -- ^ Resolvers.
-> HashMap Name a -- ^ Variable substitution function. -> Maybe Text -- ^ Operation name.
-> Aeson.Object -- ^ Variable substitution function.
-> Text -- ^ Text representing a @GraphQL@ request document. -> Text -- ^ Text representing a @GraphQL@ request document.
-> m Aeson.Value -- ^ Response. -> m Aeson.Value -- ^ Response.
graphqlSubs schema f graphqlSubs schema operationName variableValues document' =
= either parseError (execute schema f) either parseError executeRequest parsed >>= formatResponse
. parse document "" where
parsed = parse document "" document'
formatResponse (Response data'' Seq.Empty) =
pure $ Aeson.object [("data", data'')]
formatResponse (Response data'' errors') = pure $ Aeson.object
[ ("data", data'')
, ("errors", Aeson.toJSON $ toJSON <$> errors')
]
toJSON Error{ line = 0, column = 0, ..} =
Aeson.object [("message", Aeson.toJSON message)]
toJSON Error{..} = Aeson.object
[ ("message", Aeson.toJSON message)
, ("line", Aeson.toJSON line)
, ("column", Aeson.toJSON column)
]
executeRequest = execute schema operationName variableValues

View File

@ -1,3 +1,4 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
@ -5,7 +6,9 @@
module Language.GraphQL.Error module Language.GraphQL.Error
( parseError ( parseError
, CollectErrsT , CollectErrsT
, Error(..)
, Resolution(..) , Resolution(..)
, Response(..)
, addErr , addErr
, addErrMsg , addErrMsg
, runCollectErrs , runCollectErrs
@ -13,12 +16,16 @@ module Language.GraphQL.Error
) where ) where
import Control.Monad.Trans.State (StateT, modify, runStateT) import Control.Monad.Trans.State (StateT, modify, runStateT)
import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.Sequence (Seq(..), (|>))
import qualified Data.Sequence as Seq
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text
import Data.Void (Void) import Data.Void (Void)
import Language.GraphQL.AST.Document (Name) import Language.GraphQL.AST.Document (Name)
import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Type.Schema import Language.GraphQL.Type.Schema
import Prelude hiding (null)
import Text.Megaparsec import Text.Megaparsec
( ParseErrorBundle(..) ( ParseErrorBundle(..)
, PosState(..) , PosState(..)
@ -31,59 +38,72 @@ import Text.Megaparsec
-- | Executor context. -- | Executor context.
data Resolution m = Resolution data Resolution m = Resolution
{ errors :: [Aeson.Value] { errors :: Seq Error
, types :: HashMap Name (Type m) , types :: HashMap Name (Type m)
} }
-- | Wraps a parse error into a list of errors. -- | Wraps a parse error into a list of errors.
parseError :: Applicative f => ParseErrorBundle Text Void -> f Aeson.Value parseError :: (Applicative f, Serialize a)
=> ParseErrorBundle Text Void
-> f (Response a)
parseError ParseErrorBundle{..} = parseError ParseErrorBundle{..} =
pure $ Aeson.object [("errors", Aeson.toJSON $ fst $ foldl go ([], bundlePosState) bundleErrors)] pure $ Response null $ fst
$ foldl go (Seq.empty, bundlePosState) bundleErrors
where where
errorObject s SourcePos{..} = Aeson.object errorObject s SourcePos{..} = Error
[ ("message", Aeson.toJSON $ init $ parseErrorTextPretty s) (Text.pack $ init $ parseErrorTextPretty s)
, ("line", Aeson.toJSON $ unPos sourceLine) (unPos' sourceLine)
, ("column", Aeson.toJSON $ unPos sourceColumn) (unPos' sourceColumn)
] unPos' = fromIntegral . unPos
go (result, state) x = go (result, state) x =
let (_, newState) = reachOffset (errorOffset x) state let (_, newState) = reachOffset (errorOffset x) state
sourcePosition = pstateSourcePos newState sourcePosition = pstateSourcePos newState
in (errorObject x sourcePosition : result, newState) in (result |> errorObject x sourcePosition, newState)
-- | A wrapper to pass error messages around. -- | A wrapper to pass error messages around.
type CollectErrsT m = StateT (Resolution m) m type CollectErrsT m = StateT (Resolution m) m
-- | Adds an error to the list of errors. -- | Adds an error to the list of errors.
addErr :: Monad m => Aeson.Value -> CollectErrsT m () addErr :: Monad m => Error -> CollectErrsT m ()
addErr v = modify appender addErr v = modify appender
where where
appender resolution@Resolution{..} = resolution{ errors = v : errors } appender :: Monad m => Resolution m -> Resolution m
appender resolution@Resolution{..} = resolution{ errors = errors |> v }
makeErrorMessage :: Text -> Aeson.Value makeErrorMessage :: Text -> Error
makeErrorMessage s = Aeson.object [("message", Aeson.toJSON s)] makeErrorMessage s = Error s 0 0
-- | Constructs a response object containing only the error with the given -- | Constructs a response object containing only the error with the given
-- message. -- message.
singleError :: Text -> Aeson.Value singleError :: Serialize a => Text -> Response a
singleError message = Aeson.object singleError message = Response null $ Seq.singleton $ makeErrorMessage message
[ ("errors", Aeson.toJSON [makeErrorMessage message])
]
-- | Convenience function for just wrapping an error message. -- | Convenience function for just wrapping an error message.
addErrMsg :: Monad m => Text -> CollectErrsT m () addErrMsg :: Monad m => Text -> CollectErrsT m ()
addErrMsg = addErr . makeErrorMessage addErrMsg = addErr . makeErrorMessage
-- | @GraphQL@ error.
data Error = Error
{ message :: Text
, line :: Word
, column :: Word
} deriving (Eq, Show)
-- | The server\'s response describes the result of executing the requested
-- operation if successful, and describes any errors encountered during the
-- request.
data Response a = Response
{ data' :: a
, errors :: Seq Error
} deriving (Eq, Show)
-- | Runs the given query computation, but collects the errors into an error -- | Runs the given query computation, but collects the errors into an error
-- list, which is then sent back with the data. -- list, which is then sent back with the data.
runCollectErrs :: Monad m runCollectErrs :: (Monad m, Serialize a)
=> HashMap Name (Type m) => HashMap Name (Type m)
-> CollectErrsT m Aeson.Value -> CollectErrsT m a
-> m Aeson.Value -> m (Response a)
runCollectErrs types' res = do runCollectErrs types' res = do
(dat, Resolution{..}) <- runStateT res $ Resolution{ errors = [], types = types' } (dat, Resolution{..}) <- runStateT res
if null errors $ Resolution{ errors = Seq.empty, types = types' }
then return $ Aeson.object [("data", dat)] pure $ Response dat errors
else return $ Aeson.object
[ ("data", dat)
, ("errors", Aeson.toJSON $ reverse errors)
]

View File

@ -1,10 +1,9 @@
-- | This module provides functions to execute a @GraphQL@ request. -- | This module provides functions to execute a @GraphQL@ request.
module Language.GraphQL.Execute module Language.GraphQL.Execute
( execute ( execute
, executeWithName , module Language.GraphQL.Execute.Coerce
) where ) where
import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.Sequence (Seq(..)) import Data.Sequence (Seq(..))
@ -18,54 +17,38 @@ import qualified Language.GraphQL.Type.Definition as Definition
import qualified Language.GraphQL.Type.Out as Out import qualified Language.GraphQL.Type.Out as Out
import Language.GraphQL.Type.Schema import Language.GraphQL.Type.Schema
-- | The substitution is applied to the document, and the resolvers are applied
-- to the resulting fields.
--
-- Returns the result of the query against the schema wrapped in a /data/
-- field, or errors wrapped in an /errors/ field.
execute :: (Monad m, VariableValue a)
=> Schema m -- ^ Resolvers.
-> HashMap.HashMap Name a -- ^ Variable substitution function.
-> Document -- @GraphQL@ document.
-> m Aeson.Value
execute schema = executeRequest schema Nothing
-- | The substitution is applied to the document, and the resolvers are applied -- | The substitution is applied to the document, and the resolvers are applied
-- to the resulting fields. The operation name can be used if the document -- to the resulting fields. The operation name can be used if the document
-- defines multiple root operations. -- defines multiple root operations.
-- --
-- Returns the result of the query against the schema wrapped in a /data/ -- Returns the result of the query against the schema wrapped in a /data/
-- field, or errors wrapped in an /errors/ field. -- field, or errors wrapped in an /errors/ field.
executeWithName :: (Monad m, VariableValue a) execute :: (Monad m, VariableValue a, Serialize b)
=> Schema m -- ^ Resolvers => Schema m -- ^ Resolvers.
-> Text -- ^ Operation name. -> Maybe Text -- ^ Operation name.
-> HashMap.HashMap Name a -- ^ Variable substitution function. -> HashMap.HashMap Name a -- ^ Variable substitution function.
-> Document -- ^ @GraphQL@ Document. -> Document -- @GraphQL@ document.
-> m Aeson.Value -> m (Response b)
executeWithName schema operationName = execute schema operationName subs document =
executeRequest schema (Just operationName)
executeRequest :: (Monad m, VariableValue a)
=> Schema m
-> Maybe Text
-> HashMap.HashMap Name a
-> Document
-> m Aeson.Value
executeRequest schema operationName subs document =
case Transform.document schema operationName subs document of case Transform.document schema operationName subs document of
Left queryError -> pure $ singleError $ Transform.queryError queryError Left queryError -> pure $ singleError $ Transform.queryError queryError
Right (Transform.Document types' rootObjectType operation) Right transformed -> executeRequest transformed
| (Transform.Query _ fields) <- operation ->
executeOperation types' rootObjectType fields executeRequest :: (Monad m, Serialize a)
| (Transform.Mutation _ fields) <- operation -> => Transform.Document m
executeOperation types' rootObjectType fields -> m (Response a)
executeRequest (Transform.Document types' rootObjectType operation)
| (Transform.Query _ fields) <- operation =
executeOperation types' rootObjectType fields
| (Transform.Mutation _ fields) <- operation =
executeOperation types' rootObjectType fields
-- This is actually executeMutation, but we don't distinguish between queries -- This is actually executeMutation, but we don't distinguish between queries
-- and mutations yet. -- and mutations yet.
executeOperation :: Monad m executeOperation :: (Monad m, Serialize a)
=> HashMap Name (Type m) => HashMap Name (Type m)
-> Out.ObjectType m -> Out.ObjectType m
-> Seq (Transform.Selection m) -> Seq (Transform.Selection m)
-> m Aeson.Value -> m (Response a)
executeOperation types' objectType fields = executeOperation types' objectType fields =
runCollectErrs types' $ executeSelectionSet Definition.Null objectType fields runCollectErrs types' $ executeSelectionSet Definition.Null objectType fields

View File

@ -4,6 +4,7 @@ module Language.GraphQL.ErrorSpec
) where ) where
import qualified Data.Aeson as Aeson import qualified Data.Aeson as Aeson
import qualified Data.Sequence as Seq
import Language.GraphQL.Error import Language.GraphQL.Error
import Test.Hspec ( Spec import Test.Hspec ( Spec
, describe , describe
@ -14,11 +15,6 @@ import Test.Hspec ( Spec
spec :: Spec spec :: Spec
spec = describe "singleError" $ spec = describe "singleError" $
it "constructs an error with the given message" $ it "constructs an error with the given message" $
let expected = Aeson.object let errors'' = Seq.singleton $ Error "Message." 0 0
[ expected = Response Aeson.Null errors''
("errors", Aeson.toJSON
[ Aeson.object [("message", "Message.")]
]
)
]
in singleError "Message." `shouldBe` expected in singleError "Message." `shouldBe` expected

View File

@ -47,28 +47,26 @@ spec :: Spec
spec = spec =
describe "execute" $ do describe "execute" $ do
it "skips unknown fields" $ it "skips unknown fields" $
let expected = Aeson.object let data'' = Aeson.object
[ "data" .= Aeson.object [ "philosopher" .= Aeson.object
[ "philosopher" .= Aeson.object [ "firstName" .= ("Friedrich" :: String)
[ "firstName" .= ("Friedrich" :: String)
]
] ]
] ]
execute' = execute schema (mempty :: HashMap Name Aeson.Value) expected = Response data'' mempty
execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
actual = runIdentity actual = runIdentity
$ either parseError execute' $ either parseError execute'
$ parse document "" "{ philosopher { firstName surname } }" $ parse document "" "{ philosopher { firstName surname } }"
in actual `shouldBe` expected in actual `shouldBe` expected
it "merges selections" $ it "merges selections" $
let expected = Aeson.object let data'' = Aeson.object
[ "data" .= Aeson.object [ "philosopher" .= Aeson.object
[ "philosopher" .= Aeson.object [ "firstName" .= ("Friedrich" :: String)
[ "firstName" .= ("Friedrich" :: String) , "lastName" .= ("Nietzsche" :: String)
, "lastName" .= ("Nietzsche" :: String)
]
] ]
] ]
execute' = execute schema (mempty :: HashMap Name Aeson.Value) expected = Response data'' mempty
execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
actual = runIdentity actual = runIdentity
$ either parseError execute' $ either parseError execute'
$ parse document "" "{ philosopher { firstName } philosopher { lastName } }" $ parse document "" "{ philosopher { firstName } philosopher { lastName } }"

View File

@ -361,4 +361,4 @@ testQuery q expected = runIdentity (graphql schema q) `shouldBe` expected
testQueryParams :: Aeson.Object -> Text -> Aeson.Value -> Expectation testQueryParams :: Aeson.Object -> Text -> Aeson.Value -> Expectation
testQueryParams f q expected = testQueryParams f q expected =
runIdentity (graphqlSubs schema f q) `shouldBe` expected runIdentity (graphqlSubs schema Nothing f q) `shouldBe` expected