@@ -1,9 +1,23 @@
1−module Main (main, logShow) where
1+module Main
2+ ( main
3+ -- Shush the compiler about unused definitions
4+ , logShow
5+ , forAllShrink
6+ , inits
7+ ) where
28
3−import Test.Framework (Test, defaultMain, testGroup)
9+import Test.Framework (Test, TestName, defaultMain, testGroup)
410import Test.Framework.Providers.QuickCheck2 (testProperty)
511import Test.Framework.Providers.HUnit (testCase)
6−import Test.QuickCheck (Gen, choose, suchThatMaybe, forAll, forAllShrink, Property)
12+import Test.QuickCheck
13+ ( Gen
14+ , choose
15+ , suchThatMaybe
16+ , forAll
17+ , forAllShrink
18+ , Property
19+ , Arbitrary(arbitrary)
20+ )
721import Test.QuickCheck.Property (morallyDubiousIOProperty, Result(..), result)
822import Test.HUnit (Assertion, assertFailure)
923import Data.Map (Map)
@@ -11,7 +25,11 @@ import qualified Data.Map as Map
1125import Control.Exception (Exception, throwIO)
1226import Control.Concurrent (forkIO, threadDelay)
1327import Control.Concurrent.Chan (Chan, newChan, writeChan, readChan)
28+import Control.Monad (replicateM)
1429import Data.List (inits)
30+import Data.ByteString (ByteString)
31+import Data.ByteString.Char8 (pack)
32+import qualified Data.ByteString as BSS (concat)
1533
1634import Network.Transport
1735import Network.Transport.TCP (createTransport, defaultTCPParameters)
@@ -24,6 +42,7 @@ data ScriptCmd =
2442 NewEndPoint
2543 | Connect Int Int
2644 | Close Int
45+ | Send Int [ByteString]
2746 deriving Show
2847
2948type Script = [ScriptCmd]
@@ -39,7 +58,7 @@ execScript transport script = do
3958 where
4059 go :: [EndPoint] -> [Connection] -> Script -> IO ()
4160 go _endPoints _conns [] = do
42− threadDelay 100000
61+ threadDelay 10000
4362 writeChan chan Nothing
4463 go endPoints conns (NewEndPoint : cmds) = do
4564 endPoint <- throwIfLeft $ newEndPoint transport
@@ -55,6 +74,10 @@ execScript transport script = do
5574 close (conns !! connIx)
5675 threadDelay 10000
5776 go endPoints conns cmds
77+ go endPoints conns (Send connIx payload : cmds) = do
78+ Right () <- send (conns !! connIx) payload
79+ threadDelay 10000
80+ go endPoints conns cmds
5881
5982 forwardTo :: Chan (Maybe (Int, Event)) -> (Int, EndPoint) -> IO ()
6083 forwardTo chan (ix, endPoint) = go
@@ -91,16 +114,28 @@ verify script = go script []
91114 go (NewEndPoint : cmds) conns evs =
92115 go cmds conns evs
93116 go (Connect _fr to : cmds) conns evs =
94− case evs Map.! to of
95− (ConnectionOpened connId _rel _addr : epEvs) ->
96− go cmds (conns ++ [(to, connId)]) (Map.insert to epEvs evs)
97− _ -> Just $ "Missing (ConnectionOpened <<connId>> <<rel>> <<addr>>) event in " ++ show evs
117+ let epEvs = evs Map.! to
118+ in case epEvs of
119+ (ConnectionOpened connId _rel _addr : epEvs') ->
120+ go cmds (conns ++ [(to, connId)]) (Map.insert to epEvs' evs)
121+ _ ->
122+ Just $ "Missing (ConnectionOpened <<connId>> <<rel>> <<addr>>) event in " ++ show evs
98123 go (Close connIx : cmds) conns evs =
99− let (epIx, connId) = conns !! connIx in
100− case evs Map.! epIx of
101− (ConnectionClosed connId' : epEvs) | connId' == connId ->
102− go cmds conns (Map.insert epIx epEvs evs)
103− _ -> Just $ "Missing (ConnectionClosed " ++ show connId ++ ") event in " ++ show evs
124+ let (epIx, connId) = conns !! connIx
125+ epEvs = evs Map.! epIx
126+ in case epEvs of
127+ (ConnectionClosed connId' : epEvs') | connId' == connId ->
128+ go cmds conns (Map.insert epIx epEvs' evs)
129+ _ ->
130+ Just $ "Missing (ConnectionClosed " ++ show connId ++ ") event in " ++ show evs
131+ go (Send connIx payload : cmds) conns evs =
132+ let (epIx, connId) = conns !! connIx
133+ epEvs = evs Map.! epIx
134+ in case epEvs of
135+ (Received connId' payload' : epEvs') | connId' == connId && BSS.concat payload == BSS.concat payload' ->
136+ go cmds conns (Map.insert epIx epEvs' evs)
137+ _ ->
138+ Just $ "Missing (Received " ++ show connId ++ " " ++ show payload ++ ") event in " ++ show epEvs
104139
105140--------------------------------------------------------------------------------
106141-- Script generators --
@@ -153,6 +188,41 @@ script_ConnectClose numEndPoints = do
153188 isOpen :: Map Int Bool -> Int -> Bool
154189 isOpen conns connIx = connIx `Map.member` conns && conns Map.! connIx
155190
191+script_ConnectSendClose :: Int -> Gen Script
192+script_ConnectSendClose numEndPoints = do
193+ script <- go Map.empty
194+ return (replicate numEndPoints NewEndPoint ++ script)
195+ where
196+ go :: Map Int Bool -> Gen Script
197+ go conns = do
198+ next <- choose (0, 3) :: Gen Int
199+ case next of
200+ 0 -> do
201+ fr <- choose (0, numEndPoints - 1)
202+ to <- choose (0, numEndPoints - 1)
203+ cmds <- go (Map.insert (Map.size conns) True conns)
204+ return (Connect fr to : cmds)
205+ 1 -> do
206+ mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns
207+ case mConn of
208+ Nothing -> go conns
209+ Just conn -> do
210+ payload <- arbitrary
211+ cmds <- go conns
212+ return (Send conn payload : cmds)
213+ 2 -> do
214+ mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns
215+ case mConn of
216+ Nothing -> go conns
217+ Just conn -> do
218+ cmds <- go (Map.insert conn False conns)
219+ return (Close conn : cmds)
220+ _ ->
221+ return []
222+
223+ isOpen :: Map Int Bool -> Int -> Bool
224+ isOpen conns connIx = connIx `Map.member` conns && conns Map.! connIx
225+
156226--------------------------------------------------------------------------------
157227-- Individual scripts to test specific bugs --
158228--------------------------------------------------------------------------------
@@ -213,20 +283,30 @@ script_Bug1 = [
213283-- Main application driver --
214284--------------------------------------------------------------------------------
215285
286+basicTests :: Transport -> Int -> [Test]
287+basicTests transport numEndPoints = [
288+ testGen "NewEndPoint" transport (script_NewEndPoint 2)
289+ , testGen "Connect" transport (script_Connect 2)
290+ , testGen "ConnectClose" transport (script_ConnectClose 2)
291+ , testGen "ConnectSendClose" transport (script_ConnectSendClose 2)
292+ ]
293+
216294tests :: Transport -> [Test]
217295tests transport = [
218296 testGroup "Bugs" [
219− testOne "Bug1" script_Bug1
220− ]
221− , testGroup "Unidirectional" [
222− testQC "NewEndPoint" (script_NewEndPoint 2)
223− , testQC "Connect" (script_Connect 2)
224− , testQC "ConnectClose" (script_ConnectClose 2)
297+ testOne "Bug1" transport script_Bug1
225298 ]
299+ , testGroup "One endpoint, with delays" (basicTests transport 1)
300+ , testGroup "Two endpoints, with delays" (basicTests transport 2)
301+ , testGroup "Three endpoints, with delays" (basicTests transport 3)
226302 ]
227303 where
228− testOne label script = testCase label (testScript transport script)
229− testQC label script = testProperty label (testScriptGen transport script)
304+
305+testOne :: TestName -> Transport -> Script -> Test
306+testOne label transport script = testCase label (testScript transport script)
307+
308+testGen :: TestName -> Transport -> Gen Script -> Test
309+testGen label transport script = testProperty label (testScriptGen transport script)
230310
231311main :: IO ()
232312main = do
@@ -272,3 +352,8 @@ throwIfLeft p = do
272352 Left a -> throwIO a
273353 Right b -> return b
274354
355+instance Arbitrary ByteString where
356+ arbitrary = do
357+ len <- choose (0, 10)
358+ xs <- replicateM len arbitrary
359+ return (pack xs)