@@ -2,8 +2,10 @@ module Main (main, logShow) where
22
33import Test.Framework (Test, defaultMain, testGroup)
44import Test.Framework.Providers.QuickCheck2 (testProperty)
5−import Test.QuickCheck (Gen, choose, suchThatMaybe, forAllShrink, Property)
5+import Test.Framework.Providers.HUnit (testCase)
6+import Test.QuickCheck (Gen, choose, suchThatMaybe, forAll, forAllShrink, Property)
67import Test.QuickCheck.Property (morallyDubiousIOProperty, Result(..), result)
8+import Test.HUnit (Assertion, assertFailure)
79import Data.Map (Map)
810import qualified Data.Map as Map
911import Control.Exception (Exception, throwIO)
@@ -16,13 +18,9 @@ import Network.Transport.TCP (createTransport, defaultTCPParameters)
1618
1719data ScriptCmd =
1820 NewEndPoint
19− | Connect Int Int Reliability ConnectHints
21+ | Connect Int Int
2022 | Close Int
21−
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
23+ deriving Show
2624
2725type Script = [ScriptCmd]
2826
@@ -52,7 +50,7 @@ script_Connect numEndPoints = do
5250 fr <- choose (0, numEndPoints - 1)
5351 to <- choose (0, numEndPoints - 1)
5452 cmds <- go
55− return (Connect fr to ReliableOrdered defaultConnectHints : cmds)
53+ return (Connect fr to : cmds)
5654 _ ->
5755 return []
5856
@@ -69,7 +67,7 @@ script_ConnectClose numEndPoints = do
6967 fr <- choose (0, numEndPoints - 1)
7068 to <- choose (0, numEndPoints - 1)
7169 cmds <- go (Map.insert (Map.size conns) True conns)
72− return (Connect fr to ReliableOrdered defaultConnectHints : cmds)
70+ return (Connect fr to : cmds)
7371 1 -> do
7472 mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns
7573 case mConn of
@@ -102,8 +100,8 @@ execScript transport script = do
102100 _tid <- forkIO $ forwardTo chan (endPointIx, endPoint)
103101 threadDelay 10000
104102 go (endPoints ++ [endPoint]) conns cmds
105− go endPoints conns (Connect fr to rel hints : cmds) = do
106− conn <- throwIfLeft $ connect (endPoints !! fr) (address (endPoints !! to)) rel hints
103+ go endPoints conns (Connect fr to : cmds) = do
104+ conn <- throwIfLeft $ connect (endPoints !! fr) (address (endPoints !! to)) ReliableOrdered defaultConnectHints
107105 threadDelay 10000
108106 go endPoints (conns ++ [conn]) cmds
109107 go endPoints conns (Close connIx : cmds) = do
@@ -135,13 +133,8 @@ execScript transport script = do
135133 insertEvent ev Nothing = Just [ev]
136134 insertEvent ev (Just evs) = Just (ev : evs)
137135
138−verify :: Script -> Map Int [Event] -> Result
139−verify script = \evs -> case go script [] evs of
140− Nothing -> result { ok = Just True
141− }
142− Just err -> result { ok = Just False
143− , reason = '\n' : err ++ "\nAll events: " ++ show evs
144− }
136+verify :: Script -> Map Int [Event] -> Maybe String
137+verify script = go script []
145138 where
146139 go :: Script -> [(Int, ConnectionId)] -> Map Int [Event] -> Maybe String
147140 go [] _conns evs =
@@ -150,11 +143,11 @@ verify script = \evs -> case go script [] evs of
150143 else Just $ "Unexpected events: " ++ show evs
151144 go (NewEndPoint : cmds) conns evs =
152145 go cmds conns evs
153− go (Connect _fr to rel _hints : cmds) conns evs =
146+ go (Connect _fr to : cmds) conns evs =
154147 case evs Map.! to of
155− (ConnectionOpened connId rel' _addr : epEvs) | rel' == rel ->
148+ (ConnectionOpened connId _rel _addr : epEvs) ->
156149 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
158151 go (Close connIx : cmds) conns evs =
159152 let (epIx, connId) = conns !! connIx in
160153 case evs Map.! epIx of
@@ -162,19 +155,45 @@ verify script = \evs -> case go script [] evs of
162155 go cmds conns (Map.insert epIx epEvs evs)
163156 _ -> Just $ "Missing (ConnectionClosed " ++ show connId ++ ") event in " ++ show evs
164157
165−genericProp :: Transport -> Int -> (Int -> Gen Script) -> Property
166−genericProp transport numEndPoints scriptGen =
167− forAllShrink (scriptGen numEndPoints) inits $ \script ->
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+
169+genericProp :: Transport -> Gen Script -> Property
170+genericProp transport scriptGen =
171+ forAll scriptGen $ \script ->
168172 morallyDubiousIOProperty $ do
173+ logShow script
169174 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 ()
171189
172190tests :: Transport -> [Test]
173191tests transport = [
174192 testGroup "Unidirectional" [
175− testProperty "NewEndPoint" (genericProp transport 2 script_NewEndPoint)
176− , testProperty "Connect" (genericProp transport 2 script_Connect)
177− , testProperty "ConnectClose" (genericProp transport 2 script_ConnectClose)
193+ -- testProperty "NewEndPoint" (genericProp transport (script_NewEndPoint 2))
194+ --, testProperty "Connect" (genericProp transport (script_Connect 2))
195+ testCase "testScript1" (testOneScript transport testScript1)
196+ -- testProperty "ConnectClose" (genericProp transport (script_ConnectClose 2))
178197 ]
179198 ]
180199