@@ -1,3 +1,9 @@
1+-- Test the TCP transport using QuickCheck generated scripts
3+-- TODO: This is not quite working yet. The main problem, I think, is the
4+-- allocation of "bundle ID"s to connections. The problem is exposed by the
5+-- aptly-named regression test script_Foo (to be renamed once I figure out what
6+-- bug that test is actually exposing :)
1module Main
7module Main
3 -- Shush the compiler about unused definitions
9 -- Shush the compiler about unused definitions
@@ -123,9 +129,12 @@ data ExpEvent =
123 deriving Show
129 deriving Show
125data RunState = RunState {
131data RunState = RunState {
126− _endPoints :: [EndPoint]
132+ _endPoints :: [EndPoint]
127− , _connections :: [(Connection, ConnectionInfo)]
133+ , _connections :: [(Connection, ConnectionInfo)]
128− , _expectedEvents :: Map EndPointAddress [ExpEvent]
134+ , _expectedEvents :: Map EndPointAddress [ExpEvent]
135+ -- | For each endpoint we create we create a thread that forwards the events
136+ -- of that endpoint to a central channel. We collect the thread IDs so that
137+ -- we can kill these thread when we are done.
129 , _forwardingThreads :: [ThreadId]
138 , _forwardingThreads :: [ThreadId]
130 -- | When a connection from A to be may break, we add both (A, B, n)
139 -- | When a connection from A to be may break, we add both (A, B, n)
131 -- and (B, A, n) to _mayBreak. Then once we detect that from A to B
140 -- and (B, A, n) to _mayBreak. Then once we detect that from A to B
@@ -135,12 +144,12 @@ data RunState = RunState {
135 -- has broken in the other direction.
144 -- has broken in the other direction.
137 -- | Invariant: not mayBreak && broken
146 -- | Invariant: not mayBreak && broken
138− , _mayBreak :: Set (EndPointAddress, EndPointAddress, BundleId)
147+ , _mayBreak :: Set (EndPointAddress, EndPointAddress, BundleId)
139− , _broken :: Set (EndPointAddress, EndPointAddress, BundleId)
148+ , _broken :: Set (EndPointAddress, EndPointAddress, BundleId)
140 -- | Current bundle ID between two endpoints
149 -- | Current bundle ID between two endpoints
142 -- Invariant: For all keys (A, B), A <= B
151 -- Invariant: For all keys (A, B), A <= B
143− , _currentBundle :: Map (EndPointAddress, EndPointAddress) BundleId
152+ , _currentBundle :: Map (EndPointAddress, EndPointAddress) BundleId
146initialRunState :: RunState
155initialRunState :: RunState
@@ -177,8 +186,8 @@ verify (transport, transportInternals) script = do
177 endPointB <- address <$> get (endPointAtIx j)
186 endPointB <- address <$> get (endPointAtIx j)
178 mConn <- liftIO $ connect endPointA endPointB ReliableOrdered defaultConnectHints
187 mConn <- liftIO $ connect endPointA endPointB ReliableOrdered defaultConnectHints
179 let bundleId = currentBundle (address endPointA) endPointB
188 let bundleId = currentBundle (address endPointA) endPointB
180− connBroken = broken (address endPointA) endPointB
189+ connBroken = broken (address endPointA) endPointB
181− connMayBreak = mayBreak (address endPointA) endPointB
190+ connMayBreak = mayBreak (address endPointA) endPointB
182 case mConn of
191 case mConn of
183 Right conn -> do
192 Right conn -> do
184 bundleBroken <- get bundleId >>= get . connBroken
193 bundleBroken <- get bundleId >>= get . connBroken
@@ -224,6 +233,9 @@ verify (transport, transportInternals) script = do
225 liftIO $ throwIO err
234 liftIO $ throwIO err
226 append (expectedEventsAt (target connInfo)) (ExpReceived connInfo payload)
235 append (expectedEventsAt (target connInfo)) (ExpReceived connInfo payload)
236+ -- TODO: This will only work if a connection between 'i' and 'j' has
237+ -- already been established. We would need to modify the mock network
238+ -- layer to support breaking "future" connections
227 runCmd (BreakAfterReads n i j) = do
239 runCmd (BreakAfterReads n i j) = do
228 endPointA <- address <$> get (endPointAtIx i)
240 endPointA <- address <$> get (endPointAtIx i)
229 endPointB <- address <$> get (endPointAtIx j)
241 endPointB <- address <$> get (endPointAtIx j)