Skip to content

Commit 50bd3a1

Browse files
sebrightsebright
committed
Continued refactoring tests
1 parent 481d84d commit 50bd3a1

File tree

3 files changed

+99
-133
lines changed

3 files changed

+99
-133
lines changed

‎tests/Internal.hs‎

Lines changed: 32 additions & 63 deletions
Original file line numberDiff line numberDiff line change
@@ -1,28 +1,19 @@
1-
{-# LANGUAGE OverloadedStrings,
2-
ExistentialQuantification #-}
1+
{-# LANGUAGE OverloadedStrings #-}
32

43
module Internal ( request
54
, errRsp
65
, rpcErr
76
, defaultIdErrRsp
87
, nullIdErrRsp
9-
, fromJson
108
, array
9+
, rspToIdString
1110
, defaultRq
1211
, defaultRsp
1312
, method
1413
, params
1514
, id'
1615
, version
17-
, result
18-
, defaultId
19-
, defaultResult
20-
, errKey
21-
, dataKey
22-
, msgKey
23-
, resultKey
24-
, idKey
25-
, versionKey) where
16+
, result) where
2617

2718
import qualified Data.Aeson as A
2819
import Data.Aeson ((.=))
@@ -32,57 +23,56 @@ import qualified Data.Vector as V
3223
import Data.Text (Text)
3324
import Control.Applicative ((<$>))
3425

35-
fromJson :: A.FromJSON a => A.Value -> Maybe a
36-
fromJson v = case A.fromJSON v of
37-
A.Success x -> Just x
38-
_ -> Nothing
39-
4026
array :: [A.Value] -> A.Value
4127
array = A.Array . V.fromList
4228

43-
defaultRq :: A.Value
44-
defaultRq = request (Just defaultId) "subtract" args
45-
where args = Just $ A.object ["x" .= A.Number 1, "y" .= A.Number 2]
46-
47-
method :: A.Value -> Text -> A.Value
48-
method rq m = insert rq "method" $ Just $ A.String m
49-
50-
params :: A.Value -> Maybe A.Value -> A.Value
51-
params rq = insert rq "params"
52-
53-
id' :: A.Value -> Maybe A.Value -> A.Value
54-
id' rq = insert rq "id"
55-
56-
version :: A.Value -> Maybe A.Value -> A.Value
57-
version rq = insert rq "jsonrpc"
29+
rspToIdString :: A.Value -> Maybe String
30+
rspToIdString (A.Object rsp) = show <$> H.lookup "id" rsp
31+
rspToIdString _ = Nothing
5832

5933
request :: Maybe A.Value -> Text -> Maybe A.Value -> A.Value
6034
request i m args = A.object $ catMaybes [ Just $ "method" .= A.String m
6135
, ("params" .=) <$> args
62-
, (idKey .=) <$> i
63-
, Just (versionKey .= defaultVersion)]
36+
, ("id" .=) <$> i
37+
, Just ("jsonrpc" .= A.String "2.0")]
38+
39+
defaultRq :: A.Value
40+
defaultRq = request (Just defaultId) "subtract" args
41+
where args = Just $ A.object ["x" .= A.Number 1, "y" .= A.Number 2]
42+
43+
response :: A.Value -> Text -> A.Value -> A.Value
44+
response i key res = A.object ["id" .= i, key .= res, "jsonrpc" .= A.String "2.0"]
6445

6546
defaultRsp :: A.Value
6647
defaultRsp = response defaultId "result" defaultResult
6748

68-
result :: A.Value -> A.Value -> A.Value
69-
result rsp = insert rsp "result" . Just
70-
7149
defaultIdErrRsp :: Int -> A.Value
7250
defaultIdErrRsp = errRsp defaultId
7351

7452
nullIdErrRsp :: Int -> A.Value
7553
nullIdErrRsp = errRsp A.Null
7654

7755
errRsp :: A.Value -> Int -> A.Value
78-
errRsp i code = response i errKey $ rpcErr Nothing code ""
56+
errRsp i code = response i "error" $ rpcErr Nothing code ""
7957

