Skip to content

Commit 481d84d

Browse files
sebrightsebright
committed
Continued refactoring tests
1 parent 86f979b commit 481d84d

File tree

3 files changed

+97
-97
lines changed

3 files changed

+97
-97
lines changed

‎tests/Internal.hs‎

Lines changed: 50 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -2,16 +2,21 @@
22
ExistentialQuantification #-}
33

44
module Internal ( request
5-
, request2_0
6-
, idRequest
7-
, successRsp
8-
, idSuccessRsp
95
, errRsp
106
, rpcErr
11-
, idErrRsp
7+
, defaultIdErrRsp
8+
, nullIdErrRsp
129
, fromJson
1310
, array
11+
, defaultRq
12+
, defaultRsp
13+
, method
14+
, params
15+
, id'
16+
, version
17+
, result
1418
, defaultId
19+
, defaultResult
1520
, errKey
1621
, dataKey
1722
, msgKey
@@ -21,6 +26,7 @@ module Internal ( request
2126

2227
import qualified Data.Aeson as A
2328
import Data.Aeson ((.=))
29+
import qualified Data.HashMap.Strict as H
2430
import Data.Maybe (catMaybes)
2531
import qualified Data.Vector as V
2632
import Data.Text (Text)
@@ -34,26 +40,39 @@ fromJson v = case A.fromJSON v of
3440
array :: [A.Value] -> A.Value
3541
array = A.Array . V.fromList
3642

37-
idRequest :: Text -> Maybe A.Value -> A.Value
38-
idRequest = request2_0 (Just defaultId)
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]
3946

40-
request2_0 :: Maybe A.Value -> Text -> Maybe A.Value -> A.Value
41-
request2_0 i = request (Just version) i . A.String
47+
method :: A.Value -> Text -> A.Value
48+
method rq m = insert rq "method" $ Just $ A.String m
4249

43-
request :: Maybe Text -> Maybe A.Value -> A.Value -> Maybe A.Value -> A.Value
44-
request ver i method args = A.object $ catMaybes [ Just $ "method" .= method
45-
, ("params" .=) <$> args
46-
, (idKey .=) <$> i
47-
, (versionKey .=) <$> ver ]
50+
params :: A.Value -> Maybe A.Value -> A.Value
51+
params rq = insert rq "params"
4852

49-
idSuccessRsp :: A.Value -> A.Value
50-
idSuccessRsp = successRsp defaultId
53+
id' :: A.Value -> Maybe A.Value -> A.Value
54+
id' rq = insert rq "id"
5155

52-
successRsp :: A.Value -> A.Value -> A.Value
53-
successRsp i = response i "result"
56+
version :: A.Value -> Maybe A.Value -> A.Value
57+
version rq = insert rq "jsonrpc"
5458

55-
idErrRsp :: Int -> A.Value
56-
idErrRsp = errRsp defaultId
59+
request :: Maybe A.Value -> Text -> Maybe A.Value -> A.Value
60+
request i m args = A.object $ catMaybes [ Just $ "method" .= A.String m
61+
, ("params" .=) <$> args
62+
, (idKey .=) <$> i
63+
, Just (versionKey .= defaultVersion)]
64+
65+
defaultRsp :: A.Value
66+
defaultRsp = response defaultId "result" defaultResult
67+
68+
result :: A.Value -> A.Value -> A.Value
69+
result rsp = insert rsp "result" . Just
70+
71+
defaultIdErrRsp :: Int -> A.Value
72+
defaultIdErrRsp = errRsp defaultId
73+
74+
nullIdErrRsp :: Int -> A.Value
75+
nullIdErrRsp = errRsp A.Null
5776

5877
errRsp :: A.Value -> Int -> A.Value
5978
errRsp i code = response i errKey $ rpcErr Nothing code ""
@@ -63,11 +82,19 @@ rpcErr d code msg = A.object $ ["code" .= code, msgKey .= msg] ++ dataPair
6382
where dataPair = catMaybes [(dataKey .=) <$> d]
6483

6584
response :: A.Value -> Text -> A.Value -> A.Value
66-
response i key result = A.object [idKey .= i, key .= result, versionKey .= version]
85+
response i key res = A.object [idKey .= i, key .= res, versionKey .= defaultVersion]
86+
87+
insert :: A.Value -> Text -> Maybe A.Value -> A.Value
88+
insert (A.Object obj) key Nothing = A.Object $ H.delete key obj
89+
insert (A.Object obj) key (Just val) = A.Object $ H.insert key val obj
90+
insert v _ _ = v
6791

6892
defaultId :: A.Value
6993
defaultId = A.Number 3
7094

95+
defaultResult :: A.Value
96+
defaultResult = A.Number (-1)
97+
7198
versionKey :: Text
7299
versionKey = "jsonrpc"
73100

@@ -86,5 +113,5 @@ msgKey = "message"
86113
dataKey :: Text
87114
dataKey = "data"
88115

89-
version :: Text
90-
version = "2.0"
116+
defaultVersion :: Text
117+
defaultVersion = "2.0"

‎tests/TestParallelism.hs‎

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -37,15 +37,17 @@ testParallelizingTasks = do
3737

3838
rspToIntId :: A.Value -> Maybe Int
3939
rspToIntId (A.Object rsp) = fromJson =<< H.lookup idKey rsp
40+
rspToIntId _ = Nothing
4041

4142
rspToCharResult :: A.Value -> Maybe Char
4243
rspToCharResult (A.Object rsp) = fromJson =<< H.lookup resultKey rsp
44+
rspToCharResult _ = Nothing
4345

4446
lockRequest :: Int -> A.Value
45-
lockRequest i = request2_0 (Just $ A.toJSON i) "lock" $ Just A.emptyObject
47+
lockRequest i = request (Just $ A.Number $ fromIntegral i) "lock" $ Just A.emptyObject
4648

4749
unlockRequest :: Char -> A.Value
48-
unlockRequest ch = request2_0 Nothing "unlock" $ Just $ A.object ["value" .= ch]
50+
unlockRequest ch = request Nothing "unlock" $ Just $ A.object ["value" .= ch]
4951

5052
lockMethod :: MVar Char -> Method IO
5153
lockMethod lock = toMethod "lock" f ()

‎tests/TestSuite.hs‎

Lines changed: 43 additions & 72 deletions
Original file line numberDiff line numberDiff line change
@@ -11,7 +11,6 @@ import Data.Function (on)
1111
import qualified Data.Aeson as A
1212
import Data.Aeson ((.=))
1313
import qualified Data.Aeson.Types as A
14-
import Data.Text (Text)
1514
import qualified Data.ByteString.Lazy.Char8 as B
1615
import qualified Data.HashMap.Strict as H
1716
import Control.Applicative
@@ -28,43 +27,43 @@ main = defaultMain $ errorHandlingTests ++ otherTests
2827

2928
errorHandlingTests :: [Test]
3029
errorHandlingTests = [ testCase "invalid JSON" $
31-
assertSubtractResponse (A.String "5") (errRsp A.Null (-32700))
30+
assertSubtractResponse (A.String "5") $ nullIdErrRsp (-32700)
3231

3332
, testCase "invalid JSON RPC" $
34-
assertSubtractResponse (A.object ["id" .= A.Number 10]) (errRsp A.Null (-32600))
33+
assertSubtractResponse (A.object ["id" .= A.Number 10]) $ nullIdErrRsp (-32600)
3534

3635
, testCase "empty batch call" $
37-
assertSubtractResponse A.emptyArray (errRsp A.Null (-32600))
36+
assertSubtractResponse A.emptyArray $ nullIdErrRsp (-32600)
3837

3938
, testCase "invalid batch element" $
40-
removeErrMsg <$> callSubtractMethods (array [A.Bool True]) @?= Just (array [errRsp A.Null (-32600)])
39+
removeErrMsg <$> callSubtractMethods (array [A.Bool True]) @?= Just (array [nullIdErrRsp (-32600)])
4140

42-
, testCase "wrong request version" testWrongVersion
41+
, testCase "wrong request version" $
42+
assertSubtractResponse (defaultRq `version` Just "1.0") $ nullIdErrRsp (-32600)
4343

44-
, testCase "wrong id type" testWrongIdType
44+
, testCase "wrong id type" $
45+
assertSubtractResponse (defaultRq `id'` (Just $ A.Bool True)) $ nullIdErrRsp (-32600)
4546

46-
, let req = idRequest "add" $ Just defaultArgs
47-
rsp = idErrRsp (-32601)
48-
in testCase "method not found" $ assertSubtractResponse req rsp
47+
, testCase "method not found" $
48+
assertSubtractResponse (defaultRq `method` "add") (defaultIdErrRsp (-32601))
4949

50-
, let req = idRequest "Subtract" $ Just defaultArgs
51-
rsp = idErrRsp (-32601)
52-
in testCase "wrong method name capitalization" $ assertSubtractResponse req rsp
50+
, testCase "wrong method name capitalization" $
51+
assertSubtractResponse (defaultRq `method` "Subtract") (defaultIdErrRsp (-32601))
5352

5453
, testCase "missing required named argument" $
55-
assertInvalidParams "subtract" $ A.object ["a" .= A.Number 1, "y" .= A.Number 20]
54+
assertInvalidParams $ defaultRq `params` Just (A.object ["a" .= A.Number 1, "y" .= A.Number 20])
5655

5756
, testCase "missing required unnamed argument" $
58-
assertInvalidParams "subtract 2" $ array [A.Number 0]
57+
assertInvalidParams $ defaultRq `method` "flipped subtract" `params` Just (array [A.Number 0])
5958

6059
, testCase "wrong argument type" $
61-
assertInvalidParams "subtract" $ A.object [("x", A.Number 1), ("y", A.String "2")]
60+
assertInvalidParams $ defaultRq `params` Just (A.object ["x" .= A.Number 1, "y" .= A.String "2"])
6261

6362
, testCase "extra unnamed arguments" $
64-
assertInvalidParams "subtract" $ array $ map A.Number [1, 2, 3]
63+
assertInvalidParams $ defaultRq `params` Just (array $ map A.Number [1, 2, 3])
6564

66-
, let req = request2_0 Nothing "12345" $ Just defaultArgs
67-
in testCase "invalid notification" $ callSubtractMethods req @?= (Nothing :: Maybe A.Value) ]
65+
, let req = defaultRq `id'` Nothing `method` "12345"
66+
in testCase "invalid notification" $ callSubtractMethods req @?= Nothing ]
6867

