git.iko.soy/distributed-process
on master help sign in
Cleanup. Add support for 'send'
c9cc0d1Edsko de Vries
network-transport-tcp/network-transport-tcp.cabal+3−2
compare with master
unifiedsplit
@@ -67,6 +67,7 @@ Test-Suite TestQC
67 HUnit,
67 HUnit,
68 network-transport,
68 network-transport,
69 network-transport-tcp,
69 network-transport-tcp,
70− containers
70+ containers,
71+ bytestring
71− ghc-options: -threaded -Wall
72+ ghc-options: -threaded -Wall -fno-warn-orphans
72 HS-Source-Dirs: tests
73 HS-Source-Dirs: tests
network-transport-tcp/tests/TestQC.hs+106−21
@@ -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
2
8
3−import Test.Framework (Test, defaultMain, testGroup)
9+import Test.Framework (Test, TestName, defaultMain, testGroup)
4import Test.Framework.Providers.QuickCheck2 (testProperty)
10import Test.Framework.Providers.QuickCheck2 (testProperty)
5import Test.Framework.Providers.HUnit (testCase)
11import 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+ )
7import Test.QuickCheck.Property (morallyDubiousIOProperty, Result(..), result)
21import Test.QuickCheck.Property (morallyDubiousIOProperty, Result(..), result)
8import Test.HUnit (Assertion, assertFailure)
22import Test.HUnit (Assertion, assertFailure)
9import Data.Map (Map)
23import Data.Map (Map)
@@ -11,7 +25,11 @@ import qualified Data.Map as Map
11import Control.Exception (Exception, throwIO)
25import Control.Exception (Exception, throwIO)
12import Control.Concurrent (forkIO, threadDelay)
26import Control.Concurrent (forkIO, threadDelay)
13import Control.Concurrent.Chan (Chan, newChan, writeChan, readChan)
27import Control.Concurrent.Chan (Chan, newChan, writeChan, readChan)
28+import Control.Monad (replicateM)
14import Data.List (inits)
29import Data.List (inits)
30+import Data.ByteString (ByteString)
31+import Data.ByteString.Char8 (pack)
32+import qualified Data.ByteString as BSS (concat)
15
33
16import Network.Transport
34import Network.Transport
17import Network.Transport.TCP (createTransport, defaultTCPParameters)
35import Network.Transport.TCP (createTransport, defaultTCPParameters)
@@ -24,6 +42,7 @@ data ScriptCmd =
24 NewEndPoint
42 NewEndPoint
25 | Connect Int Int
43 | Connect Int Int
26 | Close Int
44 | Close Int
45+ | Send Int [ByteString]
27 deriving Show
46 deriving Show
28
47
29type Script = [ScriptCmd]
48type Script = [ScriptCmd]
@@ -39,7 +58,7 @@ execScript transport script = do
39 where
58 where
40 go :: [EndPoint] -> [Connection] -> Script -> IO ()
59 go :: [EndPoint] -> [Connection] -> Script -> IO ()
41 go _endPoints _conns [] = do
60 go _endPoints _conns [] = do
42− threadDelay 100000
61+ threadDelay 10000
43 writeChan chan Nothing
62 writeChan chan Nothing
44 go endPoints conns (NewEndPoint : cmds) = do
63 go endPoints conns (NewEndPoint : cmds) = do
45 endPoint <- throwIfLeft $ newEndPoint transport
64 endPoint <- throwIfLeft $ newEndPoint transport
@@ -55,6 +74,10 @@ execScript transport script = do
55 close (conns !! connIx)
74 close (conns !! connIx)
56 threadDelay 10000
75 threadDelay 10000
57 go endPoints conns cmds
76 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
58
81
59 forwardTo :: Chan (Maybe (Int, Event)) -> (Int, EndPoint) -> IO ()
82 forwardTo :: Chan (Maybe (Int, Event)) -> (Int, EndPoint) -> IO ()
60 forwardTo chan (ix, endPoint) = go
83 forwardTo chan (ix, endPoint) = go
@@ -91,16 +114,28 @@ verify script = go script []
91 go (NewEndPoint : cmds) conns evs =
114 go (NewEndPoint : cmds) conns evs =
92 go cmds conns evs
115 go cmds conns evs
93 go (Connect _fr to : cmds) conns evs =
116 go (Connect _fr to : cmds) conns evs =
94− case evs Map.! to of
117+ let epEvs = evs Map.! to
118+ in case epEvs of
95− (ConnectionOpened connId _rel _addr : epEvs) ->
119+ (ConnectionOpened connId _rel _addr : epEvs') ->
96− go cmds (conns ++ [(to, connId)]) (Map.insert to epEvs evs)
120+ go cmds (conns ++ [(to, connId)]) (Map.insert to epEvs' evs)
121+ _ ->
97− _ -> Just $ "Missing (ConnectionOpened <<connId>> <<rel>> <<addr>>) event in " ++ show evs
122+ Just $ "Missing (ConnectionOpened <<connId>> <<rel>> <<addr>>) event in " ++ show evs
98 go (Close connIx : cmds) conns evs =
123 go (Close connIx : cmds) conns evs =
99− let (epIx, connId) = conns !! connIx in
124+ let (epIx, connId) = conns !! connIx
100− case evs Map.! epIx of
125+ epEvs = evs Map.! epIx
126+ in case epEvs of
101− (ConnectionClosed connId' : epEvs) | connId' == connId ->
127+ (ConnectionClosed connId' : epEvs') | connId' == connId ->
102− go cmds conns (Map.insert epIx epEvs evs)
128+ go cmds conns (Map.insert epIx epEvs' evs)
129+ _ ->
103− _ -> Just $ "Missing (ConnectionClosed " ++ show connId ++ ") event in " ++ show evs
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
104
139
105--------------------------------------------------------------------------------
140--------------------------------------------------------------------------------
106-- Script generators --
141-- Script generators --
@@ -153,6 +188,41 @@ script_ConnectClose numEndPoints = do
153 isOpen :: Map Int Bool -> Int -> Bool
188 isOpen :: Map Int Bool -> Int -> Bool
154 isOpen conns connIx = connIx `Map.member` conns && conns Map.! connIx
189 isOpen conns connIx = connIx `Map.member` conns && conns Map.! connIx
155
190
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+
156--------------------------------------------------------------------------------
226--------------------------------------------------------------------------------
157-- Individual scripts to test specific bugs --
227-- Individual scripts to test specific bugs --
158--------------------------------------------------------------------------------
228--------------------------------------------------------------------------------
@@ -213,20 +283,30 @@ script_Bug1 = [
213-- Main application driver --
283-- Main application driver --
214--------------------------------------------------------------------------------
284--------------------------------------------------------------------------------
215
285
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+
216tests :: Transport -> [Test]
294tests :: Transport -> [Test]
217tests transport = [
295tests transport = [
218 testGroup "Bugs" [
296 testGroup "Bugs" [
219− testOne "Bug1" script_Bug1
297+ testOne "Bug1" transport script_Bug1
220− ]
221− , testGroup "Unidirectional" [
222− testQC "NewEndPoint" (script_NewEndPoint 2)
223− , testQC "Connect" (script_Connect 2)
224− , testQC "ConnectClose" (script_ConnectClose 2)
225 ]
298 ]
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)
226 ]
302 ]
227 where
303 where
304+
305+testOne :: TestName -> Transport -> Script -> Test
228− testOne label script = testCase label (testScript transport script)
306+testOne label transport script = testCase label (testScript transport script)
307+
308+testGen :: TestName -> Transport -> Gen Script -> Test
229− testQC label script = testProperty label (testScriptGen transport script)
309+testGen label transport script = testProperty label (testScriptGen transport script)
230
310
231main :: IO ()
311main :: IO ()
232main = do
312main = do
@@ -272,3 +352,8 @@ throwIfLeft p = do
272 Left a -> throwIO a
352 Left a -> throwIO a
273 Right b -> return b
353 Right b -> return b
274
354
355+instance Arbitrary ByteString where
356+ arbitrary = do
357+ len <- choose (0, 10)
358+ xs <- replicateM len arbitrary
359+ return (pack xs)