@@ -16,6 +16,10 @@ import Data.List (inits)
1616import Network.Transport
1717import Network.Transport.TCP (createTransport, defaultTCPParameters)
1818
19+--------------------------------------------------------------------------------
20+-- Script infrastructure --
21+--------------------------------------------------------------------------------
22+
1923data ScriptCmd =
2024 NewEndPoint
2125 | Connect Int Int
@@ -24,63 +28,6 @@ data ScriptCmd =
2428
2529type Script = [ScriptCmd]
2630
27−logShow :: Show a => a -> IO ()
28−logShow = appendFile "log" . (++ "\n") . show
29−
30−throwIfLeft :: Exception a => IO (Either a b) -> IO b
31−throwIfLeft p = do
32− mb <- p
33− case mb of
34− Left a -> throwIO a
35− Right b -> return b
36−
37−script_NewEndPoint :: Int -> Gen Script
38−script_NewEndPoint numEndPoints = return (replicate numEndPoints NewEndPoint)
39−
40−script_Connect :: Int -> Gen Script
41−script_Connect numEndPoints = do
42− script <- go
43− return (replicate numEndPoints NewEndPoint ++ script)
44− where
45− go :: Gen Script
46− go = do
47− next <- choose (0, 1) :: Gen Int
48− case next of
49− 0 -> do
50− fr <- choose (0, numEndPoints - 1)
51− to <- choose (0, numEndPoints - 1)
52− cmds <- go
53− return (Connect fr to : cmds)
54− _ ->
55− return []
56−
57−script_ConnectClose :: Int -> Gen Script
58−script_ConnectClose numEndPoints = do
59− script <- go Map.empty
60− return (replicate numEndPoints NewEndPoint ++ script)
61− where
62− go :: Map Int Bool -> Gen Script
63− go conns = do
64− next <- choose (0, 2) :: Gen Int
65− case next of
66− 0 -> do
67− fr <- choose (0, numEndPoints - 1)
68− to <- choose (0, numEndPoints - 1)
69− cmds <- go (Map.insert (Map.size conns) True conns)
70− return (Connect fr to : cmds)
71− 1 -> do
72− mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns
73− case mConn of
74− Nothing -> go conns
75− Just conn -> do
76− cmds <- go (Map.insert conn False conns)
77− return (Close conn : cmds)
78− _ ->
79− return []
80−
81− isOpen :: Map Int Bool -> Int -> Bool
82− isOpen conns connIx = connIx `Map.member` conns && conns Map.! connIx
83−
8431execScript :: Transport -> Script -> IO (Map Int [Event])
8532execScript transport script = do
8633 chan <- newChan
@@ -155,6 +102,61 @@ verify script = go script []
155102 go cmds conns (Map.insert epIx epEvs evs)
156103 _ -> Just $ "Missing (ConnectionClosed " ++ show connId ++ ") event in " ++ show evs
157104
105+--------------------------------------------------------------------------------
106+-- Script generators --
107+--------------------------------------------------------------------------------
108+
109+script_NewEndPoint :: Int -> Gen Script
110+script_NewEndPoint numEndPoints = return (replicate numEndPoints NewEndPoint)
111+
112+script_Connect :: Int -> Gen Script
113+script_Connect numEndPoints = do
114+ script <- go
115+ return (replicate numEndPoints NewEndPoint ++ script)
116+ where
117+ go :: Gen Script
118+ go = do
119+ next <- choose (0, 1) :: Gen Int
120+ case next of
121+ 0 -> do
122+ fr <- choose (0, numEndPoints - 1)
123+ to <- choose (0, numEndPoints - 1)
124+ cmds <- go
125+ return (Connect fr to : cmds)
126+ _ ->
127+ return []
128+
129+script_ConnectClose :: Int -> Gen Script
130+script_ConnectClose numEndPoints = do
131+ script <- go Map.empty
132+ return (replicate numEndPoints NewEndPoint ++ script)
133+ where
134+ go :: Map Int Bool -> Gen Script
135+ go conns = do
136+ next <- choose (0, 2) :: Gen Int
137+ case next of
138+ 0 -> do
139+ fr <- choose (0, numEndPoints - 1)
140+ to <- choose (0, numEndPoints - 1)
141+ cmds <- go (Map.insert (Map.size conns) True conns)
142+ return (Connect fr to : cmds)
143+ 1 -> do
144+ mConn <- choose (0, Map.size conns - 1) `suchThatMaybe` isOpen conns
145+ case mConn of
146+ Nothing -> go conns
147+ Just conn -> do
148+ cmds <- go (Map.insert conn False conns)
149+ return (Close conn : cmds)
150+ _ ->
151+ return []
152+
153+ isOpen :: Map Int Bool -> Int -> Bool
154+ isOpen conns connIx = connIx `Map.member` conns && conns Map.! connIx
155+
156+--------------------------------------------------------------------------------
157+-- Individual scripts to test specific bugs --
158+--------------------------------------------------------------------------------
159+
158160testScript1 :: Script
159161testScript1 = [
160162 NewEndPoint
@@ -166,6 +168,29 @@ testScript1 = [
166168 , Connect 1 0
167169 ]
168170
171+--------------------------------------------------------------------------------
172+-- Main application driver --
173+--------------------------------------------------------------------------------
174+
175+tests :: Transport -> [Test]
176+tests transport = [
177+ testGroup "Unidirectional" [
178+ -- testProperty "NewEndPoint" (genericProp transport (script_NewEndPoint 2))
179+ --, testProperty "Connect" (genericProp transport (script_Connect 2))
180+ testCase "testScript1" (testOneScript transport testScript1)
181+ -- testProperty "ConnectClose" (genericProp transport (script_ConnectClose 2))
182+ ]
183+ ]
184+
185+main :: IO ()
186+main = do
187+ Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
188+ defaultMain (tests transport)
189+
190+--------------------------------------------------------------------------------
191+-- Test infrastructure --
192+--------------------------------------------------------------------------------
193+
169194genericProp :: Transport -> Gen Script -> Property
170195genericProp transport scriptGen =
171196 forAll scriptGen $ \script ->
@@ -187,17 +212,17 @@ testOneScript transport script = do
187212 Just err -> assertFailure $ "Failed with script " ++ show script ++ ": " ++ err
188213 Nothing -> return ()
189214
190−tests :: Transport -> [Test]
191−tests transport = [
192− testGroup "Unidirectional" [
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))
197− ]
198− ]
215+--------------------------------------------------------------------------------
216+-- Auxiliary
217+--------------------------------------------------------------------------------
218+
219+logShow :: Show a => a -> IO ()
220+logShow = appendFile "log" . (++ "\n") . show
221+
222+throwIfLeft :: Exception a => IO (Either a b) -> IO b
223+throwIfLeft p = do
224+ mb <- p
225+ case mb of
226+ Left a -> throwIO a
227+ Right b -> return b
199228
200−main :: IO ()
201−main = do
202− Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
203− defaultMain (tests transport)