6968
otherTests :: [Test]
7069
otherTests = [ testCase "encode RPC error" $
@@ -79,25 +78,22 @@ otherTests = [ testCase "encode RPC error" $
7978
, testCase "batch notifications" testBatchNotifications
8079
, testCase "allow missing version" testAllowMissingVersion
8180

82-
, testCase "no arguments" $
83-
assertGetTimeResponse Nothing
81+
, testCase "no arguments" $ assertGetTimeResponse Nothing
8482

85-
, testCase "empty argument array" $
86-
assertGetTimeResponse $ Just A.emptyArray
83+
, testCase "empty argument array" $ assertGetTimeResponse $ Just A.emptyArray
8784

88-
, testCase "empty argument A.object" $
89-
assertGetTimeResponse $ Just A.emptyObject
85+
, testCase "empty argument A.object" $ assertGetTimeResponse $ Just A.emptyObject
9086

91-
, let req = subtractRq $ Just $ A.object ["x" .= A.Number 10, "y" .= A.Number 20, "z" .= A.String "extra"]
92-
rsp = idSuccessRsp $ A.Number (-10)
87+
, let req = defaultRq `params` (Just $ A.object ["x" .= A.Number 10, "y" .= A.Number 20, "z" .= A.String "extra"])
88+
rsp = defaultRsp `result` A.Number (-10)
9389
in testCase "allow extra named argument" $ assertSubtractResponse req rsp
9490

95-
, let req = subtractRq $ Just $ A.object [("x1", A.Number 500), ("x", A.Number 1000)]
96-
rsp = idSuccessRsp $ A.Number 1000
91+
, let req = defaultRq `params` (Just $ A.object [("x1", A.Number 500), ("x", A.Number 1000)])
92+
rsp = defaultRsp `result` A.Number 1000
9793
in testCase "use default named argument" $ assertSubtractResponse req rsp
9894

99-
, let req = subtractRq $ Just $ array [A.Number 4]
100-
rsp = idSuccessRsp $ A.Number 4
95+
, let req = defaultRq `params` (Just $ array [A.Number 4])
96+
rsp = defaultRsp `result` A.Number 4
10197
in testCase "use default unnamed argument" $ assertSubtractResponse req rsp
10298

10399
, testCase "string request ID" $ assertEqualId $ A.String "ID 5"
@@ -111,32 +107,18 @@ assertSubtractResponse rq expectedRsp = removeErrMsg <$> rsp @?= Just expectedRs
111107
where rsp = callSubtractMethods rq
112108

113109
assertEqualId :: A.Value -> Assertion
114-
assertEqualId i = let req = request2_0 (Just i) "subtract" (Just defaultArgs)
115-
rsp = successRsp i defaultResult
116-
in assertSubtractResponse req rsp
117-
118-
assertInvalidParams :: Text -> A.Value -> Assertion
119-
assertInvalidParams name args = let req = idRequest name $ Just args
120-
rsp = idErrRsp (-32602)
121-
in assertSubtractResponse req rsp
122-
123-
testWrongVersion :: Assertion
124-
testWrongVersion = removeErrMsg <$> rsp @?= Just (errRsp A.Null (-32600))
125-
where rsp = callSubtractMethods $ request ver (Just defaultId) (A.String "subtract") args
126-
ver = Just "1.0"
127-
args = Just $ A.object ["x" .= A.Number 4]
128-
129-
testWrongIdType :: Assertion
130-
testWrongIdType = removeErrMsg <$> rsp @?= Just (errRsp A.Null (-32600))
131-
where rsp = callSubtractMethods $ request2_0 (Just $ A.Bool True) "subtract" args
132-
args = Just $ A.object ["x" .= A.Number 4]
110+
assertEqualId i = assertSubtractResponse (defaultRq `id'` Just i) (defaultRsp `id'` Just i)
111+
112+
assertInvalidParams :: A.Value -> Assertion
113+
assertInvalidParams req = assertSubtractResponse req (defaultIdErrRsp (-32602))
133114

134115
testBatch :: Assertion
135116
testBatch = sortBy (compare `on` idToString) <$> response @?= Just expected
136-
where expected = [successRsp i1 (A.Number 2), successRsp i2 (A.Number 4)]
137-
response :: Maybe [A.Value]
138-
response = A.decode =<< runIdentity (call (toMethods [subtractMethod]) $ A.encode rq)
139-
rq = [request2_0 (Just i1) "subtract" (toArgs 10 8), request2_0 (Just i2) "subtract" (toArgs 24 20)]
117+
where expected = [rsp i1 2, rsp i2 4]
118+
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]
121+
where rq i x y = defaultRq `id'` Just i `params` toArgs x y
140122
toArgs :: Int -> Int -> Maybe A.Value
141123
toArgs x y = Just $ A.object ["x" .= x, "y" .= y]
142124
i1 = A.Number 1
@@ -148,13 +130,11 @@ testBatch = sortBy (compare `on` idToString) <$> response @?= Just expected
148130
testBatchNotifications :: Assertion
149131
testBatchNotifications = runState response 0 @?= (Nothing, 10)
150132
where response = call (toMethods [incrementStateMethod]) $ A.encode rq
151-
rq = replicate 10 $ request2_0 Nothing "increment" Nothing
133+
rq = replicate 10 $ request Nothing "increment" Nothing
152134

153135
testAllowMissingVersion :: Assertion
154-
testAllowMissingVersion = (fromByteString =<< runIdentity response) @?= (Just $ idSuccessRsp (A.Number 1))
155-
where response = call (toMethods [subtractMethod]) $ A.encode requestNoVersion
156-
requestNoVersion = request Nothing (Just defaultId) "subtract" args
157-
args = Just $ A.object ["x" .= A.Number 1]
136+
testAllowMissingVersion = callSubtractMethods requestNoVersion @?= (Just $ defaultRsp `result` A.Number 1)
137+
where requestNoVersion = defaultRq `version` Nothing `params` Just (A.object ["x" .= A.Number 1])
158138

159139
incrementStateMethod :: Method (State Int)
160140
incrementStateMethod = toMethod "increment" f ()
@@ -164,8 +144,8 @@ incrementStateMethod = toMethod "increment" f ()
164144
assertGetTimeResponse :: Maybe A.Value -> Assertion
165145
assertGetTimeResponse args = passed @? "unexpected RPC response"
166146
where passed = (expected ==) <$> rsp
167-
expected = Just $ idSuccessRsp (A.Number 100)
168-
req = idRequest "get_time_seconds" args
147+
expected = Just $ defaultRsp `result` A.Number 100
148+
req = defaultRq `method` "get_time_seconds" `params` args
169149
rsp = callGetTimeMethod req
170150

171151
callSubtractMethods :: A.Value -> Maybe A.Value
@@ -189,8 +169,8 @@ subtractMethod :: Method Identity
189169
subtractMethod = toMethod "subtract" subtract (Required "x" :+: Optional "y" 0 :+: ())
190170

191171
flippedSubtractMethod :: Method Identity
192-
flippedSubtractMethod = toMethod "subtract 2" (flip subtract) params
193-
where params = Optional "y" (-1000) :+: Required "x" :+: ()
172+
flippedSubtractMethod = toMethod "flipped subtract" (flip subtract) ps
173+
where ps = Optional "y" (-1000) :+: Required "x" :+: ()
194174

195175
subtract :: Int -> Int -> RpcResult Identity Int
196176
subtract x y = return (x - y)
@@ -206,12 +186,3 @@ removeErrMsg (A.Object rsp) = A.Object $ H.adjust removeMsg errKey rsp
206186
removeMsg v = v
207187
removeErrMsg (A.Array rsps) = A.Array $ removeErrMsg <$> rsps
208188
removeErrMsg v = v
209-
210-
defaultArgs :: A.Value
211-
defaultArgs = array $ map A.Number [1, 2]
212-
213-
defaultResult :: A.Value
214-
defaultResult = A.Number (-1)
215-
216-
subtractRq :: Maybe A.Value -> A.Value
217-
subtractRq = idRequest "subtract"

0 commit comments

Comments
 (0)