Continued refactoring tests

Author: sebright

json-rpc-server.cabal

@@ -55,7 +55,7 @@ executable demo
 test-suite tests
   hs-source-dirs:      tests
   main-is:             TestSuite.hs
-  other-modules:       TestTypes
+  other-modules:       TestParallelism, Internal
   type:                exitcode-stdio-1.0
   build-depends:       base >=4.5 && <4.7,
                        json-rpc-server,

tests/Internal.hs

@@ -0,0 +1,90 @@
+{-# LANGUAGE OverloadedStrings,
+             ExistentialQuantification #-}
+
+module Internal ( request
+                , request2_0
+                , idRequest
+                , successRsp
+                , idSuccessRsp
+                , errRsp
+                , rpcErr
+                , idErrRsp
+                , fromJson
+                , array
+                , defaultId
+                , errKey
+                , dataKey
+                , msgKey
+                , resultKey
+                , idKey
+                , versionKey) where
+
+import qualified Data.Aeson as A
+import Data.Aeson ((.=))
+import Data.Maybe (catMaybes)
+import qualified Data.Vector as V
+import Data.Text (Text)
+import Control.Applicative ((<$>))
+
+fromJson :: A.FromJSON a => A.Value -> Maybe a
+fromJson v = case A.fromJSON v of
+               A.Success x -> Just x
+               _ -> Nothing
+
+array :: [A.Value] -> A.Value
+array = A.Array . V.fromList
+
+idRequest :: Text -> Maybe A.Value -> A.Value
+idRequest = request2_0 (Just defaultId)
+
+request2_0 :: Maybe A.Value -> Text -> Maybe A.Value -> A.Value
+request2_0 i = request (Just version) i . A.String
+
+request :: Maybe Text -> Maybe A.Value -> A.Value -> Maybe A.Value -> A.Value
+request ver i method args = A.object $ catMaybes [ Just $ "method" .= method
+                                                 , ("params" .=) <$> args
+                                                 , (idKey .=) <$> i
+                                                 , (versionKey .=) <$> ver ]
+
+idSuccessRsp :: A.Value -> A.Value
+idSuccessRsp = successRsp defaultId
+
+successRsp :: A.Value -> A.Value -> A.Value
+successRsp i = response i "result"
+
+idErrRsp :: Int -> A.Value
+idErrRsp = errRsp defaultId
+
+errRsp :: A.Value -> Int -> A.Value
+errRsp i code = response i errKey $ rpcErr Nothing code ""
+
+rpcErr :: Maybe A.Value -> Int -> Text -> A.Value
+rpcErr d code msg = A.object $ ["code" .= code, msgKey .= msg] ++ dataPair 
+    where dataPair = catMaybes [(dataKey .=) <$> d]
+
+response :: A.Value -> Text -> A.Value -> A.Value
+response i key result = A.object [idKey .= i, key .= result, versionKey .= version]
+
+defaultId :: A.Value
+defaultId = A.Number 3
+
+versionKey :: Text
+versionKey = "jsonrpc"
+
+idKey :: Text
+idKey = "id"
+
+resultKey :: Text
+resultKey = "result"
+
+errKey :: Text
+errKey = "error"
+
+msgKey :: Text
+msgKey = "message"
+
+dataKey :: Text
+dataKey = "data"
+
+version :: Text
+version = "2.0"

tests/TestParallelism.hs

@@ -3,9 +3,11 @@
 module TestParallelism (testParallelizingTasks) where
 
 import Network.JsonRpc.Server
-import TestTypes
+import Internal
 import Data.List (sort)
 import qualified Data.Aeson as A
+import Data.Aeson ((.=))
+import qualified Data.Aeson.Types as A
 import Data.Maybe (fromJust)
 import qualified Data.HashMap.Strict as H
 import Control.Applicative ((<$>))
@@ -33,18 +35,17 @@ testParallelizingTasks = do
                            , unlockRequest 'A']
           createMethods lock = toMethods [lockMethod lock, unlockMethod lock]
 
-rspToIntId :: TestResponse -> Maybe Int
-rspToIntId = fromNumId . rspId
+rspToIntId :: A.Value -> Maybe Int
+rspToIntId (A.Object rsp) = fromJson =<< H.lookup idKey rsp
 
-rspToCharResult :: TestResponse -> Maybe Char
-rspToCharResult rsp = let (Right r) = rspResult rsp
-                      in fromJust $ fromJson r
+rspToCharResult :: A.Value -> Maybe Char
+rspToCharResult (A.Object rsp) = fromJson =<< H.lookup resultKey rsp
 
-lockRequest :: Int -> TestRequest
-lockRequest i = TestRequest "lock" (Nothing :: Maybe ()) (Just $ idNumber i)
+lockRequest :: Int -> A.Value
+lockRequest i = request2_0 (Just $ A.toJSON i) "lock" $ Just A.emptyObject
 
-unlockRequest :: Char -> TestRequest
-unlockRequest ch = TestRequest "unlock" (Just $ H.fromList [("value" :: String, ch)]) Nothing
+unlockRequest :: Char -> A.Value
+unlockRequest ch = request2_0 Nothing "unlock" $ Just $ A.object ["value" .= ch]
 
 lockMethod :: MVar Char -> Method IO
 lockMethod lock = toMethod "lock" f ()