Skip to content

Commit 66dec39

Browse files
sebrightsebright
committed
Continued refactoring tests
1 parent fe3aea6 commit 66dec39

File tree

2 files changed

+99
-77
lines changed

2 files changed

+99
-77
lines changed

‎tests/TestSuite.hs‎

Lines changed: 92 additions & 72 deletions
Original file line numberDiff line numberDiff line change
@@ -17,107 +17,125 @@ import Control.Applicative
1717
import Control.Monad.Trans
1818
import Control.Monad.State
1919
import Control.Monad.Identity
20-
import Test.HUnit hiding (State)
20+
import Test.HUnit hiding (State, Test)
2121
import Test.Framework
2222
import Test.Framework.Providers.HUnit
2323
import Prelude hiding (subtract)
2424

2525
main :: IO ()
26-
main = defaultMain [ testCase "encode RPC error" $
27-
fromByteString (encode $ rpcError (-1) "error") @?= Just (TestRpcError (-1) "error" Nothing)
26+
main = defaultMain $ errorHandlingTests ++ otherTests
2827

29-
, let err = rpcErrorWithData 1 "my message" errData
30-
testError = TestRpcError 1 "my message" $ Just $ toJSON errData
31-
errData = ('\x03BB', [True], ())
32-
in testCase "encode error with data" $ fromByteString (encode err) @?= Just testError
28+
errorHandlingTests :: [Test]
29+
errorHandlingTests = [ testCase "invalid JSON" $
30+
assertSubtractResponse ("5" :: String) (errResponse idNull (-32700))
3331

34-
, testCase "invalid JSON" $
35-
assertSubtractResponse ("5" :: String) (errResponse idNull (-32700))
32+
, testCase "invalid JSON RPC" $
33+
assertSubtractResponse (object ["id" .= (10 :: Int)]) (errResponse idNull (-32600))
3634

37-
, testCase "invalid JSON RPC" $
38-
assertSubtractResponse (object ["id" .= (10 :: Int)]) (errResponse idNull (-32600))
35+
, testCase "empty batch call" $
36+
assertSubtractResponse emptyArray (errResponse idNull (-32600))
3937

40-
, testCase "empty batch call" $
41-
assertSubtractResponse emptyArray (errResponse idNull (-32600))
38+
, testCase "invalid batch element" $
39+
map removeErrMsg <$> callSubtractMethods [True] @?= Just [errResponse idNull (-32600)]
4240

43-
, testCase "invalid batch element" $
44-
map removeErrMsg <$> callSubtractMethods [True] @?= Just [errResponse idNull (-32600)]
41+
, testCase "wrong request version" testWrongVersion
4542

46-
, testCase "wrong version in request" testWrongVersion
43+
, testCase "wrong id type" testWrongIdType
4744

48-
, let req = TestRequest "add" (Just defaultArgs) (Just nonNullId)
49-
rsp = errResponse nonNullId (-32601)
50-
in testCase "method not found" $ assertSubtractResponse req rsp
45+
, let req = TestRequest "add" (Just defaultArgs) (Just defaultIdNonNull)
46+
rsp = errResponse defaultIdNonNull (-32601)
47+
in testCase "method not found" $ assertSubtractResponse req rsp
5148

52-
, let req = TestRequest "Subtract" (Just defaultArgs) (Just nonNullId)
53-
rsp = errResponse nonNullId (-32601)
54-
in testCase "wrong method name capitalization" $ assertSubtractResponse req rsp
49+
, let req = TestRequest "Subtract" (Just defaultArgs) (Just defaultIdNonNull)
50+
rsp = errResponse defaultIdNonNull (-32601)
51+
in testCase "wrong method name capitalization" $ assertSubtractResponse req rsp
5552

56-
, let req = subtractRequestNamed [("X", Number 1), ("y", Number 20)] nonNullId
57-
rsp = errResponse nonNullId (-32602)
58-
in testCase "missing required named argument" $ assertSubtractResponse req rsp
53+
, testCase "missing required named argument" $
54+
assertInvalidParams "subtract" $ object ["a" .= Number 1, "y" .= Number 20]
5955

60-
, let req = TestRequest "subtract 2" (Just [Number 0]) (Just nonNullId)
61-
rsp = errResponse nonNullId (-32602)
62-
in testCase "missing required unnamed argument" $ assertSubtractResponse req rsp
56+
, testCase "missing required unnamed argument" $
57+
assertInvalidParams "subtract 2" [Number 0]
6358

64-
, let req = subtractRequestNamed [("x", Number 1), ("y", String "2")] nonNullId
65-
rsp = errResponse nonNullId (-32602)
66-
in testCase "wrong argument type" $ assertSubtractResponse req rsp
59+
, testCase "wrong argument type" $
60+
assertInvalidParams "subtract" $ object [("x", Number 1), ("y", String "2")]
6761

68-
, let req = subtractRequestUnnamed (map Number [1, 2, 3]) nonNullId
69-
rsp = errResponse nonNullId (-32602)
70-
in testCase "disallow extra unnamed arguments" $ assertSubtractResponse req rsp
62+
, testCase "extra unnamed arguments" $
63+
assertInvalidParams "subtract" $ map Number [1, 2, 3]
7164

72-
, let req = TestRequest "12345" (Nothing :: Maybe ()) Nothing
73-
in testCase "invalid notification" $ callSubtractMethods req @?= (Nothing :: Maybe Value)
65+
, let req = TestRequest "12345" (Just defaultArgs) Nothing
66+
in testCase "invalid notification" $ callSubtractMethods req @?= (Nothing :: Maybe Value) ]
7467

75-
, testCase "batch request" testBatch
76-
, testCase "batch notifications" testBatchNotifications
77-
, testCase "allow missing version" testAllowMissingVersion
68+
otherTests :: [Test]
69+
otherTests = [ testCase "encode RPC error" $
70+
fromByteString (encode $ rpcError (-1) "error") @?= Just (TestRpcError (-1) "error" Nothing)
7871

79-
, testCase "no arguments" $
80-
assertGetTimeResponse (Nothing :: Maybe Value)
72+
, let err = rpcErrorWithData 1 "my message" errData
73+
testError = TestRpcError 1 "my message" $ Just $ toJSON errData
74+
errData = ('\x03BB', [True], ())
75+
in testCase "encode RPC error with data" $ fromByteString (encode err) @?= Just testError
8176

82-
, testCase "empty argument array" $
83-
assertGetTimeResponse $ Just (empty :: Array)
77+
, testCase "batch request" testBatch
78+
, testCase "batch notifications" testBatchNotifications
79+
, testCase "allow missing version" testAllowMissingVersion
8480

85-
, testCase "empty argument object" $
86-
assertGetTimeResponse $ Just (H.empty :: Object)
81+
, testCase "no arguments" $
82+
assertGetTimeResponse (Nothing :: Maybe Value)
8783

88-
, let req = subtractRequestNamed [("x", Number 10), ("y", Number 20), ("z", String "extra")] nonNullId
89-
rsp = TestResponse nonNullId $ Right $ Number (-10)
90-
in testCase "allow extra named argument" $ assertSubtractResponse req rsp
84+
, testCase "empty argument array" $
85+
assertGetTimeResponse $ Just (empty :: Array)
9186

92-
, let req = subtractRequestNamed [("x1", Number 500), ("x", Number 1000)] nonNullId
93-
rsp = TestResponse nonNullId (Right $ Number 1000)
94-
in testCase "use default named argument" $ assertSubtractResponse req rsp
87+
, testCase "empty argument object" $
88+
assertGetTimeResponse $ Just (H.empty :: Object)
9589

96-
, let req = subtractRequestUnnamed [Number 4] nonNullId
97-
rsp = TestResponse nonNullId (Right $ Number 4)
98-
in testCase "use default unnamed argument" $ assertSubtractResponse req rsp
90+
, let req = subtractRequestNamed ["x" .= Number 10, "y" .= Number 20, "z" .= String "extra"]
91+
rsp = TestResponse defaultIdNonNull $ Right $ Number (-10)
92+
in testCase "allow extra named argument" $ assertSubtractResponse req rsp
9993

100-
, let req = subtractRequestNamed [("y", Number 70), ("x", Number (-10))] idNull
101-
rsp = TestResponse idNull (Right $ Number (-80))
102-
in testCase "null request ID" $ assertSubtractResponse req rsp
94+
, let req = subtractRequestNamed [("x1", Number 500), ("x", Number 1000)]
95+
rsp = TestResponse defaultIdNonNull (Right $ Number 1000)
96+
in testCase "use default named argument" $ assertSubtractResponse req rsp
10397

104-
, testCase "parallelize tasks" P.testParallelizingTasks ]
98+
, let req = subtractRequestUnnamed [Number 4]
99+
rsp = TestResponse defaultIdNonNull (Right $ Number 4)
100+
in testCase "use default unnamed argument" $ assertSubtractResponse req rsp
101+
102+
, testCase "string request ID" $ assertEqualId $ idString "ID 5"
103+
104+
, testCase "null request ID" $ assertEqualId idNull
105+
106+
, testCase "parallelize tasks" P.testParallelizingTasks ]
105107

