diff --git a/json-rpc-generic.cabal b/json-rpc-generic.cabal --- a/json-rpc-generic.cabal +++ b/json-rpc-generic.cabal @@ -1,5 +1,5 @@ name: json-rpc-generic -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Generic encoder and decode for JSON-RPC description: This package contains generic encoder and decode for JSON-RPC homepage: http://github.com/khibino/haskell-json-rpc-generic @@ -28,7 +28,9 @@ Data.JsonRpc.Instances Data.JsonRpc - -- other-modules: + other-modules: + Data.JsonRpc.Integral + other-extensions: TypeOperators FlexibleContexts diff --git a/src/Data/JsonRpc/Failure.hs b/src/Data/JsonRpc/Failure.hs --- a/src/Data/JsonRpc/Failure.hs +++ b/src/Data/JsonRpc/Failure.hs @@ -2,7 +2,8 @@ {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} module Data.JsonRpc.Failure ( - Failure (..), Error (..), ErrorStatus (..), + Failure (..), Error (..), + ErrorStatus (..), toCode, fromCode, failure, makeError, serverError, @@ -11,7 +12,8 @@ ) where import Prelude hiding (userError) -import Control.Monad (MonadPlus, guard) +import Control.Monad (MonadPlus, mplus, guard) +import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Foldable (Foldable) import Data.Traversable (Traversable) @@ -28,49 +30,95 @@ data Error e = Error - { _code :: !Int + { _code :: !ErrorStatus , _message :: !Text , _data :: !(Maybe e) } deriving (Eq, Show, Functor, Foldable, Traversable) +{- +-- citation from http://www.jsonrpc.org/specification +-- +-- The error codes from and including -32768 to -32000 are reserved for pre-defined errors. +-- Any code within this range, but not defined explicitly below is reserved for future use. +-- The error codes are nearly the same as those suggested for XML-RPC at the following +-- url: http://xmlrpc-epi.sourceforge.net/specs/rfc.fault_codes.php +-- +-- code message meaning +-- -32700 Parse error Invalid JSON was received by the server. +-- An error occurred on the server while parsing the JSON text. +-- -32600 Invalid Request The JSON sent is not a valid Request object. +-- -32601 Method not found The method does not exist / is not available. +-- -32602 Invalid params Invalid method parameter(s). +-- -32603 Internal error Internal JSON-RPC error. +-- -32000 to -32099 Server error Reserved for implementation-defined server-errors. + +-- The remainder of the space is available for application defined errors. + -} data ErrorStatus = ParseError | InvalidRequest | MethodNotFound | InvalidParams | InternalError - | ServerError !Int - | MethodError !Int !Text + | ServerError !Integer + | MethodError !Integer deriving (Eq, Show) -failure :: Maybe Id -> ErrorStatus -> Maybe e -> Failure e -failure mayId s = - Failure "2.0" mayId . makeError s +failure :: Maybe Id -> ErrorStatus -> Maybe Text -> Maybe e -> Failure e +failure mayId s mm = + Failure "2.0" mayId . makeError s mm -makeError :: ErrorStatus -> Maybe e -> Error e -makeError = d where - d ParseError = Error (-32700) "Parse error" - d InvalidRequest = Error (-32600) "Invalid Request" - d MethodNotFound = Error (-32601) "Method not found" - d InvalidParams = Error (-32602) "Invalid params" - d InternalError = Error (-32603) "Internal error" - d (ServerError c) = Error c "Server error" - d (MethodError c m) = Error c m +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" -serverError :: MonadPlus m - => Int +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' + +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 +serverError c' = do + let c = fromIntegral c' guard $ -32099 <= c && c <= -32000 return $ ServerError c -methodError :: MonadPlus m - => Int - -> Text +methodError :: (Integral a, MonadPlus m) + => a -> m ErrorStatus -methodError c s = do +methodError c' = do + let c = fromIntegral c' guard $ c < -32768 || -32000 < c - return $ MethodError c s + return $ MethodError c emptyError :: Maybe () emptyError = Nothing diff --git a/src/Data/JsonRpc/Id.hs b/src/Data/JsonRpc/Id.hs --- a/src/Data/JsonRpc/Id.hs +++ b/src/Data/JsonRpc/Id.hs @@ -1,12 +1,12 @@ module Data.JsonRpc.Id (Id(..), numberId) where -import Control.Applicative (Applicative, pure) -import Control.Monad (MonadPlus, guard) - +import Control.Applicative (Applicative, (<$>)) +import Control.Monad (MonadPlus) import Data.Text (Text) -import Data.Scientific (Scientific, toDecimalDigits) +import Data.Scientific (Scientific) +import Data.JsonRpc.Integral (fromScientific) {- -- citation from http://www.jsonrpc.org/specification @@ -34,8 +34,4 @@ deriving (Eq, Ord, Show, Read) numberId :: (MonadPlus m, Applicative m) => Scientific -> m Id -numberId sci = do - let (ds, e) = toDecimalDigits sci - guard $ sci == 0 || null (drop e ds) -- test integral - - pure . NumberId $ round sci +numberId sci = NumberId <$> fromScientific sci diff --git a/src/Data/JsonRpc/Instances.hs b/src/Data/JsonRpc/Instances.hs --- a/src/Data/JsonRpc/Instances.hs +++ b/src/Data/JsonRpc/Instances.hs @@ -12,10 +12,12 @@ import Data.Aeson.Types (Options (..)) import qualified Data.Aeson.Types as Aeson +import Data.JsonRpc.Integral (fromScientific) import Data.JsonRpc.Id (Id(..), numberId) import Data.JsonRpc.Request (Request (..)) import Data.JsonRpc.Success (Success (..)) -import Data.JsonRpc.Failure (Failure (..), Error (..)) +import Data.JsonRpc.Failure (Failure (..), Error (..), ErrorStatus (..)) +import qualified Data.JsonRpc.Failure as Failure import Data.JsonRpc.Response (Response (..)) @@ -52,6 +54,21 @@ deriving instance Generic (Error e) deriving instance Generic (Failure e) + +instance FromJSON ErrorStatus where + parseJSON = d where + d (String {}) = parseError "string is not allowed" + d (Number n) = do + i <- fromScientific n <|> parseError "not integer number" + Failure.fromCode i <|> parseError "unknown error code range" + d (Object {}) = parseError "object is not allowed" + d (Array {}) = parseError "array is not allowed" + d (Bool {}) = parseError "boolean is not allowed" + d Null = parseError "null is not allowed" + parseError = fail . ("JSON RPC error code: " ++) + +instance ToJSON ErrorStatus where + toJSON = Number . fromIntegral . Failure.toCode instance FromJSON e => FromJSON (Error e) where parseJSON = genericParseJSON customOptions diff --git a/src/Data/JsonRpc/Integral.hs b/src/Data/JsonRpc/Integral.hs new file mode 100644 --- /dev/null +++ b/src/Data/JsonRpc/Integral.hs @@ -0,0 +1,14 @@ + +module Data.JsonRpc.Integral ( + fromScientific, + ) where + +import Control.Monad (MonadPlus, guard) +import Data.Scientific (Scientific, toDecimalDigits) + + +fromScientific :: MonadPlus m => Scientific -> m Integer +fromScientific sci = do + let (ds, e) = toDecimalDigits sci + guard $ sci == 0 || null (drop e ds) -- test integral + return $ round sci diff --git a/test/Eq.hs b/test/Eq.hs --- a/test/Eq.hs +++ b/test/Eq.hs @@ -115,7 +115,7 @@ exSuccess = success exId Foo {foo = 234, bar = "Hello", baz = [5,6,7,8]} exFailure :: Failure String -exFailure = failure (Just exId) Failure.InvalidRequest Nothing +exFailure = failure (Just exId) Failure.InvalidRequest Nothing Nothing eqResponseS :: Test eqResponseS = diff --git a/test/Instances.hs b/test/Instances.hs --- a/test/Instances.hs +++ b/test/Instances.hs @@ -47,10 +47,10 @@ genServerError = ServerError <$> choose (-32099, -32000) genMethodErrorA :: Gen ErrorStatus -genMethodErrorA = MethodError <$> choose (-31999, 0) <*> genText +genMethodErrorA = MethodError <$> choose (-31999, 0) genMethodErrorB :: Gen ErrorStatus -genMethodErrorB = MethodError <$> choose (-65535, -32769) <*> genText +genMethodErrorB = MethodError <$> choose (-65535, -32769) instance Arbitrary ErrorStatus where arbitrary = @@ -65,10 +65,14 @@ , (2, genMethodErrorB) ] +genErrorMessage :: Gen (Maybe Text) +genErrorMessage = frequency [ (1, pure Nothing), (2, Just <$> genText) ] + instance Arbitrary e => Arbitrary (Error e) where arbitrary = makeError <$> arbitrary + <*> genErrorMessage <*> arbitrary instance Arbitrary e => Arbitrary (Failure e) where @@ -76,6 +80,7 @@ failure <$> arbitrary <*> arbitrary + <*> genErrorMessage <*> arbitrary instance (Arbitrary e, Arbitrary a) => Arbitrary (Response e a) where diff --git a/test/Iso.hs b/test/Iso.hs --- a/test/Iso.hs +++ b/test/Iso.hs @@ -6,7 +6,7 @@ import Data.Aeson (FromJSON, ToJSON) import qualified Data.Aeson as Aeson -import Data.JsonRpc (Request, Response, Error, genericToArrayJSON) +import Data.JsonRpc (Request, Response, Error, ErrorStatus, genericToArrayJSON) import Instances (Example) @@ -22,6 +22,9 @@ requestA r = Aeson.decode (Aeson.encode $ genericToArrayJSON <$> r) == Just r +errorStatus :: ErrorStatus -> Bool +errorStatus = aesonED + errorObj :: Error Example -> Bool errorObj = aesonED @@ -32,5 +35,6 @@ tests = [ qcTest "iso - request" request , qcTest "iso - request array" requestA + , qcTest "iso - error status" errorStatus , qcTest "iso - error object" errorObj , qcTest "iso - response" response ]