json-rpc-client 0.1.0.0 → 0.1.2.0
raw patch · 8 files changed
+241/−130 lines, 8 filesdep +scientificdep +vector-algorithmsdep ~basePVP ok
version bump matches the API change (PVP)
Dependencies added: scientific, vector-algorithms
Dependency ranges changed: base
API changes (from Hackage documentation)
Files
- README.md +3/−1
- demo/Client.hs +7/−6
- demo/Server.hs +2/−2
- json-rpc-client.cabal +12/−9
- src/Network/JsonRpc/Client.hs +61/−34
- src/Network/JsonRpc/ServerAdapter.hs +4/−4
- tests/Properties.hs +5/−2
- tests/Tests.hs +147/−72
README.md view
@@ -10,4 +10,6 @@ server-side methods with the package [json-rpc-server] (http://hackage.haskell.org/package/json-rpc-server). This library does not handle transport, so a function for-communicating with the server must be provided.+communicating with the server must be provided. The+documentation is on Hackage:+<http://hackage.haskell.org/package/json-rpc-client>.
demo/Client.hs view
@@ -64,12 +64,13 @@ -- Create a function for communicating with the server: connection :: Connection (ReadInOut IO)-connection input = do- (inH, outH) <- ask- liftIO $ B.hPutStrLn inH input- liftIO $ hFlush inH- line <- (head . B.lines) <$> liftIO (B.hGetContents outH)- return $ if B.null line then Nothing else Just line+connection input = ask >>= \(inH, outH) -> liftIO $+ do B.hPutStrLn inH input+ hFlush inH+ line <- (head . B.lines) <$> B.hGetContents outH+ return $ if B.null line+ then Nothing+ else Just line -- Run the server as a subprocess: main = do
demo/Server.hs view
@@ -6,7 +6,7 @@ import Signatures (concatenateSig, incrementSig) import Network.JsonRpc.Server (Method, call, toMethods) import Network.JsonRpc.ServerAdapter (toServerMethod)-import System.IO (hFlush, stdout)+import System.IO (BufferMode (LineBuffering), hSetBuffering, stdout) import qualified Data.ByteString.Lazy.Char8 as B import Data.Maybe (fromMaybe) import Control.Monad (forM_)@@ -29,10 +29,10 @@ -- Call the set of methods with requests from stdin, -- and print responses to stdout: main = do+ hSetBuffering stdout LineBuffering contents <- B.getContents count <- newMVar 0 forM_ (B.lines contents) $ \request -> do response <- runReaderT (call methods request) count B.putStrLn $ fromMaybe "" response- hFlush stdout where methods = toMethods [concatenate, increment]
json-rpc-client.cabal view
@@ -1,5 +1,5 @@ name: json-rpc-client-version: 0.1.0.0+version: 0.1.2.0 license: MIT license-file: LICENSE category: Network, JSON@@ -9,7 +9,8 @@ build-type: Simple extra-source-files: README.md cabal-version: >=1.10-tested-with: GHC == 7.0.4, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.3+tested-with: GHC == 7.0.4, GHC == 7.4.2, GHC == 7.6.3,+ GHC == 7.8.3, GHC == 7.10.1 description: Functions for creating a JSON-RPC 2.0 client. See <http://www.jsonrpc.org/specification>. This library supports batch requests and notifications, as well as single method@@ -34,14 +35,15 @@ library exposed-modules: Network.JsonRpc.Client Network.JsonRpc.ServerAdapter- build-depends: base >=4.3.1 && <4.8,+ build-depends: base >=4.3.1 && <4.9, json-rpc-server >=0.1.4 && <0.2, aeson >=0.7 && <0.9, bytestring >=0.9.1.10 && <0.11, mtl >=2.1.1 && <2.3, text >=0.11.2 && <1.3, unordered-containers >=0.2.3 && <0.3,- vector >=0.10 && <0.11+ vector >=0.10 && <0.11,+ vector-algorithms >=0.5.4 && <0.7 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall@@ -51,7 +53,7 @@ main-is: Server.hs other-modules: Signatures if flag (demo)- build-depends: base >=4.3.1 && <4.8,+ build-depends: base >=4.3.1 && <4.9, json-rpc-client, json-rpc-server >=0.1.4 && <0.2, aeson >=0.7 && <0.9,@@ -59,7 +61,6 @@ mtl >=2.1.1 && <2.3, text >=0.11.2 && <1.3 default-language: Haskell2010- ghc-options: -Wall else buildable: False @@ -68,7 +69,7 @@ main-is: Client.hs other-modules: Signatures if flag (demo)- build-depends: base >=4.3.1 && <4.8,+ build-depends: base >=4.3.1 && <4.9, json-rpc-client, json-rpc-server >=0.1.4 && <0.2, process >=1.1.0.1 && <1.3,@@ -77,7 +78,6 @@ mtl >=2.1.1 && <2.3, text >=0.11.2 && <1.3 default-language: Haskell2010- ghc-options: -Wall else buildable: False @@ -86,13 +86,16 @@ main-is: All.hs other-modules: Tests, Properties type: exitcode-stdio-1.0- build-depends: base >=4.3.1 && <4.8,+ build-depends: base >=4.3.1 && <4.9, json-rpc-client, json-rpc-server >=0.1.4 && <0.2, aeson >=0.7 && <0.9, bytestring >=0.9.1.10 && <0.11, mtl >=2.1.1 && <2.3,+ scientific >=0.2 && <0.4, text >=0.11.2 && <1.3,+ unordered-containers >=0.2.3 && <0.3,+ vector >=0.10 && <0.11, HUnit >=1.2.4.2 && <1.3, QuickCheck >=2.4.2 && <2.8, test-framework >=0.6 && <0.9,
src/Network/JsonRpc/Client.hs view
@@ -24,21 +24,27 @@ -- * Types Connection , RpcResult+ -- * Signatures , Signature (..) , (:::) (..)+ -- * Single Requests , toFunction , toFunction_+ -- * Batch Requests , Batch () , toBatchFunction , toBatchFunction_ , voidBatch , runBatch+ -- * Errors+ -- $errors , RpcError (..) , clientCode+ -- * Type Classes , ClientFunction , ComposeMultiParam) where@@ -48,13 +54,19 @@ import Data.Aeson ((.=), (.:)) import Data.Text (Text (), pack) import Data.ByteString.Lazy (ByteString)-import qualified Data.HashMap.Lazy as H-import Data.Function (on)+import qualified Data.HashMap.Strict as H+import Data.Ord (comparing) import Data.Maybe (catMaybes)-import Data.List (sortBy)-import Control.Applicative (Applicative (..), Alternative (..), (<$>), (<*>), (<|>))+import qualified Data.Vector as V+import qualified Data.Vector.Algorithms.Intro as VA+import Control.Arrow ((&&&)) import Control.Monad.Error (ErrorT (..), throwError, lift, (<=<))+import Control.Applicative (Alternative (..), (<|>)) +#if !MIN_VERSION_base(4,8,0)+import Control.Applicative (Applicative (..), (<$>), (<*>))+#endif+ -- $summary -- * Create one 'Signature' for each server-side method to be called. -- 'Signature's can be shared between client and server, using@@ -75,6 +87,11 @@ -- Compile both programs with the @demo@ flag. Then run the client by passing -- it a command to run the server (e.g., @demo-client demo-server@). +-- $errors+-- 'RpcError' is used for all server-side errors, as described in the+-- specification. Additionally, the error code @-31999@ is used for any+-- errors that occur while parsing the server's response.+ -- | Function used to send requests to the server. -- 'Nothing' represents no response, as when a JSON-RPC -- server receives only notifications.@@ -95,7 +112,7 @@ toBatchFunction :: ClientFunction ps r f => Signature ps r -- ^ Method signature. -> f -- ^ Client-side function with a return type of @'Batch' r@.-toBatchFunction s@(Signature name params) = toBatch name params (resultType s) H.empty+toBatchFunction s@(Signature name params) = _toBatch name params (resultType s) H.empty -- | Creates a function for calling a JSON-RPC method as a notification and as part of a batch request. toBatchFunction_ :: (ClientFunction ps r f, ComposeMultiParam (Batch r -> Batch ()) f g) =>@@ -118,7 +135,7 @@ toFunction_ server = composeWithBatch $ runBatch server . voidBatch composeWithBatch :: (ClientFunction ps r g, ComposeMultiParam f g h) => f -> Signature ps r -> h-composeWithBatch f = compose f . toBatchFunction+composeWithBatch f = _compose f . toBatchFunction -- | Evaluates a batch. The process depends on its size: -- @@ -131,33 +148,42 @@ Connection m -- ^ Function for sending requests to the server. -> Batch r -- ^ Batch to be evaluated. -> RpcResult m r -- ^ Result.-runBatch server batch = let requests = zipWith assignId (bRequests batch) [1..]- sort = sortBy (compare `on` rsId)- liftResult = ErrorT . return- in processRqs server requests >>=- liftResult . bToResult batch . map rsResult . sort+runBatch server batch = liftResult . bToResult batch =<<+ validate . sort =<<+ processRqs server idRequests+ where requests = bRequests batch+ idRequests = V.zipWith assignId requests ids+ where ids = V.postscanl' incId 0 requests+ incId i rq = if rqIsNotification rq then i else i + 1+ sort = V.modify $ VA.sortBy $ comparing rsId+ liftResult = ErrorT . return+ validate rsps = let (results, ids) = V.unzip $ V.map (rsResult &&& rsId) rsps+ in if ids /= V.enumFromN 1 (bNonNotifications batch)+ then throwError $ clientError $+ "Invalid response IDs: " ++ show ids+ else return results assignId :: Request -> Int -> IdRequest assignId rq i = IdRequest { idRqMethod = rqMethod rq , idRqId = if rqIsNotification rq then Nothing else Just i , idRqParams = rqParams rq } -processRqs :: (Monad m, Functor m) => Connection m -> [IdRequest] -> RpcResult m [Response]-processRqs server requests = case requests of- [] -> return []- [rq] -> process (:[]) rq- rqs -> process id rqs+processRqs :: (Monad m, Functor m) =>+ Connection m -> V.Vector IdRequest -> RpcResult m (V.Vector Response)+processRqs server requests | V.null requests = return V.empty+ | V.length requests == 1 = process V.singleton $ V.head requests+ | otherwise = process id requests where decode rsp = case A.eitherDecode rsp of Right r -> return r Left msg -> throwError $ clientError $ "Client cannot parse JSON response: " ++ msg- process f rqs = maybe (return []) (fmap f . decode) =<<+ process f rqs = maybe (return V.empty) (fmap f . decode) =<< (lift . server . A.encode) rqs -- | Converts all requests in a batch to notifications. voidBatch :: Batch r -> Batch () voidBatch batch = Batch { bNonNotifications = 0- , bRequests = map toNotification $ bRequests batch+ , bRequests = V.map toNotification $ bRequests batch , bToResult = const $ return () } where toNotification rq = rq { rqIsNotification = True } @@ -165,27 +191,27 @@ -- values of this type using its 'Applicative' and 'Alternative' -- instances before running them with 'runBatch'. data Batch r = Batch { bNonNotifications :: Int- , bRequests :: [Request]- , bToResult :: [Result A.Value] -> Result r }+ , bRequests :: V.Vector Request+ , bToResult :: V.Vector (Result A.Value) -> Result r } instance Functor Batch where fmap f batch = batch { bToResult = fmap f . bToResult batch } instance Applicative Batch where- pure x = empty { bToResult = const (return x) }+ pure x = empty { bToResult = const $ return x } (<*>) = combine (<*>) instance Alternative Batch where empty = Batch { bNonNotifications = 0- , bRequests = []+ , bRequests = V.empty , bToResult = const $ throwError $ clientError "empty" } (<|>) = combine (<|>) combine :: (Result a -> Result b -> Result c) -> Batch a -> Batch b -> Batch c combine f (Batch n1 rqs1 g1) (Batch n2 rqs2 g2) = Batch { bNonNotifications = n1 + n2- , bRequests = rqs1 ++ rqs2- , bToResult = \rs -> let (rs1, rs2) = splitAt n1 rs+ , bRequests = rqs1 V.++ rqs2+ , bToResult = \rs -> let (rs1, rs2) = V.splitAt n1 rs in g1 rs1 `f` g2 rs2 } data ResultType r = ResultType@@ -203,32 +229,33 @@ -- | Relationship between the parameters ('ps'), return type ('r'), -- and client-side batch function ('f') of a JSON-RPC method. class ClientFunction ps r f | ps r -> f, f -> ps r where- toBatch :: Text -> ps -> ResultType r -> A.Object -> f+ _toBatch :: Text -> ps -> ResultType r -> A.Object -> f instance A.FromJSON r => ClientFunction () r (Batch r) where- toBatch name _ _ priorArgs = Batch { bNonNotifications = 1- , bRequests = [Request name False priorArgs]- , bToResult = decode <=< head }+ _toBatch name _ _ priorArgs = Batch { bNonNotifications = 1+ , bRequests = V.singleton $+ Request name False priorArgs+ , bToResult = decode <=< V.head } where decode result = case A.fromJSON result of A.Success r -> Right r- A.Error msg -> Left $ clientError $+ A.Error msg -> throwError . clientError $ "Client received wrong result type: " ++ msg instance (ClientFunction ps r f, A.ToJSON a) => ClientFunction (a ::: ps) r (a -> f) where- toBatch name (p ::: ps) rt priorArgs a = let newArgs = H.insert p (A.toJSON a) priorArgs- in toBatch name ps rt newArgs+ _toBatch name (p ::: ps) rt priorArgs a = let newArgs = H.insert p (A.toJSON a) priorArgs+ in _toBatch name ps rt newArgs -- | Relationship between a function ('g') taking any number of arguments and yielding a @'Batch' a@, -- a function ('f') taking a @'Batch' a@, and the function ('h') that applies g to all of its -- arguments and then applies f to the result. class ComposeMultiParam f g h | f g -> h, g h -> f where- compose :: f -> g -> h+ _compose :: f -> g -> h instance ComposeMultiParam (Batch a -> b) (Batch a) b where- compose = ($)+ _compose = ($) instance ComposeMultiParam f g h => ComposeMultiParam f (a -> g) (a -> h) where- compose f g = compose f . g+ _compose f g = _compose f . g data Request = Request { rqMethod :: Text , rqIsNotification :: Bool
src/Network/JsonRpc/ServerAdapter.hs view
@@ -18,16 +18,16 @@ -- The parameters of the resulting method match the order -- and types of the parameters in the signature and are all 'Required'. toServerMethod :: (ConvertParams ps1 ps2, MethodParams f ps2 m r) => Signature ps1 r -> f -> Method m-toServerMethod (Signature name ps) f = toMethod name f $ toServerParams ps+toServerMethod (Signature name ps) f = toMethod name f $ _toServerParams ps -- | Relationship between the parameters in a 'Signature' ('ps1') -- and the parameters expected by 'toMethod' ('ps2') for a given -- RPC method. class ConvertParams ps1 ps2 | ps1 -> ps2, ps2 -> ps1 where- toServerParams :: ps1 -> ps2+ _toServerParams :: ps1 -> ps2 instance ConvertParams () () where- toServerParams = id+ _toServerParams = id instance ConvertParams ps1 ps2 => ConvertParams (p ::: ps1) (p :+: ps2) where- toServerParams (name ::: ps1) = Required name :+: toServerParams ps1+ _toServerParams (name ::: ps1) = Required name :+: _toServerParams ps1
tests/Properties.hs view
@@ -21,8 +21,6 @@ import Control.Monad.State (State, runState, evalState, gets, put, modify) import Data.Text (Text, pack) import Data.List (nub)-import Data.Traversable (traverse)-import Control.Applicative (pure, (<$>), (<*>)) import Test.QuickCheck( Arbitrary (..), CoArbitrary (..), Blind (..) , Property, Gen, listOf, oneof, (==>)) import Test.Framework (Test)@@ -32,6 +30,11 @@ import Test.QuickCheck.Gen.Unsafe (promote) #else import Test.QuickCheck.Gen (promote)+#endif++#if !MIN_VERSION_base(4,8,0)+import Data.Traversable (traverse)+import Control.Applicative (pure, (<$>), (<*>)) #endif properties :: [Test]
tests/Tests.hs view
@@ -9,98 +9,165 @@ module Tests (tests) where import Network.JsonRpc.Client-import Network.JsonRpc.ServerAdapter-import Network.JsonRpc.Server (toMethods, rpcError, callWithBatchStrategy)+import Network.JsonRpc.ServerAdapter (toServerMethod)+import Network.JsonRpc.Server (toMethods, rpcError, call, callWithBatchStrategy)+ import qualified Data.Aeson as A import Data.Aeson ((.=)) import qualified Data.ByteString.Lazy as B-import Data.Text (unpack)-import Data.List (isInfixOf)-import Control.Applicative (pure, empty, (<$>), (<$), (<*>), (<|>))+import Data.Maybe (fromJust)+import Data.Ratio ((%))+import Data.Scientific (Scientific)+import qualified Data.HashMap.Strict as M+import qualified Data.Vector as V import Control.Monad.Error (runErrorT, throwError)-import Control.Monad.State (State, runState, evalState, modify, when)+import Control.Monad.State (State, runState, modify, when) import Test.HUnit hiding (State, Test) import Test.Framework (Test) import Test.Framework.Providers.HUnit (testCase) import Prelude hiding (subtract)+import Control.Applicative (empty, (<|>)) +#if !MIN_VERSION_base(4,8,0)+import Control.Applicative (pure, (<$>), (<$), (<*>))+#endif+ tests :: [Test]-tests = [ testCase "single request" $ runServer (subtract 22 1) @?= (Right 21, 1)+tests = [ testCase "single request" $+ runResult (subtract 22 1) @?= (Right 21, 1) - , testCase "batch with one request" $ myRunBatch (subtractB 1 2) @?= (Right (-1), 1)+ , testCase "batch with one request" $+ myRunBatch (subtractB 1 2) @?= (Right (-1), 1) - , let result = myRunBatch $ pure (,) <*> subtractB 7 3 <*> divideB 15 12- in testCase "batch 1" $ result @?= (Right (4, 1.25), 2)+ , testCase "batch with multiple requests" $+ let result = myRunBatch $ pure (,) <*> subtractB 7 3 <*> divideB 15 12+ in result @?= (Right (4, 5%4), 2) - , let result = myRunBatch $ (+) <$> subtractB 5 3 <*> ((*) <$> subtractB 11 2 <*> subtractB 15 10)- in testCase "batch 2" $ result @?= (Right 47, 3)+ , testCase "requests combined right to left" $+ let result = myRunBatch $+ (+) <$> subtractB 5 3 <*> ((*) <$> subtractB 11 2 <*> subtractB 15 10)+ in result @?= (Right 47, 3) - , let result = myRunBatch $ (*) <$> ((+) <$> subtractB 5 3 <*> subtractB 11 2) <*> subtractB 15 10- in testCase "batch 3" $ result @?= (Right 55, 3)+ , testCase "requests combined left to right" $+ let result = myRunBatch $+ (*) <$> ((+) <$> subtractB 5 3 <*> subtractB 11 2) <*> subtractB 15 10+ in result @?= (Right 55, 3) , testCase "single notification" $- runServer (subtract_ 1 2) @?= (Right (), 1)+ runResult (subtract_ 1 2) @?= (Right (), 1) , testCase "batch with one notification" $ myRunBatch (subtractB_ 1 2) @?= (Right (), 1) - , let result = myRunBatch $ (,) <$> subtractB_ 5 4 <*> subtractB 20 16- in testCase "notification at start of batch" $ result @?= (Right ((), 4), 2)+ , testCase "notification at start of batch" $+ let result = myRunBatch $+ (,) <$> subtractB_ 5 4 <*> subtractB 20 16+ in result @?= (Right ((), 4), 2) - , let result = myRunBatch $ (,) <$> subtractB 5 4 <*> subtractB_ 20 16- in testCase "notification at end of batch" $ result @?= (Right (1, ()), 2)+ , testCase "notification at end of batch" $+ let result = myRunBatch $+ (,) <$> subtractB 5 4 <*> subtractB_ 20 16+ in result @?= (Right (1, ()), 2) - , let result = myRunBatch $ (:) <$> divideB 4 2 <*> ((:[]) <$> divideB 1 0)- in testCase "batch with error" $ result @?= (Left (-32050), 1)+ , testCase "single request with error" $+ runResult (divide 10 0) @?= (Left divByZeroCode, 0) - , testCase "single request with error" $ runServer (divide 10 0) @?= (Left (-32050), 0)+ , testCase "error at start of batch" $+ let result = myRunBatch $+ (:) <$> divideB 4 0 <*> ((:[]) <$> divideB 1 1)+ in result @?= (Left divByZeroCode, 1) - , let result = runServer $ runBatch badServer $ (||) <$> pure True <*> pure False- badServer = error "unnecessarily sent to server"- in testCase "batch with no requests" $ result @?= (Right True, 0)+ , testCase "error at end of batch" $+ let result = myRunBatch $+ (+) <$> divideB 4 2 <*> divideB 1 0+ in result @?= (Left divByZeroCode, 1) - , let result = myRunBatch $ divideB 1 0 <|> divideB 2 1- in testCase "batch alternative with failure first" $ result @?= (Right 2, 1)+ , testCase "batch with multiple errors" $+ let result = myRunBatch $+ (,) <$> divideB 1 0 <*> missingMethodB+ in result @?= (Left divByZeroCode, 0) - , let result = myRunBatch $ divideB 2 1 <|> divideB 1 0- in testCase "batch alternative with failure last" $ result @?= (Right 2, 1)+ , testCase "batch with no requests is not sent to server" $+ let result = runResult $+ runBatch badServer $ (||) <$> pure True <*> pure False+ badServer = constServer $ error "server was used"+ in result @?= (Right True, 0) - , let result = myRunBatch $ divideB 2 0 <|> divideB 1 0- in testCase "batch alternative with all failures" $ result @?= (Left (-32050), 0)+ , testCase "batch alternative with failure first" $+ let result = myRunBatch $ divideB 1 0 <|> divideB 2 1+ in result @?= (Right 2, 1) - , let result = myRunBatch $ divideB 2 1 <|> divideB 1 1- in testCase "batch alternative with no failures" $ result @?= (Right 2, 2)+ , testCase "batch alternative with failure last" $+ let result = myRunBatch $ divideB 2 1 <|> divideB 1 0+ in result @?= (Right 2, 1) - , testCase "empty batch" $ myRunBatch (empty :: Batch String) @?= (Left (-31999), 0)+ , testCase "batch alternative with all failures" $+ let result = myRunBatch $ divideB 2 0 <|> missingMethodB+ in result @?= (Left (-32601), 0) - , testCase "bad JSON response" $- assertErrorMsg (A.encode $ A.Number 3) ["Client cannot parse JSON response"]+ , testCase "batch alternative with no failures" $+ let result = myRunBatch $ divideB 2 1 <|> divideB 1 1+ in result @?= (Right 2, 2) - , let response = A.encode $ A.object [ "result" .= A.Number 3- , "jsonrpc" .= A.String "2.0" ]- in testCase "missing response id attribute" $ assertErrorMsg response- [ "Client cannot parse JSON response"- , "key \"id\" not present" ]+ , testCase "empty batch" $+ myRunBatch (empty :: Batch String) @?= (Left (-31999), 0) - , let response = A.encode [A.String "element"]- in testCase "non-object response" $- assertErrorMsg response ["expecting a JSON-RPC response"]+ , testCase "invalid JSON response" $+ let result = subtractWithConstServer $ A.Number 3+ in runResult result @?= (Left clientCode, 0) - , let response = A.encode $ A.object [ "id" .= A.Number 3- , "result" .= True- , "jsonrpc" .= A.String "2.0"]- in testCase "wrong response result type" $- assertErrorMsg response ["wrong result type"]+ , testCase "missing ID attribute in response" $+ let result = subtractWithConstServer $+ A.object [ "result" .= A.Number 3+ , "jsonrpc" .= A.String "2.0" ]+ in runResult result @?= (Left clientCode, 0)++ , testCase "non-object response to single request" $+ let result = subtractWithConstServer $ A.toJSON [A.String "element"]+ in runResult result @?= (Left clientCode, 0)++ , testCase "wrong result type in response" $+ let result = subtractWithConstServer $+ A.object [ "id" .= A.Number 3+ , "result" .= True+ , "jsonrpc" .= A.String "2.0" ]+ in runResult result @?= (Left clientCode, 0)++ , testCase "detect modified single request ID" $+ let result = toFunction (idModifyingServer (+1)) subtractSig 10 1+ in runResult result @?= (Left clientCode, 1)++ , testCase "detect modified batch response IDs" $+ let result = runBatch (idModifyingServer (+1)) $+ (+) <$> subtractB 10 1 <*> subtractB 2 1+ in runResult result @?= (Left clientCode, 2)++ , testCase "detect duplicate batch response IDs" $+ let result = runBatch (idModifyingServer (const 0)) $+ (,) <$> divideB 3 1 <*> divideB 3 1+ in runResult result @?= (Left clientCode, 2)++ , testCase "handle reversed batch responses" $+ let result = runBatch reversingServer $+ (,) <$> subtractB 2 1 <*> subtractB 4 2+ reversingServer = callWithBatchStrategy (sequence . reverse) methods+ in runResult result @?= (Right (1, 2), 2) ] -type Result r = RpcResult (State Int) r+-- | Monad used by server to keep a count of requests.+type RequestCount = State Int +type Result r = RpcResult RequestCount r+ subtractSig :: Signature (Int ::: Int ::: ()) Int subtractSig = Signature "subtract" ("x" ::: "y" ::: ()) -divideSig :: Signature (Double ::: Double ::: ()) Double+divideSig :: Signature (Rational ::: Rational ::: ()) Rational divideSig = Signature "divide" ("x" ::: "y" ::: ()) +missingMethodSig :: Signature () Rational+missingMethodSig = Signature "f" ()+ subtract = toFunction myServer subtractSig subtract_ = toFunction_ myServer subtractSig@@ -113,41 +180,49 @@ divideB = toBatchFunction divideSig -runServer :: Result a -> (Either Int a, Int)-runServer server = runState (mapLeft errCode <$> runErrorT server) 0+missingMethodB = toBatchFunction missingMethodSig++-- | Returns the error code or result, and the new server state.+runResult :: Result a -> (Either Int a, Int)+runResult result = runState (mapLeft errCode <$> runErrorT result) 0 where mapLeft f (Left x) = Left $ f x mapLeft _ (Right x) = Right x myRunBatch :: A.FromJSON a => Batch a -> (Either Int a, Int)-myRunBatch = runServer . runBatch myServer+myRunBatch = runResult . runBatch myServer -myServer :: B.ByteString -> State Int (Maybe B.ByteString)-myServer = callWithBatchStrategy (sequence . reverse) methods+myServer :: B.ByteString -> RequestCount (Maybe B.ByteString)+myServer = call methods -assertErrorMsg :: B.ByteString -> [String] -> Assertion-assertErrorMsg response expected = (runServer result @?= (Left (-31999), 0)) >>- mapM_ (assertErrorMsgContains result) expected- where result = toFunction badServer subtractSig 10 1- badServer = constServer response+subtractWithConstServer :: A.Value -> RpcResult RequestCount Int+subtractWithConstServer response = toFunction server subtractSig 1 2+ where server = constServer $ A.encode response -constServer :: B.ByteString -> B.ByteString -> State Int (Maybe B.ByteString)-constServer = const . return . Just+idModifyingServer :: (Scientific -> Scientific) -> Connection RequestCount+idModifyingServer f = responseModifyingServer modifyIds+ where modifyIds (A.Array rs) = A.Array $ V.map modifyIds rs+ modifyIds (A.Object r) = A.Object $ M.adjust modifyId "id" r+ where modifyId (A.Number i) = A.Number $ f i+ modifyId x = x+ modifyIds x = x -assertErrorMsgContains :: Result a -> String -> Assertion-assertErrorMsgContains server expected = case evalState (runErrorT server) 0 of- Right _ -> assertFailure "Expected an error, but got a result."- Left err -> assertBool msg $ expected `isInfixOf` errorMsg- where errorMsg = unpack $ errMsg err- msg = "Wrong error message: " ++ errorMsg+responseModifyingServer :: (A.Value -> A.Value) -> Connection RequestCount+responseModifyingServer f rq = modifyResponse <$> myServer rq+ where modifyResponse rsp = A.encode . f . fromJust . A.decode <$> rsp +constServer :: B.ByteString -> Connection RequestCount+constServer = const . return . Just+ methods = toMethods [subtractMethod, divideMethod] subtractMethod = toServerMethod subtractSig f- where f :: Int -> Int -> RpcResult (State Int) Int+ where f :: Int -> Int -> RpcResult RequestCount Int f x y = (x - y) <$ modify (+1) divideMethod = toServerMethod divideSig f- where f :: Double -> Double -> RpcResult (State Int) Double+ where f :: Rational -> Rational -> RpcResult RequestCount Rational f x y = do- when (y == 0) $ throwError $ rpcError (-32050) "divide by zero"+ when (y == 0) $ throwError $ rpcError divByZeroCode "divide by zero" x / y <$ modify (+1)++divByZeroCode = -32050