{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
module Data.JsonRpc.Failure (
Failure (..), Error (..),
ErrorStatus (..), toCode, fromCode, refineStatus,
failure, makeError,
serverError,
methodError,
emptyError,
) where
import Prelude hiding (userError)
import Control.Monad (MonadPlus, mplus, guard)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Foldable (Foldable)
import Data.Traversable (Traversable)
import Data.JsonRpc.Id (Id)
data Failure e =
Failure
{ _jsonrpc :: !Text
, _id :: !(Maybe Id)
, _error :: !(Error e)
} deriving (Eq, Show, Functor, Foldable, Traversable)
data Error e =
Error
{ _code :: !ErrorStatus
, _message :: !Text
, _data :: !(Maybe e)
} deriving (Eq, Show, Functor, Foldable, Traversable)
data ErrorStatus
= ParseError
| InvalidRequest
| MethodNotFound
| InvalidParams
| InternalError
| ServerError !Integer
| MethodError !Integer
deriving (Eq, Show)
failure :: Maybe Id -> ErrorStatus -> Maybe Text -> Maybe e -> Failure e
failure mayId s mm =
Failure "2.0" mayId . makeError s mm
defaultMessage :: ErrorStatus -> Text
defaultMessage = d where
d ParseError = "Parse error"
d InvalidRequest = "Invalid Request"
d MethodNotFound = "Method not found"
d InvalidParams = "Invalid params"
d InternalError = "Internal error"
d (ServerError _) = "Server error"
d (MethodError _) = "Application method error"
toCode :: ErrorStatus -> Integer
toCode = d where
d ParseError = -32700
d InvalidRequest = -32600
d MethodNotFound = -32601
d InvalidParams = -32602
d InternalError = -32603
d (ServerError c) = c
d (MethodError c) = c
fromCode :: (Integral a, MonadPlus m)
=> a
-> m ErrorStatus
fromCode c'
| c == -32700 = return ParseError
| c == -32600 = return InvalidRequest
| c == -32601 = return MethodNotFound
| c == -32602 = return InvalidParams
| c == -32603 = return InternalError
| otherwise = serverError c `mplus` methodError c
where
c = toInteger c'
refineStatus :: MonadPlus m
=> ErrorStatus
-> m ErrorStatus
refineStatus e = do
e' <- fromCode $ toCode e
guard $ e' == e
return e
makeError :: ErrorStatus -> Maybe Text -> Maybe e -> Error e
makeError e = Error e . fromMaybe (defaultMessage e)
serverError :: (Integral a, MonadPlus m)
=> a
-> m ErrorStatus
serverError c' = do
let c = fromIntegral c'
guard $ -32099 <= c && c <= -32000
return $ ServerError c
methodError :: (Integral a, MonadPlus m)
=> a
-> m ErrorStatus
methodError c' = do
let c = fromIntegral c'
guard $ c < -32768 || -32000 < c
return $ MethodError c
emptyError :: Maybe ()
emptyError = Nothing