Simplified API by removing Methods type.

Author: grayjay

changelog.md

@@ -0,0 +1,5 @@
+0.2.0.0
+
+* Updated the error handling type from ErrorT to ExceptT.
+
+* Simplified the call function, so Methods and toMethods are no longer necessary.

demo/Demo.hs

@@ -23,10 +23,8 @@ main = do
 
 type Server = ReaderT (MVar Integer) IO
 
-methods :: Methods Server
-methods = toMethods [add, printSequence, increment]
-
-add, printSequence, increment :: Method Server
+methods :: [Method Server]
+methods = [add, printSequence, increment]
 
 add = toMethod "add" f (Required "x" :+: Required "y" :+: ())
     where f :: Double -> Double -> RpcResult Server Double

json-rpc-server.cabal

@@ -9,9 +9,9 @@ category:            Network, JSON
 maintainer:          Kristen Kozak <[email protected]>
 synopsis:            JSON-RPC 2.0 on the server side.
 build-type:          Simple
+extra-source-files:  changelog.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, GHC == 7.10.1
+tested-with:         GHC == 7.0.1, GHC == 7.6.2, 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,

src/Network/JsonRpc/Server.hs

@@ -20,8 +20,6 @@ module Network.JsonRpc.Server (
                              RpcResult
                            , Method
                            , toMethod
-                           , Methods
-                           , toMethods
                            , call
                            , callWithBatchStrategy
                            , Parameter(..)
@@ -30,7 +28,10 @@ module Network.JsonRpc.Server (
                           -- ** Errors
                            , RpcError (..)
                            , rpcError
-                           , rpcErrorWithData) where
+                           , rpcErrorWithData
+                           -- ** Deprecated
+                           , Methods
+                           , toMethods) where
 
 import Network.JsonRpc.Types
 import Data.Text (Text, append, pack)
@@ -40,7 +41,7 @@ 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 (liftM, (<=<))
 import Control.Monad.Identity (runIdentity)
 import Control.Monad.Except (runExceptT, throwError)
 
@@ -52,10 +53,8 @@ import Control.Applicative ((<$>))
 -- * Create methods by calling 'toMethod' and providing the method
 --   names, lists of parameters, and functions to be called.
 --
--- * Create a set of methods by calling 'toMethods'.
---
 -- * Process a request by calling 'call' or 'callWithBatchStrategy'
---   on the 'Methods' and input 'B.ByteString'.
+--   on the 'Method's and input 'B.ByteString'.
 
 -- $requests
 -- This library handles by-name and by-position arguments, batch and
@@ -78,54 +77,65 @@ import Control.Applicative ((<$>))
 -- | Creates a method from a name, function, and parameter descriptions.
 --   The parameter names must be unique.
 toMethod :: (MethodParams f p m r, A.ToJSON r, Monad m) => Text -> f -> p -> Method m
-toMethod name f params = let f' args = A.toJSON <$> _apply f params args
+toMethod name f params = let f' args = A.toJSON `liftM` _apply f params args
                          in Method name f'
 
