json-rpc-server 0.1.6.0 → 0.2.0.0

raw patch · 8 files changed

+96/−113 lines, 8 filesdep ~mtlPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: mtl

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• changelog.md +5/−0
• demo/Demo.hs +3/−5
• json-rpc-server.cabal +9/−7
• src/Network/JsonRpc/Server.hs +52/−48
• src/Network/JsonRpc/Types.hs +20/−44
• tests/TestParallelism.hs +1/−1
• tests/TestSuite.hs +5/−7

@@ -1,6 +1,6 @@ The MIT License (MIT) -Copyright (c) 2013 grayjay+Copyright (c) 2013 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

@@ -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.

@@ -9,7 +9,7 @@ import Data.Maybe (fromMaybe) import Control.Monad (forM_, when) import Control.Monad.Trans (liftIO)-import Control.Monad.Error (throwError)+import Control.Monad.Except (throwError) import Control.Monad.Reader (ReaderT, ask, runReaderT) import Control.Concurrent.MVar (MVar, newMVar, modifyMVar) @@ -23,10 +23,8 @@  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

@@ -2,16 +2,18 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                json-rpc-server-version:             0.1.6.0+version:             0.2.0.0 license:             MIT license-file:        LICENSE category:            Network, JSON maintainer:          Kristen Kozak <grayjay@wordroute.com> 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+homepage:            https://github.com/grayjay/json-rpc-server+bug-reports:         https://github.com/grayjay/json-rpc-server/issues 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,@@ -24,7 +26,7 @@  source-repository head   type:              git-  location:          https://github.com/grayjay/json-rpc-server+  location:          git://github.com/grayjay/json-rpc-server.git  flag demo   description:       Builds the JSON-RPC demo.@@ -38,7 +40,7 @@                        aeson >=0.6 && <0.10,                        deepseq >= 1.1 && <1.5,                        bytestring >=0.9 && <0.11,-                       mtl >=1.1.1 && <2.3,+                       mtl >=2.2.1 && <2.3,                        text >=0.11 && <1.3,                        vector >=0.7.1 && <0.11,                        unordered-containers >=0.1 && <0.3@@ -52,7 +54,7 @@     build-depends:     base >=4.3 && <4.9,                        json-rpc-server,                        bytestring >=0.9 && <0.11,-                       mtl >=1.1.1 && <2.3+                       mtl >=2.2.1 && <2.3   else     buildable:         False @@ -68,7 +70,7 @@                        test-framework-hunit >=0.3 && <0.4,                        aeson >=0.6 && <0.10,                        bytestring >=0.9 && <0.11,-                       mtl >=1.1.1 && <2.3,+                       mtl >=2.2.1 && <2.3,                        text >=0.11 && <1.3,                        vector >=0.7.1 && <0.11,                        unordered-containers >=0.1 && <0.3

@@ -4,10 +4,6 @@              TypeOperators,              OverloadedStrings #-} -#if MIN_VERSION_mtl(2,2,1)-{-# OPTIONS_GHC -fno-warn-deprecations #-}-#endif- -- | Functions for implementing the server side of JSON-RPC 2.0. --   See <http://www.jsonrpc.org/specification>. module Network.JsonRpc.Server (@@ -24,8 +20,6 @@                              RpcResult                            , Method                            , toMethod-                           , Methods-                           , toMethods                            , call                            , callWithBatchStrategy                            , Parameter(..)@@ -34,7 +28,10 @@                           -- ** Errors                            , RpcError (..)                            , rpcError-                           , rpcErrorWithData) where+                           , rpcErrorWithData+                           -- ** Deprecated+                           , Methods+                           , toMethods) where  import Network.JsonRpc.Types import Data.Text (Text, append, pack)@@ -44,9 +41,9 @@ 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.Error (runErrorT, throwError)+import Control.Monad.Except (runExceptT, throwError)  #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>))@@ -56,10 +53,8 @@ -- * 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@@ -87,7 +82,7 @@ -- > import Data.Maybe (fromMaybe) -- > import Control.Monad (forM_, when) -- > import Control.Monad.Trans (liftIO)--- > import Control.Monad.Error (throwError)+-- > import Control.Monad.Except (throwError) -- > import Control.Monad.Reader (ReaderT, ask, runReaderT) -- > import Control.Concurrent.MVar (MVar, newMVar, modifyMVar) -- > @@ -101,10 +96,8 @@ -- >  -- > 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@@ -129,55 +122,66 @@ -- | 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 $ runErrorT $ 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"+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 => Methods m -> A.Value -> m (Maybe Response)-singleCall (Methods fs) val = case parsed of+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` runErrorT (applyMethodTo args =<< method)-                                    where method = lookupMethod name fs-    where parsed = runIdentity $ runErrorT $ parseValue val+                                  toResponse i `liftM` runExceptT (applyMethodTo args =<< method)+                                    where method = lookupMethod name methods+    where parsed = runIdentity $ runExceptT $ parseValue val           applyMethodTo args (Method _ f) = f args  nullIdResponse :: RpcError -> Maybe Response@@ -188,7 +192,7 @@                    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 @@ -196,11 +200,11 @@ 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

