graphql/src/Language/GraphQL/Error.hs

89 lines
2.8 KiB
Haskell
Raw Normal View History

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
2019-09-20 08:47:14 +02:00
-- | Error handling.
module Language.GraphQL.Error
2019-07-14 05:58:05 +02:00
( parseError
, CollectErrsT
, Resolution(..)
2019-07-14 05:58:05 +02:00
, addErr
, addErrMsg
, runCollectErrs
2019-07-23 06:04:33 +02:00
, singleError
2019-07-14 05:58:05 +02:00
) where
import Control.Monad.Trans.State (StateT, modify, runStateT)
import qualified Data.Aeson as Aeson
import Data.HashMap.Strict (HashMap)
import Data.Text (Text)
import Data.Void (Void)
import Language.GraphQL.AST.Document (Name)
import Language.GraphQL.Type.Schema
2020-02-20 05:16:14 +01:00
import Text.Megaparsec
( ParseErrorBundle(..)
, PosState(..)
, SourcePos(..)
, errorOffset
, parseErrorTextPretty
, reachOffset
, unPos
)
data Resolution m = Resolution
{ errors :: [Aeson.Value]
, types :: HashMap Name (Type m)
}
-- | Wraps a parse error into a list of errors.
parseError :: Applicative f => ParseErrorBundle Text Void -> f Aeson.Value
parseError ParseErrorBundle{..} =
2020-02-20 05:16:14 +01:00
pure $ Aeson.object [("errors", Aeson.toJSON $ fst $ foldl go ([], bundlePosState) bundleErrors)]
where
errorObject s SourcePos{..} = Aeson.object
[ ("message", Aeson.toJSON $ init $ parseErrorTextPretty s)
, ("line", Aeson.toJSON $ unPos sourceLine)
, ("column", Aeson.toJSON $ unPos sourceColumn)
]
go (result, state) x =
2020-02-20 05:16:14 +01:00
let (_, newState) = reachOffset (errorOffset x) state
sourcePosition = pstateSourcePos newState
in (errorObject x sourcePosition : result, newState)
2019-06-28 11:12:28 +02:00
-- | A wrapper to pass error messages around.
type CollectErrsT m = StateT (Resolution m) m
-- | Adds an error to the list of errors.
2019-06-28 11:12:28 +02:00
addErr :: Monad m => Aeson.Value -> CollectErrsT m ()
addErr v = modify appender
where
appender resolution@Resolution{..} = resolution{ errors = v : errors }
2019-07-23 06:04:33 +02:00
makeErrorMessage :: Text -> Aeson.Value
makeErrorMessage s = Aeson.object [("message", Aeson.toJSON s)]
-- | 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])
]
-- | Convenience function for just wrapping an error message.
2019-06-28 11:12:28 +02:00
addErrMsg :: Monad m => Text -> CollectErrsT m ()
2019-07-23 06:04:33 +02:00
addErrMsg = addErr . makeErrorMessage
2019-06-28 11:12:28 +02:00
-- | Runs the given query computation, but collects the errors into an error
-- list, which is then sent back with the data.
runCollectErrs :: Monad m
=> HashMap Name (Type m)
-> CollectErrsT m Aeson.Value
-> m Aeson.Value
runCollectErrs types' res = do
(dat, Resolution{..}) <- runStateT res $ Resolution{ errors = [], types = types' }
if null errors
2019-06-28 11:12:28 +02:00
then return $ Aeson.object [("data", dat)]
else return $ Aeson.object
[ ("data", dat)
, ("errors", Aeson.toJSON $ reverse errors)
]