@@ -26,7 +26,6 @@ import Test.HUnit (Assertion, assertFailure)
2626import Data.Map (Map)
2727import qualified Data.Map as Map
2828import Control.Category ((>>>))
29−import Control.Arrow (second)
3029import Control.Applicative ((<$>))
3130import Control.Exception (Exception, throwIO, try)
3231import Control.Concurrent (forkIO, threadDelay, ThreadId, killThread)
@@ -164,6 +163,7 @@ verify (transport, transportInternals) script = do
164163 tid <- liftIO $ forkIO (forward endPoint)
165164 modify endPoints (snoc endPoint)
166165 modify forwardingThreads (tid :)
166+ set (expectedEventsAt (address endPoint)) []
167167 Left err ->
168168 liftIO $ throwIO err
169169 runCmd (Connect i j) = do
@@ -235,7 +235,7 @@ verify (transport, transportInternals) script = do
235235 threadDelay 10000
236236 mapM_ killThread (st ^. forwardingThreads)
237237 evs <- go []
238− return (groupByKey evs)
238+ return $ groupByKey (map address (st ^. endPoints)) evs
239239 where
240240 go acc = do
241241 mEv <- tryPopR allEvents
@@ -543,8 +543,8 @@ script_BreakSend = [
543543 ]
544544
545545-- | Simulate broken network connection during connect
546−script_BreakConnect :: Script
547−script_BreakConnect = [
546+script_BreakConnect1 :: Script
547+script_BreakConnect1 = [
548548 NewEndPoint
549549 , NewEndPoint
550550 , Connect 0 1
@@ -552,6 +552,16 @@ script_BreakConnect = [
552552 , Connect 0 1
553553 ]
554554
555+-- | Simulate broken network connection during connect
556+script_BreakConnect2 :: Script
557+script_BreakConnect2 = [
558+ NewEndPoint
559+ , NewEndPoint
560+ , Connect 0 1
561+ , BreakAfterReads 1 0 1
562+ , Connect 0 1
563+ ]
564+
555565-- | Simulate broken send, then reconnect
556566script_BreakSendReconnect :: Script
557567script_BreakSendReconnect = [
@@ -578,16 +588,24 @@ basicTests transport numEndPoints trans = [
578588
579589tests :: (Transport, TransportInternals) -> [Test]
580590tests transport = [
581− testGroup "Specific scripts" [
582− testOne "Bug1" transport script_Bug1
583− , testOne "BreakSend" transport script_BreakSend
584− , testOne "BreakConnect" transport script_BreakConnect
585− , testOne "BreakSendReconnect" transport script_BreakSendReconnect
586− ]
587− , testGroup "One endpoint, with delays" (basicTests transport 1 id)
588− , testGroup "Two endpoints, with delays" (basicTests transport 2 id)
589− , testGroup "Three endpoints, with delays" (basicTests transport 3 id)
590− , testGroup "Four endpoints, with delay, single error" (basicTests transport 4 (withErrors 1))
591+ testGroup "Regression tests" [
592+ testOne "Bug1" transport script_Bug1
593+ ]
594+ , testGroup "Specific scripts" [
595+ testOne "BreakSend" transport script_BreakSend
596+ , testOne "BreakConnect1" transport script_BreakConnect1
597+ , testOne "BreakConnect2" transport script_BreakConnect2
598+ , testOne "BreakSendReconnect" transport script_BreakSendReconnect
599+ ]
600+ , testGroup "Without errors" [
601+ testGroup "One endpoint, with delays" (basicTests transport 1 id)
602+ , testGroup "Two endpoints, with delays" (basicTests transport 2 id)
603+ , testGroup "Three endpoints, with delays" (basicTests transport 3 id)
604+ ]
605+ , testGroup "Single error" [
606+ testGroup "Two endpoints, with delays" (basicTests transport 2 (withErrors 1))
607+ , testGroup "Three endpoints, with delays" (basicTests transport 3 (withErrors 1))
608+ ]
591609 ]
592610 where
593611
@@ -696,6 +714,16 @@ instance Show [Event] where
696714instance Show [ExpEvent] where
697715 show = ("\n" ++) . show . verticalList
698716
717+instance Show (Map EndPointAddress [ExpEvent]) where
718+ show = ("\n" ++) . show . PP.brackets . PP.vcat
719+ . map (\(addr, evs) -> PP.hcat . PP.punctuate PP.comma $ [PP.text (show addr), verticalList evs])
720+ . Map.toList
721+
722+instance Show (Map EndPointAddress [Event]) where
723+ show = ("\n" ++) . show . PP.brackets . PP.vcat
724+ . map (\(addr, evs) -> PP.hcat . PP.punctuate PP.comma $ [PP.text (show addr), verticalList evs])
725+ . Map.toList
726+
699727--------------------------------------------------------------------------------
700728-- Draw random values from probability distributions --
701729--------------------------------------------------------------------------------
@@ -749,8 +777,11 @@ listAccessor i = accessor (!! i) (error "listAccessor.set not defined")
749777snoc :: a -> [a] -> [a]
750778snoc x xs = xs ++ [x]
751779
752−groupByKey :: Ord a => [(a, b)] -> Map a [b]
753−groupByKey = Map.fromListWith (++) . map (second return)
780+groupByKey :: Ord a => [a] -> [(a, b)] -> Map a [b]
781+groupByKey keys = go (Map.fromList [(key, []) | key <- keys])
782+ where
783+ go acc [] = Map.map reverse acc
784+ go acc ((key, val) : rest) = go (Map.adjust (val :) key acc) rest
754785
755786--------------------------------------------------------------------------------
756787-- Expected failures (can't find explicit support for this in test-framework) --