--- | Creates a set of methods to be called by name. The names must be unique.
+type Methods m = [Method m]
+{-# DEPRECATED Methods "Use ['Method' m]." #-}
+
 toMethods :: [Method m] -> Methods m
-toMethods fs = Methods $ H.fromList $ map pair fs
-    where pair mth@(Method name _) = (name, mth)
+toMethods = id
+{-# DEPRECATED toMethods "Use 'call' directly." #-}
+
+type MethodMap m = H.HashMap Text (Method m)
 
 -- | Handles one JSON-RPC request. It is the same as
 --   @callWithBatchStrategy sequence@.
-call :: Monad m => Methods m   -- ^ Choice of methods to call.
+call :: Monad m => [Method 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.
 call = callWithBatchStrategy sequence
 
--- | Handles one JSON-RPC request.
+-- | Handles one JSON-RPC request. The method names must be unique.
 callWithBatchStrategy :: Monad m =>
                          (forall a . NFData a => [m a] -> m [a]) -- ^ Function specifying the
                                                                  --   evaluation strategy.
-                      -> Methods m                               -- ^ Choice of methods to call.
+                      -> [Method 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 $ runExceptT $ parseVal =<< parseJson input
-          parseJson = maybe invalidJson return . A.decode
-          parseVal val = case val of
-                           obj@(A.Object _) -> return $ Left obj
-                           A.Array vec | V.null vec -> throwInvalidRpc "Empty batch request"
-                                       | otherwise -> return $ Right $ V.toList vec
-                           _ -> throwInvalidRpc "Not a JSON object or array"
-          callMethod rq = case rq of
-                            Left val -> encodeJust `liftM` singleCall fs val
-                            Right vals -> encodeJust `liftM` batchCall strategy fs vals
-              where encodeJust r = A.encode <$> r
-          returnErr = return . Just . A.encode . nullIdResponse
-          invalidJson = throwError $ rpcError (-32700) "Invalid JSON"
-
-singleCall :: Monad m => Methods m -> A.Value -> m (Maybe Response)
-singleCall (Methods fs) val = case parsed of
+callWithBatchStrategy strategy methods =
+    mthMap `seq` either returnErr callMethod . parse
+  where
+    mthMap = H.fromList $
+             map (\mth@(Method name _) -> (name, mth)) methods
+    parse :: B.ByteString -> Either RpcError (Either A.Value [A.Value])
+    parse = runIdentity . runExceptT . parseVal <=< parseJson
+    parseJson = maybe invalidJson return . A.decode
+    parseVal val =
+        case val of
+          obj@(A.Object _) -> return $ Left obj
+          A.Array vec | V.null vec -> throwInvalidRpc "Empty batch request"
+                      | otherwise -> return $ Right $ V.toList vec
+          _ -> throwInvalidRpc "Not a JSON object or array"
+    callMethod rq =
+        case rq of
+          Left val -> encodeJust `liftM` singleCall mthMap val
+          Right vals -> encodeJust `liftM` batchCall strategy mthMap vals
+      where
+        encodeJust r = A.encode <$> r
+    returnErr = return . Just . A.encode . nullIdResponse
+    invalidJson = throwError $ rpcError (-32700) "Invalid JSON"
+
+singleCall :: Monad m => MethodMap m -> A.Value -> m (Maybe Response)
+singleCall methods val = case parsed of
                                 Left err -> return $ nullIdResponse err
                                 Right (Request name args i) ->
                                   toResponse i `liftM` runExceptT (applyMethodTo args =<< method)
-                                    where method = lookupMethod name fs
+                                    where method = lookupMethod name methods
     where parsed = runIdentity $ runExceptT $ parseValue val
           applyMethodTo args (Method _ f) = f args
 
@@ -137,19 +147,19 @@ parseValue val = case A.fromJSON val of
                    A.Error msg -> throwInvalidRpc $ pack msg
                    A.Success x -> return x
 
-lookupMethod :: Monad m => Text -> H.HashMap Text (Method m) -> RpcResult m (Method m)
+lookupMethod :: Monad m => Text -> MethodMap m -> RpcResult m (Method m)
 lookupMethod name = maybe notFound return . H.lookup name
     where notFound = throwError $ rpcError (-32601) $ "Method not found: " `append` name
 
 throwInvalidRpc :: Monad m => Text -> RpcResult m a
 throwInvalidRpc = throwError . rpcErrorWithData (-32600) "Invalid JSON-RPC 2.0 request"
 
 batchCall :: Monad m => (forall a. NFData a => [m a] -> m [a])
-          -> Methods m
+          -> MethodMap m
           -> [A.Value]
           -> m (Maybe [Response])
-batchCall strategy mths vals = (noNull . catMaybes) `liftM` results
-    where results = strategy $ map (singleCall mths) vals
+batchCall strategy methods vals = (noNull . catMaybes) `liftM` results
+    where results = strategy $ map (singleCall methods) vals
           noNull rs = if null rs then Nothing else Just rs
 
 toResponse :: A.ToJSON a => Maybe Id -> Either RpcError a -> Maybe Response

src/Network/JsonRpc/Types.hs

@@ -9,7 +9,6 @@
 
 module Network.JsonRpc.Types ( RpcResult
                              , Method (..)
-                             , Methods (..)
                              , Parameter(..)
                              , (:+:) (..)
                              , MethodParams (..)
@@ -56,10 +55,10 @@ infixr :+:
 --   monad ('m'), and return type ('r'). 'p' has one 'Parameter' for
 --   every argument of 'f' and is terminated by @()@. The return type
 --   of 'f' is @RpcResult m r@. This class is treated as closed.
-class (Monad m, Functor m, A.ToJSON r) => MethodParams f p m r | f -> p m r, p m r -> f where
+class (Monad m, A.ToJSON r) => MethodParams f p m r | f -> p m r, p m r -> f where
     _apply :: f -> p -> Args -> RpcResult m r
 
-instance (Monad m, Functor m, A.ToJSON r) => MethodParams (RpcResult m r) () m r where
+instance (Monad m, A.ToJSON r) => MethodParams (RpcResult m r) () m r where
     _apply _ _ (Right ar) | not $ V.null ar =
                              throwError $ rpcError (-32602) "Too many unnamed arguments"
     _apply res _ _ = res
@@ -90,12 +89,9 @@ paramName :: Parameter a -> Text
 paramName (Optional n _) = n
 paramName (Required n) = n
 
--- | Single method.
+-- | A JSON-RPC method.
 data Method m = Method Text (Args -> RpcResult m A.Value)
 
--- | Multiple methods.
-newtype Methods m = Methods (H.HashMap Text (Method m))
-
 type Args = Either A.Object A.Array
 
 data Request = Request Text Args (Maybe Id)

tests/TestParallelism.hs

@@ -37,7 +37,7 @@ testParallelizingTasks = do
                            , unlockRequest 'B'
                            , lockRequest 2
                            , unlockRequest 'A']
-          createMethods lock = S.toMethods [lockMethod lock, unlockMethod lock]
+          createMethods lock = [lockMethod lock, unlockMethod lock]
 
 possibleResponses :: [[A.Value]]
 possibleResponses = (rsp <$>) <$> perms

tests/TestSuite.hs

@@ -35,7 +35,7 @@ main = defaultMain $ errorHandlingTests ++ otherTests
 
 errorHandlingTests :: [Test]
 errorHandlingTests = [ testCase "invalid JSON" $
-                           let rsp = runIdentity $ S.call (S.toMethods []) $ LB.pack "{"
+                           let rsp = runIdentity $ S.call [] $ LB.pack "{"
                            in removeErrMsg <$> (A.decode =<< rsp) @?= Just (nullIdErrRsp (-32700))
 
                      , testCase "invalid JSON-RPC" $
@@ -140,7 +140,7 @@ testBatch = sortBy (compare `on` rspToIdString) <$> response @?= Just expected
 
 testBatchNotifications :: Assertion
 testBatchNotifications = runState response 0 @?= (Nothing, 10)
-    where response = S.call (S.toMethods [incrementStateMethod]) $ A.encode rq
+    where response = S.call [incrementStateMethod] $ A.encode rq
           rq = replicate 10 $ request Nothing "increment" Nothing
 
 testAllowMissingVersion :: Assertion
@@ -160,15 +160,13 @@ assertGetTimeResponse args = passed @? "unexpected RPC response"
           rsp = callGetTimeMethod req
 
 callSubtractMethods :: A.Value -> Maybe A.Value
-callSubtractMethods req = let methods :: S.Methods Identity
-                              methods = S.toMethods [subtractMethod, flippedSubtractMethod]
+callSubtractMethods req = let methods :: [S.Method Identity]
+                              methods = [subtractMethod, flippedSubtractMethod]
                               rsp = S.call methods $ A.encode req
                           in A.decode =<< runIdentity rsp
 
 callGetTimeMethod :: A.Value -> IO (Maybe A.Value)
-callGetTimeMethod req = let methods :: S.Methods IO
-                            methods = S.toMethods [getTimeMethod]
-                            rsp = S.call methods $ A.encode req
+callGetTimeMethod req = let rsp = S.call [getTimeMethod] $ A.encode req
                         in (A.decode =<<) <$> rsp
 
 subtractMethod :: S.Method Identity