diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/changelog.md b/changelog.md new file mode 100644 --- /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 --- a/demo/Demo.hs +++ b/demo/Demo.hs @@ -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 diff --git a/json-rpc-server.cabal b/json-rpc-server.cabal --- a/json-rpc-server.cabal +++ b/json-rpc-server.cabal @@ -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 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 . 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 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 @@ -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 . 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 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 @@ -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 diff --git a/tests/TestParallelism.hs b/tests/TestParallelism.hs --- a/tests/TestParallelism.hs +++ b/tests/TestParallelism.hs @@ -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 diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -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