Handle errors using custom types

Fixes #32.

CHANGELOG.md

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

src/Language/GraphQL.hs

@@ -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
-import Language.GraphQL.AST.Parser
 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
+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

src/Language/GraphQL/Error.hs

@@ -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
+    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 =
         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 :: 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
---   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.
 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.
+-- 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
+    -> CollectErrsT m a
-    -> m Aeson.Value
+    -> m (Response a)
 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)
-           ]

src/Language/GraphQL/Execute.hs

@@ -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)
+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.
-    -> 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
         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
 -- 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

tests/Language/GraphQL/ErrorSpec.hs

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

tests/Language/GraphQL/ExecuteSpec.hs

@@ -47,28 +47,26 @@ spec :: Spec
 spec =
     describe "execute" $ do
         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
                     $ either parseError execute'
                     $ parse document "" "{ philosopher { firstName surname } }"
              in actual `shouldBe` expected
         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
                     $ either parseError execute'
                     $ parse document "" "{ philosopher { firstName } philosopher { lastName } }"

tests/Test/StarWars/QuerySpec.hs

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