@@ -161,8 +161,8 @@ verify (transport, transportInternals) script = do
161 case mEndPoint of
161 case mEndPoint of
162 Right endPoint -> do
162 Right endPoint -> do
163 tid <- liftIO $ forkIO (forward endPoint)
163 tid <- liftIO $ forkIO (forward endPoint)
164− modify endPoints (snoc endPoint)
164+ append endPoints endPoint
165− modify forwardingThreads (tid :)
165+ append forwardingThreads tid
166 set (expectedEventsAt (address endPoint)) []
166 set (expectedEventsAt (address endPoint)) []
167 Left err ->
167 Left err ->
168 liftIO $ throwIO err
168 liftIO $ throwIO err
@@ -184,8 +184,8 @@ verify (transport, transportInternals) script = do
184 , connectionId = connId
184 , connectionId = connId
185 , connectionBundle = currentBundleId
185 , connectionBundle = currentBundleId
187− modify connections (snoc (conn, connInfo))
187+ append connections (conn, connInfo)
188− modify (expectedEventsAt endPointB) (snoc (ExpConnectionOpened connInfo))
188+ append (expectedEventsAt endPointB) (ExpConnectionOpened connInfo)
189 Left err -> do
189 Left err -> do
190 currentBundleId <- get bundleId
190 currentBundleId <- get bundleId
191 expectingBreak <- get $ mayBreak currentBundleId
191 expectingBreak <- get $ mayBreak currentBundleId
@@ -198,7 +198,7 @@ verify (transport, transportInternals) script = do
198 runCmd (Close i) = do
198 runCmd (Close i) = do
199 (conn, connInfo) <- get (connectionAt i)
199 (conn, connInfo) <- get (connectionAt i)
200 liftIO $ close conn
200 liftIO $ close conn
201− modify (expectedEventsAt (target connInfo)) (snoc (ExpConnectionClosed connInfo))
201+ append (expectedEventsAt (target connInfo)) (ExpConnectionClosed connInfo)
202 runCmd (Send i payload) = do
202 runCmd (Send i payload) = do
203 (conn, connInfo) <- get (connectionAt i)
203 (conn, connInfo) <- get (connectionAt i)
204 mResult <- liftIO $ send conn payload
204 mResult <- liftIO $ send conn payload
@@ -213,7 +213,7 @@ verify (transport, transportInternals) script = do
213 set (broken (connectionBundle connInfo)) True
213 set (broken (connectionBundle connInfo)) True
215 liftIO $ throwIO err
215 liftIO $ throwIO err
216− modify (expectedEventsAt (target connInfo)) (snoc (ExpReceived connInfo payload))
216+ append (expectedEventsAt (target connInfo)) (ExpReceived connInfo payload)
217 runCmd (BreakAfterReads n i j) = do
217 runCmd (BreakAfterReads n i j) = do
218 endPointA <- address <$> get (endPointAtIx i)
218 endPointA <- address <$> get (endPointAtIx i)
219 endPointB <- address <$> get (endPointAtIx j)
219 endPointB <- address <$> get (endPointAtIx j)
@@ -222,8 +222,8 @@ verify (transport, transportInternals) script = do
222 scheduleReadAction sock n (sClose sock)
222 scheduleReadAction sock n (sClose sock)
223 currentBundleId <- get (currentBundle endPointA endPointB)
223 currentBundleId <- get (currentBundle endPointA endPointB)
224 set (mayBreak currentBundleId) True
224 set (mayBreak currentBundleId) True
225− modify (expectedEventsAt endPointA) (snoc (ExpConnectionLost currentBundleId endPointB))
225+ append (expectedEventsAt endPointA) (ExpConnectionLost currentBundleId endPointB)
226− modify (expectedEventsAt endPointB) (snoc (ExpConnectionLost currentBundleId endPointA))
226+ append (expectedEventsAt endPointB) (ExpConnectionLost currentBundleId endPointA)
228 forward :: EndPoint -> IO ()
228 forward :: EndPoint -> IO ()
229 forward endPoint = forever $ do
229 forward endPoint = forever $ do
@@ -586,6 +586,16 @@ script_BreakSendReconnect = [
586 , Send 1 ["ping2"]
586 , Send 1 ["ping2"]
594+ , BreakAfterReads 2 0 1
595+ , Send 0 ["pingpong"]
589--------------------------------------------------------------------------------
599--------------------------------------------------------------------------------
590-- Main application driver --
600-- Main application driver --
591--------------------------------------------------------------------------------
601--------------------------------------------------------------------------------
@@ -609,6 +619,7 @@ tests transport = [
609 , testOne "BreakConnect1" transport script_BreakConnect1
619 , testOne "BreakConnect1" transport script_BreakConnect1
610 , testOne "BreakConnect2" transport script_BreakConnect2
620 , testOne "BreakConnect2" transport script_BreakConnect2
611 , testOne "BreakSendReconnect" transport script_BreakSendReconnect
621 , testOne "BreakSendReconnect" transport script_BreakSendReconnect
622+ , testOne "Foo" transport script_Foo
613 , testGroup "Without errors" [
624 , testGroup "Without errors" [
614 testGroup "One endpoint, with delays" (basicTests transport 1 id)
625 testGroup "One endpoint, with delays" (basicTests transport 1 id)
@@ -787,6 +798,9 @@ instance Arbitrary ByteString where
787listAccessor :: Int -> Accessor [a] a
798listAccessor :: Int -> Accessor [a] a
788listAccessor i = accessor (!! i) (error "listAccessor.set not defined")
799listAccessor i = accessor (!! i) (error "listAccessor.set not defined")
801+append :: Monad m => Accessor st [a] -> a -> StateT st m ()
802+append acc x = modify acc (snoc x)
790snoc :: a -> [a] -> [a]
804snoc :: a -> [a] -> [a]
791snoc x xs = xs ++ [x]
805snoc x xs = xs ++ [x]