From 561bbf8251465bd70f12a605d3d63a939c4eea9b Mon Sep 17 00:00:00 2001 From: Kristen Kozak Date: Sun, 5 Jul 2015 17:58:01 -0700 Subject: [PATCH] Simplified API by removing Methods type. --- changelog.md | 5 +++ demo/Demo.hs | 6 +-- json-rpc-server.cabal | 4 +- src/Network/JsonRpc/Server.hs | 84 ++++++++++++++++++++--------------- src/Network/JsonRpc/Types.hs | 10 ++--- tests/TestParallelism.hs | 2 +- tests/TestSuite.hs | 12 +++-- 7 files changed, 65 insertions(+), 58 deletions(-) create mode 100644 changelog.md diff --git a/changelog.md b/changelog.md new file mode 100644 index 0000000..a9cf539 --- /dev/null +++ b/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. diff --git a/demo/Demo.hs b/demo/Demo.hs index cbcc83c..0e02d5f 100644 --- a/demo/Demo.hs +++ b/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 diff --git a/json-rpc-server.cabal b/json-rpc-server.cabal index d0c235a..241f17e 100644 --- a/json-rpc-server.cabal +++ b/json-rpc-server.cabal @@ -9,9 +9,9 @@ category: Network, JSON maintainer: Kristen Kozak 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 . This library uses 'ByteString' for input and output, diff --git a/src/Network/JsonRpc/Server.hs b/src/Network/JsonRpc/Server.hs index 38a9580..470ce76 100644 --- a/src/Network/JsonRpc/Server.hs +++ b/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,7 +147,7 @@ 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 @@ -145,11 +155,11 @@ 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 diff --git a/src/Network/JsonRpc/Types.hs b/src/Network/JsonRpc/Types.hs index 4db3a61..6833548 100644 --- a/src/Network/JsonRpc/Types.hs +++ b/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) diff --git a/tests/TestParallelism.hs b/tests/TestParallelism.hs index 011a2b5..2819fa7 100644 --- a/tests/TestParallelism.hs +++ b/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 diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs index 5fb2c00..91517ab 100644 --- a/tests/TestSuite.hs +++ b/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