diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,4 +2,4 @@ =============== [![Build Status](https://travis-ci.org/grayjay/json-rpc-server.svg?branch=master)](https://travis-ci.org/grayjay/json-rpc-server) -An implementation of the server side of JSON RPC 2.0. See . This library uses ByteString for input and output, leaving the choice of transport up to the user. The documentation is on Hackage: . +An implementation of the server side of JSON-RPC 2.0. See . This library uses ByteString for input and output, leaving the choice of transport up to the user. The documentation is on Hackage: . diff --git a/demo/Demo.hs b/demo/Demo.hs --- a/demo/Demo.hs +++ b/demo/Demo.hs @@ -3,34 +3,35 @@ module Main (main) where import Network.JsonRpc.Server -import Happstack.Server.SimpleHTTP( ServerPartT, simpleHTTP, nullConf - , askRq, rqBody, unBody, toResponse) +import qualified Data.ByteString.Lazy.Char8 as B import Data.List (intercalate) import Data.Maybe (fromMaybe) -import Control.Monad (when) +import Control.Monad (forM_, when) import Control.Monad.Trans (liftIO) import Control.Monad.Error (throwError) import Control.Monad.Reader (ReaderT, ask, runReaderT) -import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar) +import Control.Concurrent.MVar (MVar, newMVar, modifyMVar) main :: IO () -main = newMVar 0 >>= \count -> - simpleHTTP nullConf $ do - request <- askRq - body <- liftIO $ getBody request - result <- runReaderT (call methods body) count - let resultStr = fromMaybe "" result - return $ toResponse resultStr - where getBody r = unBody `fmap` readMVar (rqBody r) +main = do + contents <- B.getContents + count <- newMVar 0 + forM_ (B.lines contents) $ \request -> do + response <- runReaderT (call methods request) count + B.putStrLn $ fromMaybe "" response -type Server = ReaderT (MVar Integer) (ServerPartT IO) +type Server = ReaderT (MVar Integer) IO methods :: Methods Server -methods = toMethods [printSequence, getCount, add] +methods = toMethods [add, printSequence, increment] -printSequence, getCount, add :: Method Server +add, printSequence, increment :: Method Server -printSequence = toMethod "print" f params +add = toMethod "add" f (Required "x" :+: Required "y" :+: ()) + where f :: Double -> Double -> RpcResult Server Double + f x y = liftIO $ return (x + y) + +printSequence = toMethod "print_sequence" f params where params = Required "string" :+: Optional "count" 1 :+: Optional "separator" ',' :+: () @@ -40,11 +41,7 @@ liftIO $ print $ intercalate [sep] $ replicate count str negativeCount = rpcError (-32000) "negative count" -getCount = toMethod "get_count" f () +increment = toMethod "increment_and_get_count" f () where f :: RpcResult Server Integer f = ask >>= \count -> liftIO $ modifyMVar count inc where inc x = return (x + 1, x + 1) - -add = toMethod "add" f (Required "x" :+: Required "y" :+: ()) - where f :: Double -> Double -> RpcResult Server Double - f x y = liftIO $ return (x + y) diff --git a/json-rpc-server.cabal b/json-rpc-server.cabal --- a/json-rpc-server.cabal +++ b/json-rpc-server.cabal @@ -2,28 +2,28 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: json-rpc-server -version: 0.1.3.0 +version: 0.1.4.0 license: MIT license-file: LICENSE category: Network, JSON maintainer: Kristen Kozak -synopsis: JSON RPC 2.0 on the server side. +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 -description: An implementation of the server side of JSON RPC 2.0. +description: An implementation of the server side of JSON-RPC 2.0. See . This library uses 'ByteString' for input and output, leaving the choice of transport up to the user. - See the 'Network.JsonRpc.Server' module for an example. + See the "Network.JsonRpc.Server" module for an example. source-repository head type: git location: https://github.com/grayjay/json-rpc-server flag demo - description: Builds the demo Happstack JSON RPC server. + description: Builds the JSON-RPC demo. default: False manual: True @@ -46,8 +46,8 @@ if flag (demo) build-depends: base >=4.3 && <4.8, json-rpc-server, - mtl >=1.1.1 && <2.3, - happstack-server >=6.2.4 && <7.4 + bytestring >=0.9 && <0.11, + mtl >=1.1.1 && <2.3 ghc-options: -Wall else buildable: False 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 @@ -8,14 +8,14 @@ {-# OPTIONS_GHC -fno-warn-deprecations #-} #endif --- | Functions for implementing the server side of JSON RPC 2.0. +-- | Functions for implementing the server side of JSON-RPC 2.0. -- See . module Network.JsonRpc.Server ( -- ** Instructions -- $instructions - -- ** Unnamed and Optional Arguments - -- $arguments + -- ** Requests + -- $requests -- ** Example -- $example @@ -32,7 +32,7 @@ , (:+:) (..) , MethodParams -- ** Errors - , RpcError + , RpcError (..) , rpcError , rpcErrorWithData) where @@ -57,51 +57,55 @@ -- * Process a request by calling 'call' or 'callWithBatchStrategy' -- on the 'Methods' and input 'B.ByteString'. --- $arguments --- RPC methods can have any mix of required and optional parameters. --- When a request uses unnamed arguments, the function is applied to --- the arguments in order. The function will be called as long as --- all required arguments are specified, and the number of arguments --- provided is not greater than the total number of required and --- optional parameters. +-- $requests +-- This library handles by-name and by-position arguments, batch and +-- single requests, and notifications. It also allows each +-- parameter of a method to be either optional (with a default value) +-- or required. The function is called as long as all required +-- arguments are present. A request providing more positional +-- arguments than the total number of optional and required +-- parameters to a function results in an error. However, additional +-- by-name arguments are ignored. -- $example --- Here is an example of a simple Happstack server with three methods. --- Compile it with the build flag @demo@. +-- Here is an example with three JSON-RPC methods. It reads requests +-- from stdin and writes responses to stdout. Compile it with the +-- build flag @demo@. -- -- > {-# LANGUAGE OverloadedStrings #-} -- > -- > module Main (main) where -- > -- > import Network.JsonRpc.Server --- > import Happstack.Server.SimpleHTTP( ServerPartT, simpleHTTP, nullConf --- > , askRq, rqBody, unBody, toResponse) +-- > import qualified Data.ByteString.Lazy.Char8 as B -- > import Data.List (intercalate) -- > import Data.Maybe (fromMaybe) --- > import Control.Monad (when) +-- > import Control.Monad (forM_, when) -- > import Control.Monad.Trans (liftIO) -- > import Control.Monad.Error (throwError) -- > import Control.Monad.Reader (ReaderT, ask, runReaderT) --- > import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar) +-- > import Control.Concurrent.MVar (MVar, newMVar, modifyMVar) -- > -- > main :: IO () --- > main = newMVar 0 >>= \count -> --- > simpleHTTP nullConf $ do --- > request <- askRq --- > body <- liftIO $ getBody request --- > result <- runReaderT (call methods body) count --- > let resultStr = fromMaybe "" result --- > return $ toResponse resultStr --- > where getBody r = unBody `fmap` readMVar (rqBody r) +-- > main = do +-- > contents <- B.getContents +-- > count <- newMVar 0 +-- > forM_ (B.lines contents) $ \request -> do +-- > response <- runReaderT (call methods request) count +-- > B.putStrLn $ fromMaybe "" response -- > --- > type Server = ReaderT (MVar Integer) (ServerPartT IO) +-- > type Server = ReaderT (MVar Integer) IO -- > -- > methods :: Methods Server --- > methods = toMethods [printSequence, getCount, add] +-- > methods = toMethods [add, printSequence, increment] -- > --- > printSequence, getCount, add :: Method Server +-- > add, printSequence, increment :: Method Server -- > --- > printSequence = toMethod "print" f params +-- > add = toMethod "add" f (Required "x" :+: Required "y" :+: ()) +-- > where f :: Double -> Double -> RpcResult Server Double +-- > f x y = liftIO $ return (x + y) +-- > +-- > printSequence = toMethod "print_sequence" f params -- > where params = Required "string" :+: -- > Optional "count" 1 :+: -- > Optional "separator" ',' :+: () @@ -111,14 +115,10 @@ -- > liftIO $ print $ intercalate [sep] $ replicate count str -- > negativeCount = rpcError (-32000) "negative count" -- > --- > getCount = toMethod "get_count" f () +-- > increment = toMethod "increment_and_get_count" f () -- > where f :: RpcResult Server Integer -- > f = ask >>= \count -> liftIO $ modifyMVar count inc -- > where inc x = return (x + 1, x + 1) --- > --- > add = toMethod "add" f (Required "x" :+: Required "y" :+: ()) --- > where f :: Double -> Double -> RpcResult Server Double --- > f x y = liftIO $ return (x + y) -- -- | Creates a method from a name, function, and parameter descriptions. @@ -132,21 +132,21 @@ toMethods fs = Methods $ H.fromList $ map pair fs where pair mth@(Method name _) = (name, mth) --- | Handles one JSON RPC request. It is the same as +-- | Handles one JSON-RPC request. It is the same as -- @callWithBatchStrategy sequence@. call :: Monad m => Methods m -- ^ Choice of methods to call. - -> B.ByteString -- ^ JSON RPC request. + -> 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. 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. + -> 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. @@ -188,7 +188,7 @@ 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" +throwInvalidRpc = throwError . rpcErrorWithData (-32600) "Invalid JSON-RPC 2.0 request" batchCall :: Monad m => (forall a. [m a] -> m [a]) -> Methods m 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 @@ -20,7 +20,7 @@ , Request (..) , Response (..) , Id (..) - , RpcError + , RpcError (..) , rpcError , rpcErrorWithData) where @@ -56,7 +56,7 @@ -- 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 where +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 instance (Monad m, Functor m, A.ToJSON r) => MethodParams (RpcResult m r) () m r where @@ -113,15 +113,15 @@ instance A.FromJSON Request where parseJSON (A.Object x) = (checkVersion =<< x .:? versionKey .!= jsonRpcVersion) *> - (Request <$> - x .: "method" <*> - (parseParams =<< x .:? "params" .!= emptyObject) <*> - parseId) + (Request <$> + x .: "method" <*> + (parseParams =<< x .:? "params" .!= emptyObject) <*> + parseId) where parseParams (A.Object obj) = return $ Left obj parseParams (A.Array ar) = return $ Right ar parseParams _ = empty checkVersion ver = when (ver /= jsonRpcVersion) $ - fail $ "Wrong JSON RPC version: " ++ unpack ver + fail $ "Wrong JSON-RPC version: " ++ unpack ver -- (.:?) parses Null value as Nothing so parseId needs -- to use both (.:?) and (.:) to handle all cases parseId = x .:? idKey >>= \optional -> @@ -153,9 +153,11 @@ toJSON (IdNumber x) = x toJSON IdNull = A.Null --- | Error to be returned to the client. -data RpcError = RpcError Int Text (Maybe A.Value) - deriving Show +-- | JSON-RPC error. +data RpcError = RpcError { errCode :: Int + , errMsg :: Text + , errData :: Maybe A.Value } + deriving (Show, Eq) instance Error RpcError where noMsg = strMsg "unknown error" @@ -166,6 +168,13 @@ where pairs = catMaybes [ Just $ "code" .= code , Just $ "message" .= msg , ("data" .=) <$> data' ] + +instance A.FromJSON RpcError where + parseJSON (A.Object v) = RpcError <$> + v .: "code" <*> + v .: "message" <*> + v .:? "data" + parseJSON _ = empty -- | Creates an 'RpcError' with the given error code and message. -- According to the specification, server error codes should be diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -32,7 +32,7 @@ errorHandlingTests = [ testCase "invalid JSON" $ assertSubtractResponse (A.String "5") $ nullIdErrRsp (-32700) - , testCase "invalid JSON RPC" $ + , testCase "invalid JSON-RPC" $ assertSubtractResponse (A.object ["id" .= A.Number 10]) $ nullIdErrRsp (-32600) , testCase "empty batch call" $