json-rpc-server 0.1.1.0 → 0.1.2.0
raw patch · 8 files changed
+353/−328 lines, 8 filesdep ~aesondep ~basedep ~happstack-server
Dependency ranges changed: aeson, base, happstack-server, mtl, vector
Files
- README.md +3/−1
- json-rpc-server.cabal +15/−15
- src/Network/JsonRpc/Server.hs +17/−13
- src/Network/JsonRpc/Types.hs +24/−11
- tests/Internal.hs +86/−0
- tests/TestParallelism.hs +64/−0
- tests/TestSuite.hs +144/−208
- tests/TestTypes.hs +0/−80
README.md view
@@ -1,3 +1,5 @@ json-rpc-server ===============-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.+[](https://travis-ci.org/grayjay/json-rpc-server)++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. The documentation is on Hackage: <http://hackage.haskell.org/package/json-rpc-server>.
json-rpc-server.cabal view
@@ -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 <http://www.jsonrpc.org/specification>. 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
src/Network/JsonRpc/Server.hs view
@@ -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 <http://www.jsonrpc.org/specification>. 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
src/Network/JsonRpc/Types.hs view
@@ -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)
+ tests/Internal.hs view
@@ -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)
+ tests/TestParallelism.hs view
@@ -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
tests/TestSuite.hs view
@@ -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
− tests/TestTypes.hs
@@ -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"