106108
assertSubtractResponse :: ToJSON a => a -> TestResponse -> Assertion
107109
assertSubtractResponse request expectedRsp = removeErrMsg <$> rsp @?= Just expectedRsp
108110
where rsp = callSubtractMethods request
109111

112+
assertEqualId :: TestId -> Assertion
113+
assertEqualId i = let req = TestRequest "subtract" (Just defaultArgs) (Just i)
114+
rsp = TestResponse i $ Right defaultResult
115+
in assertSubtractResponse req rsp
116+
117+
assertInvalidParams :: ToJSON a => Text -> a -> Assertion
118+
assertInvalidParams name args = let req = TestRequest name (Just args) $ Just defaultIdNonNull
119+
rsp = errResponse defaultIdNonNull (-32602)
120+
in assertSubtractResponse req rsp
121+
110122
testWrongVersion :: Assertion
111123
testWrongVersion = removeErrMsg <$> rsp @?= Just (errResponse idNull (-32600))
112124
where rsp = callSubtractMethods $ Object $ H.insert versionKey (String "1") hm
113-
Object hm = toJSON $ subtractRequestNamed [("x", Number 4)] nonNullId
125+
Object hm = toJSON $ subtractRequestNamed [("x", Number 4)]
126+
127+
testWrongIdType :: Assertion
128+
testWrongIdType = removeErrMsg <$> rsp @?= Just (errResponse idNull (-32600))
129+
where rsp = callSubtractMethods $ Object $ H.insert idKey (Bool True) hm
130+
Object hm = toJSON $ subtractRequestNamed [("x", Number 4)]
114131

