Handle errors using custom types

Fixes #32.

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
-        [ ("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])
-    ]
+-- 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
+-- list, which is then sent back with the data.
+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

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)
-    => 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 ->
-              executeOperation types' rootObjectType fields
-          | (Transform.Mutation _ fields) <- operation ->
-              executeOperation types' rootObjectType fields
+        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 =
+        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