diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,13 @@ +json-rpc-client +=============== +[![Build Status](https://travis-ci.org/grayjay/json-rpc-client.svg?branch=master)](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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/demo/Client.hs b/demo/Client.hs new file mode 100644 --- /dev/null +++ b/demo/Client.hs @@ -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 diff --git a/demo/Server.hs b/demo/Server.hs new file mode 100644 --- /dev/null +++ b/demo/Server.hs @@ -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] diff --git a/demo/Signatures.hs b/demo/Signatures.hs new file mode 100644 --- /dev/null +++ b/demo/Signatures.hs @@ -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" () diff --git a/json-rpc-client.cabal b/json-rpc-client.cabal new file mode 100644 --- /dev/null +++ b/json-rpc-client.cabal @@ -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 +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 + . 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 + . + 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 diff --git a/src/Network/JsonRpc/Client.hs b/src/Network/JsonRpc/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/JsonRpc/Client.hs @@ -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 . + + +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" diff --git a/src/Network/JsonRpc/ServerAdapter.hs b/src/Network/JsonRpc/ServerAdapter.hs new file mode 100644 --- /dev/null +++ b/src/Network/JsonRpc/ServerAdapter.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE MultiParamTypeClasses, + FunctionalDependencies, + UndecidableInstances, + TypeOperators #-} + +-- | Convenience function for creating server-side methods from +-- 'Signature's with the package +-- . +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 diff --git a/tests/All.hs b/tests/All.hs new file mode 100644 --- /dev/null +++ b/tests/All.hs @@ -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 diff --git a/tests/Properties.hs b/tests/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/Properties.hs @@ -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 diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -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)