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]
## Added
- `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
- `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` provides now only functionality related to parsing and encoding, as it
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
- `Type.Out.Resolver`: It is an unneeded layer of complexity. Resolvers are a
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
### Fixed

View File

@ -1,3 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-- | This module provides the functions to parse and execute @GraphQL@ queries.
module Language.GraphQL
( graphql
@ -5,13 +8,11 @@ module Language.GraphQL
) where
import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap)
import qualified Data.Sequence as Seq
import Data.Text (Text)
import Language.GraphQL.AST.Document
import Language.GraphQL.AST.Parser
import Language.GraphQL.AST
import Language.GraphQL.Error
import Language.GraphQL.Execute
import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Type.Schema
import Text.Megaparsec (parse)
@ -21,16 +22,32 @@ graphql :: Monad m
=> Schema m -- ^ Resolvers.
-> Text -- ^ Text representing a @GraphQL@ request document.
-> 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
-- applied to the query and the query is then executed using to the given
-- 'Schema'.
graphqlSubs :: (Monad m, VariableValue a)
graphqlSubs :: Monad m
=> 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.
-> m Aeson.Value -- ^ Response.
graphqlSubs schema f
= either parseError (execute schema f)
. parse document ""
graphqlSubs schema operationName variableValues document' =
either parseError executeRequest parsed >>= formatResponse
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 RecordWildCards #-}
@ -5,7 +6,9 @@
module Language.GraphQL.Error
( parseError
, CollectErrsT
, Error(..)
, Resolution(..)
, Response(..)
, addErr
, addErrMsg
, runCollectErrs
@ -13,12 +16,16 @@ module Language.GraphQL.Error
) where
import Control.Monad.Trans.State (StateT, modify, runStateT)
import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap)
import Data.Sequence (Seq(..), (|>))
import qualified Data.Sequence as Seq
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Void (Void)
import Language.GraphQL.AST.Document (Name)
import Language.GraphQL.Execute.Coerce
import Language.GraphQL.Type.Schema
import Prelude hiding (null)
import Text.Megaparsec
( ParseErrorBundle(..)
, PosState(..)
@ -31,59 +38,72 @@ import Text.Megaparsec
-- | Executor context.
data Resolution m = Resolution
{ errors :: [Aeson.Value]
{ errors :: Seq Error
, types :: HashMap Name (Type m)
}
-- | 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{..} =
pure $ Aeson.object [("errors", Aeson.toJSON $ fst $ foldl go ([], bundlePosState) bundleErrors)]
pure $ Response null $ fst
$ foldl go (Seq.empty, bundlePosState) bundleErrors
where
errorObject s SourcePos{..} = Aeson.object
[ ("message", Aeson.toJSON $ init $ parseErrorTextPretty s)
, ("line", Aeson.toJSON $ unPos sourceLine)
, ("column", Aeson.toJSON $ unPos sourceColumn)
]
errorObject s SourcePos{..} = Error
(Text.pack $ init $ parseErrorTextPretty s)
(unPos' sourceLine)
(unPos' sourceColumn)
unPos' = fromIntegral . unPos
go (result, state) x =
let (_, newState) = reachOffset (errorOffset x) state
sourcePosition = pstateSourcePos newState
in (errorObject x sourcePosition : result, newState)
in (result |> errorObject x sourcePosition, newState)
-- | A wrapper to pass error messages around.
type CollectErrsT m = StateT (Resolution m) m
-- | 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
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 s = Aeson.object [("message", Aeson.toJSON s)]
makeErrorMessage :: Text -> Error
makeErrorMessage s = Error s 0 0
-- | Constructs a response object containing only the error with the given
-- message.
singleError :: Text -> Aeson.Value
singleError message = Aeson.object
[ ("errors", Aeson.toJSON [makeErrorMessage message])
]
singleError :: Serialize a => Text -> Response a
singleError message = Response null $ Seq.singleton $ makeErrorMessage message
-- | Convenience function for just wrapping an error message.
addErrMsg :: Monad m => Text -> CollectErrsT m ()
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
-- list, which is then sent back with the data.
runCollectErrs :: Monad m
runCollectErrs :: (Monad m, Serialize a)
=> HashMap Name (Type m)
-> CollectErrsT m Aeson.Value
-> m Aeson.Value
-> CollectErrsT m a
-> m (Response a)
runCollectErrs types' res = do
(dat, Resolution{..}) <- runStateT res $ Resolution{ errors = [], types = types' }
if null errors
then return $ Aeson.object [("data", dat)]
else return $ Aeson.object
[ ("data", dat)
, ("errors", Aeson.toJSON $ reverse errors)
]
(dat, Resolution{..}) <- runStateT res
$ Resolution{ errors = Seq.empty, types = types' }
pure $ Response dat errors

View File

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

View File

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

View File

@ -47,28 +47,26 @@ spec :: Spec
spec =
describe "execute" $ do
it "skips unknown fields" $
let expected = Aeson.object
[ "data" .= Aeson.object
let data'' = Aeson.object
[ "philosopher" .= Aeson.object
[ "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
$ either parseError execute'
$ parse document "" "{ philosopher { firstName surname } }"
in actual `shouldBe` expected
it "merges selections" $
let expected = Aeson.object
[ "data" .= Aeson.object
let data'' = Aeson.object
[ "philosopher" .= Aeson.object
[ "firstName" .= ("Friedrich" :: 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
$ either parseError execute'
$ 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 f q expected =
runIdentity (graphqlSubs schema f q) `shouldBe` expected
runIdentity (graphqlSubs schema Nothing f q) `shouldBe` expected