Improved error code tests

Author: sebright

json-rpc-server.cabal

@@ -68,4 +68,4 @@ test-suite tests
                        text >=0.11 && <1.2,
                        vector >=0.8 && <0.11,
                        unordered-containers >=0.1 && <0.3
-  ghc-options:         -Wall -fno-warn-incomplete-patterns
+  ghc-options:         -Wall

tests/TestParallelism.hs

@@ -8,24 +8,23 @@ import Data.List (sort)
 import qualified Data.Aeson as A
 import Data.Maybe (fromJust)
 import qualified Data.HashMap.Strict as H
-import qualified Data.ByteString.Lazy.Char8 as B
 import Control.Applicative ((<$>))
 import Control.Monad.Trans (liftIO)
 import Control.Concurrent (forkIO)
 import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
 import Test.HUnit ((@?=), Assertion)
 
--- | Tests sending a batch request where each request either
+-- | Tests parallelizing a batch request.  Each request either
 --   locks or unlocks an MVar.  The MVar is initially locked,
---   so the first lock request would not succeed if the
---   requests were serialized.
+--   so the first lock request cannot succeed if the requests
+--   are serialized.
 testParallelizingTasks :: Assertion
 testParallelizingTasks = do
   methods <- createMethods <$> newEmptyMVar
   output <- callWithBatchStrategy parallelize methods input
