json-rpc-server 0.1.0.0 → 0.1.1.0
raw patch · 7 files changed
+157/−167 lines, 7 filesdep −attoparsecdep ~aesondep ~basedep ~bytestring
Dependencies removed: attoparsec
Dependency ranges changed: aeson, base, bytestring, mtl, text, unordered-containers, vector
Files
- README.md +1/−1
- demo/Demo.hs +3/−2
- json-rpc-server.cabal +14/−16
- src/Network/JsonRpc/Server.hs +20/−19
- src/Network/JsonRpc/Types.hs +43/−55
- tests/TestSuite.hs +28/−29
- tests/TestTypes.hs +48/−45
README.md view
@@ -1,3 +1,3 @@ json-rpc-server ===============-An implemation of the server side of JSON RPC 2.0. See <http://www.jsonrpc.org/specification>. This library uses ByteString for input and output, leaving the choice of transport up to the user. See the demo folder for an example.+An implementation of the server side of JSON RPC 2.0. See <http://www.jsonrpc.org/specification>. This library uses ByteString for input and output, leaving the choice of transport up to the user. See the demo folder for an example.
demo/Demo.hs view
@@ -3,14 +3,15 @@ module Main (main) where import Network.JsonRpc.Server-import Happstack.Server.SimpleHTTP hiding (Method, body, result)+import Happstack.Server.SimpleHTTP( ServerPartT, simpleHTTP, nullConf+ , askRq, rqBody, unBody, toResponse) import Data.List (intercalate) import Data.Maybe (fromMaybe) import Control.Monad (when) import Control.Monad.Trans (liftIO) import Control.Monad.Error (throwError) import Control.Monad.Reader (ReaderT, ask, runReaderT)-import Control.Concurrent.MVar+import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar) main :: IO () main = newMVar 0 >>= \count ->
json-rpc-server.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: json-rpc-server-version: 0.1.0.0+version: 0.1.1.0 license: MIT license-file: LICENSE category: Network, JSON@@ -12,7 +12,7 @@ extra-source-files: README.md cabal-version: >=1.8 tested-with: GHC == 7.4.1, GHC == 7.6.3-description: An implemation of the server side of JSON RPC 2.0.+description: An implementation of the server side of JSON RPC 2.0. See <http://www.jsonrpc.org/specification>. This library uses 'ByteString' for input and output, leaving the choice of transport up to the user.@@ -31,13 +31,12 @@ exposed-modules: Network.JsonRpc.Server other-modules: Network.JsonRpc.Types build-depends: base >=4.5 && <4.7,- aeson >=0.6 && <0.7,+ aeson >=0.6 && <0.8, bytestring >=0.9 && <0.11, mtl >=2.1 && <2.2,- text >=0.11 && <0.12,+ text >=0.11 && <1.2, vector >=0.8 && <0.11,- unordered-containers >=0.1 && <0.3,- attoparsec >=0.8 && <0.11+ unordered-containers >=0.1 && <0.3 hs-source-dirs: src ghc-options: -Wall @@ -45,9 +44,9 @@ main-is: Demo.hs hs-source-dirs: demo if flag (demo)- build-depends: base,+ build-depends: base >=4.5 && <4.7, json-rpc-server,- mtl,+ mtl >=2.1 && <2.2, happstack-server >=7.3 && <7.4 ghc-options: -Wall else@@ -58,16 +57,15 @@ main-is: TestSuite.hs other-modules: TestTypes type: exitcode-stdio-1.0- build-depends: base,+ build-depends: base >=4.5 && <4.7, json-rpc-server, HUnit >=1.2 && <1.3, test-framework >=0.7 && <0.9, test-framework-hunit >=0.3 && <0.4,- aeson,- bytestring,- mtl,- text,- vector,- unordered-containers,- attoparsec+ aeson >=0.6 && <0.8,+ bytestring >=0.9 && <0.11,+ mtl >=2.1 && <2.2,+ text >=0.11 && <1.2,+ vector >=0.8 && <0.11,+ unordered-containers >=0.1 && <0.3 ghc-options: -Wall -fno-warn-incomplete-patterns
src/Network/JsonRpc/Server.hs view
@@ -35,7 +35,7 @@ import Data.Text (Text, append, pack) import Data.Maybe (catMaybes) import qualified Data.ByteString.Lazy as B-import Data.Aeson+import qualified Data.Aeson as A import qualified Data.Vector as V import qualified Data.HashMap.Strict as H import Control.Applicative ((<$>))@@ -70,14 +70,15 @@ -- > module Main (main) where -- > -- > import Network.JsonRpc.Server--- > import Happstack.Server.SimpleHTTP hiding (Method, body, result)+-- > import Happstack.Server.SimpleHTTP( ServerPartT, simpleHTTP, nullConf+-- > , askRq, rqBody, unBody, toResponse) -- > import Data.List (intercalate) -- > import Data.Maybe (fromMaybe) -- > import Control.Monad (when) -- > import Control.Monad.Trans (liftIO) -- > import Control.Monad.Error (throwError) -- > import Control.Monad.Reader (ReaderT, ask, runReaderT)--- > import Control.Concurrent.MVar+-- > import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar) -- > -- > main :: IO () -- > main = newMVar 0 >>= \count ->@@ -118,8 +119,8 @@ -- | Creates a method from a name, function, and parameter descriptions. -- The parameter names must be unique.-toMethod :: (MethodParams f p m r, ToJSON r, Monad m) => Text -> f -> p -> Method m-toMethod name f params = let f' args = toJSON <$> apply f params args+toMethod :: (MethodParams f p m r, A.ToJSON r, Monad m) => Text -> f -> p -> Method m+toMethod name f params = let f' args = A.toJSON <$> apply f params args in Method name f' -- | Creates a set of methods to be called by name. The names must be unique.@@ -146,22 +147,22 @@ -- 'Nothing' in the case of a notification, -- all wrapped in the given monad. callWithBatchStrategy strategy fs input = either returnErr callMethod request- where request :: Either RpcError (Either Value [Value])+ where request :: Either RpcError (Either A.Value [A.Value]) request = runIdentity $ runErrorT $ parseVal =<< parseJson input- parseJson = maybe invalidJson return . decode+ parseJson = maybe invalidJson return . A.decode parseVal val = case val of- obj@(Object _) -> return $ Left obj- Array vec | V.null vec -> throwError $ invalidRpcError "Empty batch request"+ obj@(A.Object _) -> return $ Left obj+ A.Array vec | V.null vec -> throwError $ invalidRpcError "Empty batch request" | otherwise -> return $ Right $ V.toList vec _ -> throwError $ invalidRpcError "Not a JSON object or array" callMethod rq = case rq of Left val -> encodeJust `liftM` singleCall fs val Right vals -> encodeJust `liftM` batchCall strategy fs vals- where encodeJust r = (encode . toJSON) <$> r- returnErr = return . Just . encode . toJSON . nullIdResponse+ where encodeJust r = (A.encode . A.toJSON) <$> r+ returnErr = return . Just . A.encode . A.toJSON . nullIdResponse invalidJson = throwError $ rpcError (-32700) "Invalid JSON" -singleCall :: Monad m => Methods m -> Value -> m (Maybe Response)+singleCall :: Monad m => Methods m -> A.Value -> m (Maybe Response) singleCall (Methods fs) val = case parsed of Left err -> return $ nullIdResponse err Right (Request name args i) ->@@ -173,10 +174,10 @@ nullIdResponse :: RpcError -> Maybe Response nullIdResponse err = toResponse (Just IdNull) (Left err :: Either RpcError ()) -parseValue :: (FromJSON a, Monad m) => Value -> RpcResult m a-parseValue val = case fromJSON val of- Error msg -> throwError $ invalidRpcError $ pack msg- Success x -> return x+parseValue :: (A.FromJSON a, Monad m) => A.Value -> RpcResult m a+parseValue val = case A.fromJSON val of+ A.Error msg -> throwError $ invalidRpcError $ pack msg+ A.Success x -> return x lookupMethod :: Monad m => Text -> H.HashMap Text (Method m) -> RpcResult m (Method m) lookupMethod name = maybe notFound return . H.lookup name@@ -187,12 +188,12 @@ batchCall :: Monad m => (forall a. [m a] -> m [a]) -> Methods m- -> [Value]+ -> [A.Value] -> m (Maybe [Response]) batchCall strategy mths vals = (noNull . catMaybes) `liftM` results where results = strategy $ map (singleCall mths) vals noNull rs = if null rs then Nothing else Just rs -toResponse :: ToJSON a => Maybe Id -> Either RpcError a -> Maybe Response-toResponse (Just i) r = Just $ Response i $ toJSON <$> r+toResponse :: A.ToJSON a => Maybe Id -> Either RpcError a -> Maybe Response+toResponse (Just i) r = Just $ Response i $ A.toJSON <$> r toResponse Nothing _ = Nothing
src/Network/JsonRpc/Types.hs view
@@ -22,11 +22,11 @@ import Data.String (fromString) import Data.Maybe (catMaybes) import Data.Text (Text, append, unpack)-import Data.Aeson+import qualified Data.Aeson as A+import Data.Aeson ((.=), (.:), (.:?), (.!=)) import Data.Aeson.Types (emptyObject) import qualified Data.Vector as V import qualified Data.HashMap.Strict as H-import Data.Attoparsec.Number (Number) import Control.Applicative ((<$>), (<*>), (<|>), (*>), empty) import Control.Monad (when) import Control.Monad.Error (Error, ErrorT, throwError, strMsg, noMsg)@@ -51,15 +51,15 @@ -- monad ('m'), and return type ('r'). 'p' has one 'Parameter' for -- every argument of 'f' and is terminated by @()@. The return type -- of 'f' is @RpcResult m r@. This class is treated as closed.-class (Monad m, Functor m, ToJSON r) => MethodParams f p m r | f -> p m r where+class (Monad m, Functor m, A.ToJSON r) => MethodParams f p m r | f -> p m r where apply :: f -> p -> Args -> RpcResult m r -instance (Monad m, Functor m, ToJSON r) => MethodParams (RpcResult m r) () m r where+instance (Monad m, Functor m, A.ToJSON r) => MethodParams (RpcResult m r) () m r where apply r _ args | Left _ <- args = r | Right ar <- args, V.null ar = r | otherwise = throwError $ rpcError (-32602) "Too many unnamed arguments" -instance (FromJSON a, MethodParams f p m r) => MethodParams (a -> f) (a :+: p) m r where+instance (A.FromJSON a, MethodParams f p m r) => MethodParams (a -> f) (a :+: p) m r where apply f (param :+: ps) args = arg >>= \a -> apply (f a) ps nextArgs where arg = either (parseArg name) return =<< (Left <$> lookupValue <|> Right <$> paramDefault param)@@ -67,22 +67,22 @@ nextArgs = tailOrEmpty <$> args name = paramName param -lookupArg :: Monad m => Text -> Object -> RpcResult m Value+lookupArg :: Monad m => Text -> A.Object -> RpcResult m A.Value lookupArg name hm = case H.lookup name hm of Nothing -> throwError $ missingArgError name Just v -> return v -headArg :: Monad m => Text -> V.Vector a -> RpcResult m a+headArg :: Monad m => Text -> A.Array -> RpcResult m A.Value headArg name vec | V.null vec = throwError $ missingArgError name | otherwise = return $ V.head vec -tailOrEmpty :: V.Vector a -> V.Vector a+tailOrEmpty :: A.Array -> A.Array tailOrEmpty vec = if V.null vec then V.empty else V.tail vec -parseArg :: (Monad m, FromJSON r) => Text -> Value -> RpcResult m r-parseArg name val = case fromJSON val of- Error msg -> throwError $ rpcErrorWithData (-32602) ("Wrong type for argument: " `append` name) msg- Success x -> return x+parseArg :: (Monad m, A.FromJSON r) => Text -> A.Value -> RpcResult m r+parseArg name val = case A.fromJSON val of+ A.Error msg -> throwError $ rpcErrorWithData (-32602) ("Wrong type for argument: " `append` name) msg+ A.Success x -> return x paramDefault :: Monad m => Parameter a -> RpcResult m a paramDefault (Optional _ d) = return d@@ -96,62 +96,63 @@ paramName (Required n) = n -- | Single method.-data Method m = Method Text (Args -> RpcResult m Value)+data Method m = Method Text (Args -> RpcResult m A.Value) -- | Multiple methods. newtype Methods m = Methods (H.HashMap Text (Method m)) -type Args = Either Object Array+type Args = Either A.Object A.Array data Request = Request Text Args (Maybe Id) -instance FromJSON Request where- parseJSON (Object x) = (checkVersion =<< x .:? versionKey .!= jsonRpcVersion) *>+instance A.FromJSON Request where+ parseJSON (A.Object x) = (checkVersion =<< x .:? versionKey .!= jsonRpcVersion) *> (Request <$>- x .: methodKey <*>- (parseParams =<< x .:? paramsKey .!= emptyObject) <*>+ x .: "method" <*>+ (parseParams =<< x .:? "params" .!= emptyObject) <*> (Just <$> x .: idKey <|> return Nothing)) -- (.:?) parses Null value as Nothing- where parseParams (Object obj) = return $ Left obj- parseParams (Array ar) = return $ Right ar+ where parseParams (A.Object obj) = return $ Left obj+ parseParams (A.Array ar) = return $ Right ar parseParams _ = empty checkVersion ver = when (ver /= jsonRpcVersion) (fail $ "Wrong JSON RPC version: " ++ unpack ver) parseJSON _ = empty -data Response = Response Id (Either RpcError Value)+data Response = Response Id (Either RpcError A.Value) -instance ToJSON Response where- toJSON (Response i result) = object pairs+instance A.ToJSON Response where+ toJSON (Response i result) = A.object pairs where pairs = [ versionKey .= jsonRpcVersion- , either (errorKey .=) (resultKey .=) result+ , either ("error" .=) ("result" .=) result , idKey .= i] -data Id = IdString Text | IdNumber Number | IdNull+-- IdNumber cannot directly reference the type stored in A.Number,+-- since it changes between aeson-0.6 and 0.7.+data Id = IdString A.Value | IdNumber A.Value | IdNull -instance FromJSON Id where- parseJSON (String x) = return $ IdString x- parseJSON (Number x) = return $ IdNumber x- parseJSON Null = return IdNull+instance A.FromJSON Id where+ parseJSON x@(A.String _) = return $ IdString x+ parseJSON x@(A.Number _) = return $ IdNumber x+ parseJSON A.Null = return IdNull parseJSON _ = empty -instance ToJSON Id where- toJSON i = case i of- IdString x -> toJSON x- IdNumber x -> toJSON x- IdNull -> Null+instance A.ToJSON Id where+ toJSON (IdString x) = x+ toJSON (IdNumber x) = x+ toJSON IdNull = A.Null -- | Error to be returned to the client.-data RpcError = RpcError Int Text (Maybe Value)+data RpcError = RpcError Int Text (Maybe A.Value) deriving Show instance Error RpcError where noMsg = strMsg "unknown error" strMsg msg = RpcError (-32000) (fromString msg) Nothing -instance ToJSON RpcError where- toJSON (RpcError code msg data') = object pairs- where pairs = catMaybes [ Just $ codeKey .= code- , Just $ msgKey .= msg- , (dataKey .=) <$> data' ]+instance A.ToJSON RpcError where+ toJSON (RpcError code msg data') = A.object pairs+ where pairs = catMaybes [ Just $ "code" .= code+ , Just $ "message" .= msg+ , ("data" .=) <$> data' ] -- | Creates an 'RpcError' with the given error code and message. -- According to the specification, server error codes should be@@ -162,23 +163,10 @@ -- | Creates an 'RpcError' with the given code, message, and additional data. -- See 'rpcError' for the recommended error code ranges.-rpcErrorWithData :: ToJSON a => Int -> Text -> a -> RpcError-rpcErrorWithData code msg errorData = RpcError code msg $ Just $ toJSON errorData+rpcErrorWithData :: A.ToJSON a => Int -> Text -> a -> RpcError+rpcErrorWithData code msg errorData = RpcError code msg $ Just $ A.toJSON errorData jsonRpcVersion, versionKey, idKey :: Text jsonRpcVersion = "2.0" versionKey = "jsonrpc" idKey = "id"--methodKey, paramsKey :: Text-methodKey = "method"-paramsKey = "params"--resultKey, errorKey :: Text-resultKey = "result"-errorKey = "error"--codeKey, msgKey, dataKey :: Text-codeKey = "code"-msgKey = "message"-dataKey = "data"
tests/TestSuite.hs view
@@ -4,7 +4,7 @@ import Network.JsonRpc.Server import TestTypes-import Data.List ((\\), sort)+import Data.List ((\\)) import Data.Aeson import Data.Aeson.Types import Data.Text (Text)@@ -49,59 +49,59 @@ , testCase "parallelize tasks" testParallelizingTasks ] testEncodeError :: Assertion-testEncodeError = (fromByteString $ encode $ toJSON err) @?= Just testError+testEncodeError = fromByteString (encode $ toJSON err) @?= Just testError where err = rpcError (-1) "error" testError = TestRpcError (-1) "error" Nothing testEncodeErrorWithData :: Assertion-testEncodeErrorWithData = (fromByteString $ encode $ toJSON err) @?= Just testError+testEncodeErrorWithData = fromByteString (encode $ toJSON err) @?= Just testError where err = rpcErrorWithData 1 "my message" errorData testError = TestRpcError 1 "my message" $ Just $ toJSON errorData- errorData = (['\x03BB'], True, ())+ errorData = ('\x03BB', [True], ()) testInvalidJson :: Assertion-testInvalidJson = checkResponseWithSubtract "5" IdNull (-32700)+testInvalidJson = checkResponseWithSubtract "5" idNull (-32700) testInvalidJsonRpc :: Assertion-testInvalidJsonRpc = checkResponseWithSubtract (encode $ object ["id" .= (10 :: Int)]) IdNull (-32600)+testInvalidJsonRpc = checkResponseWithSubtract (encode $ object ["id" .= (10 :: Int)]) idNull (-32600) testEmptyBatchCall :: Assertion-testEmptyBatchCall = checkResponseWithSubtract (encode emptyArray) IdNull (-32600)+testEmptyBatchCall = checkResponseWithSubtract (encode emptyArray) idNull (-32600) testWrongVersion :: Assertion-testWrongVersion = checkResponseWithSubtract (encode requestWrongVersion) IdNull (-32600)+testWrongVersion = checkResponseWithSubtract (encode requestWrongVersion) idNull (-32600) where requestWrongVersion = Object $ H.insert versionKey (String "1") hm- Object hm = toJSON $ subtractRequestNamed [("a1", Number 4)] (IdNumber 10)+ Object hm = toJSON $ subtractRequestNamed [("a1", Number 4)] (idNumber 10) testMethodNotFound :: Assertion testMethodNotFound = checkResponseWithSubtract (encode request) i (-32601) where request = TestRequest "ad" Nothing (Just i)- i = IdNumber 3+ i = idNumber 3 testWrongMethodNameCapitalization :: Assertion testWrongMethodNameCapitalization = checkResponseWithSubtract (encode request) i (-32601) where request = TestRequest "Add" Nothing (Just i)- i = IdNull+ i = idNull testMissingRequiredNamedArg :: Assertion testMissingRequiredNamedArg = checkResponseWithSubtract (encode request) i (-32602) where request = subtractRequestNamed [("A1", Number 1), ("a2", Number 20)] i- i = IdNumber 2+ i = idNumber 2 testMissingRequiredUnnamedArg :: Assertion testMissingRequiredUnnamedArg = checkResponseWithSubtract (encode request) i (-32602) where request = TestRequest "subtract 2" (Just $ Right $ V.fromList [Number 0]) (Just i)- i = IdString ""+ i = idString "" testWrongArgType :: Assertion testWrongArgType = checkResponseWithSubtract (encode request) i (-32602) where request = subtractRequestNamed [("a1", Number 1), ("a2", Bool True)] i- i = IdString "ABC"+ i = idString "ABC" testDisallowExtraUnnamedArg :: Assertion testDisallowExtraUnnamedArg = checkResponseWithSubtract (encode request) i (-32602) where request = subtractRequestUnnamed (map Number [1, 2, 3]) i- i = IdString "i"+ i = idString "i" testNoResponseToInvalidNotification :: Assertion testNoResponseToInvalidNotification = runIdentity response @?= Nothing@@ -114,8 +114,8 @@ response = call (toMethods [subtractMethod]) $ encode request request = [subtractRequestNamed (toArgs 10 8) i1, subtractRequestNamed (toArgs 24 20) i2] toArgs x y = [("a1", Number x), ("a2", Number y)]- i1 = IdString "1"- i2 = IdString "2"+ i1 = idString "1"+ i2 = idString "2" testBatchNotifications :: Assertion testBatchNotifications = runState response 0 @?= (Nothing, 10)@@ -127,32 +127,32 @@ where requestNoVersion = Object $ H.delete versionKey hm Object hm = toJSON $ subtractRequestNamed [("a1", Number 1)] i response = call (toMethods [subtractMethod]) $ encode requestNoVersion- i = IdNumber (-1)+ i = idNumber (-1) testAllowExtraNamedArg :: Assertion testAllowExtraNamedArg = (fromByteString =<< runIdentity response) @?= (Just $ TestResponse i (Right $ Number (-10))) where response = call (toMethods [subtractMethod]) $ encode request request = subtractRequestNamed args i args = [("a1", Number 10), ("a2", Number 20), ("a3", String "extra")]- i = IdString "ID"+ i = idString "ID" testDefaultNamedArg :: Assertion testDefaultNamedArg = (fromByteString =<< runIdentity response) @?= (Just $ TestResponse i (Right $ Number 1000)) where response = call (toMethods [subtractMethod]) $ encode request request = subtractRequestNamed args i args = [("a", Number 500), ("a1", Number 1000)]- i = IdNumber 3+ i = idNumber 3 testDefaultUnnamedArg :: Assertion testDefaultUnnamedArg = (fromByteString =<< runIdentity response) @?= (Just $ TestResponse i (Right $ Number 4)) where response = call (toMethods [subtractMethod]) $ encode request request = subtractRequestUnnamed [Number 4] i- i = IdNumber 0+ i = idNumber 0 testNullId :: Assertion-testNullId = (fromByteString =<< runIdentity response) @?= (Just $ TestResponse IdNull (Right $ Number (-80)))+testNullId = (fromByteString =<< runIdentity response) @?= (Just $ TestResponse idNull (Right $ Number (-80))) where response = call (toMethods [subtractMethod]) $ encode request- request = subtractRequestNamed args IdNull+ request = subtractRequestNamed args idNull args = [("a2", Number 70), ("a1", Number (-10))] testNoArgs :: Assertion@@ -167,14 +167,14 @@ testParallelizingTasks :: Assertion testParallelizingTasks = assert $ do a <- actual- let ids = map fromIdNumber a+ let ids = map rspId a vals = map fromResult a- return $ (sort ids == [1, 2]) &&- (sort vals == ["A", "B"])+ return $ equalContents ids (map idNumber [1, 2]) &&+ equalContents vals ["A", "B"] where actual = (fromJust . fromByteString . fromJust) <$> (flip (callWithBatchStrategy parallelize) input =<< methods) input = encode [ lockRequest 1, unlockRequest (String "A") , unlockRequest (String "B"), lockRequest 2]- lockRequest i = TestRequest "lock" Nothing (Just $ IdNumber i)+ lockRequest i = TestRequest "lock" Nothing (Just $ idNumber i) unlockRequest str = TestRequest "unlock" (Just $ Right $ V.fromList [str]) Nothing methods = createMethods <$> newEmptyMVar createMethods lock = toMethods [lockMethod lock, unlockMethod lock]@@ -185,7 +185,6 @@ where f :: String -> RpcResult IO () f val = liftIO $ putMVar lock val fromResult r | Right (String str) <- rspResult r = str- fromIdNumber r | IdNumber i <- rspId r = i parallelize :: [IO a] -> IO [a] parallelize tasks = do@@ -205,7 +204,7 @@ ((fromByteString . fromJust) <$> call (toMethods [getTimeMethod]) (encode getTimeRequest)) where expected = Just $ TestResponse i (Right $ Number 100) getTimeRequest = TestRequest "get_time_seconds" requestArgs (Just i)- i = IdString "Id 1"+ i = idString "Id 1" subtractRequestNamed :: [(Text, Value)] -> TestId -> TestRequest subtractRequestNamed args i = TestRequest "subtract 1" (Just $ Left $ H.fromList args) (Just i)
tests/TestTypes.hs view
@@ -3,75 +3,78 @@ module TestTypes ( TestRequest (..) , TestResponse (..) , TestRpcError (..)- , TestId (..)- , jsonRpcVersion+ , TestId+ , idString+ , idNumber+ , idNull , versionKey) where -import Data.Aeson-import Data.Aeson.Types+import qualified Data.Aeson as A+import Data.Aeson ((.=), (.:), (.:?)) import Data.Maybe (catMaybes)-import Data.Text (Text)-import Data.Attoparsec.Number (Number)+import Data.String (IsString, fromString)+import Data.Text (Text, pack) import Data.HashMap.Strict (size)-import Control.Applicative+import Control.Applicative ((<$>), (<*>), (<|>), pure, empty)+import Control.Monad (when, guard) data TestRpcError = TestRpcError { errCode :: Int , errMsg :: Text- , errData :: Maybe Value}+ , errData :: Maybe A.Value} deriving (Eq, Show) -instance FromJSON TestRpcError where- parseJSON (Object err) = (TestRpcError <$>- err .: "code" <*>- err .: "message" <*>- err .:? "data") >>= checkKeys- where checkKeys e = let checkSize s = failIf $ size err /= s- in pure e <* checkSize (case errData e of- Nothing -> 2- Just _ -> 3)+instance A.FromJSON TestRpcError where+ parseJSON (A.Object obj) = do+ d <- obj .:? "data"+ when (size obj /= maybe 2 (const 3) d) $ fail "Wrong number of keys"+ TestRpcError <$> obj .: "code" <*> obj .: "message" <*> pure d parseJSON _ = empty -data TestRequest = TestRequest Text (Maybe (Either Object Array)) (Maybe TestId)+data TestRequest = TestRequest Text (Maybe (Either A.Object A.Array)) (Maybe TestId) -instance ToJSON TestRequest where- toJSON (TestRequest name params i) = object pairs- where pairs = catMaybes [Just $ "method" .= toJSON name, idPair, paramsPair]+instance A.ToJSON TestRequest where+ toJSON (TestRequest name params i) = A.object pairs+ where pairs = catMaybes [Just $ "method" .= name, idPair, paramsPair] idPair = ("id" .=) <$> i paramsPair = either toPair toPair <$> params- where toPair v = "params" .= toJSON v+ where toPair v = "params" .= v data TestResponse = TestResponse { rspId :: TestId- , rspResult :: Either TestRpcError Value }+ , rspResult :: Either TestRpcError A.Value } deriving (Eq, Show) -instance FromJSON TestResponse where- parseJSON (Object r) = failIf (size r /= 3) *> checkVersion *>- (TestResponse <$>- r .: "id" <*>- ((Left <$> r .: "error") <|> (Right <$> r .: "result")))- where checkVersion = r .: versionKey >>= failIf . (/= jsonRpcVersion)+instance A.FromJSON TestResponse where+ parseJSON (A.Object obj) = do+ guard (size obj == 3)+ guard . (pack "2.0" ==) =<< obj .: versionKey+ TestResponse <$> obj .: "id" <*>+ ((Left <$> obj .: "error") <|> (Right <$> obj .: "result")) parseJSON _ = empty -failIf :: Bool -> Parser ()-failIf b = if b then empty else pure ()--data TestId = IdString Text | IdNumber Number | IdNull+-- IdNumber cannot directly reference the type stored in A.Number,+-- since it changes between aeson-0.6 and 0.7.+data TestId = IdString A.Value | IdNumber A.Value | IdNull deriving (Eq, Show) -instance FromJSON TestId where- parseJSON (String x) = return $ IdString x- parseJSON (Number x) = return $ IdNumber x- parseJSON Null = return IdNull+idString :: String -> TestId+idString = IdString . A.String . fromString++idNumber :: Integer -> TestId+idNumber = IdNumber . A.Number . fromInteger++idNull :: TestId+idNull = IdNull++instance A.FromJSON TestId where+ parseJSON x@(A.String _) = return $ IdString x+ parseJSON x@(A.Number _) = return $ IdNumber x+ parseJSON A.Null = return IdNull parseJSON _ = empty -instance ToJSON TestId where- toJSON i = case i of- IdString x -> toJSON x- IdNumber x -> toJSON x- IdNull -> Null+instance A.ToJSON TestId where+ toJSON (IdString x) = x+ toJSON (IdNumber x) = x+ toJSON IdNull = A.Null versionKey :: Text versionKey = "jsonrpc"--jsonRpcVersion :: Text-jsonRpcVersion = "2.0"