8058
rpcErr :: Maybe A.Value -> Int -> Text -> A.Value
81-
rpcErr d code msg = A.object $ ["code" .= code, msgKey .= msg] ++ dataPair
82-
where dataPair = catMaybes [(dataKey .=) <$> d]
59+
rpcErr d code msg = A.object $ ["code" .= code, "message" .= msg] ++ dataPair
60+
where dataPair = catMaybes [("data" .=) <$> d]
8361

84-
response :: A.Value -> Text -> A.Value -> A.Value
85-
response i key res = A.object [idKey .= i, key .= res, versionKey .= defaultVersion]
62+
method :: A.Value -> Text -> A.Value
63+
method rq m = insert rq "method" $ Just $ A.String m
64+
65+
params :: A.Value -> Maybe A.Value -> A.Value
66+
params rq = insert rq "params"
67+
68+
id' :: A.Value -> Maybe A.Value -> A.Value
69+
id' rq = insert rq "id"
70+
71+
version :: A.Value -> Maybe A.Value -> A.Value
72+
version rq = insert rq "jsonrpc"
73+
74+
result :: A.Value -> A.Value -> A.Value
75+
result rsp = insert rsp "result" . Just
8676

8777
insert :: A.Value -> Text -> Maybe A.Value -> A.Value
8878
insert (A.Object obj) key Nothing = A.Object $ H.delete key obj
@@ -94,24 +84,3 @@ defaultId = A.Number 3
9484

9585
defaultResult :: A.Value
9686
defaultResult = A.Number (-1)
97-
98-
versionKey :: Text
99-
versionKey = "jsonrpc"
100-
101-
idKey :: Text
102-
idKey = "id"
103-
104-
resultKey :: Text
105-
resultKey = "result"
106-
107-
errKey :: Text
108-
errKey = "error"
109-
110-
msgKey :: Text
111-
msgKey = "message"
112-
113-
dataKey :: Text
114-
dataKey = "data"
115-
116-
defaultVersion :: Text
117-
defaultVersion = "2.0"

‎tests/TestParallelism.hs‎

Lines changed: 19 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -2,19 +2,20 @@
22

33
module TestParallelism (testParallelizingTasks) where
44

5-
import Network.JsonRpc.Server
5+
import qualified Network.JsonRpc.Server as S
6+
import Network.JsonRpc.Server ((:+:) (..))
67
import Internal
7-
import Data.List (sort)
8+
import Data.List (sortBy, permutations)
9+
import Data.Function (on)
810
import qualified Data.Aeson as A
911
import Data.Aeson ((.=))
1012
import qualified Data.Aeson.Types as A
1113
import Data.Maybe (fromJust)
12-
import qualified Data.HashMap.Strict as H
1314
import Control.Applicative ((<$>))
1415
import Control.Monad.Trans (liftIO)
1516
import Control.Concurrent (forkIO)
1617
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)
17-
import Test.HUnit ((@?=), Assertion)
18+
import Test.HUnit (Assertion, assert)
1819

1920
-- | Tests parallelizing a batch request. Each request either
2021
-- locks or unlocks an MVar. The MVar is initially locked,
@@ -23,40 +24,36 @@ import Test.HUnit ((@?=), Assertion)
2324
testParallelizingTasks :: Assertion
2425
testParallelizingTasks = do
2526
methods <- createMethods <$> newEmptyMVar
26-
output <- callWithBatchStrategy parallelize methods input
27-
let rsp = fromJust $ fromJson =<< A.decode =<< output
28-
sort (map rspToIntId rsp) @?= map Just [1..3]
29-
sort (map rspToCharResult rsp) @?= map Just "ABC"
27+
output <- S.callWithBatchStrategy parallelize methods input
28+
let rsp = fromJust $ A.decode =<< output
29+
assert $ elem (sortBy (compare `on` rspToIdString) rsp) possibleResponses
3030
where input = A.encode [ lockRequest 1
3131
, lockRequest 3
3232
, unlockRequest 'C'
3333
, unlockRequest 'B'
3434
, lockRequest 2
3535
, unlockRequest 'A']
36-
createMethods lock = toMethods [lockMethod lock, unlockMethod lock]
36+
createMethods lock = S.toMethods [lockMethod lock, unlockMethod lock]
3737