@@ -7,13 +7,8 @@              TypeSynonymInstances,              OverloadedStrings #-} -#if MIN_VERSION_mtl(2,2,1)-{-# OPTIONS_GHC -fno-warn-deprecations #-}-#endif- module Network.JsonRpc.Types ( RpcResult                              , Method (..)-                             , Methods (..)                              , Parameter(..)                              , (:+:) (..)                              , MethodParams (..)@@ -24,7 +19,6 @@                              , rpcError                              , rpcErrorWithData) where -import Data.String (fromString) import Data.Maybe (catMaybes) import Data.Text (Text, append, unpack) import qualified Data.Aeson as A@@ -33,8 +27,8 @@ 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 Control.Monad (when)+import Control.Monad.Except (ExceptT (..), throwError) import Prelude hiding (length) import Control.Applicative ((<|>), empty) @@ -44,7 +38,7 @@  -- | 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+type RpcResult m r = ExceptT RpcError m r  -- | Parameter expected by a method. data Parameter a@@ -61,43 +55,32 @@ --   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-    apply :: f -> p -> Args -> RpcResult m r+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-    apply _ _ (Right ar) | not $ V.null ar =+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+    _apply res _ _ = res  instance (A.FromJSON a, MethodParams f p m r) => MethodParams (a -> f) (a :+: p) m r where-    apply f (param :+: ps) args = arg >>= \a -> apply (f a) ps nextArgs-        where arg = either (parseArg name) return =<<-                    (Left <$> lookupValue) `mplus` (Right <$> paramDefault param)-              lookupValue = either (lookupArg name) (headArg name) args-              nextArgs = tailOrEmpty <$> args-              name = paramName param--lookupArg :: Monad m => Text -> A.Object -> RpcResult m A.Value-lookupArg name hm = case H.lookup name hm of-                      Nothing -> throwError $ missingArgError name-                      Just v -> return v--headArg :: Monad m => Text -> A.Array -> RpcResult m A.Value-headArg name vec | V.null vec = throwError $ missingArgError name-                 | otherwise = return $ V.head vec--tailOrEmpty :: A.Array -> A.Array-tailOrEmpty vec = if V.null vec then V.empty else V.tail vec+    _apply f (param :+: ps) args =+        ExceptT (return arg) >>= \a -> _apply (f a) ps nextArgs+      where+        arg = maybe (paramDefault param) (parseArg name) lookupValue+        lookupValue = either (H.lookup name) (V.!? 0) args+        nextArgs = V.drop 1 <$> args+        name = paramName param -parseArg :: (Monad m, A.FromJSON r) => Text -> A.Value -> RpcResult m r+parseArg :: A.FromJSON r => Text -> A.Value -> Either RpcError r parseArg name val = case A.fromJSON val of                       A.Error msg -> throwError $ argTypeError msg                       A.Success x -> return x     where argTypeError = rpcErrorWithData (-32602) $ "Wrong type for argument: " `append` name -paramDefault :: Monad m => Parameter a -> RpcResult m a-paramDefault (Optional _ d) = return d-paramDefault (Required name) = throwError $ missingArgError name+paramDefault :: Parameter a -> Either RpcError a+paramDefault (Optional _ d) = Right d+paramDefault (Required name) = Left $ missingArgError name  missingArgError :: Text -> RpcError missingArgError name = rpcError (-32602) $ "Cannot find required argument: " `append` name@@ -106,12 +89,9 @@ 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)@@ -174,10 +154,6 @@  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"-    strMsg msg = RpcError (-32000) (fromString msg) Nothing  instance A.ToJSON RpcError where     toJSON (RpcError code msg data') = A.object pairs

@@ -37,7 +37,7 @@                            , 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

@@ -35,7 +35,7 @@  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 @@  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 @@           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