git.iko.soy/distributed-process
on master help sign in
Add support for testing individual scripts
9a836deEdsko de Vries
network-transport-tcp/network-transport-tcp.cabal+2
compare with master
unifiedsplit
@@ -62,7 +62,9 @@ Test-Suite TestQC
62 Build-Depends: base >= 4.3 && < 5,
62 Build-Depends: base >= 4.3 && < 5,
63 test-framework,
63 test-framework,
64 test-framework-quickcheck2,
64 test-framework-quickcheck2,
65+ test-framework-hunit,
65 QuickCheck,
66 QuickCheck,
67+ HUnit,
66 network-transport,
68 network-transport,
67 network-transport-tcp,
69 network-transport-tcp,
68 containers
70 containers
network-transport-tcp/tests/TestQC.hs+47−28
@@ -2,8 +2,10 @@ module Main (main, logShow) where
2
2
3import Test.Framework (Test, defaultMain, testGroup)
3import Test.Framework (Test, defaultMain, testGroup)
4import Test.Framework.Providers.QuickCheck2 (testProperty)
4import Test.Framework.Providers.QuickCheck2 (testProperty)
5+import Test.Framework.Providers.HUnit (testCase)
5−import Test.QuickCheck (Gen, choose, suchThatMaybe, forAllShrink, Property)
6+import Test.QuickCheck (Gen, choose, suchThatMaybe, forAll, forAllShrink, Property)
6import Test.QuickCheck.Property (morallyDubiousIOProperty, Result(..), result)
7import Test.QuickCheck.Property (morallyDubiousIOProperty, Result(..), result)
8+import Test.HUnit (Assertion, assertFailure)
7import Data.Map (Map)
9import Data.Map (Map)
8import qualified Data.Map as Map
10import qualified Data.Map as Map
9import Control.Exception (Exception, throwIO)
11import Control.Exception (Exception, throwIO)
@@ -16,13 +18,9 @@ import Network.Transport.TCP (createTransport, defaultTCPParameters)
16
18
17data ScriptCmd =
19data ScriptCmd =
18 NewEndPoint
20 NewEndPoint
19− | Connect Int Int Reliability ConnectHints
21+ | Connect Int Int
20 | Close Int
22 | Close Int
21−
23+ deriving Show
22−instance Show ScriptCmd where
23− show NewEndPoint = "NewEndPoint"
24− show (Connect fr to _ _) = "Connect " ++ show fr ++ " " ++ show to
25− show (Close i) = "Close " ++ show i
26
24
27type Script = [ScriptCmd]
25type Script = [ScriptCmd]
28
26
@@ -52,7 +50,7 @@ script_Connect numEndPoints = do
52 fr <- choose (0, numEndPoints - 1)
50 fr <- choose (0, numEndPoints - 1)
53 to <- choose (0, numEndPoints - 1)
51 to <- choose (0, numEndPoints - 1)
54 cmds <- go
52 cmds <- go
55− return (Connect fr to ReliableOrdered defaultConnectHints : cmds)
53+ return (Connect fr to : cmds)
56 _ ->
54 _ ->
57 return []
55 return []
58
56
@@ -69,7 +67,7 @@ script_ConnectClose numEndPoints = do
69 fr <- choose (0, numEndPoints - 1)
67 fr <- choose (0, numEndPoints - 1)
70 to <- choose (0, numEndPoints - 1)
68 to <- choose (0, numEndPoints - 1)
71 cmds <- go (Map.insert (Map.size conns) True conns)
69 cmds <- go (Map.insert (Map.size conns) True conns)
72− return (Connect fr to ReliableOrdered defaultConnectHints : cmds)
70+ return (Connect fr to : cmds)
73 1 -> do
71 1 -> do
74 mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns
72 mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns
75 case mConn of
73 case mConn of
@@ -102,8 +100,8 @@ execScript transport script = do
102 _tid <- forkIO $ forwardTo chan (endPointIx, endPoint)
100 _tid <- forkIO $ forwardTo chan (endPointIx, endPoint)
103 threadDelay 10000
101 threadDelay 10000
104 go (endPoints ++ [endPoint]) conns cmds
102 go (endPoints ++ [endPoint]) conns cmds
105− go endPoints conns (Connect fr to rel hints : cmds) = do
103+ go endPoints conns (Connect fr to : cmds) = do
106− conn <- throwIfLeft $ connect (endPoints !! fr) (address (endPoints !! to)) rel hints
104+ conn <- throwIfLeft $ connect (endPoints !! fr) (address (endPoints !! to)) ReliableOrdered defaultConnectHints
107 threadDelay 10000
105 threadDelay 10000
108 go endPoints (conns ++ [conn]) cmds
106 go endPoints (conns ++ [conn]) cmds
109 go endPoints conns (Close connIx : cmds) = do
107 go endPoints conns (Close connIx : cmds) = do
@@ -135,13 +133,8 @@ execScript transport script = do
135 insertEvent ev Nothing = Just [ev]
133 insertEvent ev Nothing = Just [ev]
136 insertEvent ev (Just evs) = Just (ev : evs)
134 insertEvent ev (Just evs) = Just (ev : evs)
137
135
138−verify :: Script -> Map Int [Event] -> Result
136+verify :: Script -> Map Int [Event] -> Maybe String
139−verify script = \evs -> case go script [] evs of
137+verify script = go script []
140− Nothing -> result { ok = Just True
141− }
142− Just err -> result { ok = Just False
143− , reason = '\n' : err ++ "\nAll events: " ++ show evs
144− }
145 where
138 where
146 go :: Script -> [(Int, ConnectionId)] -> Map Int [Event] -> Maybe String
139 go :: Script -> [(Int, ConnectionId)] -> Map Int [Event] -> Maybe String
147 go [] _conns evs =
140 go [] _conns evs =
@@ -150,11 +143,11 @@ verify script = \evs -> case go script [] evs of
150 else Just $ "Unexpected events: " ++ show evs
143 else Just $ "Unexpected events: " ++ show evs
151 go (NewEndPoint : cmds) conns evs =
144 go (NewEndPoint : cmds) conns evs =
152 go cmds conns evs
145 go cmds conns evs
153− go (Connect _fr to rel _hints : cmds) conns evs =
146+ go (Connect _fr to : cmds) conns evs =
154 case evs Map.! to of
147 case evs Map.! to of
155− (ConnectionOpened connId rel' _addr : epEvs) | rel' == rel ->
148+ (ConnectionOpened connId _rel _addr : epEvs) ->
156 go cmds (conns ++ [(to, connId)]) (Map.insert to epEvs evs)
149 go cmds (conns ++ [(to, connId)]) (Map.insert to epEvs evs)
157− _ -> Just $ "Missing (ConnectionOpened <<connId>> " ++ show rel ++ " <<addr>>) event in " ++ show evs
150+ _ -> Just $ "Missing (ConnectionOpened <<connId>> <<rel>> <<addr>>) event in " ++ show evs
158 go (Close connIx : cmds) conns evs =
151 go (Close connIx : cmds) conns evs =
159 let (epIx, connId) = conns !! connIx in
152 let (epIx, connId) = conns !! connIx in
160 case evs Map.! epIx of
153 case evs Map.! epIx of
@@ -162,19 +155,45 @@ verify script = \evs -> case go script [] evs of
162 go cmds conns (Map.insert epIx epEvs evs)
155 go cmds conns (Map.insert epIx epEvs evs)
163 _ -> Just $ "Missing (ConnectionClosed " ++ show connId ++ ") event in " ++ show evs
156 _ -> Just $ "Missing (ConnectionClosed " ++ show connId ++ ") event in " ++ show evs
164
157
158+testScript1 :: Script
159+testScript1 = [
160+ NewEndPoint
161+ , NewEndPoint
162+ , Connect 0 1
163+ , Close 0
164+ , Connect 1 0
165+ , Close 1
166+ , Connect 1 0
167+ ]
168+
165−genericProp :: Transport -> Int -> (Int -> Gen Script) -> Property
169+genericProp :: Transport -> Gen Script -> Property
166−genericProp transport numEndPoints scriptGen =
170+genericProp transport scriptGen =
167− forAllShrink (scriptGen numEndPoints) inits $ \script ->
171+ forAll scriptGen $ \script ->
168 morallyDubiousIOProperty $ do
172 morallyDubiousIOProperty $ do
173+ logShow script
169 evs <- execScript transport script
174 evs <- execScript transport script
170− return (verify script evs)
175+ return $ case verify script evs of
176+ Nothing -> result { ok = Just True
177+ }
178+ Just err -> result { ok = Just False
179+ , reason = '\n' : err ++ "\nAll events: " ++ show evs
180+ }
181+
182+testOneScript :: Transport -> Script -> Assertion
183+testOneScript transport script = do
184+ logShow script
185+ evs <- execScript transport script
186+ case verify script evs of
187+ Just err -> assertFailure $ "Failed with script " ++ show script ++ ": " ++ err
188+ Nothing -> return ()
171
189
172tests :: Transport -> [Test]
190tests :: Transport -> [Test]
173tests transport = [
191tests transport = [
174 testGroup "Unidirectional" [
192 testGroup "Unidirectional" [
175− testProperty "NewEndPoint" (genericProp transport 2 script_NewEndPoint)
193+ -- testProperty "NewEndPoint" (genericProp transport (script_NewEndPoint 2))
176− , testProperty "Connect" (genericProp transport 2 script_Connect)
194+ --, testProperty "Connect" (genericProp transport (script_Connect 2))
195+ testCase "testScript1" (testOneScript transport testScript1)
177− , testProperty "ConnectClose" (genericProp transport 2 script_ConnectClose)
196+ -- testProperty "ConnectClose" (genericProp transport (script_ConnectClose 2))
178 ]
197 ]
179 ]
198 ]
180
199