38-
rspToIntId :: A.Value -> Maybe Int
39-
rspToIntId (A.Object rsp) = fromJson =<< H.lookup idKey rsp
40-
rspToIntId _ = Nothing
41-
42-
rspToCharResult :: A.Value -> Maybe Char
43-
rspToCharResult (A.Object rsp) = fromJson =<< H.lookup resultKey rsp
44-
rspToCharResult _ = Nothing
38+
possibleResponses :: [[A.Value]]
39+
possibleResponses = (rsp <$>) <$> perms
40+
where perms = zip `zipWith` repeat [1, 2, 3] $ permutations ["A", "B", "C"]
41+
rsp (i, r) = defaultRsp `result` A.String r `id'` Just (A.Number i)
4542

4643
lockRequest :: Int -> A.Value
4744
lockRequest i = request (Just $ A.Number $ fromIntegral i) "lock" $ Just A.emptyObject
4845

4946
unlockRequest :: Char -> A.Value
5047
unlockRequest ch = request Nothing "unlock" $ Just $ A.object ["value" .= ch]
5148

52-
lockMethod :: MVar Char -> Method IO
53-
lockMethod lock = toMethod "lock" f ()
54-
where f :: RpcResult IO Char
49+
lockMethod :: MVar Char -> S.Method IO
50+
lockMethod lock = S.toMethod "lock" f ()
51+
where f :: S.RpcResult IO Char
5552
f = liftIO $ takeMVar lock
5653

57-
unlockMethod :: MVar Char -> Method IO
58-
unlockMethod lock = toMethod "unlock" f (Required "value" :+: ())
59-
where f :: Char -> RpcResult IO ()
54+
unlockMethod :: MVar Char -> S.Method IO
55+
unlockMethod lock = S.toMethod "unlock" f (S.Required "value" :+: ())
56+
where f :: Char -> S.RpcResult IO ()
6057
f val = liftIO $ putMVar lock val
6158

6259
parallelize :: [IO a] -> IO [a]

‎tests/TestSuite.hs‎

Lines changed: 48 additions & 48 deletions
Original file line numberDiff line numberDiff line change
@@ -2,24 +2,27 @@
22

33
module Main (main) where
44

