@@ -1,11 +1,13 @@
1module Main
1module Main
3 -- Shush the compiler about unused definitions
3 -- Shush the compiler about unused definitions
5 , forAllShrink
6 , forAllShrink
10+import Prelude hiding (log)
9import Test.Framework (Test, TestName, defaultMain, testGroup)
11import Test.Framework (Test, TestName, defaultMain, testGroup)
10import Test.Framework.Providers.QuickCheck2 (testProperty)
12import Test.Framework.Providers.QuickCheck2 (testProperty)
11import Test.Framework.Providers.HUnit (testCase)
13import Test.Framework.Providers.HUnit (testCase)
@@ -17,20 +19,21 @@ import Test.QuickCheck
17 , forAllShrink
19 , forAllShrink
18 , Property
20 , Property
19 , Arbitrary(arbitrary)
21 , Arbitrary(arbitrary)
22import Test.QuickCheck.Property (morallyDubiousIOProperty, Result(..), result)
23import Test.QuickCheck.Property (morallyDubiousIOProperty, Result(..), result)
23import Test.HUnit (Assertion, assertFailure)
24import Test.HUnit (Assertion, assertFailure)
24import Data.Map (Map)
25import Data.Map (Map)
25import qualified Data.Map as Map
26import qualified Data.Map as Map
27+import Control.Applicative ((<$>))
26import Control.Exception (Exception, throwIO)
28import Control.Exception (Exception, throwIO)
27import Control.Concurrent (forkIO, threadDelay)
29import Control.Concurrent (forkIO, threadDelay)
28import Control.Concurrent.Chan (Chan, newChan, writeChan, readChan)
30import Control.Concurrent.Chan (Chan, newChan, writeChan, readChan)
29−import Control.Monad (replicateM)
31+import Control.Monad (replicateM, void)
30import Data.List (inits)
32import Data.List (inits)
31import Data.ByteString (ByteString)
33import Data.ByteString (ByteString)
32import Data.ByteString.Char8 (pack)
34import Data.ByteString.Char8 (pack)
33import qualified Data.ByteString as BSS (concat)
35import qualified Data.ByteString as BSS (concat)
36+import qualified Text.PrettyPrint as PP
35import Network.Transport
38import Network.Transport
36import Network.Transport.TCP
39import Network.Transport.TCP
@@ -72,6 +75,26 @@ data ScriptCmd =
73type Script = [ScriptCmd]
76type Script = [ScriptCmd]
78+verticalList :: [PP.Doc] -> PP.Doc
79+verticalList = PP.brackets . PP.vcat
81+eventsDoc :: Map Int [Event] -> PP.Doc
82+eventsDoc = verticalList . map aux . Map.toList
84+ aux :: (Int, [Event]) -> PP.Doc
85+ aux (i, evs) = PP.parens . PP.hsep . PP.punctuate PP.comma $ [PP.int i, verticalList (map (PP.text . show) evs)]
88+instance Show Script where
89+ show = ("\n" ++) . show . verticalList . map (PP.text . show)
91+instance Show (Map Int [Event]) where
92+ show = ("\n" ++) . show . eventsDoc
96+-- Execute ignores error codes reported back. Instead, we verify the events
75execScript :: (Transport, TransportInternals) -> Script -> IO (Map Int [Event])
98execScript :: (Transport, TransportInternals) -> Script -> IO (Map Int [Event])
76execScript (transport, transportInternals) script = do
99execScript (transport, transportInternals) script = do
77 chan <- newChan
100 chan <- newChan
@@ -81,7 +104,7 @@ execScript (transport, transportInternals) script = do
81 runScript :: Chan (Maybe (Int, Event)) -> Script -> IO ()
104 runScript :: Chan (Maybe (Int, Event)) -> Script -> IO ()
82 runScript chan = go [] []
105 runScript chan = go [] []
84− go :: [EndPoint] -> [Connection] -> Script -> IO ()
107+ go :: [EndPoint] -> [Either (TransportError ConnectErrorCode) Connection] -> Script -> IO ()
85 go _endPoints _conns [] = do
108 go _endPoints _conns [] = do
86 threadDelay 10000
109 threadDelay 10000
87 writeChan chan Nothing
110 writeChan chan Nothing
@@ -92,20 +115,24 @@ execScript (transport, transportInternals) script = do
92 threadDelay 10000
115 threadDelay 10000
93 go (endPoints ++ [endPoint]) conns cmds
116 go (endPoints ++ [endPoint]) conns cmds
94 go endPoints conns (Connect fr to : cmds) = do
117 go endPoints conns (Connect fr to : cmds) = do
95− conn <- throwIfLeft $ connect (endPoints !! fr) (address (endPoints !! to)) ReliableOrdered defaultConnectHints
118+ conn <- connect (endPoints !! fr) (address (endPoints !! to)) ReliableOrdered defaultConnectHints
96 threadDelay 10000
119 threadDelay 10000
97 go endPoints (conns ++ [conn]) cmds
120 go endPoints (conns ++ [conn]) cmds
98 go endPoints conns (Close connIx : cmds) = do
121 go endPoints conns (Close connIx : cmds) = do
99− close (conns !! connIx)
122+ case conns !! connIx of
123+ Left _err -> return ()
124+ Right conn -> close conn
100 threadDelay 10000
125 threadDelay 10000
101 go endPoints conns cmds
126 go endPoints conns cmds
102 go endPoints conns (Send connIx payload : cmds) = do
127 go endPoints conns (Send connIx payload : cmds) = do
103− Right () <- send (conns !! connIx) payload
128+ case conns !! connIx of
129+ Left _err -> return ()
130+ Right conn -> void $ send conn payload
104 threadDelay 10000
131 threadDelay 10000
105 go endPoints conns cmds
132 go endPoints conns cmds
106 go endPoints conns (BreakAfterReads n i j : cmds) = do
133 go endPoints conns (BreakAfterReads n i j : cmds) = do
107 sock <- socketBetween transportInternals (address (endPoints !! i)) (address (endPoints !! j))
134 sock <- socketBetween transportInternals (address (endPoints !! i)) (address (endPoints !! j))
108− scheduleReadAction sock n (sClose sock)
135+ scheduleReadAction sock n (putStrLn "Closing" >> sClose sock)
109 go endPoints conns cmds
136 go endPoints conns cmds
111 forwardTo :: Chan (Maybe (Int, Event)) -> (Int, EndPoint) -> IO ()
138 forwardTo :: Chan (Maybe (Int, Event)) -> (Int, EndPoint) -> IO ()
@@ -133,40 +160,40 @@ execScript (transport, transportInternals) script = do
133 insertEvent ev (Just evs) = Just (ev : evs)
160 insertEvent ev (Just evs) = Just (ev : evs)
135verify :: Script -> Map Int [Event] -> Maybe String
162verify :: Script -> Map Int [Event] -> Maybe String
136−verify script = go script []
163+verify = go []
138− go :: Script -> [(Int, ConnectionId)] -> Map Int [Event] -> Maybe String
165+ go :: [(Int, ConnectionId)] -> Script -> Map Int [Event] -> Maybe String
139− go [] _conns evs =
166+ go _conns [] evs =
140 if concat (Map.elems evs) == []
167 if concat (Map.elems evs) == []
141 then Nothing
168 then Nothing
142 else Just $ "Unexpected events: " ++ show evs
169 else Just $ "Unexpected events: " ++ show evs
143− go (NewEndPoint : cmds) conns evs =
170+ go conns (NewEndPoint : cmds) evs =
144− go cmds conns evs
171+ go conns cmds evs
145− go (Connect _fr to : cmds) conns evs =
172+ go conns (Connect _fr to : cmds) evs =
146 let epEvs = evs Map.! to
173 let epEvs = evs Map.! to
147 in case epEvs of
174 in case epEvs of
148 (ConnectionOpened connId _rel _addr : epEvs') ->
175 (ConnectionOpened connId _rel _addr : epEvs') ->
149− go cmds (conns ++ [(to, connId)]) (Map.insert to epEvs' evs)
176+ go (conns ++ [(to, connId)]) cmds (Map.insert to epEvs' evs)
151 Just $ "Missing (ConnectionOpened <<connId>> <<rel>> <<addr>>) event in " ++ show evs
178 Just $ "Missing (ConnectionOpened <<connId>> <<rel>> <<addr>>) event in " ++ show evs
152− go (Close connIx : cmds) conns evs =
179+ go conns (Close connIx : cmds) evs =
153 let (epIx, connId) = conns !! connIx
180 let (epIx, connId) = conns !! connIx
154 epEvs = evs Map.! epIx
181 epEvs = evs Map.! epIx
155 in case epEvs of
182 in case epEvs of
156 (ConnectionClosed connId' : epEvs') | connId' == connId ->
183 (ConnectionClosed connId' : epEvs') | connId' == connId ->
157− go cmds conns (Map.insert epIx epEvs' evs)
184+ go conns cmds (Map.insert epIx epEvs' evs)
159 Just $ "Missing (ConnectionClosed " ++ show connId ++ ") event in " ++ show evs
186 Just $ "Missing (ConnectionClosed " ++ show connId ++ ") event in " ++ show evs
160− go (Send connIx payload : cmds) conns evs =
187+ go conns (Send connIx payload : cmds) evs =
161 let (epIx, connId) = conns !! connIx
188 let (epIx, connId) = conns !! connIx
162 epEvs = evs Map.! epIx
189 epEvs = evs Map.! epIx
163 in case epEvs of
190 in case epEvs of
164 (Received connId' payload' : epEvs') | connId' == connId && BSS.concat payload == BSS.concat payload' ->
191 (Received connId' payload' : epEvs') | connId' == connId && BSS.concat payload == BSS.concat payload' ->
165− go cmds conns (Map.insert epIx epEvs' evs)
192+ go conns cmds (Map.insert epIx epEvs' evs)
167 Just $ "Missing (Received " ++ show connId ++ " " ++ show payload ++ ") event in " ++ show epEvs
194 Just $ "Missing (Received " ++ show connId ++ " " ++ show payload ++ ") event in " ++ show epEvs
168− go (BreakAfterReads n i j : cmds) conns evs =
195+ go conns (BreakAfterReads n i j : cmds) evs =
169− go cmds conns evs
196+ go conns cmds evs
171--------------------------------------------------------------------------------
198--------------------------------------------------------------------------------
172-- Script generators --
199-- Script generators --
@@ -238,7 +265,8 @@ script_ConnectSendClose numEndPoints = do
238 case mConn of
265 case mConn of
239 Nothing -> go conns
266 Nothing -> go conns
240 Just conn -> do
267 Just conn -> do
268+ numSegments <- choose (0, 2)
241− payload <- arbitrary
269+ payload <- replicateM numSegments arbitrary
242 cmds <- go conns
270 cmds <- go conns
243 return (Send conn payload : cmds)
271 return (Send conn payload : cmds)
@@ -263,9 +291,11 @@ withErrors numErrors gen = gen >>= insertError numErrors
263 insert <- arbitrary
291 insert <- arbitrary
264 if insert && n > 0
292 if insert && n > 0
266− -- We sometimes want big delays, but usually we want short delays
294+ numReads <- chooseFrom' (NormalD { mean = 5, stdDev = 10 }) (0, 100)
267− numReads <- elements (concat (replicate 10 [0 .. 9]) ++ [10 ..99])
295+ swap <- arbitrary
297+ then return $ Connect i j : BreakAfterReads numReads j i : cmds
268− return $ Connect i j : BreakAfterReads numReads i j : cmds
298+ else return $ Connect i j : BreakAfterReads numReads i j : cmds
270 cmds' <- insertError (n - 1) cmds
300 cmds' <- insertError (n - 1) cmds
271 return $ Connect i j : cmds'
301 return $ Connect i j : cmds'
@@ -329,6 +359,26 @@ script_Bug1 = [
329 , Connect 1 0
359 , Connect 1 0
362+-- | Simulate broken network connection during send
363+script_BreakSend :: Script
368+ , BreakAfterReads 1 1 0
372+-- | Simulate broken network connection during connect
373+script_BreakConnect :: Script
374+script_BreakConnect = [
378+ , BreakAfterReads 1 1 0
332--------------------------------------------------------------------------------
382--------------------------------------------------------------------------------
333-- Main application driver --
383-- Main application driver --
334--------------------------------------------------------------------------------
384--------------------------------------------------------------------------------
@@ -343,8 +393,10 @@ basicTests transport numEndPoints trans = [
344tests :: (Transport, TransportInternals) -> [Test]
394tests :: (Transport, TransportInternals) -> [Test]
345tests transport = [
395tests transport = [
346− testGroup "Bugs" [
396+ testGroup "Specific scripts" [
347− testOne "Bug1" transport script_Bug1
397+ testOne "Bug1" transport script_Bug1
398+ , testOne "BreakSend" transport script_BreakSend
399+ , testOne "BreakConnect" transport script_BreakConnect
349 , testGroup "One endpoint, with delays" (basicTests transport 1 id)
401 , testGroup "One endpoint, with delays" (basicTests transport 1 id)
350 , testGroup "Two endpoints, with delays" (basicTests transport 2 id)
402 , testGroup "Two endpoints, with delays" (basicTests transport 2 id)
@@ -393,8 +445,11 @@ testScript transport script = do
393-- Auxiliary
445-- Auxiliary
394--------------------------------------------------------------------------------
446--------------------------------------------------------------------------------
448+log :: String -> IO ()
449+log = appendFile "log" . (++ "\n")
396logShow :: Show a => a -> IO ()
451logShow :: Show a => a -> IO ()
397−logShow = appendFile "log" . (++ "\n") . show
452+logShow = log . show
399throwIfLeft :: Exception a => IO (Either a b) -> IO b
454throwIfLeft :: Exception a => IO (Either a b) -> IO b
400throwIfLeft p = do
455throwIfLeft p = do
@@ -405,6 +460,37 @@ throwIfLeft p = do
406instance Arbitrary ByteString where
461instance Arbitrary ByteString where
407 arbitrary = do
462 arbitrary = do
408− len <- choose (0, 10)
463+ len <- chooseFrom' (NormalD { mean = 5, stdDev = 10 }) (0, 100)
409 xs <- replicateM len arbitrary
464 xs <- replicateM len arbitrary
410 return (pack xs)
465 return (pack xs)
467+--------------------------------------------------------------------------------
468+-- Draw random values from probability distributions --
469+--------------------------------------------------------------------------------
471+data NormalD = NormalD { mean :: Double , stdDev :: Double }
473+class Distribution d where
474+ probabilityOf :: d -> Double -> Double
476+instance Distribution NormalD where
477+ probabilityOf d x = a * exp (-0.5 * b * b)
479+ a = 1 / (stdDev d * sqrt (2 * pi))
480+ b = (x - mean d) / stdDev d
482+-- | Choose from a distribution
483+chooseFrom :: Distribution d => d -> (Double, Double) -> Gen Double
484+chooseFrom d (lo, hi) = findCandidate
486+ findCandidate :: Gen Double
488+ candidate <- choose (lo, hi)
489+ uniformSample <- choose (0, 1)
490+ if uniformSample < probabilityOf d candidate
491+ then return candidate
494+chooseFrom' :: Distribution d => d -> (Int, Int) -> Gen Int
495+chooseFrom' d (lo, hi) =
496+ round <$> chooseFrom d (fromIntegral lo, fromIntegral hi)