packages feed

json-rpc-server (empty) → 0.1.0.0

raw patch · 9 files changed

+859/−0 lines, 9 filesdep +HUnitdep +aesondep +attoparsecsetup-changed

Dependencies added: HUnit, aeson, attoparsec, base, bytestring, happstack-server, json-rpc-server, mtl, test-framework, test-framework-hunit, text, unordered-containers, vector

Files

+ LICENSE view
@@ -0,0 +1,20 @@+The MIT License (MIT)++Copyright (c) 2013 grayjay++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+the Software without restriction, including without limitation the rights to+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of+the Software, and to permit persons to whom the Software is furnished to do so,+subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,3 @@+json-rpc-server+===============+An implemation of the server side of JSON RPC 2.0. See <http://www.jsonrpc.org/specification>. This library uses ByteString for input and output, leaving the choice of transport up to the user. See the demo folder for an example.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ demo/Demo.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Network.JsonRpc.Server+import Happstack.Server.SimpleHTTP hiding (Method, body, result)+import Data.List (intercalate)+import Data.Maybe (fromMaybe)+import Control.Monad (when)+import Control.Monad.Trans (liftIO)+import Control.Monad.Error (throwError)+import Control.Monad.Reader (ReaderT, ask, runReaderT)+import Control.Concurrent.MVar++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)++type Server = ReaderT (MVar Integer) (ServerPartT IO)++methods :: Methods Server+methods = toMethods [printSequence, getCount, add]++printSequence, getCount, add :: Method Server++printSequence = toMethod "print" f params+    where params = Required "string" :+:+                   Optional "count" 1 :+:+                   Optional "separator" ',' :+: ()+          f :: String -> Int -> Char -> RpcResult Server ()+          f str count sep = do+              when (count < 0) $ throwError negativeCount+              liftIO $ print $ intercalate [sep] $ replicate count str+          negativeCount = rpcError (-32000) "negative count"++getCount = toMethod "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)
+ json-rpc-server.cabal view
@@ -0,0 +1,73 @@+-- Initial json-rpc-server.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                json-rpc-server+version:             0.1.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:  README.md+cabal-version:       >=1.8+tested-with:         GHC == 7.4.1, GHC == 7.6.3+description:         An implemation of the server side of JSON RPC 2.0.+                     See <http://www.jsonrpc.org/specification>. 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.++source-repository head+  type:              git+  location:          https://github.com/grayjay/json-rpc-server++flag demo+  description:       Builds the demo Happstack JSON RPC server.+  default:           False+  manual:            True++library+  exposed-modules:     Network.JsonRpc.Server+  other-modules:       Network.JsonRpc.Types+  build-depends:       base >=4.5 && <4.7,+                       aeson >=0.6 && <0.7,+                       bytestring >=0.9 && <0.11,+                       mtl >=2.1 && <2.2,+                       text >=0.11 && <0.12,+                       vector >=0.8 && <0.11,+                       unordered-containers >=0.1 && <0.3,+                       attoparsec >=0.8 && <0.11+  hs-source-dirs:      src+  ghc-options:         -Wall++executable demo+  main-is:             Demo.hs+  hs-source-dirs:      demo+  if flag (demo)+    build-depends:     base,+                       json-rpc-server,+                       mtl,+                       happstack-server >=7.3 && <7.4+    ghc-options:       -Wall+  else+    buildable:         False++test-suite tests+  hs-source-dirs:      tests+  main-is:             TestSuite.hs+  other-modules:       TestTypes+  type:                exitcode-stdio-1.0+  build-depends:       base,+                       json-rpc-server,+                       HUnit >=1.2 && <1.3,+                       test-framework >=0.7 && <0.9,+                       test-framework-hunit >=0.3 && <0.4,+                       aeson,+                       bytestring,+                       mtl,+                       text,+                       vector,+                       unordered-containers,+                       attoparsec+  ghc-options:         -Wall -fno-warn-incomplete-patterns
+ src/Network/JsonRpc/Server.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE MultiParamTypeClasses,+             Rank2Types,+             TypeOperators,+             OverloadedStrings #-}++-- | Functions for implementing the server side of JSON RPC 2.0.+--   See <http://www.jsonrpc.org/specification>.+module Network.JsonRpc.Server (+                          -- ** Instructions+                          -- $instructions++                          -- ** Unnamed and Optional Arguments+                          -- $arguments++                          -- ** Example+                          -- $example++                          -- ** Methods+                             RpcResult+                           , Method+                           , toMethod+                           , Methods+                           , toMethods+                           , call+                           , callWithBatchStrategy+                           , Parameter(..)+                           , (:+:) (..)+                           , MethodParams+                          -- ** Errors+                           , RpcError+                           , rpcError+                           , rpcErrorWithData) where++import Network.JsonRpc.Types+import Data.Text (Text, append, pack)+import Data.Maybe (catMaybes)+import qualified Data.ByteString.Lazy as B+import Data.Aeson+import qualified Data.Vector as V+import qualified Data.HashMap.Strict as H+import Control.Applicative ((<$>))+import Control.Monad (liftM)+import Control.Monad.Identity (Identity, runIdentity)+import Control.Monad.Error (ErrorT, runErrorT, throwError)+import Prelude hiding (length)++-- $instructions+-- * 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'.++-- $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.++-- $example+-- Here is an example of a simple Happstack server with three methods.+-- Compile it with the build flag @demo@.+--   +-- > {-# LANGUAGE OverloadedStrings #-}+-- > +-- > module Main (main) where+-- > +-- > import Network.JsonRpc.Server+-- > import Happstack.Server.SimpleHTTP hiding (Method, body, result)+-- > import Data.List (intercalate)+-- > import Data.Maybe (fromMaybe)+-- > import Control.Monad (when)+-- > import Control.Monad.Trans (liftIO)+-- > import Control.Monad.Error (throwError)+-- > import Control.Monad.Reader (ReaderT, ask, runReaderT)+-- > import Control.Concurrent.MVar+-- > +-- > 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)+-- > +-- > type Server = ReaderT (MVar Integer) (ServerPartT IO)+-- > +-- > methods :: Methods Server+-- > methods = toMethods [printSequence, getCount, add]+-- > +-- > printSequence, getCount, add :: Method Server+-- > +-- > printSequence = toMethod "print" f params+-- >     where params = Required "string" :+:+-- >                    Optional "count" 1 :+:+-- >                    Optional "separator" ',' :+: ()+-- >           f :: String -> Int -> Char -> RpcResult Server ()+-- >           f str count sep = do+-- >               when (count < 0) $ throwError negativeCount+-- >               liftIO $ print $ intercalate [sep] $ replicate count str+-- >           negativeCount = rpcError (-32000) "negative count"+-- > +-- > getCount = toMethod "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.+--   The parameter names must be unique.+toMethod :: (MethodParams f p m r, ToJSON r, Monad m) => Text -> f -> p -> Method m+toMethod name f params = let f' args = toJSON <$> apply f params args+                         in Method name f'++-- | Creates a set of methods to be called by name. The names must be unique.+toMethods :: [Method m] -> Methods m+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+--   @callWithBatchStrategy sequence@.+call :: Monad m => Methods 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.+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.+                      -> 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 Value [Value])+          request = runIdentity $ runErrorT $ parseVal =<< parseJson input+          parseJson = maybe invalidJson return . decode+          parseVal val = case val of+                           obj@(Object _) -> return $ Left obj+                           Array vec | V.null vec -> throwError $ invalidRpcError "Empty batch request"+                                     | otherwise -> return $ Right $ V.toList vec+                           _ -> throwError $ invalidRpcError "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 = (encode . toJSON) <$> r+          returnErr = return . Just . encode . toJSON . nullIdResponse+          invalidJson = throwError $ rpcError (-32700) "Invalid JSON"++singleCall :: Monad m => Methods m -> Value -> m (Maybe Response)+singleCall (Methods fs) 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+          applyMethodTo args (Method _ f) = f args++nullIdResponse :: RpcError -> Maybe Response+nullIdResponse err = toResponse (Just IdNull) (Left err :: Either RpcError ())++parseValue :: (FromJSON a, Monad m) => Value -> RpcResult m a+parseValue val = case fromJSON val of+                   Error msg -> throwError $ invalidRpcError $ pack msg+                   Success x -> return x++lookupMethod :: Monad m => Text -> H.HashMap Text (Method m) -> RpcResult m (Method m)+lookupMethod name = maybe notFound return . H.lookup name+    where notFound = throwError $ rpcError (-32601) ("Method not found: " `append` name)++invalidRpcError :: Text -> RpcError+invalidRpcError = rpcErrorWithData (-32600) "Invalid JSON RPC 2.0 request"++batchCall :: Monad m => (forall a. [m a] -> m [a])+          -> Methods m+          -> [Value]+          -> m (Maybe [Response])+batchCall strategy mths vals = (noNull . catMaybes) `liftM` results+    where results = strategy $ map (singleCall mths) vals+          noNull rs = if null rs then Nothing else Just rs++toResponse :: ToJSON a => Maybe Id -> Either RpcError a -> Maybe Response+toResponse (Just i) r = Just $ Response i $ toJSON <$> r+toResponse Nothing _ = Nothing
+ src/Network/JsonRpc/Types.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE MultiParamTypeClasses,+             FunctionalDependencies,+             FlexibleInstances,+             UndecidableInstances,+             TypeOperators,+             PatternGuards,+             OverloadedStrings #-}++module Network.JsonRpc.Types ( RpcResult+                             , Method (..)+                             , Methods (..)+                             , Parameter(..)+                             , (:+:) (..)+                             , MethodParams (..)+                             , Request (..)+                             , Response (..)+                             , Id (..)+                             , RpcError+                             , rpcError+                             , rpcErrorWithData) where++import Data.String (fromString)+import Data.Maybe (catMaybes)+import Data.Text (Text, append, unpack)+import Data.Aeson+import Data.Aeson.Types (emptyObject)+import qualified Data.Vector as V+import qualified Data.HashMap.Strict as H+import Data.Attoparsec.Number (Number)+import Control.Applicative ((<$>), (<*>), (<|>), (*>), empty)+import Control.Monad (when)+import Control.Monad.Error (Error, ErrorT, throwError, strMsg, noMsg)+import Prelude hiding (length)++-- | 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++-- | Parameter expected by a method.+data Parameter a+    -- | Required parameter with a name.+    = Required Text+    -- | Optional parameter with a name and default value.+    | Optional Text a++-- | A node in a type-level linked list of 'Parameter' types.  It is right associative.+data a :+: ps = (Parameter a) :+: ps+infixr :+:++-- | Relationship between a method's function ('f'), parameters ('p'),+--   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, ToJSON r) => MethodParams f p m r | f -> p m r where+    apply :: f -> p -> Args -> RpcResult m r++instance (Monad m, Functor m, ToJSON r) => MethodParams (RpcResult m r) () m r where+    apply r _ args | Left _ <- args = r+                   | Right ar <- args, V.null ar = r+                   | otherwise = throwError $ rpcError (-32602) "Too many unnamed arguments"++instance (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 <|> Right <$> paramDefault param)+              lookupValue = either (lookupArg name) (headArg name) args+              nextArgs = tailOrEmpty <$> args+              name = paramName param++lookupArg :: Monad m => Text -> Object -> RpcResult m Value+lookupArg name hm = case H.lookup name hm of+                      Nothing -> throwError $ missingArgError name+                      Just v -> return v++headArg :: Monad m => Text -> V.Vector a -> RpcResult m a+headArg name vec | V.null vec = throwError $ missingArgError name+                 | otherwise = return $ V.head vec++tailOrEmpty :: V.Vector a -> V.Vector a+tailOrEmpty vec = if V.null vec then V.empty else V.tail vec++parseArg :: (Monad m, FromJSON r) => Text -> Value -> RpcResult m r+parseArg name val = case fromJSON val of+                      Error msg -> throwError $ rpcErrorWithData (-32602) ("Wrong type for argument: " `append` name) msg+                      Success x -> return x++paramDefault :: Monad m => Parameter a -> RpcResult m a+paramDefault (Optional _ d) = return d+paramDefault (Required name) = throwError $ missingArgError name++missingArgError :: Text -> RpcError+missingArgError name = rpcError (-32602) ("Cannot find required argument: " `append` name)++paramName :: Parameter a -> Text+paramName (Optional n _) = n+paramName (Required n) = n++-- | Single method.+data Method m = Method Text (Args -> RpcResult m Value)++-- | Multiple methods.+newtype Methods m = Methods (H.HashMap Text (Method m))++type Args = Either Object Array++data Request = Request Text Args (Maybe Id)++instance FromJSON Request where+    parseJSON (Object x) = (checkVersion =<< x .:? versionKey .!= jsonRpcVersion) *>+                           (Request <$>+                           x .: methodKey <*>+                           (parseParams =<< x .:? paramsKey .!= emptyObject) <*>+                           (Just <$> x .: idKey <|> return Nothing)) -- (.:?) parses Null value as Nothing+        where parseParams (Object obj) = return $ Left obj+              parseParams (Array ar) = return $ Right ar+              parseParams _ = empty+              checkVersion ver = when (ver /= jsonRpcVersion) (fail $ "Wrong JSON RPC version: " ++ unpack ver)+    parseJSON _ = empty++data Response = Response Id (Either RpcError Value)++instance ToJSON Response where+    toJSON (Response i result) = object pairs+        where pairs = [ versionKey .= jsonRpcVersion+                      , either (errorKey .=) (resultKey .=) result+                      , idKey .= i]++data Id = IdString Text | IdNumber Number | IdNull++instance FromJSON Id where+    parseJSON (String x) = return $ IdString x+    parseJSON (Number x) = return $ IdNumber x+    parseJSON Null = return IdNull+    parseJSON _ = empty++instance ToJSON Id where+    toJSON i = case i of+                 IdString x -> toJSON x+                 IdNumber x -> toJSON x+                 IdNull -> Null++-- | Error to be returned to the client.+data RpcError = RpcError Int Text (Maybe Value)+              deriving Show++instance Error RpcError where+    noMsg = strMsg "unknown error"+    strMsg msg = RpcError (-32000) (fromString msg) Nothing++instance ToJSON RpcError where+    toJSON (RpcError code msg data') = object pairs+        where pairs = catMaybes [ Just $ codeKey .= code+                                , Just $ msgKey .= msg+                                , (dataKey .=) <$> data' ]++-- | Creates an 'RpcError' with the given error code and message.+--   According to the specification, server error codes should be+--   in the range -32099 to -32000, and application defined errors+--   should be outside the range -32768 to -32000.+rpcError :: Int -> Text -> RpcError+rpcError code msg = RpcError code msg Nothing++-- | Creates an 'RpcError' with the given code, message, and additional data.+--   See 'rpcError' for the recommended error code ranges.+rpcErrorWithData :: ToJSON a => Int -> Text -> a -> RpcError+rpcErrorWithData code msg errorData = RpcError code msg $ Just $ toJSON errorData++jsonRpcVersion, versionKey, idKey :: Text+jsonRpcVersion = "2.0"+versionKey = "jsonrpc"+idKey = "id"++methodKey, paramsKey :: Text+methodKey = "method"+paramsKey = "params"++resultKey, errorKey :: Text+resultKey = "result"+errorKey = "error"++codeKey, msgKey, dataKey :: Text+codeKey = "code"+msgKey = "message"+dataKey = "data"
+ tests/TestSuite.hs view
@@ -0,0 +1,253 @@+{-# LANGUAGE OverloadedStrings, PatternGuards #-}++module Main (main) where++import Network.JsonRpc.Server+import TestTypes+import Data.List ((\\), sort)+import Data.Aeson+import Data.Aeson.Types+import Data.Text (Text)+import Data.Maybe+import qualified Data.ByteString.Lazy.Char8 as B+import qualified Data.Vector as V+import qualified Data.HashMap.Strict as H+import Control.Applicative+import Control.Monad.Trans+import Control.Monad.State+import Control.Monad.Identity+import Control.Concurrent (forkIO)+import Control.Concurrent.MVar+import Test.HUnit hiding (State)+import Test.Framework+import Test.Framework.Providers.HUnit++main :: IO ()+main = defaultMain [ testCase "encode error" testEncodeError+                   , testCase "encode error with data" testEncodeErrorWithData+                   , testCase "invalid JSON" testInvalidJson+                   , testCase "invalid JSON RPC" testInvalidJsonRpc+                   , testCase "empty batch call" testEmptyBatchCall+                   , testCase "wrong version in request" testWrongVersion+                   , testCase "method not found" testMethodNotFound+                   , testCase "wrong method name capitalization" testWrongMethodNameCapitalization+                   , testCase "missing required named argument" testMissingRequiredNamedArg+                   , testCase "missing required unnamed argument" testMissingRequiredUnnamedArg+                   , testCase "wrong argument type" testWrongArgType+                   , testCase "disallow extra unnamed arguments" testDisallowExtraUnnamedArg+                   , testCase "invalid notification" testNoResponseToInvalidNotification+                   , testCase "batch request" testBatch+                   , testCase "batch notifications" testBatchNotifications+                   , testCase "allow missing version" testAllowMissingVersion+                   , testCase "no arguments" testNoArgs+                   , testCase "empty argument array" testEmptyUnnamedArgs+                   , testCase "empty argument object" testEmptyNamedArgs+                   , testCase "allow extra named argument" testAllowExtraNamedArg+                   , testCase "use default named argument" testDefaultNamedArg+                   , testCase "use default unnamed argument" testDefaultUnnamedArg+                   , testCase "null request ID" testNullId+                   , testCase "parallelize tasks" testParallelizingTasks ]++testEncodeError :: Assertion+testEncodeError = (fromByteString $ encode $ toJSON err) @?= Just testError+    where err = rpcError (-1) "error"+          testError = TestRpcError (-1) "error" Nothing++testEncodeErrorWithData :: Assertion+testEncodeErrorWithData = (fromByteString $ encode $ toJSON err) @?= Just testError+    where err = rpcErrorWithData 1 "my message" errorData+          testError = TestRpcError 1 "my message" $ Just $ toJSON errorData+          errorData = (['\x03BB'], True, ())++testInvalidJson :: Assertion+testInvalidJson = checkResponseWithSubtract "5" IdNull (-32700)++testInvalidJsonRpc :: Assertion+testInvalidJsonRpc = checkResponseWithSubtract (encode $ object ["id" .= (10 :: Int)]) IdNull (-32600)++testEmptyBatchCall :: Assertion+testEmptyBatchCall = checkResponseWithSubtract (encode emptyArray) IdNull (-32600)++testWrongVersion :: Assertion+testWrongVersion = checkResponseWithSubtract (encode requestWrongVersion) IdNull (-32600)+    where requestWrongVersion = Object $ H.insert versionKey (String "1") hm+          Object hm = toJSON $ subtractRequestNamed [("a1", Number 4)] (IdNumber 10)++testMethodNotFound :: Assertion+testMethodNotFound = checkResponseWithSubtract (encode request) i (-32601)+    where request = TestRequest "ad" Nothing (Just i)+          i = IdNumber 3++testWrongMethodNameCapitalization :: Assertion+testWrongMethodNameCapitalization = checkResponseWithSubtract (encode request) i (-32601)+    where request = TestRequest "Add" Nothing (Just i)+          i = IdNull++testMissingRequiredNamedArg :: Assertion+testMissingRequiredNamedArg = checkResponseWithSubtract (encode request) i (-32602)+    where request = subtractRequestNamed [("A1", Number 1), ("a2", Number 20)] i+          i = IdNumber 2++testMissingRequiredUnnamedArg :: Assertion+testMissingRequiredUnnamedArg = checkResponseWithSubtract (encode request) i (-32602)+    where request = TestRequest "subtract 2" (Just $ Right $ V.fromList [Number 0]) (Just i)+          i = IdString ""++testWrongArgType :: Assertion+testWrongArgType = checkResponseWithSubtract (encode request) i (-32602)+    where request = subtractRequestNamed [("a1", Number 1), ("a2", Bool True)] i+          i = IdString "ABC"++testDisallowExtraUnnamedArg :: Assertion+testDisallowExtraUnnamedArg = checkResponseWithSubtract (encode request) i (-32602)+    where request = subtractRequestUnnamed (map Number [1, 2, 3]) i+          i = IdString "i"++testNoResponseToInvalidNotification :: Assertion+testNoResponseToInvalidNotification = runIdentity response @?= Nothing+    where response = call (toMethods [subtractMethod]) $ encode request+          request = TestRequest "12345" Nothing Nothing++testBatch :: Assertion+testBatch = assert (fromJust (fromByteString =<< runIdentity response) `equalContents` expected)+    where expected = [TestResponse i1 (Right $ Number 2), TestResponse i2 (Right $ Number 4)]+          response = call (toMethods [subtractMethod]) $ encode request+          request = [subtractRequestNamed (toArgs 10 8) i1, subtractRequestNamed (toArgs 24 20) i2]+          toArgs x y = [("a1", Number x), ("a2", Number y)]+          i1 = IdString "1"+          i2 = IdString "2"++testBatchNotifications :: Assertion+testBatchNotifications = runState response 0 @?= (Nothing, 10)+    where response = call (toMethods [incrementStateMethod]) $ encode request+          request = replicate 10 $ TestRequest "increment" Nothing Nothing++testAllowMissingVersion :: Assertion+testAllowMissingVersion = (fromByteString =<< runIdentity response) @?= (Just $ TestResponse i (Right $ Number 1))+    where requestNoVersion = Object $ H.delete versionKey hm+          Object hm = toJSON $ subtractRequestNamed [("a1", Number 1)] i+          response = call (toMethods [subtractMethod]) $ encode requestNoVersion+          i = IdNumber (-1)++testAllowExtraNamedArg :: Assertion+testAllowExtraNamedArg = (fromByteString =<< runIdentity response) @?= (Just $ TestResponse i (Right $ Number (-10)))+    where response = call (toMethods [subtractMethod]) $ encode request+          request = subtractRequestNamed args i+          args = [("a1", Number 10), ("a2", Number 20), ("a3", String "extra")]+          i = IdString "ID"++testDefaultNamedArg :: Assertion+testDefaultNamedArg = (fromByteString =<< runIdentity response) @?= (Just $ TestResponse i (Right $ Number 1000))+    where response = call (toMethods [subtractMethod]) $ encode request+          request = subtractRequestNamed args i+          args = [("a", Number 500), ("a1", Number 1000)]+          i = IdNumber 3++testDefaultUnnamedArg :: Assertion+testDefaultUnnamedArg = (fromByteString =<< runIdentity response) @?= (Just $ TestResponse i (Right $ Number 4))+    where response = call (toMethods [subtractMethod]) $ encode request+          request = subtractRequestUnnamed [Number 4] i+          i = IdNumber 0++testNullId :: Assertion+testNullId = (fromByteString =<< runIdentity response) @?= (Just $ TestResponse IdNull (Right $ Number (-80)))+    where response = call (toMethods [subtractMethod]) $ encode request+          request = subtractRequestNamed args IdNull+          args = [("a2", Number 70), ("a1", Number (-10))]++testNoArgs :: Assertion+testNoArgs = compareGetTimeResult Nothing++testEmptyUnnamedArgs :: Assertion+testEmptyUnnamedArgs = compareGetTimeResult $ Just $ Right empty++testEmptyNamedArgs :: Assertion+testEmptyNamedArgs = compareGetTimeResult $ Just $ Left H.empty++testParallelizingTasks :: Assertion+testParallelizingTasks = assert $ do+                           a <- actual+                           let ids = map fromIdNumber a+                               vals = map fromResult a+                           return $ (sort ids == [1, 2]) &&+                                    (sort vals == ["A", "B"])+    where actual = (fromJust . fromByteString . fromJust) <$> (flip (callWithBatchStrategy parallelize) input =<< methods)+          input = encode [ lockRequest 1, unlockRequest (String "A")+                         , unlockRequest (String "B"), lockRequest 2]+          lockRequest i = TestRequest "lock" Nothing (Just $ IdNumber i)+          unlockRequest str = TestRequest "unlock" (Just $ Right $ V.fromList [str]) Nothing+          methods = createMethods <$> newEmptyMVar+          createMethods lock = toMethods [lockMethod lock, unlockMethod lock]+          lockMethod lock = toMethod "lock" f ()+              where f :: RpcResult IO String+                    f = liftIO $ takeMVar lock+          unlockMethod lock = toMethod "unlock" f (Required "value" :+: ())+              where f :: String -> RpcResult IO ()+                    f val = liftIO $ putMVar lock val+          fromResult r | Right (String str) <- rspResult r = str+          fromIdNumber r | IdNumber i <- rspId r = i++parallelize :: [IO a] -> IO [a]+parallelize tasks = do+  results <- forM tasks $ \t -> do+                      mvar <- newEmptyMVar+                      _ <- forkIO $ putMVar mvar =<< t+                      return mvar+  forM results takeMVar++incrementStateMethod :: Method (State Int)+incrementStateMethod = toMethod "increment" f ()+    where f :: RpcResult (State Int) ()+          f = lift $ modify (+1)++compareGetTimeResult :: Maybe (Either Object Array) -> Assertion+compareGetTimeResult requestArgs = assertEqual "unexpected rpc response" expected =<<+                                   ((fromByteString . fromJust) <$> call (toMethods [getTimeMethod]) (encode getTimeRequest))+    where expected = Just $ TestResponse i (Right $ Number 100)+          getTimeRequest = TestRequest "get_time_seconds" requestArgs (Just i)+          i = IdString "Id 1"++subtractRequestNamed :: [(Text, Value)] -> TestId -> TestRequest+subtractRequestNamed args i = TestRequest "subtract 1" (Just $ Left $ H.fromList args) (Just i)++subtractRequestUnnamed :: [Value] -> TestId -> TestRequest+subtractRequestUnnamed args i = TestRequest "subtract 1" (Just $ Right $ V.fromList args) (Just i)++checkResponseWithSubtract :: B.ByteString -> TestId -> Int -> Assertion+checkResponseWithSubtract val expectedId expectedCode = actual @?= expected+    where expected = (Just expectedId, Just expectedCode)+          actual = (rspId <$> fromByteString result, getErrorCode result)+          result = fromJust $ runIdentity $ call (toMethods [subtractMethod, flippedSubtractMethod]) val++fromByteString :: FromJSON a => B.ByteString -> Maybe a+fromByteString x = case fromJSON <$> decode x of+                     Just (Success x') -> Just x'+                     _ -> Nothing++getErrorCode :: B.ByteString -> Maybe Int+getErrorCode b = fromByteString b >>= \r ->+                 case r of+                   Just (TestResponse _ (Left (TestRpcError code _ _))) -> Just code+                   _ -> Nothing++subtractMethod :: Method Identity+subtractMethod = toMethod "subtract 1" sub (Required "a1" :+: Optional "a2" 0 :+: ())+            where sub :: Int -> Int -> RpcResult Identity Int+                  sub x y = return (x - y)++flippedSubtractMethod :: Method Identity+flippedSubtractMethod = toMethod "subtract 2" sub (Optional "y" (-1000) :+: Required "x" :+: ())+            where sub :: Int -> Int -> RpcResult Identity Int+                  sub y x = return (x - y)++getTimeMethod :: Method IO+getTimeMethod = toMethod "get_time_seconds" getTime ()+    where getTime :: RpcResult IO Integer+          getTime = liftIO getTestTime++getTestTime :: IO Integer+getTestTime = return 100++equalContents :: Eq a => [a] -> [a] -> Bool+equalContents xs ys = null (xs \\ ys) &&+                      null (ys \\ xs)
+ tests/TestTypes.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedStrings #-}++module TestTypes ( TestRequest (..)+                 , TestResponse (..)+                 , TestRpcError (..)+                 , TestId (..)+                 , jsonRpcVersion+                 , versionKey) where++import Data.Aeson+import Data.Aeson.Types+import Data.Maybe (catMaybes)+import Data.Text (Text)+import Data.Attoparsec.Number (Number)+import Data.HashMap.Strict (size)+import Control.Applicative++data TestRpcError = TestRpcError { errCode :: Int+                                 , errMsg :: Text+                                 , errData :: Maybe Value}+                    deriving (Eq, Show)++instance FromJSON TestRpcError where+    parseJSON (Object err) = (TestRpcError <$>+                             err .: "code" <*>+                             err .: "message" <*>+                             err .:? "data") >>= checkKeys+        where checkKeys e = let checkSize s = failIf $ size err /= s+                            in pure e <* checkSize (case errData e of+                                                        Nothing -> 2+                                                        Just _ -> 3)+    parseJSON _ = empty++data TestRequest = TestRequest Text (Maybe (Either Object Array)) (Maybe TestId)++instance ToJSON TestRequest where+    toJSON (TestRequest name params i) = object pairs+        where pairs = catMaybes [Just $ "method" .= toJSON name, idPair, paramsPair]+              idPair = ("id" .=) <$> i+              paramsPair = either toPair toPair <$> params+                  where toPair v = "params" .= toJSON v++data TestResponse = TestResponse { rspId :: TestId+                                 , rspResult :: Either TestRpcError Value }+                    deriving (Eq, Show)++instance FromJSON TestResponse where+    parseJSON (Object r) = failIf (size r /= 3) *> checkVersion *>+                           (TestResponse <$>+                           r .: "id" <*>+                           ((Left <$> r .: "error") <|> (Right <$> r .: "result")))+        where checkVersion = r .: versionKey >>= failIf . (/= jsonRpcVersion)+    parseJSON _ = empty++failIf :: Bool -> Parser ()+failIf b = if b then empty else pure ()++data TestId = IdString Text | IdNumber Number | IdNull+              deriving (Eq, Show)++instance FromJSON TestId where+    parseJSON (String x) = return $ IdString x+    parseJSON (Number x) = return $ IdNumber x+    parseJSON Null = return IdNull+    parseJSON _ = empty++instance ToJSON TestId where+    toJSON i = case i of+                 IdString x -> toJSON x+                 IdNumber x -> toJSON x+                 IdNull -> Null++versionKey :: Text+versionKey = "jsonrpc"++jsonRpcVersion :: Text+jsonRpcVersion = "2.0"