5-
import Network.JsonRpc.Server
6-
import Internal
5+
import qualified Network.JsonRpc.Server as S
6+
import Network.JsonRpc.Server ((:+:) (..))
7+
import Internal ( request, defaultRq, defaultRsp
8+
, defaultIdErrRsp, nullIdErrRsp
9+
, version, result, rpcErr, method
10+
, params, id', array, rspToIdString)
711
import qualified TestParallelism
8-
import Data.Maybe
912
import Data.List (sortBy)
13+
import qualified Data.Vector as V
1014
import Data.Function (on)
1115
import qualified Data.Aeson as A
1216
import Data.Aeson ((.=))
1317
import qualified Data.Aeson.Types as A
14-
import qualified Data.ByteString.Lazy.Char8 as B
1518
import qualified Data.HashMap.Strict as H
16-
import Control.Applicative
17-
import Control.Monad.Trans
18-
import Control.Monad.State
19-
import Control.Monad.Identity
19+
import Control.Applicative ((<$>))
20+
import Control.Monad.Trans (liftIO)
21+
import Control.Monad.State (State, runState, lift, modify)
22+
import Control.Monad.Identity (Identity, runIdentity)
2023
import Test.HUnit hiding (State, Test)
21-
import Test.Framework
22-
import Test.Framework.Providers.HUnit
24+
import Test.Framework (defaultMain, Test)
25+
import Test.Framework.Providers.HUnit (testCase)
2326
import Prelude hiding (subtract)
2427

2528
main :: IO ()
@@ -67,15 +70,17 @@ errorHandlingTests = [ testCase "invalid JSON" $
6770

6871
otherTests :: [Test]
6972
otherTests = [ testCase "encode RPC error" $
70-
A.toJSON (rpcError (-1) "error") @?= rpcErr Nothing (-1) "error"
73+
A.toJSON (S.rpcError (-1) "error") @?= rpcErr Nothing (-1) "error"
7174

72-
, let err = rpcErrorWithData 1 "my message" errData
75+
, let err = S.rpcErrorWithData 1 "my message" errData
7376
testError = rpcErr (Just $ A.toJSON errData) 1 "my message"
7477
errData = ('\x03BB', [True], ())
7578
in testCase "encode RPC error with data" $ A.toJSON err @?= testError
7679

7780
, testCase "batch request" testBatch
81+
7882
, testCase "batch notifications" testBatchNotifications
83+
7984
, testCase "allow missing version" testAllowMissingVersion
8085

8186
, testCase "no arguments" $ assertGetTimeResponse Nothing
@@ -84,7 +89,8 @@ otherTests = [ testCase "encode RPC error" $
8489

8590
, testCase "empty argument A.object" $ assertGetTimeResponse $ Just A.emptyObject
8691

87-
, let req = defaultRq `params` (Just $ A.object ["x" .= A.Number 10, "y" .= A.Number 20, "z" .= A.String "extra"])
92+
, let req = defaultRq `params` Just args
93+
args = A.object ["x" .= A.Number 10, "y" .= A.Number 20, "z" .= A.String "extra"]
8894
rsp = defaultRsp `result` A.Number (-10)
8995
in testCase "allow extra named argument" $ assertSubtractResponse req rsp
9096

@@ -113,32 +119,31 @@ assertInvalidParams :: A.Value -> Assertion
113119
assertInvalidParams req = assertSubtractResponse req (defaultIdErrRsp (-32602))
114120

115121
testBatch :: Assertion
116-
testBatch = sortBy (compare `on` idToString) <$> response @?= Just expected
117-
where expected = [rsp i1 2, rsp i2 4]
122+
testBatch = sortBy (compare `on` rspToIdString) <$> response @?= Just expected
123+
where expected = [nullIdErrRsp (-32600), rsp i1 2, rsp i2 4]
118124
where rsp i x = defaultRsp `id'` Just i `result` A.Number x
119-
response = A.decode =<< runIdentity (call (toMethods [subtractMethod]) $ A.encode requests)
120-
requests = [rq i1 10 8, rq i2 24 20]
125+
response = fromArray =<< (removeErrMsg <$> callSubtractMethods (array requests))
126+
requests = [rq i1 10 8, rq i2 24 20, defaultRq `version` Just (A.String "abc")]
121127
where rq i x y = defaultRq `id'` Just i `params` toArgs x y
122128
toArgs :: Int -> Int -> Maybe A.Value
123129
toArgs x y = Just $ A.object ["x" .= x, "y" .= y]
124130
i1 = A.Number 1
125131
i2 = A.Number 2
126-
idToString :: A.Value -> Maybe String
127-
idToString (A.Object rsp) = show <$> H.lookup idKey rsp
128-
idToString _ = Nothing
132+
fromArray (A.Array v) = Just $ V.toList v
133+
fromArray _ = Nothing
129134

130135
testBatchNotifications :: Assertion
131136
testBatchNotifications = runState response 0 @?= (Nothing, 10)
132-
where response = call (toMethods [incrementStateMethod]) $ A.encode rq
137+
where response = S.call (S.toMethods [incrementStateMethod]) $ A.encode rq
133138
rq = replicate 10 $ request Nothing "increment" Nothing
134139

135140
testAllowMissingVersion :: Assertion
136141
testAllowMissingVersion = callSubtractMethods requestNoVersion @?= (Just $ defaultRsp `result` A.Number 1)
137142
where requestNoVersion = defaultRq `version` Nothing `params` Just (A.object ["x" .= A.Number 1])
138143

139-
incrementStateMethod :: Method (State Int)
140-
incrementStateMethod = toMethod "increment" f ()
141-
where f :: RpcResult (State Int) ()
144+
incrementStateMethod :: S.Method (State Int)
145+
incrementStateMethod = S.toMethod "increment" f ()
146+
where f :: S.RpcResult (State Int) ()
142147
f = lift $ modify (+1)
143148

144149
assertGetTimeResponse :: Maybe A.Value -> Assertion
@@ -149,40 +154,35 @@ assertGetTimeResponse args = passed @? "unexpected RPC response"
149154
rsp = callGetTimeMethod req
150155

151156
callSubtractMethods :: A.Value -> Maybe A.Value
152-
callSubtractMethods req = let methods :: Methods Identity
153-
methods = toMethods [subtractMethod, flippedSubtractMethod]
154-
rsp = call methods $ A.encode req
155-
in fromByteString =<< runIdentity rsp
157+
callSubtractMethods req = let methods :: S.Methods Identity
158+
methods = S.toMethods [subtractMethod, flippedSubtractMethod]
159+
rsp = S.call methods $ A.encode req
160+
in A.decode =<< runIdentity rsp
156161

157162
callGetTimeMethod :: A.Value -> IO (Maybe A.Value)
158-
callGetTimeMethod req = let methods :: Methods IO
159-
methods = toMethods [getTimeMethod]
160-
rsp = call methods $ A.encode req
161-
in (fromByteString =<<) <$> rsp
162-
163-
fromByteString :: A.FromJSON a => B.ByteString -> Maybe a
164-
fromByteString str = case A.fromJSON <$> A.decode str of
165-
Just (A.Success x) -> Just x
166-
_ -> Nothing
163+
callGetTimeMethod req = let methods :: S.Methods IO
164+
methods = S.toMethods [getTimeMethod]
165+
rsp = S.call methods $ A.encode req
166+
in (A.decode =<<) <$> rsp
167167

168-
subtractMethod :: Method Identity
169-
subtractMethod = toMethod "subtract" subtract (Required "x" :+: Optional "y" 0 :+: ())
168+
subtractMethod :: S.Method Identity
169+
subtractMethod = S.toMethod "subtract" subtract (S.Required "x" :+: S.Optional "y" 0 :+: ())
170170

171-
flippedSubtractMethod :: Method Identity
172-
flippedSubtractMethod = toMethod "flipped subtract" (flip subtract) ps
173-
where ps = Optional "y" (-1000) :+: Required "x" :+: ()
171+
flippedSubtractMethod :: S.Method Identity
172+
flippedSubtractMethod = S.toMethod "flipped subtract" (flip subtract) ps
173+
where ps = S.Optional "y" (-1000) :+: S.Required "x" :+: ()
174174

175-
subtract :: Int -> Int -> RpcResult Identity Int
175+
subtract :: Int -> Int -> S.RpcResult Identity Int
176176
subtract x y = return (x - y)
177177

178-
getTimeMethod :: Method IO
179-
getTimeMethod = toMethod "get_time_seconds" getTestTime ()
180-
where getTestTime :: RpcResult IO Integer
178+
getTimeMethod :: S.Method IO
179+
getTimeMethod = S.toMethod "get_time_seconds" getTestTime ()
180+
where getTestTime :: S.RpcResult IO Integer
181181
getTestTime = liftIO $ return 100
182182

183183
removeErrMsg :: A.Value -> A.Value
184-
removeErrMsg (A.Object rsp) = A.Object $ H.adjust removeMsg errKey rsp
185-
where removeMsg (A.Object err) = A.Object $ H.insert msgKey "" $ H.delete dataKey err
184+
removeErrMsg (A.Object rsp) = A.Object $ H.adjust removeMsg "error" rsp
185+
where removeMsg (A.Object err) = A.Object $ H.insert "message" "" $ H.delete "data" err
186186
removeMsg v = v
187187
removeErrMsg (A.Array rsps) = A.Array $ removeErrMsg <$> rsps
188188
removeErrMsg v = v

0 commit comments

Comments
 (0)