Support for using deepseq to evaluate batch requests

Author: sebright

json-rpc-server.cabal

@@ -11,7 +11,8 @@ synopsis:            JSON-RPC 2.0 on the server side.
 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 <http://www.jsonrpc.org/specification>. This
                      library uses 'ByteString' for input and output,
@@ -32,6 +33,7 @@ library
   other-modules:       Network.JsonRpc.Types
   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,

src/Network/JsonRpc/Server.hs

@@ -43,6 +43,7 @@ import qualified Data.ByteString.Lazy as B
 import qualified Data.Aeson as A
 import qualified Data.Vector as V
 import qualified Data.HashMap.Strict as H
+import Control.DeepSeq (NFData)
 import Control.Monad (liftM)
 import Control.Monad.Identity (runIdentity)
 import Control.Monad.Error (runErrorT, throwError)
@@ -100,13 +101,13 @@ call = callWithBatchStrategy sequence
 
 -- | 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
@@ -147,7 +148,7 @@ lookupMethod name = maybe notFound return . H.lookup name
 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])

src/Network/JsonRpc/Types.hs

@@ -32,6 +32,7 @@ import Data.Aeson ((.=), (.:), (.:?), (.!=))
 import Data.Aeson.Types (emptyObject)
 import qualified Data.Vector as V
 import qualified Data.HashMap.Strict as H
+import Control.DeepSeq (NFData, rnf)
 import Control.Monad (mplus, when)
 import Control.Monad.Error (Error, ErrorT, throwError, strMsg, noMsg)
 import Prelude hiding (length)
@@ -136,6 +137,9 @@ instance A.FromJSON Request where
 
 data Response = Response Id (Either RpcError A.Value)
 
+instance NFData Response where
+    rnf (Response i e) = rnf i `seq` rnf e `seq` ()
+
 instance A.ToJSON Response where
     toJSON (Response i result) = A.object pairs
         where pairs = [ versionKey .= jsonRpcVersion
@@ -146,6 +150,11 @@ instance A.ToJSON Response where
 -- 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 `seq` ()
+    rnf (IdNumber n) = rnf n `seq` ()
+    rnf IdNull = ()
+
 instance A.FromJSON Id where
     parseJSON x@(A.String _) = return $ IdString x
     parseJSON x@(A.Number _) = return $ IdNumber x
@@ -161,7 +170,10 @@ instance A.ToJSON Id where
 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 `seq` ()
 
 instance Error RpcError where
     noMsg = strMsg "unknown error"