json-rpc-client (empty) → 0.1.0.0
raw patch · 12 files changed
+967/−0 lines, 12 filesdep +HUnitdep +QuickCheckdep +aesonsetup-changed
Dependencies added: HUnit, QuickCheck, aeson, base, bytestring, json-rpc-client, json-rpc-server, mtl, process, test-framework, test-framework-hunit, test-framework-quickcheck2, text, unordered-containers, vector
Files
- LICENSE +18/−0
- README.md +13/−0
- Setup.hs +2/−0
- demo/Client.hs +79/−0
- demo/Server.hs +38/−0
- demo/Signatures.hs +13/−0
- json-rpc-client.cabal +102/−0
- src/Network/JsonRpc/Client.hs +257/−0
- src/Network/JsonRpc/ServerAdapter.hs +33/−0
- tests/All.hs +8/−0
- tests/Properties.hs +251/−0
- tests/Tests.hs +153/−0
+ LICENSE view
@@ -0,0 +1,18 @@+Copyright (c) 2014 Kristen Kozak++Permission is hereby granted, free of charge, to any person obtaining a copy of+this software and associated documentation files (the "Software"), to deal in+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of+the Software, and to permit persons to whom the Software is furnished to do so,+subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,13 @@+json-rpc-client+===============+[](https://travis-ci.org/grayjay/json-rpc-client)+++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+calls. It also provides a function for creating corresponding+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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ demo/Client.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE TypeOperators #-}++module Main (main) where++import Signatures (concatenateSig, incrementSig)+import Network.JsonRpc.Client+import System.Process (runInteractiveCommand, terminateProcess)+import System.IO (Handle, hFlush)+import System.Environment (getArgs)+import qualified Data.ByteString.Lazy.Char8 as B+import Data.Traversable (sequenceA)+import Control.Applicative ((<$>), (<*>))+import Control.Monad.Error (runErrorT, liftIO)+import Control.Monad.Reader (ReaderT, runReaderT, ask)++runRpcs :: Result ()+runRpcs = do+ -- Send one request (prints 1):+ printResult =<< increment++ -- Send a notification:+ increment_++ -- Batch two requests (prints (3, "abcxyz")):+ printResult =<< run ((,) <$> incrementB <*> concatenateB "abc" "xyz")++ -- Create a batch with three requests:+ let inc3 = sequenceA $ replicate 3 incrementB++ -- Run the batch (prints [4,5,6]):+ printResult =<< run inc3++ -- Run the batch as three notifications:+ run $ voidBatch inc3++ -- Send two single requests (prints "count=10"):+ printResult =<< concatenate "count=" . show =<< increment+ where printResult x = liftIO $ print x++-- This client's RPC calls need access to the stdin+-- and stdout handles of the server subprocess:+type Result a = RpcResult (ReadInOut IO) a+type ReadInOut = ReaderT (Handle, Handle)++run :: Batch r -> Result r+run = runBatch connection++-- Define some client-side RPC functions from+-- the imported Signatures.+concatenate :: String -> String -> Result String+concatenate = toFunction connection concatenateSig++concatenateB :: String -> String -> Batch String+concatenateB = toBatchFunction concatenateSig++increment :: Result Int+increment = toFunction connection incrementSig++increment_ :: Result ()+increment_ = toFunction_ connection incrementSig++incrementB :: Batch Int+incrementB = toBatchFunction incrementSig++-- 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++-- Run the server as a subprocess:+main = do+ cmd <- head <$> getArgs+ (inH, outH, _, processH) <- runInteractiveCommand cmd+ runReaderT (runErrorT runRpcs) (inH, outH)+ terminateProcess processH
+ demo/Server.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings,+ TypeOperators #-}++module Main (main) where++import Signatures (concatenateSig, incrementSig)+import Network.JsonRpc.Server (Method, call, toMethods)+import Network.JsonRpc.ServerAdapter (toServerMethod)+import System.IO (hFlush, stdout)+import qualified Data.ByteString.Lazy.Char8 as B+import Data.Maybe (fromMaybe)+import Control.Monad (forM_)+import Control.Monad.Reader (ReaderT, ask, runReaderT, liftIO)+import Control.Concurrent.MVar (MVar, newMVar, modifyMVar)++-- This server uses an MVar to maintain a count+-- that can be read and updated by RPC calls:+type Server = ReaderT (MVar Int) IO++-- Create a Method from each Signature:+concatenate, increment :: Method Server++concatenate = toServerMethod concatenateSig (\x y -> return $ x ++ y)++increment = toServerMethod incrementSig $ ask >>= \count ->+ liftIO $ modifyMVar count inc+ where inc x = return (x + 1, x + 1)++-- Call the set of methods with requests from stdin,+-- and print responses to stdout:+main = do+ 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]
+ demo/Signatures.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE OverloadedStrings,+ TypeOperators #-}++module Signatures where++import Network.JsonRpc.Client++-- Create a Signature for each server-side method:+concatenateSig :: Signature (String ::: String ::: ()) String+concatenateSig = Signature "concatenate" ("x" ::: "y" ::: ())++incrementSig :: Signature () Int+incrementSig = Signature "increment" ()
+ json-rpc-client.cabal view
@@ -0,0 +1,102 @@+name: json-rpc-client+version: 0.1.0.0+license: MIT+license-file: LICENSE+category: Network, JSON+author: Kristen Kozak+maintainer: Kristen Kozak <grayjay@wordroute.com>+synopsis: JSON-RPC 2.0 on the client side.+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+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+ calls. It also provides a function for creating corresponding+ server-side methods with the package+ <http://hackage.haskell.org/package/json-rpc-server json-rpc-server>.+ This library does not handle transport, so a function for+ communicating with the server must be provided.+ The demo folder contains an example client and server that can+ be compiled with the demo flag. See "Network.JsonRpc.Client"+ for details.++source-repository head+ type: git+ location: https://github.com/grayjay/json-rpc-client++flag demo+ description: Builds the JSON-RPC demo client and server.+ default: False+ manual: True++library+ exposed-modules: Network.JsonRpc.Client+ Network.JsonRpc.ServerAdapter+ build-depends: base >=4.3.1 && <4.8,+ 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+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall++executable demo-server+ hs-source-dirs: demo+ main-is: Server.hs+ other-modules: Signatures+ if flag (demo)+ build-depends: base >=4.3.1 && <4.8,+ json-rpc-client,+ json-rpc-server >=0.1.4 && <0.2,+ aeson >=0.7 && <0.9,+ bytestring >=0.9.2.1 && <0.11,+ mtl >=2.1.1 && <2.3,+ text >=0.11.2 && <1.3+ default-language: Haskell2010+ ghc-options: -Wall+ else+ buildable: False++executable demo-client+ hs-source-dirs: demo+ main-is: Client.hs+ other-modules: Signatures+ if flag (demo)+ build-depends: base >=4.3.1 && <4.8,+ json-rpc-client,+ json-rpc-server >=0.1.4 && <0.2,+ process >=1.1.0.1 && <1.3,+ aeson >=0.7 && <0.9,+ bytestring >=0.9.2.1 && <0.11,+ mtl >=2.1.1 && <2.3,+ text >=0.11.2 && <1.3+ default-language: Haskell2010+ ghc-options: -Wall+ else+ buildable: False++test-suite tests+ hs-source-dirs: tests+ main-is: All.hs+ other-modules: Tests, Properties+ type: exitcode-stdio-1.0+ build-depends: base >=4.3.1 && <4.8,+ 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,+ text >=0.11.2 && <1.3,+ HUnit >=1.2.4.2 && <1.3,+ QuickCheck >=2.4.2 && <2.8,+ test-framework >=0.6 && <0.9,+ test-framework-hunit >=0.3 && <0.4,+ test-framework-quickcheck2 >=0.3 && <0.4+ default-language: Haskell2010+ ghc-options: -Wall -fno-warn-missing-signatures -fno-warn-orphans
+ src/Network/JsonRpc/Client.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE CPP,+ OverloadedStrings,+ MultiParamTypeClasses,+ FunctionalDependencies,+ FlexibleInstances,+ UndecidableInstances,+ TypeOperators,+ FlexibleContexts #-}++#if MIN_VERSION_mtl(2,2,1)+{-# OPTIONS_GHC -fno-warn-deprecations #-}+#endif++-- | Functions for implementing the client side of JSON-RPC 2.0.+-- See <http://www.jsonrpc.org/specification>.+++module Network.JsonRpc.Client ( -- * Summary+ -- $summary++ -- * Demo+ -- $demo++ -- * Types+ Connection+ , RpcResult+ -- * Signatures+ , Signature (..)+ , (:::) (..)+ -- * Single Requests+ , toFunction+ , toFunction_+ -- * Batch Requests+ , Batch ()+ , toBatchFunction+ , toBatchFunction_+ , voidBatch+ , runBatch+ -- * Errors+ , RpcError (..)+ , clientCode+ -- * Type Classes+ , ClientFunction+ , ComposeMultiParam) where++import Network.JsonRpc.Server (RpcResult, RpcError (..), rpcError)+import qualified Data.Aeson as A+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 Data.Maybe (catMaybes)+import Data.List (sortBy)+import Control.Applicative (Applicative (..), Alternative (..), (<$>), (<*>), (<|>))+import Control.Monad.Error (ErrorT (..), throwError, lift, (<=<))++-- $summary+-- * Create one 'Signature' for each server-side method to be called.+-- 'Signature's can be shared between client and server, using+-- 'Network.JsonRpc.ServerAdapter.toServerMethod'.+-- * Create a function of type @Monad m => 'Connection' m@ for communicating+-- with the server.+-- * Create client-side functions by calling 'toFunction', 'toFunction_',+-- 'toBatchFunction', or 'toBatchFunction_' on the 'Signature's.+-- * Client-side functions created with 'toBatchFunction' or 'toBatchFunction_'+-- return values of type @'Batch' a@. Combine them using 'Batch' 's+-- 'Applicative' and 'Alternative' instances, before calling 'runBatch'+-- on the result.++-- $demo+-- The <../src/demo demo folder> contains a client and server that communicate+-- using a shared set of 'Signature's. The client runs the server as a+-- subprocess, sending requests to stdin and receiving responses from stdout.+-- 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@).++-- | Function used to send requests to the server.+-- 'Nothing' represents no response, as when a JSON-RPC+-- server receives only notifications.+type Connection m = ByteString -> m (Maybe ByteString)++type Result = Either RpcError++-- | Signature specifying the name,+-- parameter names and types ('ps'), and return type ('r') of a method.+data Signature ps r = Signature Text ps deriving Show++-- | A node in a linked list specifying parameter names and types.+-- It is right associative.+data p ::: ps = Text ::: ps deriving Show+infixr :::++-- | Creates a function for calling a JSON-RPC method as part of a batch request.+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++-- | 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) =>+ Signature ps r -- ^ Method signature.+ -> g -- ^ Client-side function with a return type of @'Batch' ()@.+toBatchFunction_ = composeWithBatch voidBatch++-- | Creates a function for calling a JSON-RPC method on the server.+toFunction :: (Monad m, Functor m, ClientFunction ps r f, ComposeMultiParam (Batch r -> RpcResult m r) f g) =>+ Connection m -- ^ Function for sending requests to the server.+ -> Signature ps r -- ^ Method signature.+ -> g -- ^ Client-side function with a return type of @'RpcResult' m r@.+toFunction = composeWithBatch . runBatch++-- | Creates a function for calling a JSON-RPC method on the server as a notification.+toFunction_ :: (Monad m, Functor m, ClientFunction ps r f, ComposeMultiParam (Batch r -> RpcResult m ()) f g) =>+ Connection m -- ^ Function for sending requests to the server.+ -> Signature ps r -- ^ Method signature.+ -> g -- ^ Client-side function with a return type of @'RpcResult' m ()@.+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++-- | Evaluates a batch. The process depends on its size:+-- +-- 1. If the batch is empty, the server function is not called.+-- +-- 2. If the batch has exactly one request, it is sent as a request object.+-- +-- 3. If the batch has multiple requests, they are sent as an array of request objects.+runBatch :: (Monad m, Functor m) =>+ 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++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+ 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) =<<+ (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+ , bToResult = const $ return () }+ where toNotification rq = rq { rqIsNotification = True }++-- | A batch call. Batch multiple requests by combining+-- 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 }++instance Functor Batch where+ fmap f batch = batch { bToResult = fmap f . bToResult batch }++instance Applicative Batch where+ pure x = empty { bToResult = const (return x) }+ (<*>) = combine (<*>)++instance Alternative Batch where+ empty = Batch { bNonNotifications = 0+ , bRequests = []+ , 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+ in g1 rs1 `f` g2 rs2 }++data ResultType r = ResultType++resultType :: Signature ps r -> ResultType r+resultType _ = ResultType++clientError :: String -> RpcError+clientError msg = rpcError clientCode $ pack msg++-- | Code used for all client-side errors. It is -31999.+clientCode :: Int+clientCode = -31999++-- | 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++instance A.FromJSON r => ClientFunction () r (Batch r) where+ toBatch name _ _ priorArgs = Batch { bNonNotifications = 1+ , bRequests = [Request name False priorArgs]+ , bToResult = decode <=< head }+ where decode result = case A.fromJSON result of+ A.Success r -> Right r+ A.Error msg -> Left $ 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++-- | 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++instance ComposeMultiParam (Batch a -> b) (Batch a) b where+ compose = ($)++instance ComposeMultiParam f g h => ComposeMultiParam f (a -> g) (a -> h) where+ compose f g = compose f . g++data Request = Request { rqMethod :: Text+ , rqIsNotification :: Bool+ , rqParams :: A.Object }++data IdRequest = IdRequest { idRqMethod :: Text+ , idRqId :: Maybe Int+ , idRqParams :: A.Object }++instance A.ToJSON IdRequest where+ toJSON rq = A.object $ catMaybes [ Just $ "jsonrpc" .= A.String "2.0"+ , Just $ "method" .= idRqMethod rq+ , ("id" .=) <$> idRqId rq+ , let params = idRqParams rq+ in if H.null params+ then Nothing+ else Just $ "params" .= params ]++data Response = Response { rsResult :: Result A.Value+ , rsId :: Int }++instance A.FromJSON Response where+ parseJSON = A.withObject "JSON-RPC response object" $+ \v -> Response <$>+ (Right <$> v .: "result" <|> Left <$> v .: "error") <*>+ v .: "id"
+ src/Network/JsonRpc/ServerAdapter.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE MultiParamTypeClasses,+ FunctionalDependencies,+ UndecidableInstances,+ TypeOperators #-}++-- | Convenience function for creating server-side methods from+-- 'Signature's with the package+-- <http://hackage.haskell.org/package/json-rpc-server json-rpc-server>.+module Network.JsonRpc.ServerAdapter ( -- * Server Methods+ toServerMethod+ , ConvertParams ) where++import Network.JsonRpc.Client( Signature (..), (:::) (..))+import Network.JsonRpc.Server( Method, MethodParams+ , Parameter (..), toMethod, (:+:) (..))++-- | Creates a method from the given signature and function.+-- 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++-- | 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++instance ConvertParams () () where+ toServerParams = id++instance ConvertParams ps1 ps2 => ConvertParams (p ::: ps1) (p :+: ps2) where+ toServerParams (name ::: ps1) = Required name :+: toServerParams ps1
+ tests/All.hs view
@@ -0,0 +1,8 @@+module Main (main) where++import qualified Tests+import qualified Properties+import Test.Framework (defaultMain)++main :: IO ()+main = defaultMain $ Properties.properties ++ Tests.tests
+ tests/Properties.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE CPP,+ OverloadedStrings,+ TypeOperators,+ MultiParamTypeClasses,+ TypeSynonymInstances,+ UndecidableInstances,+ FlexibleContexts,+ FlexibleInstances #-}++#if MIN_VERSION_mtl(2,2,1)+{-# OPTIONS_GHC -fno-warn-deprecations #-}+#endif++module Properties (properties) where++import Network.JsonRpc.Client+import Network.JsonRpc.ServerAdapter+import Network.JsonRpc.Server+import Data.Aeson (ToJSON, FromJSON)+import Control.Monad.Error (ErrorT (..), runErrorT, throwError)+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)+import Test.Framework.Providers.QuickCheck2 (testProperty)++#if MIN_VERSION_QuickCheck(2,7,0)+import Test.QuickCheck.Gen.Unsafe (promote)+#else+import Test.QuickCheck.Gen (promote)+#endif++properties :: [Test]+properties = [ testProperty "rpc vs. direct call" prop_rpcVsDirect+ , testProperty "single vs. batch" prop_singleVsBatch+ , testProperty "batch functor id law" prop_functorId+ , testProperty "batch functor composition law" prop_functorComposition+ , testProperty "batch applicative id law" prop_applicativeId+ , testProperty "batch applicative composition law" prop_applicativeComposition+ , testProperty "batch applicative homomorphism law" prop_applicativeHomomorphism+ , testProperty "batch applicative interchange law" prop_applicativeInterchange+ , testProperty "no unexpected errors" prop_noUnexpectedErrors ]++type A = Int+type B = Double+type C = Maybe Int+type D = (Bool, Int)+type E = Integer+type S = Int++prop_rpcVsDirect :: Signature (A ::: B ::: ()) C+ -> Blind (A -> B -> RpcResult (State D) C)+ -> A -> B -> D -> Property+prop_rpcVsDirect sig@(Signature _ ps) (Blind f) x y state = unique (paramNames ps) ==>+ run (f x y) == run (rpcFunction x y)+ where server = call $ toMethods [toServerMethod sig f]+ rpcFunction = toFunction server sig+ run result = runState (runErrorT result) state++-- A sequence of requests should yield the same result whether batched or+-- sent individually in the State monad, if the server evaluates the+-- requests sequentially. The state differs because the server processes+-- all requests in a batch, but the client can stop sending single requests+-- after the first failure.+prop_singleVsBatch :: Signature (A ::: B ::: ()) C+ -> Blind (A -> B -> RpcResult (State D) C)+ -> [(A, B)] -> D -> Bool+prop_singleVsBatch sig (Blind f) args state = let server = call $ toMethods [toServerMethod sig f]+ function = toFunction server sig+ functionB = toBatchFunction sig+ run result = evalState (runErrorT result) state+ in run (mapM (uncurry function) args) ==+ run (runBatch server $ traverse (uncurry functionB) args)++type Sigs = Signature (A ::: B ::: ()) C+ :*: Signature () D+ :*: Signature (E ::: D ::: C ::: B ::: ()) A++prop_functorId :: Sigs+ -> ToServer Sigs S+ -> ToBatch Sigs A+ -> S+ -> Bool+prop_functorId sigs toServer toBatchX state = run (fmap id x) == run (id x)+ where x = getBatch toBatchX sigs+ run = myRunBatch toServer sigs state++prop_functorComposition :: Sigs+ -> ToServer Sigs S+ -> Blind (B -> C)+ -> Blind (A -> B)+ -> ToBatch Sigs A+ -> S+ -> Bool+prop_functorComposition sigs toServer (Blind f) (Blind g) toBatchX state =+ run (fmap (f . g) x) == run (fmap f . fmap g $ x)+ where x = getBatch toBatchX sigs+ run = myRunBatch toServer sigs state++prop_applicativeId :: Sigs+ -> ToServer Sigs S+ -> ToBatch Sigs A+ -> S+ -> Bool+prop_applicativeId sigs toServer toBatch state = run (pure id <*> v) == run v+ where v = getBatch toBatch sigs+ run = myRunBatch toServer sigs state++prop_applicativeComposition :: Sigs+ -> ToServer Sigs S+ -> ToBatch Sigs (B -> C)+ -> ToBatch Sigs (A -> B)+ -> ToBatch Sigs A+ -> S+ -> Bool+prop_applicativeComposition sigs toServer toBatchU toBatchV toBatchW state =+ run (pure (.) <*> u <*> v <*> w) ==+ run (u <*> (v <*> w))+ where u = getBatch toBatchU sigs+ v = getBatch toBatchV sigs+ w = getBatch toBatchW sigs+ run = myRunBatch toServer sigs state++prop_applicativeHomomorphism :: Sigs+ -> ToServer Sigs S+ -> Blind (A -> B)+ -> A+ -> S+ -> Bool+prop_applicativeHomomorphism sigs toServer (Blind f) x state =+ run (pure f <*> pure x) ==+ run (pure (f x))+ where run = myRunBatch toServer sigs state++prop_applicativeInterchange :: Sigs+ -> ToServer Sigs S+ -> ToBatch Sigs (A -> B)+ -> A+ -> S+ -> Bool+prop_applicativeInterchange sigs toServer toBatchU y state =+ run (u <*> pure y) ==+ run (pure ($ y) <*> u)+ where u = getBatch toBatchU sigs+ run = myRunBatch toServer sigs state++prop_noUnexpectedErrors :: Sigs+ -> ToServer Sigs S+ -> ToBatch Sigs A+ -> S+ -> Property+prop_noUnexpectedErrors sigs toServer toBatch state = unique (methodNames sigs) ==>+ all unique (allParamNames sigs) ==>+ case run batch of+ (Left err, _) -> err == testError+ _ -> True+ where batch = getBatch toBatch sigs+ run = myRunBatch toServer sigs state++unique xs = nub xs == xs++myRunBatch toServer sigs state result = let server = getServer toServer sigs+ in runState (runErrorT $ runBatch server result) state++data a :*: b = a :*: b deriving Show+infixr :*:++class SignatureSet ss where+ methodNames :: ss -> [Text]+ allParamNames :: ss -> [[Text]]+ batchFromSigs :: Arbitrary a => ss -> Gen (Batch a)+ toServerMethods :: ss -> Gen [Method (State S)]++instance (TestClientFunction ps r f1, Params ps,+ MethodParams f2 ps2 (State S) r, ConvertParams ps ps2, Arbitrary f2, Arbitrary r, CoArbitrary r)+ => SignatureSet (Signature ps r) where+ methodNames (Signature name _) = [name]+ allParamNames (Signature _ ps) = [paramNames ps]+ batchFromSigs = batchFromSig+ toServerMethods sig = (\f -> [toServerMethod sig f]) <$> arbitrary++instance (SignatureSet ss, TestClientFunction ps r f1, Params ps,+ MethodParams f2 ps2 (State S) r, ConvertParams ps ps2, Arbitrary f2, Arbitrary r, CoArbitrary r)+ => SignatureSet (Signature ps r :*: ss) where+ methodNames (Signature name _ :*: sigs) = name : methodNames sigs+ allParamNames (Signature _ ps :*: sigs) = paramNames ps : allParamNames sigs+ batchFromSigs (sig :*: sigs) = oneof [batchFromSig sig, batchFromSigs sigs]+ toServerMethods (sig :*: sigs) = combine <$> arbitrary <*> toServerMethods sigs+ where combine f sm = toServerMethod sig f : sm++batchFromSig sig = ((<$>) <$> arbitrary) <*> arbitraryFunctionCall (toBatchFunction sig)++newtype ToBatch ss r = ToBatch { getBatch :: ss -> Batch r }++instance Show (ToBatch ss r) where+ show _ = "ToBatch"++instance (SignatureSet ss, Arbitrary r) => Arbitrary (ToBatch ss r) where+ arbitrary = ToBatch <$> oneof+ [ promote batchFromSigs+ , promote $ combine <$> batchFromSigs <*> (batchFromSigs :: SignatureSet ss => ss -> Gen (Batch String))]+ where combine x y = (<*>) <$> x <*> y++instance (Arbitrary s, Arbitrary ss) => Arbitrary (s :*: ss) where+ arbitrary = (:*:) <$> arbitrary <*> arbitrary++newtype ToServer ss s = ToServer { getServer :: ss -> Connection (State s) }++instance Show (ToServer ss s) where+ show _ = "ToServer"++instance SignatureSet ss => Arbitrary (ToServer ss S) where+ arbitrary = ToServer <$> promote (\ss -> (call . toMethods) <$> toServerMethods ss)++testError = rpcError 9999 "Test error"++instance (Arbitrary a, Arbitrary s, CoArbitrary s) =>+ Arbitrary (RpcResult (State s) a) where+ arbitrary = (>>) <$> (sequence <$> stateSeq) <*> oneof stateEnd+ where stateEnd = [ return (throwError testError), gets <$> arbitrary ]+ stateSeq = listOf $ oneof [ put <$> arbitrary+ , modify <$> arbitrary ]++instance Arbitrary ps => Arbitrary (p ::: ps) where+ arbitrary = (:::) <$> (pack <$> arbitrary) <*> arbitrary++instance Arbitrary ps => Arbitrary (Signature ps r) where+ arbitrary = Signature <$> (pack <$> arbitrary) <*> arbitrary++class (ClientFunction ps r f, Arbitrary r, FromJSON r) => TestClientFunction ps r f where+ arbitraryFunctionCall :: f -> Gen (Batch r)++instance (Arbitrary r, FromJSON r) => TestClientFunction () r (Batch r) where+ arbitraryFunctionCall = return++instance (TestClientFunction ps r f, Arbitrary a, ToJSON a)+ => TestClientFunction (a ::: ps) r (a -> f) where+ arbitraryFunctionCall f = arbitraryFunctionCall =<< (f <$> arbitrary)++class Params ps where+ paramNames :: ps -> [Text]++instance Params () where+ paramNames _ = []++instance Params ps => Params (p ::: ps) where+ paramNames (p ::: ps) = p : paramNames ps
+ tests/Tests.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE CPP,+ OverloadedStrings,+ TypeOperators #-}++#if MIN_VERSION_mtl(2,2,1)+{-# OPTIONS_GHC -fno-warn-deprecations #-}+#endif++module Tests (tests) where++import Network.JsonRpc.Client+import Network.JsonRpc.ServerAdapter+import Network.JsonRpc.Server (toMethods, rpcError, 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 Control.Monad.Error (runErrorT, throwError)+import Control.Monad.State (State, runState, evalState, modify, when)+import Test.HUnit hiding (State, Test)+import Test.Framework (Test)+import Test.Framework.Providers.HUnit (testCase)+import Prelude hiding (subtract)++tests :: [Test]+tests = [ testCase "single request" $ runServer (subtract 22 1) @?= (Right 21, 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)++ , let result = myRunBatch $ (+) <$> subtractB 5 3 <*> ((*) <$> subtractB 11 2 <*> subtractB 15 10)+ in testCase "batch 2" $ 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 "single notification" $+ runServer (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)++ , let result = myRunBatch $ (,) <$> subtractB 5 4 <*> subtractB_ 20 16+ in testCase "notification at end of batch" $ 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" $ runServer (divide 10 0) @?= (Left (-32050), 0)++ , 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)++ , let result = myRunBatch $ divideB 1 0 <|> divideB 2 1+ in testCase "batch alternative with failure first" $ result @?= (Right 2, 1)++ , let result = myRunBatch $ divideB 2 1 <|> divideB 1 0+ in testCase "batch alternative with failure last" $ result @?= (Right 2, 1)++ , let result = myRunBatch $ divideB 2 0 <|> divideB 1 0+ in testCase "batch alternative with all failures" $ result @?= (Left (-32050), 0)++ , let result = myRunBatch $ divideB 2 1 <|> divideB 1 1+ in testCase "batch alternative with no failures" $ result @?= (Right 2, 2)++ , testCase "empty batch" $ myRunBatch (empty :: Batch String) @?= (Left (-31999), 0)++ , testCase "bad JSON response" $+ assertErrorMsg (A.encode $ A.Number 3) ["Client cannot parse JSON response"]++ , 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" ]++ , let response = A.encode [A.String "element"]+ in testCase "non-object response" $+ assertErrorMsg response ["expecting a JSON-RPC response"]++ , 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"]+ ]++type Result r = RpcResult (State Int) r++subtractSig :: Signature (Int ::: Int ::: ()) Int+subtractSig = Signature "subtract" ("x" ::: "y" ::: ())++divideSig :: Signature (Double ::: Double ::: ()) Double+divideSig = Signature "divide" ("x" ::: "y" ::: ())++subtract = toFunction myServer subtractSig++subtract_ = toFunction_ myServer subtractSig++subtractB = toBatchFunction subtractSig++subtractB_ = toBatchFunction_ subtractSig++divide = toFunction myServer divideSig++divideB = toBatchFunction divideSig++runServer :: Result a -> (Either Int a, Int)+runServer server = runState (mapLeft errCode <$> runErrorT server) 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++myServer :: B.ByteString -> State Int (Maybe B.ByteString)+myServer = callWithBatchStrategy (sequence . reverse) 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++constServer :: B.ByteString -> B.ByteString -> State Int (Maybe B.ByteString)+constServer = const . return . Just++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++methods = toMethods [subtractMethod, divideMethod]++subtractMethod = toServerMethod subtractSig f+ where f :: Int -> Int -> RpcResult (State Int) Int+ f x y = (x - y) <$ modify (+1)++divideMethod = toServerMethod divideSig f+ where f :: Double -> Double -> RpcResult (State Int) Double+ f x y = do+ when (y == 0) $ throwError $ rpcError (-32050) "divide by zero"+ x / y <$ modify (+1)