diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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: +. diff --git a/demo/Client.hs b/demo/Client.hs --- a/demo/Client.hs +++ b/demo/Client.hs @@ -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 diff --git a/demo/Server.hs b/demo/Server.hs --- a/demo/Server.hs +++ b/demo/Server.hs @@ -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] diff --git a/json-rpc-client.cabal b/json-rpc-client.cabal --- a/json-rpc-client.cabal +++ b/json-rpc-client.cabal @@ -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 . 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, diff --git a/src/Network/JsonRpc/Client.hs b/src/Network/JsonRpc/Client.hs --- a/src/Network/JsonRpc/Client.hs +++ b/src/Network/JsonRpc/Client.hs @@ -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 diff --git a/src/Network/JsonRpc/ServerAdapter.hs b/src/Network/JsonRpc/ServerAdapter.hs --- a/src/Network/JsonRpc/ServerAdapter.hs +++ b/src/Network/JsonRpc/ServerAdapter.hs @@ -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 diff --git a/tests/Properties.hs b/tests/Properties.hs --- a/tests/Properties.hs +++ b/tests/Properties.hs @@ -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] diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -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