-  let result = fromJust $ fromByteString =<< output
-  sort (map rspToIntId result) @?= map Just [1..3] 
-  sort (map rspToCharVal result) @?= map Just "ABC"
+  let rsp = fromJust $ fromJson =<< A.decode =<< output
+  sort (map rspToIntId rsp) @?= map Just [1..3]
+  sort (map rspToCharResult rsp) @?= map Just "ABC"
     where input = A.encode [ lockRequest 1
                            , lockRequest 3
                            , unlockRequest 'C'
@@ -37,9 +36,9 @@ testParallelizingTasks = do
 rspToIntId :: TestResponse -> Maybe Int
 rspToIntId = fromNumId . rspId
 
-rspToCharVal :: TestResponse -> Maybe Char
-rspToCharVal resp = let (Right r) = rspResult resp
-                    in fromJust $ fromJson r
+rspToCharResult :: TestResponse -> Maybe Char
+rspToCharResult rsp = let (Right r) = rspResult rsp
+                      in fromJust $ fromJson r
 
 lockRequest :: Int -> TestRequest
 lockRequest i = TestRequest "lock" (Nothing :: Maybe ()) (Just $ idNumber i)
@@ -63,8 +62,3 @@ parallelize tasks = mapM takeMVar =<< mapM fork tasks
                       mvar <- newEmptyMVar
                       _ <- forkIO $ putMVar mvar =<< t
                       return mvar
-
-fromByteString :: A.FromJSON a => B.ByteString -> Maybe a
-fromByteString str = case A.fromJSON <$> A.decode str of
-                     Just (A.Success x) -> Just x
-                     _ -> Nothing

tests/TestSuite.hs

@@ -27,6 +27,7 @@ main = defaultMain [ testCase "encode RPC error" testEncodeRpcError
                    , testCase "invalid JSON" testInvalidJson
                    , testCase "invalid JSON RPC" testInvalidJsonRpc
                    , testCase "empty batch call" testEmptyBatchCall
+                   , testCase "invalid batch element" testInvalidBatchElement
                    , testCase "wrong version in request" testWrongVersion
                    , testCase "method not found" testMethodNotFound
                    , testCase "wrong method name capitalization" testWrongMethodNameCapitalization
@@ -53,34 +54,48 @@ testEncodeRpcError = fromByteString (encode err) @?= Just testError
           testError = TestRpcError (-1) "error" Nothing
 
 testEncodeErrorWithData :: Assertion
-testEncodeErrorWithData = fromByteString (toByteString err) @?= Just testError
+testEncodeErrorWithData = fromByteString (encode 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)
+testInvalidJson = do
+  (rspToErrCode =<< rsp) @?= Just (-32700)
+  rspId <$> rsp @?= Just idNull
+      where rsp = callSubtractMethods ("5" :: String)
 
 testInvalidJsonRpc :: Assertion
-testInvalidJsonRpc = checkResponseWithSubtract (encode $ object ["id" .= (10 :: Int)]) idNull (-32600)
+testInvalidJsonRpc = do
+  (rspToErrCode =<< rsp) @?= Just (-32600)
+  rspId <$> rsp @?= Just idNull
+      where rsp = callSubtractMethods $ object ["id" .= (10 :: Int)]
 
 testEmptyBatchCall :: Assertion
-testEmptyBatchCall = checkResponseWithSubtract (encode emptyArray) idNull (-32600)
+testEmptyBatchCall = do
+  (rspToErrCode =<< rsp) @?= Just (-32600)
+  rspId <$> rsp @?= Just idNull
+      where rsp = callSubtractMethods emptyArray
+
+testInvalidBatchElement :: Assertion
+testInvalidBatchElement = do
+  length <$> rsp @?= Just 1
+  (rspToErrCode . head =<< rsp) @?= Just (-32600)
+  rspId . head <$> rsp @?= Just idNull
+      where rsp = callSubtractMethods [True]
 
 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" (Just [Number 1, Number 2]) (Just i)
-          i = idNumber 3
+testMethodNotFound = (rspToErrCode =<< callSubtractMethods req) @?= Just (-32601)
+    where req = TestRequest "ad" (Just [1, 2 :: Int]) (Just defaultId)
 
 testWrongMethodNameCapitalization :: Assertion
-testWrongMethodNameCapitalization = checkResponseWithSubtract (encode request) i (-32601)
-    where request = TestRequest "Add" (Just [Number 1, Number 2]) (Just i)
-          i = idNull
+testWrongMethodNameCapitalization = (rspToErrCode =<< callSubtractMethods req) @?= Just (-32601)
+    where req = TestRequest "Add" (Just [Number 1, Number 2]) (Just defaultId)
 
 testMissingRequiredNamedArg :: Assertion
 testMissingRequiredNamedArg = checkResponseWithSubtract (encode request) i (-32602)
@@ -182,6 +197,12 @@ subtractRequestNamed args i = TestRequest "subtract 1" (Just $ H.fromList args)
 subtractRequestUnnamed :: [Value] -> TestId -> TestRequest
 subtractRequestUnnamed args i = TestRequest "subtract 1" (Just args) (Just i)
 
+callSubtractMethods :: (ToJSON a, FromJSON b) => a -> Maybe b
+callSubtractMethods req = let methods :: Methods Identity
+                              methods = toMethods [subtractMethod, flippedSubtractMethod]
+                              rsp = call methods $ encode req
+                          in fromByteString =<< runIdentity rsp
+
 checkResponseWithSubtract :: B.ByteString -> TestId -> Int -> Assertion
 checkResponseWithSubtract input expectedId expectedCode = do
   rspId <$> res2 @?= Just expectedId
@@ -195,9 +216,6 @@ fromByteString str = case fromJSON <$> decode str of
                      Just (Success x) -> Just x
                      _ -> Nothing
 
-toByteString :: ToJSON a => a -> B.ByteString
-toByteString = encode . toJSON
-
 getErrorCode :: TestResponse -> Maybe Int
 getErrorCode (TestResponse _ (Left (TestRpcError code _ _))) = Just code
 getErrorCode _ = Nothing
@@ -219,3 +237,10 @@ getTimeMethod = toMethod "get_time_seconds" getTime ()
 
 getTestTime :: IO Integer
 getTestTime = return 100
+
+rspToErrCode :: TestResponse -> Maybe Int
+rspToErrCode (TestResponse _ (Left (TestRpcError code _ _))) = Just code
+rspToErrCode _ = Nothing
+
+defaultId :: TestId
+defaultId = idNumber 3