115132
testBatch :: Assertion
116133
testBatch = sortBy (compare `on` fromIntId) (fromJust (fromByteString =<< runIdentity response)) @?= expected
117134
where expected = [TestResponse i1 (Right $ Number 2), TestResponse i2 (Right $ Number 4)]
118135
response = call (toMethods [subtractMethod]) $ encode request
119-
request = [subtractRequestNamed (toArgs 10 8) i1, subtractRequestNamed (toArgs 24 20) i2]
120-
toArgs x y = [("x", Number x), ("y", Number y)]
136+
request = [TestRequest "subtract" (toArgs 10 8) (Just i1), TestRequest "subtract" (toArgs 24 20) (Just i2)]
137+
toArgs :: Int -> Int -> Maybe Value
138+
toArgs x y = Just $ object ["x" .= x, "y" .= y]
121139
i1 = idNumber 1
122140
i2 = idNumber 2
123141
fromIntId rsp = (fromNumId $ rspId rsp) :: Maybe Int
@@ -128,11 +146,10 @@ testBatchNotifications = runState response 0 @?= (Nothing, 10)
128146
request = replicate 10 $ TestRequest "increment" (Nothing :: Maybe ()) Nothing
129147

130148
testAllowMissingVersion :: Assertion
131-
testAllowMissingVersion = (fromByteString =<< runIdentity response) @?= (Just $ TestResponse i (Right $ Number 1))
149+
testAllowMissingVersion = (fromByteString =<< runIdentity response) @?= (Just $ TestResponse defaultIdNonNull (Right $ Number 1))
132150
where requestNoVersion = Object $ H.delete versionKey hm
133-
Object hm = toJSON $ subtractRequestNamed [("x", Number 1)] i
151+
Object hm = toJSON $ subtractRequestNamed [("x", Number 1)]
134152
response = call (toMethods [subtractMethod]) $ encode requestNoVersion
135-
i = idNumber (-1)
136153

