packages feed

json-rpc-generic 0.1.0.0 → 0.2.0.0

raw patch · 8 files changed

+127/−41 lines, 8 filesdep ~aeson

Dependency ranges changed: aeson

Files

json-rpc-generic.cabal view
@@ -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
src/Data/JsonRpc/Failure.hs view
@@ -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
src/Data/JsonRpc/Id.hs view
@@ -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
src/Data/JsonRpc/Instances.hs view
@@ -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
+ src/Data/JsonRpc/Integral.hs view
@@ -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
test/Eq.hs view
@@ -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 =
test/Instances.hs view
@@ -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
test/Iso.hs view
@@ -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 ]