diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,5 @@ json-rpc-server =============== -An implementation of the server side of JSON RPC 2.0. See . This library uses ByteString for input and output, leaving the choice of transport up to the user. See the demo folder for an example. +[![Build Status](https://travis-ci.org/grayjay/json-rpc-server.svg?branch=master)](https://travis-ci.org/grayjay/json-rpc-server) + +An implementation of the server side of JSON RPC 2.0. See . This library uses ByteString for input and output, leaving the choice of transport up to the user. The documentation is on Hackage: . diff --git a/json-rpc-server.cabal b/json-rpc-server.cabal --- a/json-rpc-server.cabal +++ b/json-rpc-server.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: json-rpc-server -version: 0.1.1.0 +version: 0.1.2.0 license: MIT license-file: LICENSE category: Network, JSON @@ -11,7 +11,7 @@ build-type: Simple extra-source-files: README.md cabal-version: >=1.8 -tested-with: GHC == 7.4.1, GHC == 7.6.3 +tested-with: GHC == 7.0.1, GHC == 7.4.1, GHC == 7.6.2, GHC == 7.6.3, GHC == 7.8.3 description: An implementation of the server side of JSON RPC 2.0. See . This library uses 'ByteString' for input and output, @@ -30,12 +30,12 @@ library exposed-modules: Network.JsonRpc.Server other-modules: Network.JsonRpc.Types - build-depends: base >=4.5 && <4.7, - aeson >=0.6 && <0.8, + build-depends: base >=4.3 && <4.8, + aeson >=0.6 && <0.9, bytestring >=0.9 && <0.11, - mtl >=2.1 && <2.2, + mtl >=1.1.1 && <2.3, text >=0.11 && <1.2, - vector >=0.8 && <0.11, + vector >=0.7.1 && <0.11, unordered-containers >=0.1 && <0.3 hs-source-dirs: src ghc-options: -Wall @@ -44,10 +44,10 @@ main-is: Demo.hs hs-source-dirs: demo if flag (demo) - build-depends: base >=4.5 && <4.7, + build-depends: base >=4.3 && <4.8, json-rpc-server, - mtl >=2.1 && <2.2, - happstack-server >=7.3 && <7.4 + mtl >=1.1.1 && <2.3, + happstack-server >=6.2.4 && <7.4 ghc-options: -Wall else buildable: False @@ -55,17 +55,17 @@ test-suite tests hs-source-dirs: tests main-is: TestSuite.hs - other-modules: TestTypes + other-modules: TestParallelism, Internal type: exitcode-stdio-1.0 - build-depends: base >=4.5 && <4.7, + build-depends: base >=4.3 && <4.8, json-rpc-server, HUnit >=1.2 && <1.3, test-framework >=0.7 && <0.9, test-framework-hunit >=0.3 && <0.4, - aeson >=0.6 && <0.8, + aeson >=0.6 && <0.9, bytestring >=0.9 && <0.11, - mtl >=2.1 && <2.2, + mtl >=1.1.1 && <2.3, text >=0.11 && <1.2, - vector >=0.8 && <0.11, + vector >=0.7.1 && <0.11, unordered-containers >=0.1 && <0.3 - ghc-options: -Wall -fno-warn-incomplete-patterns + ghc-options: -Wall diff --git a/src/Network/JsonRpc/Server.hs b/src/Network/JsonRpc/Server.hs --- a/src/Network/JsonRpc/Server.hs +++ b/src/Network/JsonRpc/Server.hs @@ -1,8 +1,13 @@ -{-# LANGUAGE MultiParamTypeClasses, +{-# LANGUAGE CPP, + MultiParamTypeClasses, Rank2Types, TypeOperators, OverloadedStrings #-} +#if MIN_VERSION_mtl(2,2,1) +{-# OPTIONS_GHC -fno-warn-deprecations #-} +#endif + -- | Functions for implementing the server side of JSON RPC 2.0. -- See . module Network.JsonRpc.Server ( @@ -40,9 +45,8 @@ import qualified Data.HashMap.Strict as H import Control.Applicative ((<$>)) import Control.Monad (liftM) -import Control.Monad.Identity (Identity, runIdentity) -import Control.Monad.Error (ErrorT, runErrorT, throwError) -import Prelude hiding (length) +import Control.Monad.Identity (runIdentity) +import Control.Monad.Error (runErrorT, throwError) -- $instructions -- * Create methods by calling 'toMethod' and providing the method @@ -152,14 +156,14 @@ parseJson = maybe invalidJson return . A.decode parseVal val = case val of 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" + A.Array vec | V.null vec -> throwInvalidRpc "Empty batch request" + | otherwise -> return $ Right $ V.toList vec + _ -> throwInvalidRpc "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 = (A.encode . A.toJSON) <$> r - returnErr = return . Just . A.encode . A.toJSON . nullIdResponse + where encodeJust r = A.encode <$> r + returnErr = return . Just . A.encode . nullIdResponse invalidJson = throwError $ rpcError (-32700) "Invalid JSON" singleCall :: Monad m => Methods m -> A.Value -> m (Maybe Response) @@ -176,15 +180,15 @@ 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.Error msg -> throwInvalidRpc $ 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 - where notFound = throwError $ rpcError (-32601) ("Method not found: " `append` name) + where notFound = throwError $ rpcError (-32601) $ "Method not found: " `append` name -invalidRpcError :: Text -> RpcError -invalidRpcError = rpcErrorWithData (-32600) "Invalid JSON RPC 2.0 request" +throwInvalidRpc :: Monad m => Text -> RpcResult m a +throwInvalidRpc = throwError . rpcErrorWithData (-32600) "Invalid JSON RPC 2.0 request" batchCall :: Monad m => (forall a. [m a] -> m [a]) -> Methods m diff --git a/src/Network/JsonRpc/Types.hs b/src/Network/JsonRpc/Types.hs --- a/src/Network/JsonRpc/Types.hs +++ b/src/Network/JsonRpc/Types.hs @@ -1,11 +1,16 @@ -{-# LANGUAGE MultiParamTypeClasses, +{-# LANGUAGE CPP, + MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, UndecidableInstances, TypeOperators, - PatternGuards, + TypeSynonymInstances, OverloadedStrings #-} +#if MIN_VERSION_mtl(2,2,1) +{-# OPTIONS_GHC -fno-warn-deprecations #-} +#endif + module Network.JsonRpc.Types ( RpcResult , Method (..) , Methods (..) @@ -28,7 +33,7 @@ import qualified Data.Vector as V import qualified Data.HashMap.Strict as H import Control.Applicative ((<$>), (<*>), (<|>), (*>), empty) -import Control.Monad (when) +import Control.Monad (mplus, when) import Control.Monad.Error (Error, ErrorT, throwError, strMsg, noMsg) import Prelude hiding (length) @@ -55,14 +60,14 @@ apply :: f -> p -> Args -> RpcResult m r 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" + apply _ _ (Right ar) | not $ V.null ar = + throwError $ rpcError (-32602) "Too many unnamed arguments" + apply res _ _ = res 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) + (Left <$> lookupValue) `mplus` (Right <$> paramDefault param) lookupValue = either (lookupArg name) (headArg name) args nextArgs = tailOrEmpty <$> args name = paramName param @@ -81,15 +86,16 @@ 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.Error msg -> throwError $ argTypeError msg A.Success x -> return x + where argTypeError = rpcErrorWithData (-32602) $ "Wrong type for argument: " `append` name paramDefault :: Monad m => Parameter a -> RpcResult m a paramDefault (Optional _ d) = return d paramDefault (Required name) = throwError $ missingArgError name missingArgError :: Text -> RpcError -missingArgError name = rpcError (-32602) ("Cannot find required argument: " `append` name) +missingArgError name = rpcError (-32602) $ "Cannot find required argument: " `append` name paramName :: Parameter a -> Text paramName (Optional n _) = n @@ -110,11 +116,18 @@ (Request <$> x .: "method" <*> (parseParams =<< x .:? "params" .!= emptyObject) <*> - (Just <$> x .: idKey <|> return Nothing)) -- (.:?) parses Null value as Nothing + parseId) 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) + checkVersion ver = when (ver /= jsonRpcVersion) $ + fail $ "Wrong JSON RPC version: " ++ unpack ver + -- (.:?) parses Null value as Nothing so parseId needs + -- to use both (.:?) and (.:) to handle all cases + parseId = x .:? idKey >>= \optional -> + case optional of + Nothing -> Just <$> (x .: idKey) <|> return Nothing + _ -> return optional parseJSON _ = empty data Response = Response Id (Either RpcError A.Value) diff --git a/tests/Internal.hs b/tests/Internal.hs new file mode 100644 --- /dev/null +++ b/tests/Internal.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Internal ( request + , errRsp + , rpcErr + , defaultIdErrRsp + , nullIdErrRsp + , array + , rspToIdString + , defaultRq + , defaultRsp + , method + , params + , id' + , version + , result) where + +import qualified Data.Aeson as A +import Data.Aeson ((.=)) +import qualified Data.HashMap.Strict as H +import Data.Maybe (catMaybes) +import qualified Data.Vector as V +import Data.Text (Text) +import Control.Applicative ((<$>)) + +array :: [A.Value] -> A.Value +array = A.Array . V.fromList + +rspToIdString :: A.Value -> Maybe String +rspToIdString (A.Object rsp) = show <$> H.lookup "id" rsp +rspToIdString _ = Nothing + +request :: Maybe A.Value -> Text -> Maybe A.Value -> A.Value +request i m args = A.object $ catMaybes [ Just $ "method" .= A.String m + , ("params" .=) <$> args + , ("id" .=) <$> i + , Just ("jsonrpc" .= A.String "2.0")] + +defaultRq :: A.Value +defaultRq = request (Just defaultId) "subtract" args + where args = Just $ A.object ["x" .= A.Number 1, "y" .= A.Number 2] + +response :: A.Value -> Text -> A.Value -> A.Value +response i key res = A.object ["id" .= i, key .= res, "jsonrpc" .= A.String "2.0"] + +defaultRsp :: A.Value +defaultRsp = response defaultId "result" defaultResult + +defaultIdErrRsp :: Int -> A.Value +defaultIdErrRsp = errRsp defaultId + +nullIdErrRsp :: Int -> A.Value +nullIdErrRsp = errRsp A.Null + +errRsp :: A.Value -> Int -> A.Value +errRsp i code = response i "error" $ rpcErr Nothing code "" + +rpcErr :: Maybe A.Value -> Int -> Text -> A.Value +rpcErr d code msg = A.object $ ["code" .= code, "message" .= msg] ++ dataPair + where dataPair = catMaybes [("data" .=) <$> d] + +method :: A.Value -> Text -> A.Value +method rq m = insert rq "method" $ Just $ A.String m + +params :: A.Value -> Maybe A.Value -> A.Value +params rq = insert rq "params" + +id' :: A.Value -> Maybe A.Value -> A.Value +id' rq = insert rq "id" + +version :: A.Value -> Maybe A.Value -> A.Value +version rq = insert rq "jsonrpc" + +result :: A.Value -> A.Value -> A.Value +result rsp = insert rsp "result" . Just + +insert :: A.Value -> Text -> Maybe A.Value -> A.Value +insert (A.Object obj) key Nothing = A.Object $ H.delete key obj +insert (A.Object obj) key (Just val) = A.Object $ H.insert key val obj +insert v _ _ = v + +defaultId :: A.Value +defaultId = A.Number 3 + +defaultResult :: A.Value +defaultResult = A.Number (-1) diff --git a/tests/TestParallelism.hs b/tests/TestParallelism.hs new file mode 100644 --- /dev/null +++ b/tests/TestParallelism.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TestParallelism (testParallelizingTasks) where + +import qualified Network.JsonRpc.Server as S +import Network.JsonRpc.Server ((:+:) (..)) +import Internal +import Data.List (sortBy, permutations) +import Data.Function (on) +import qualified Data.Aeson as A +import Data.Aeson ((.=)) +import qualified Data.Aeson.Types as A +import Data.Maybe (fromJust) +import Control.Applicative ((<$>)) +import Control.Monad.Trans (liftIO) +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) +import Test.HUnit (Assertion, assert) + +-- | Tests parallelizing a batch request. Each request either +-- locks or unlocks an MVar. The MVar is initially locked, +-- so the first lock request cannot succeed if the requests +-- are serialized. +testParallelizingTasks :: Assertion +testParallelizingTasks = do + methods <- createMethods <$> newEmptyMVar + output <- S.callWithBatchStrategy parallelize methods input + let rsp = fromJust $ A.decode =<< output + assert $ elem (sortBy (compare `on` rspToIdString) rsp) possibleResponses + where input = A.encode [ lockRequest 1 + , lockRequest 3 + , unlockRequest 'C' + , unlockRequest 'B' + , lockRequest 2 + , unlockRequest 'A'] + createMethods lock = S.toMethods [lockMethod lock, unlockMethod lock] + +possibleResponses :: [[A.Value]] +possibleResponses = (rsp <$>) <$> perms + where perms = zip `zipWith` repeat [1, 2, 3] $ permutations ["A", "B", "C"] + rsp (i, r) = defaultRsp `result` A.String r `id'` Just (A.Number i) + +lockRequest :: Int -> A.Value +lockRequest i = request (Just $ A.Number $ fromIntegral i) "lock" $ Just A.emptyObject + +unlockRequest :: Char -> A.Value +unlockRequest ch = request Nothing "unlock" $ Just $ A.object ["value" .= ch] + +lockMethod :: MVar Char -> S.Method IO +lockMethod lock = S.toMethod "lock" f () + where f :: S.RpcResult IO Char + f = liftIO $ takeMVar lock + +unlockMethod :: MVar Char -> S.Method IO +unlockMethod lock = S.toMethod "unlock" f (S.Required "value" :+: ()) + where f :: Char -> S.RpcResult IO () + f val = liftIO $ putMVar lock val + +parallelize :: [IO a] -> IO [a] +parallelize tasks = mapM takeMVar =<< mapM fork tasks + where fork t = do + mvar <- newEmptyMVar + _ <- forkIO $ putMVar mvar =<< t + return mvar diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -1,252 +1,188 @@ -{-# LANGUAGE OverloadedStrings, PatternGuards #-} +{-# LANGUAGE OverloadedStrings #-} module Main (main) where -import Network.JsonRpc.Server -import TestTypes -import Data.List ((\\)) -import Data.Aeson -import Data.Aeson.Types -import Data.Text (Text) -import Data.Maybe -import qualified Data.ByteString.Lazy.Char8 as B +import qualified Network.JsonRpc.Server as S +import Network.JsonRpc.Server ((:+:) (..)) +import Internal ( request, defaultRq, defaultRsp + , defaultIdErrRsp, nullIdErrRsp + , version, result, rpcErr, method + , params, id', array, rspToIdString) +import qualified TestParallelism +import Data.List (sortBy) import qualified Data.Vector as V +import Data.Function (on) +import qualified Data.Aeson as A +import Data.Aeson ((.=)) +import qualified Data.Aeson.Types as A import qualified Data.HashMap.Strict as H -import Control.Applicative -import Control.Monad.Trans -import Control.Monad.State -import Control.Monad.Identity -import Control.Concurrent (forkIO) -import Control.Concurrent.MVar -import Test.HUnit hiding (State) -import Test.Framework -import Test.Framework.Providers.HUnit +import Control.Applicative ((<$>)) +import Control.Monad.Trans (liftIO) +import Control.Monad.State (State, runState, lift, modify) +import Control.Monad.Identity (Identity, runIdentity) +import Test.HUnit hiding (State, Test) +import Test.Framework (defaultMain, Test) +import Test.Framework.Providers.HUnit (testCase) +import Prelude hiding (subtract) main :: IO () -main = defaultMain [ testCase "encode error" testEncodeError - , testCase "encode error with data" testEncodeErrorWithData - , testCase "invalid JSON" testInvalidJson - , testCase "invalid JSON RPC" testInvalidJsonRpc - , testCase "empty batch call" testEmptyBatchCall - , testCase "wrong version in request" testWrongVersion - , testCase "method not found" testMethodNotFound - , testCase "wrong method name capitalization" testWrongMethodNameCapitalization - , testCase "missing required named argument" testMissingRequiredNamedArg - , testCase "missing required unnamed argument" testMissingRequiredUnnamedArg - , testCase "wrong argument type" testWrongArgType - , testCase "disallow extra unnamed arguments" testDisallowExtraUnnamedArg - , testCase "invalid notification" testNoResponseToInvalidNotification - , testCase "batch request" testBatch - , testCase "batch notifications" testBatchNotifications - , testCase "allow missing version" testAllowMissingVersion - , testCase "no arguments" testNoArgs - , testCase "empty argument array" testEmptyUnnamedArgs - , testCase "empty argument object" testEmptyNamedArgs - , testCase "allow extra named argument" testAllowExtraNamedArg - , testCase "use default named argument" testDefaultNamedArg - , testCase "use default unnamed argument" testDefaultUnnamedArg - , testCase "null request ID" testNullId - , testCase "parallelize tasks" testParallelizingTasks ] +main = defaultMain $ errorHandlingTests ++ otherTests -testEncodeError :: Assertion -testEncodeError = fromByteString (encode $ toJSON err) @?= Just testError - where err = rpcError (-1) "error" - testError = TestRpcError (-1) "error" Nothing +errorHandlingTests :: [Test] +errorHandlingTests = [ testCase "invalid JSON" $ + assertSubtractResponse (A.String "5") $ nullIdErrRsp (-32700) -testEncodeErrorWithData :: Assertion -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], ()) + , testCase "invalid JSON RPC" $ + assertSubtractResponse (A.object ["id" .= A.Number 10]) $ nullIdErrRsp (-32600) -testInvalidJson :: Assertion -testInvalidJson = checkResponseWithSubtract "5" idNull (-32700) + , testCase "empty batch call" $ + assertSubtractResponse A.emptyArray $ nullIdErrRsp (-32600) -testInvalidJsonRpc :: Assertion -testInvalidJsonRpc = checkResponseWithSubtract (encode $ object ["id" .= (10 :: Int)]) idNull (-32600) + , testCase "invalid batch element" $ + removeErrMsg <$> callSubtractMethods (array [A.Bool True]) @?= Just (array [nullIdErrRsp (-32600)]) -testEmptyBatchCall :: Assertion -testEmptyBatchCall = checkResponseWithSubtract (encode emptyArray) idNull (-32600) + , testCase "wrong request version" $ + assertSubtractResponse (defaultRq `version` Just "1.0") $ nullIdErrRsp (-32600) -testWrongVersion :: Assertion -testWrongVersion = checkResponseWithSubtract (encode requestWrongVersion) idNull (-32600) - where requestWrongVersion = Object $ H.insert versionKey (String "1") hm - Object hm = toJSON $ subtractRequestNamed [("a1", Number 4)] (idNumber 10) + , testCase "wrong id type" $ + assertSubtractResponse (defaultRq `id'` (Just $ A.Bool True)) $ nullIdErrRsp (-32600) -testMethodNotFound :: Assertion -testMethodNotFound = checkResponseWithSubtract (encode request) i (-32601) - where request = TestRequest "ad" Nothing (Just i) - i = idNumber 3 + , testCase "method not found" $ + assertSubtractResponse (defaultRq `method` "add") (defaultIdErrRsp (-32601)) -testWrongMethodNameCapitalization :: Assertion -testWrongMethodNameCapitalization = checkResponseWithSubtract (encode request) i (-32601) - where request = TestRequest "Add" Nothing (Just i) - i = idNull + , testCase "wrong method name capitalization" $ + assertSubtractResponse (defaultRq `method` "Subtract") (defaultIdErrRsp (-32601)) -testMissingRequiredNamedArg :: Assertion -testMissingRequiredNamedArg = checkResponseWithSubtract (encode request) i (-32602) - where request = subtractRequestNamed [("A1", Number 1), ("a2", Number 20)] i - i = idNumber 2 + , testCase "missing required named argument" $ + assertInvalidParams $ defaultRq `params` Just (A.object ["a" .= A.Number 1, "y" .= A.Number 20]) -testMissingRequiredUnnamedArg :: Assertion -testMissingRequiredUnnamedArg = checkResponseWithSubtract (encode request) i (-32602) - where request = TestRequest "subtract 2" (Just $ Right $ V.fromList [Number 0]) (Just i) - i = idString "" + , testCase "missing required unnamed argument" $ + assertInvalidParams $ defaultRq `method` "flipped subtract" `params` Just (array [A.Number 0]) -testWrongArgType :: Assertion -testWrongArgType = checkResponseWithSubtract (encode request) i (-32602) - where request = subtractRequestNamed [("a1", Number 1), ("a2", Bool True)] i - i = idString "ABC" + , testCase "wrong argument type" $ + assertInvalidParams $ defaultRq `params` Just (A.object ["x" .= A.Number 1, "y" .= A.String "2"]) -testDisallowExtraUnnamedArg :: Assertion -testDisallowExtraUnnamedArg = checkResponseWithSubtract (encode request) i (-32602) - where request = subtractRequestUnnamed (map Number [1, 2, 3]) i - i = idString "i" + , testCase "extra unnamed arguments" $ + assertInvalidParams $ defaultRq `params` Just (array $ map A.Number [1, 2, 3]) -testNoResponseToInvalidNotification :: Assertion -testNoResponseToInvalidNotification = runIdentity response @?= Nothing - where response = call (toMethods [subtractMethod]) $ encode request - request = TestRequest "12345" Nothing Nothing + , let req = defaultRq `id'` Nothing `method` "12345" + in testCase "invalid notification" $ callSubtractMethods req @?= Nothing ] -testBatch :: Assertion -testBatch = assert (fromJust (fromByteString =<< runIdentity response) `equalContents` expected) - where expected = [TestResponse i1 (Right $ Number 2), TestResponse i2 (Right $ Number 4)] - 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" +otherTests :: [Test] +otherTests = [ testCase "encode RPC error" $ + A.toJSON (S.rpcError (-1) "error") @?= rpcErr Nothing (-1) "error" -testBatchNotifications :: Assertion -testBatchNotifications = runState response 0 @?= (Nothing, 10) - where response = call (toMethods [incrementStateMethod]) $ encode request - request = replicate 10 $ TestRequest "increment" Nothing Nothing + , let err = S.rpcErrorWithData 1 "my message" errData + testError = rpcErr (Just $ A.toJSON errData) 1 "my message" + errData = ('\x03BB', [True], ()) + in testCase "encode RPC error with data" $ A.toJSON err @?= testError -testAllowMissingVersion :: Assertion -testAllowMissingVersion = (fromByteString =<< runIdentity response) @?= (Just $ TestResponse i (Right $ Number 1)) - where requestNoVersion = Object $ H.delete versionKey hm - Object hm = toJSON $ subtractRequestNamed [("a1", Number 1)] i - response = call (toMethods [subtractMethod]) $ encode requestNoVersion - i = idNumber (-1) + , testCase "batch request" testBatch -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" + , testCase "batch notifications" testBatchNotifications -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 + , testCase "allow missing version" testAllowMissingVersion -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 + , testCase "no arguments" $ assertGetTimeResponse Nothing -testNullId :: Assertion -testNullId = (fromByteString =<< runIdentity response) @?= (Just $ TestResponse idNull (Right $ Number (-80))) - where response = call (toMethods [subtractMethod]) $ encode request - request = subtractRequestNamed args idNull - args = [("a2", Number 70), ("a1", Number (-10))] + , testCase "empty argument array" $ assertGetTimeResponse $ Just A.emptyArray -testNoArgs :: Assertion -testNoArgs = compareGetTimeResult Nothing + , testCase "empty argument A.object" $ assertGetTimeResponse $ Just A.emptyObject -testEmptyUnnamedArgs :: Assertion -testEmptyUnnamedArgs = compareGetTimeResult $ Just $ Right empty + , let req = defaultRq `params` Just args + args = A.object ["x" .= A.Number 10, "y" .= A.Number 20, "z" .= A.String "extra"] + rsp = defaultRsp `result` A.Number (-10) + in testCase "allow extra named argument" $ assertSubtractResponse req rsp -testEmptyNamedArgs :: Assertion -testEmptyNamedArgs = compareGetTimeResult $ Just $ Left H.empty + , let req = defaultRq `params` (Just $ A.object [("x1", A.Number 500), ("x", A.Number 1000)]) + rsp = defaultRsp `result` A.Number 1000 + in testCase "use default named argument" $ assertSubtractResponse req rsp -testParallelizingTasks :: Assertion -testParallelizingTasks = assert $ do - a <- actual - let ids = map rspId a - vals = map fromResult a - 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) - unlockRequest str = TestRequest "unlock" (Just $ Right $ V.fromList [str]) Nothing - methods = createMethods <$> newEmptyMVar - createMethods lock = toMethods [lockMethod lock, unlockMethod lock] - lockMethod lock = toMethod "lock" f () - where f :: RpcResult IO String - f = liftIO $ takeMVar lock - unlockMethod lock = toMethod "unlock" f (Required "value" :+: ()) - where f :: String -> RpcResult IO () - f val = liftIO $ putMVar lock val - fromResult r | Right (String str) <- rspResult r = str + , let req = defaultRq `params` (Just $ array [A.Number 4]) + rsp = defaultRsp `result` A.Number 4 + in testCase "use default unnamed argument" $ assertSubtractResponse req rsp -parallelize :: [IO a] -> IO [a] -parallelize tasks = do - results <- forM tasks $ \t -> do - mvar <- newEmptyMVar - _ <- forkIO $ putMVar mvar =<< t - return mvar - forM results takeMVar + , testCase "string request ID" $ assertEqualId $ A.String "ID 5" -incrementStateMethod :: Method (State Int) -incrementStateMethod = toMethod "increment" f () - where f :: RpcResult (State Int) () - f = lift $ modify (+1) + , testCase "null request ID" $ assertEqualId A.Null -compareGetTimeResult :: Maybe (Either Object Array) -> Assertion -compareGetTimeResult requestArgs = assertEqual "unexpected rpc response" expected =<< - ((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" + , testCase "parallelize tasks" TestParallelism.testParallelizingTasks ] -subtractRequestNamed :: [(Text, Value)] -> TestId -> TestRequest -subtractRequestNamed args i = TestRequest "subtract 1" (Just $ Left $ H.fromList args) (Just i) +assertSubtractResponse :: A.Value -> A.Value -> Assertion +assertSubtractResponse rq expectedRsp = removeErrMsg <$> rsp @?= Just expectedRsp + where rsp = callSubtractMethods rq -subtractRequestUnnamed :: [Value] -> TestId -> TestRequest -subtractRequestUnnamed args i = TestRequest "subtract 1" (Just $ Right $ V.fromList args) (Just i) +assertEqualId :: A.Value -> Assertion +assertEqualId i = assertSubtractResponse (defaultRq `id'` Just i) (defaultRsp `id'` Just i) -checkResponseWithSubtract :: B.ByteString -> TestId -> Int -> Assertion -checkResponseWithSubtract val expectedId expectedCode = actual @?= expected - where expected = (Just expectedId, Just expectedCode) - actual = (rspId <$> fromByteString result, getErrorCode result) - result = fromJust $ runIdentity $ call (toMethods [subtractMethod, flippedSubtractMethod]) val +assertInvalidParams :: A.Value -> Assertion +assertInvalidParams req = assertSubtractResponse req (defaultIdErrRsp (-32602)) -fromByteString :: FromJSON a => B.ByteString -> Maybe a -fromByteString x = case fromJSON <$> decode x of - Just (Success x') -> Just x' - _ -> Nothing +testBatch :: Assertion +testBatch = sortBy (compare `on` rspToIdString) <$> response @?= Just expected + where expected = [nullIdErrRsp (-32600), rsp i1 2, rsp i2 4] + where rsp i x = defaultRsp `id'` Just i `result` A.Number x + response = fromArray =<< (removeErrMsg <$> callSubtractMethods (array requests)) + requests = [rq (Just i1) 10 8, rq (Just i2) 24 20, rq Nothing 15 1, defaultRq `version` Just (A.String "abc")] + where rq i x y = defaultRq `id'` i `params` toArgs x y + toArgs :: Int -> Int -> Maybe A.Value + toArgs x y = Just $ A.object ["x" .= x, "y" .= y] + i1 = A.Number 1 + i2 = A.Number 2 + fromArray (A.Array v) = Just $ V.toList v + fromArray _ = Nothing -getErrorCode :: B.ByteString -> Maybe Int -getErrorCode b = fromByteString b >>= \r -> - case r of - Just (TestResponse _ (Left (TestRpcError code _ _))) -> Just code - _ -> Nothing +testBatchNotifications :: Assertion +testBatchNotifications = runState response 0 @?= (Nothing, 10) + where response = S.call (S.toMethods [incrementStateMethod]) $ A.encode rq + rq = replicate 10 $ request Nothing "increment" Nothing -subtractMethod :: Method Identity -subtractMethod = toMethod "subtract 1" sub (Required "a1" :+: Optional "a2" 0 :+: ()) - where sub :: Int -> Int -> RpcResult Identity Int - sub x y = return (x - y) +testAllowMissingVersion :: Assertion +testAllowMissingVersion = callSubtractMethods requestNoVersion @?= (Just $ defaultRsp `result` A.Number 1) + where requestNoVersion = defaultRq `version` Nothing `params` Just (A.object ["x" .= A.Number 1]) -flippedSubtractMethod :: Method Identity -flippedSubtractMethod = toMethod "subtract 2" sub (Optional "y" (-1000) :+: Required "x" :+: ()) - where sub :: Int -> Int -> RpcResult Identity Int - sub y x = return (x - y) +incrementStateMethod :: S.Method (State Int) +incrementStateMethod = S.toMethod "increment" f () + where f :: S.RpcResult (State Int) () + f = lift $ modify (+1) -getTimeMethod :: Method IO -getTimeMethod = toMethod "get_time_seconds" getTime () - where getTime :: RpcResult IO Integer - getTime = liftIO getTestTime +assertGetTimeResponse :: Maybe A.Value -> Assertion +assertGetTimeResponse args = passed @? "unexpected RPC response" + where passed = (expected ==) <$> rsp + expected = Just $ defaultRsp `result` A.Number 100 + req = defaultRq `method` "get_time_seconds" `params` args + rsp = callGetTimeMethod req -getTestTime :: IO Integer -getTestTime = return 100 +callSubtractMethods :: A.Value -> Maybe A.Value +callSubtractMethods req = let methods :: S.Methods Identity + methods = S.toMethods [subtractMethod, flippedSubtractMethod] + rsp = S.call methods $ A.encode req + in A.decode =<< runIdentity rsp -equalContents :: Eq a => [a] -> [a] -> Bool -equalContents xs ys = null (xs \\ ys) && - null (ys \\ xs) +callGetTimeMethod :: A.Value -> IO (Maybe A.Value) +callGetTimeMethod req = let methods :: S.Methods IO + methods = S.toMethods [getTimeMethod] + rsp = S.call methods $ A.encode req + in (A.decode =<<) <$> rsp + +subtractMethod :: S.Method Identity +subtractMethod = S.toMethod "subtract" subtract (S.Required "x" :+: S.Optional "y" 0 :+: ()) + +flippedSubtractMethod :: S.Method Identity +flippedSubtractMethod = S.toMethod "flipped subtract" (flip subtract) ps + where ps = S.Optional "y" (-1000) :+: S.Required "x" :+: () + +subtract :: Int -> Int -> S.RpcResult Identity Int +subtract x y = return (x - y) + +getTimeMethod :: S.Method IO +getTimeMethod = S.toMethod "get_time_seconds" getTestTime () + where getTestTime :: S.RpcResult IO Integer + getTestTime = liftIO $ return 100 + +removeErrMsg :: A.Value -> A.Value +removeErrMsg (A.Object rsp) = A.Object $ H.adjust removeMsg "error" rsp + where removeMsg (A.Object err) = A.Object $ H.insert "message" "" $ H.delete "data" err + removeMsg v = v +removeErrMsg (A.Array rsps) = A.Array $ removeErrMsg `V.map` rsps +removeErrMsg v = v diff --git a/tests/TestTypes.hs b/tests/TestTypes.hs deleted file mode 100644 --- a/tests/TestTypes.hs +++ /dev/null @@ -1,80 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module TestTypes ( TestRequest (..) - , TestResponse (..) - , TestRpcError (..) - , TestId - , idString - , idNumber - , idNull - , versionKey) where - -import qualified Data.Aeson as A -import Data.Aeson ((.=), (.:), (.:?)) -import Data.Maybe (catMaybes) -import Data.String (IsString, fromString) -import Data.Text (Text, pack) -import Data.HashMap.Strict (size) -import Control.Applicative ((<$>), (<*>), (<|>), pure, empty) -import Control.Monad (when, guard) - -data TestRpcError = TestRpcError { errCode :: Int - , errMsg :: Text - , errData :: Maybe A.Value} - deriving (Eq, Show) - -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 A.Object A.Array)) (Maybe TestId) - -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" .= v - -data TestResponse = TestResponse { rspId :: TestId - , rspResult :: Either TestRpcError A.Value } - deriving (Eq, Show) - -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 - --- 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) - -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 A.ToJSON TestId where - toJSON (IdString x) = x - toJSON (IdNumber x) = x - toJSON IdNull = A.Null - -versionKey :: Text -versionKey = "jsonrpc"