137154
incrementStateMethod :: Method (State Int)
138155
incrementStateMethod = toMethod "increment" f ()
@@ -142,15 +159,15 @@ incrementStateMethod = toMethod "increment" f ()
142159
assertGetTimeResponse :: ToJSON a => a -> Assertion
143160
assertGetTimeResponse args = passed @? "unexpected RPC response"
144161
where passed = (expected ==) <$> rsp
145-
expected = Just $ TestResponse nonNullId (Right $ Number 100)
146-
req = TestRequest "get_time_seconds" (Just args) (Just nonNullId)
162+
expected = Just $ TestResponse defaultIdNonNull (Right $ Number 100)
163+
req = TestRequest "get_time_seconds" (Just args) (Just defaultIdNonNull)
147164
rsp = callGetTimeMethod req
148165

149-
subtractRequestNamed :: [(Text, Value)] -> TestId -> TestRequest
150-
subtractRequestNamed args i = TestRequest "subtract" (Just $ H.fromList args) (Just i)
166+
subtractRequestNamed :: [(Text, Value)] -> TestRequest
167+
subtractRequestNamed args = TestRequest "subtract" (Just $ H.fromList args) (Just defaultIdNonNull)
151168

152-
subtractRequestUnnamed :: [Value] -> TestId -> TestRequest
153-
subtractRequestUnnamed args i = TestRequest "subtract" (Just args) (Just i)
169+
subtractRequestUnnamed :: [Value] -> TestRequest
170+
subtractRequestUnnamed args = TestRequest "subtract" (Just args) (Just defaultIdNonNull)
154171

155172
callSubtractMethods :: (ToJSON a, FromJSON b) => a -> Maybe b
156173
callSubtractMethods req = let methods :: Methods Identity
@@ -192,8 +209,11 @@ removeErrMsg rsp = rsp
192209
errResponse :: TestId -> Int -> TestResponse
193210
errResponse i code = TestResponse i (Left (TestRpcError code "" Nothing))
194211

195-
nonNullId :: TestId
196-
nonNullId = idNumber 3
212+
defaultIdNonNull :: TestId
213+
defaultIdNonNull = idNumber 3
197214

198215
defaultArgs :: [Int]
199216
defaultArgs = [1, 2]
217+
218+
defaultResult :: Value
219+
defaultResult = Number (-1)

‎tests/TestTypes.hs‎

Lines changed: 7 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -10,6 +10,7 @@ module TestTypes ( TestRequest (..)
1010
, idNull
1111
, fromNumId
1212
, fromJson
13+
, idKey
1314
, versionKey) where
1415

1516
import qualified Data.Aeson as A
@@ -21,9 +22,7 @@ import Data.HashMap.Strict (size)
2122
import Control.Applicative ((<$>), (<*>), (<|>), pure, empty)
2223
import Control.Monad (when, guard)
2324

24-
data TestRpcError = TestRpcError { errCode :: Int
25-
, errMsg :: Text
26-
, errData :: Maybe A.Value}
25+
data TestRpcError = TestRpcError Int Text (Maybe A.Value)
2726
deriving (Eq, Show)
2827

2928
instance A.FromJSON TestRpcError where
@@ -38,7 +37,7 @@ data TestRequest = forall a. A.ToJSON a => TestRequest Text (Maybe a) (Maybe Tes
3837
instance A.ToJSON TestRequest where
3938
toJSON (TestRequest name params i) = A.object pairs
4039
where pairs = catMaybes [Just $ "method" .= name, idPair, paramsPair]
41-
idPair = ("id" .=) <$> i
40+
idPair = (idKey .=) <$> i
4241
paramsPair = ("params" .=) <$> params
4342

4443
data TestResponse = TestResponse { rspId :: TestId
@@ -49,7 +48,7 @@ instance A.FromJSON TestResponse where
4948
parseJSON (A.Object obj) = do
5049
guard (size obj == 3)
5150
guard . (pack "2.0" ==) =<< obj .: versionKey
52-
TestResponse <$> obj .: "id" <*>
51+
TestResponse <$> obj .: idKey <*>
5352
((Left <$> obj .: "error") <|> (Right <$> obj .: "result"))
5453
parseJSON _ = empty
5554

@@ -88,3 +87,6 @@ instance A.ToJSON TestId where
8887

8988
versionKey :: Text
9089
versionKey = "jsonrpc"
90+
91+
idKey :: Text
92+
idKey = "id"

0 commit comments

Comments
 (0)