diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,5 @@ json-rpc-server =============== -[![Build Status](https://travis-ci.org/grayjay/json-rpc-server.svg?branch=master)](https://travis-ci.org/grayjay/json-rpc-server) +[![Hackage](https://img.shields.io/hackage/v/json-rpc-server.svg?style=flat)](https://hackage.haskell.org/package/json-rpc-server) [![Build Status](https://travis-ci.org/grayjay/json-rpc-server.svg?branch=master)](https://travis-ci.org/grayjay/json-rpc-server) -An implementation of the server side of JSON-RPC 2.0. See . This library uses ByteString for input and output, leaving the choice of transport up to the user. The documentation is on Hackage: . +An implementation of the server side of JSON-RPC 2.0. See . json-rpc-server uses ByteString for input and output, leaving the choice of transport up to the user. It can be used with [json-rpc-client](http://hackage.haskell.org/package/json-rpc-client) to create a client and server that communicate with the same methods. diff --git a/demo/Demo.hs b/demo/Demo.hs --- a/demo/Demo.hs +++ b/demo/Demo.hs @@ -3,6 +3,7 @@ module Main (main) where import Network.JsonRpc.Server +import System.IO (BufferMode (LineBuffering), hSetBuffering, stdout) import qualified Data.ByteString.Lazy.Char8 as B import Data.List (intercalate) import Data.Maybe (fromMaybe) @@ -12,8 +13,8 @@ import Control.Monad.Reader (ReaderT, ask, runReaderT) import Control.Concurrent.MVar (MVar, newMVar, modifyMVar) -main :: IO () main = do + hSetBuffering stdout LineBuffering contents <- B.getContents count <- newMVar 0 forM_ (B.lines contents) $ \request -> do diff --git a/json-rpc-server.cabal b/json-rpc-server.cabal --- a/json-rpc-server.cabal +++ b/json-rpc-server.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: json-rpc-server -version: 0.1.4.0 +version: 0.1.5.0 license: MIT license-file: LICENSE category: Network, JSON @@ -11,12 +11,17 @@ build-type: Simple extra-source-files: README.md cabal-version: >=1.8 -tested-with: GHC == 7.0.1, GHC == 7.4.1, GHC == 7.6.2, GHC == 7.6.3, GHC == 7.8.3 +tested-with: GHC == 7.0.1, GHC == 7.4.1, GHC == 7.6.2, + GHC == 7.6.3, GHC == 7.8.3, GHC == 7.10.1 description: An implementation of the server side of JSON-RPC 2.0. See . This library uses 'ByteString' for input and output, leaving the choice of transport up to the user. See the "Network.JsonRpc.Server" module for an example. + json-rpc-server can be used with + + to create a client and server that communicate + with the same methods. source-repository head type: git @@ -30,8 +35,9 @@ library exposed-modules: Network.JsonRpc.Server other-modules: Network.JsonRpc.Types - build-depends: base >=4.3 && <4.8, + build-depends: base >=4.3 && <4.9, aeson >=0.6 && <0.9, + deepseq >= 1.1 && <1.5, bytestring >=0.9 && <0.11, mtl >=1.1.1 && <2.3, text >=0.11 && <1.3, @@ -44,11 +50,10 @@ main-is: Demo.hs hs-source-dirs: demo if flag (demo) - build-depends: base >=4.3 && <4.8, + build-depends: base >=4.3 && <4.9, json-rpc-server, bytestring >=0.9 && <0.11, mtl >=1.1.1 && <2.3 - ghc-options: -Wall else buildable: False @@ -57,7 +62,7 @@ main-is: TestSuite.hs other-modules: TestParallelism, Internal type: exitcode-stdio-1.0 - build-depends: base >=4.3 && <4.8, + build-depends: base >=4.3 && <4.9, json-rpc-server, HUnit >=1.2 && <1.3, test-framework >=0.7 && <0.9, diff --git a/src/Network/JsonRpc/Server.hs b/src/Network/JsonRpc/Server.hs --- a/src/Network/JsonRpc/Server.hs +++ b/src/Network/JsonRpc/Server.hs @@ -43,11 +43,15 @@ import qualified Data.Aeson as A import qualified Data.Vector as V import qualified Data.HashMap.Strict as H -import Control.Applicative ((<$>)) +import Control.DeepSeq (NFData) import Control.Monad (liftM) import Control.Monad.Identity (runIdentity) import Control.Monad.Error (runErrorT, throwError) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif + -- $instructions -- * Create methods by calling 'toMethod' and providing the method -- names, lists of parameters, and functions to be called. @@ -77,6 +81,7 @@ -- > module Main (main) where -- > -- > import Network.JsonRpc.Server +-- > import System.IO (BufferMode (LineBuffering), hSetBuffering, stdout) -- > import qualified Data.ByteString.Lazy.Char8 as B -- > import Data.List (intercalate) -- > import Data.Maybe (fromMaybe) @@ -86,8 +91,8 @@ -- > import Control.Monad.Reader (ReaderT, ask, runReaderT) -- > import Control.Concurrent.MVar (MVar, newMVar, modifyMVar) -- > --- > main :: IO () -- > main = do +-- > hSetBuffering stdout LineBuffering -- > contents <- B.getContents -- > count <- newMVar 0 -- > forM_ (B.lines contents) $ \request -> do @@ -143,13 +148,13 @@ -- | Handles one JSON-RPC request. callWithBatchStrategy :: Monad m => - (forall a . [m a] -> m [a]) -- ^ Function specifying the - -- evaluation strategy. - -> Methods m -- ^ Choice of methods to call. - -> B.ByteString -- ^ JSON-RPC request. - -> m (Maybe B.ByteString) -- ^ The response wrapped in 'Just', or - -- 'Nothing' in the case of a notification, - -- all wrapped in the given monad. + (forall a . NFData a => [m a] -> m [a]) -- ^ Function specifying the + -- evaluation strategy. + -> Methods m -- ^ Choice of methods to call. + -> B.ByteString -- ^ JSON-RPC request. + -> m (Maybe B.ByteString) -- ^ The response wrapped in 'Just', or + -- 'Nothing' in the case of a notification, + -- all wrapped in the given monad. callWithBatchStrategy strategy fs input = either returnErr callMethod request where request :: Either RpcError (Either A.Value [A.Value]) request = runIdentity $ runErrorT $ parseVal =<< parseJson input @@ -190,7 +195,7 @@ throwInvalidRpc :: Monad m => Text -> RpcResult m a throwInvalidRpc = throwError . rpcErrorWithData (-32600) "Invalid JSON-RPC 2.0 request" -batchCall :: Monad m => (forall a. [m a] -> m [a]) +batchCall :: Monad m => (forall a. NFData a => [m a] -> m [a]) -> Methods m -> [A.Value] -> m (Maybe [Response]) diff --git a/src/Network/JsonRpc/Types.hs b/src/Network/JsonRpc/Types.hs --- a/src/Network/JsonRpc/Types.hs +++ b/src/Network/JsonRpc/Types.hs @@ -32,11 +32,16 @@ import Data.Aeson.Types (emptyObject) import qualified Data.Vector as V import qualified Data.HashMap.Strict as H -import Control.Applicative ((<$>), (<*>), (<|>), (*>), empty) +import Control.DeepSeq (NFData, rnf) import Control.Monad (mplus, when) import Control.Monad.Error (Error, ErrorT, throwError, strMsg, noMsg) import Prelude hiding (length) +import Control.Applicative ((<|>), empty) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<*>), (*>)) +#endif + -- | Return type of a method. A method call can either fail with an 'RpcError' -- or succeed with a result of type 'r'. type RpcResult m r = ErrorT RpcError m r @@ -132,6 +137,9 @@ data Response = Response Id (Either RpcError A.Value) +instance NFData Response where + rnf (Response i e) = rnf i `seq` rnf e + instance A.ToJSON Response where toJSON (Response i result) = A.object pairs where pairs = [ versionKey .= jsonRpcVersion @@ -142,6 +150,11 @@ -- since it changes between aeson-0.6 and 0.7. data Id = IdString A.Value | IdNumber A.Value | IdNull +instance NFData Id where + rnf (IdString s) = rnf s + rnf (IdNumber n) = rnf n + rnf IdNull = () + instance A.FromJSON Id where parseJSON x@(A.String _) = return $ IdString x parseJSON x@(A.Number _) = return $ IdNumber x @@ -157,7 +170,10 @@ data RpcError = RpcError { errCode :: Int , errMsg :: Text , errData :: Maybe A.Value } - deriving (Show, Eq) + deriving (Show, Eq) + +instance NFData RpcError where + rnf (RpcError e m d) = rnf e `seq` rnf m `seq` rnf d instance Error RpcError where noMsg = strMsg "unknown error" diff --git a/tests/Internal.hs b/tests/Internal.hs --- a/tests/Internal.hs +++ b/tests/Internal.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP, + OverloadedStrings #-} module Internal ( request , errRsp @@ -21,7 +22,10 @@ import Data.Maybe (catMaybes) import qualified Data.Vector as V import Data.Text (Text) + +#if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) +#endif array :: [A.Value] -> A.Value array = A.Array . V.fromList diff --git a/tests/TestParallelism.hs b/tests/TestParallelism.hs --- a/tests/TestParallelism.hs +++ b/tests/TestParallelism.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP, + OverloadedStrings #-} module TestParallelism (testParallelizingTasks) where @@ -11,12 +12,15 @@ import Data.Aeson ((.=)) import qualified Data.Aeson.Types as A import Data.Maybe (fromJust) -import Control.Applicative ((<$>)) import Control.Monad.Trans (liftIO) import Control.Concurrent (forkIO) import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) import Test.HUnit (Assertion, assert) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif + -- | Tests parallelizing a batch request. Each request either -- locks or unlocks an MVar. The MVar is initially locked, -- so the first lock request cannot succeed if the requests @@ -37,7 +41,7 @@ possibleResponses :: [[A.Value]] possibleResponses = (rsp <$>) <$> perms - where perms = zip `zipWith` repeat [1, 2, 3] $ permutations ["A", "B", "C"] + where perms = map (zip [1, 2, 3]) $ permutations ["A", "B", "C"] rsp (i, r) = defaultRsp `result` A.String r `id'` Just (A.Number i) lockRequest :: Int -> A.Value diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP, + OverloadedStrings #-} module Main (main) where @@ -16,7 +17,6 @@ import Data.Aeson ((.=)) import qualified Data.Aeson.Types as A import qualified Data.HashMap.Strict as H -import Control.Applicative ((<$>)) import Control.Monad.Trans (liftIO) import Control.Monad.State (State, runState, lift, modify) import Control.Monad.Identity (Identity, runIdentity) @@ -24,6 +24,10 @@ import Test.Framework (defaultMain, Test) import Test.Framework.Providers.HUnit (testCase) import Prelude hiding (subtract) + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>)) +#endif main :: IO () main = defaultMain $ errorHandlingTests ++ otherTests