@@ -1,11 +1,13 @@
11module Main
22 ( main
33 -- Shush the compiler about unused definitions
4+ , log
45 , logShow
56 , forAllShrink
67 , inits
78 ) where
89
10+import Prelude hiding (log)
911import Test.Framework (Test, TestName, defaultMain, testGroup)
1012import Test.Framework.Providers.QuickCheck2 (testProperty)
1113import Test.Framework.Providers.HUnit (testCase)
@@ -17,20 +19,21 @@ import Test.QuickCheck
1719 , forAllShrink
1820 , Property
1921 , Arbitrary(arbitrary)
20− , elements
2122 )
2223import Test.QuickCheck.Property (morallyDubiousIOProperty, Result(..), result)
2324import Test.HUnit (Assertion, assertFailure)
2425import Data.Map (Map)
2526import qualified Data.Map as Map
27+import Control.Applicative ((<$>))
2628import Control.Exception (Exception, throwIO)
2729import Control.Concurrent (forkIO, threadDelay)
2830import Control.Concurrent.Chan (Chan, newChan, writeChan, readChan)
29−import Control.Monad (replicateM)
31+import Control.Monad (replicateM, void)
3032import Data.List (inits)
3133import Data.ByteString (ByteString)
3234import Data.ByteString.Char8 (pack)
3335import qualified Data.ByteString as BSS (concat)
36+import qualified Text.PrettyPrint as PP
3437
3538import Network.Transport
3639import Network.Transport.TCP
@@ -72,6 +75,26 @@ data ScriptCmd =
7275
7376type Script = [ScriptCmd]
7477
78+verticalList :: [PP.Doc] -> PP.Doc
79+verticalList = PP.brackets . PP.vcat
80+
81+eventsDoc :: Map Int [Event] -> PP.Doc
82+eventsDoc = verticalList . map aux . Map.toList
83+ where
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)]
86+
87+
88+instance Show Script where
89+ show = ("\n" ++) . show . verticalList . map (PP.text . show)
90+
91+instance Show (Map Int [Event]) where
92+ show = ("\n" ++) . show . eventsDoc
93+
94+-- | Execute a script
95+--
96+-- Execute ignores error codes reported back. Instead, we verify the events
97+-- that are posted
7598execScript :: (Transport, TransportInternals) -> Script -> IO (Map Int [Event])
7699execScript (transport, transportInternals) script = do
77100 chan <- newChan
@@ -81,7 +104,7 @@ execScript (transport, transportInternals) script = do
81104 runScript :: Chan (Maybe (Int, Event)) -> Script -> IO ()
82105 runScript chan = go [] []
83106 where
84− go :: [EndPoint] -> [Connection] -> Script -> IO ()
107+ go :: [EndPoint] -> [Either (TransportError ConnectErrorCode) Connection] -> Script -> IO ()
85108 go _endPoints _conns [] = do
86109 threadDelay 10000
87110 writeChan chan Nothing
@@ -92,20 +115,24 @@ execScript (transport, transportInternals) script = do
92115 threadDelay 10000
93116 go (endPoints ++ [endPoint]) conns cmds
94117 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
96119 threadDelay 10000
97120 go endPoints (conns ++ [conn]) cmds
98121 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
100125 threadDelay 10000
101126 go endPoints conns cmds
102127 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
104131 threadDelay 10000
105132 go endPoints conns cmds
106133 go endPoints conns (BreakAfterReads n i j : cmds) = do
107134 sock <- socketBetween transportInternals (address (endPoints !! i)) (address (endPoints !! j))
108− scheduleReadAction sock n (sClose sock)
135+ scheduleReadAction sock n (putStrLn "Closing" >> sClose sock)
109136 go endPoints conns cmds
110137
111138 forwardTo :: Chan (Maybe (Int, Event)) -> (Int, EndPoint) -> IO ()
@@ -133,40 +160,40 @@ execScript (transport, transportInternals) script = do
133160 insertEvent ev (Just evs) = Just (ev : evs)
134161
135162verify :: Script -> Map Int [Event] -> Maybe String
136−verify script = go script []
163+verify = go []
137164 where
138− go :: Script -> [(Int, ConnectionId)] -> Map Int [Event] -> Maybe String
139− go [] _conns evs =
165+ go :: [(Int, ConnectionId)] -> Script -> Map Int [Event] -> Maybe String
166+ go _conns [] evs =
140167 if concat (Map.elems evs) == []
141168 then Nothing
142169 else Just $ "Unexpected events: " ++ show evs
143− go (NewEndPoint : cmds) conns evs =
144− go cmds conns evs
145− go (Connect _fr to : cmds) conns evs =
170+ go conns (NewEndPoint : cmds) evs =
171+ go conns cmds evs
172+ go conns (Connect _fr to : cmds) evs =
146173 let epEvs = evs Map.! to
147174 in case epEvs of
148175 (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)
150177 _ ->
151178 Just $ "Missing (ConnectionOpened <<connId>> <<rel>> <<addr>>) event in " ++ show evs
152− go (Close connIx : cmds) conns evs =
179+ go conns (Close connIx : cmds) evs =
153180 let (epIx, connId) = conns !! connIx
154181 epEvs = evs Map.! epIx
155182 in case epEvs of
156183 (ConnectionClosed connId' : epEvs') | connId' == connId ->
157− go cmds conns (Map.insert epIx epEvs' evs)
184+ go conns cmds (Map.insert epIx epEvs' evs)
158185 _ ->
159186 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 =
161188 let (epIx, connId) = conns !! connIx
162189 epEvs = evs Map.! epIx
163190 in case epEvs of
164191 (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)
166193 _ ->
167194 Just $ "Missing (Received " ++ show connId ++ " " ++ show payload ++ ") event in " ++ show epEvs
168− go (BreakAfterReads n i j : cmds) conns evs =
169− go cmds conns evs
195+ go conns (BreakAfterReads n i j : cmds) evs =
196+ go conns cmds evs
170197
171198--------------------------------------------------------------------------------
172199-- Script generators --
@@ -238,7 +265,8 @@ script_ConnectSendClose numEndPoints = do
238265 case mConn of
239266 Nothing -> go conns
240267 Just conn -> do
241− payload <- arbitrary
268+ numSegments <- choose (0, 2)
269+ payload <- replicateM numSegments arbitrary
242270 cmds <- go conns
243271 return (Send conn payload : cmds)
244272 2 -> do
@@ -263,9 +291,11 @@ withErrors numErrors gen = gen >>= insertError numErrors
263291 insert <- arbitrary
264292 if insert && n > 0
265293 then do
266− -- We sometimes want big delays, but usually we want short delays
267− numReads <- elements (concat (replicate 10 [0 .. 9]) ++ [10 ..99])
268− return $ Connect i j : BreakAfterReads numReads i j : cmds
294+ numReads <- chooseFrom' (NormalD { mean = 5, stdDev = 10 }) (0, 100)
295+ swap <- arbitrary
296+ if swap
297+ then return $ Connect i j : BreakAfterReads numReads j i : cmds
298+ else return $ Connect i j : BreakAfterReads numReads i j : cmds
269299 else do
270300 cmds' <- insertError (n - 1) cmds
271301 return $ Connect i j : cmds'
@@ -329,6 +359,26 @@ script_Bug1 = [
329359 , Connect 1 0
330360 ]
331361
362+-- | Simulate broken network connection during send
363+script_BreakSend :: Script
364+script_BreakSend = [
365+ NewEndPoint
366+ , NewEndPoint
367+ , Connect 0 1
368+ , BreakAfterReads 1 1 0
369+ , Send 0 ["ping"]
370+ ]
371+
372+-- | Simulate broken network connection during connect
373+script_BreakConnect :: Script
374+script_BreakConnect = [
375+ NewEndPoint
376+ , NewEndPoint
377+ , Connect 0 1
378+ , BreakAfterReads 1 1 0
379+ , Connect 0 1
380+ ]
381+
332382--------------------------------------------------------------------------------
333383-- Main application driver --
334384--------------------------------------------------------------------------------
@@ -343,8 +393,10 @@ basicTests transport numEndPoints trans = [
343393
344394tests :: (Transport, TransportInternals) -> [Test]
345395tests transport = [
346− testGroup "Bugs" [
347− testOne "Bug1" transport script_Bug1
396+ testGroup "Specific scripts" [
397+ testOne "Bug1" transport script_Bug1
398+ , testOne "BreakSend" transport script_BreakSend
399+ , testOne "BreakConnect" transport script_BreakConnect
348400 ]
349401 , testGroup "One endpoint, with delays" (basicTests transport 1 id)
350402 , testGroup "Two endpoints, with delays" (basicTests transport 2 id)
@@ -393,8 +445,11 @@ testScript transport script = do
393445-- Auxiliary
394446--------------------------------------------------------------------------------
395447
448+log :: String -> IO ()
449+log = appendFile "log" . (++ "\n")
450+
396451logShow :: Show a => a -> IO ()
397−logShow = appendFile "log" . (++ "\n") . show
452+logShow = log . show
398453
399454throwIfLeft :: Exception a => IO (Either a b) -> IO b
400455throwIfLeft p = do
@@ -405,6 +460,37 @@ throwIfLeft p = do
405460
406461instance Arbitrary ByteString where
407462 arbitrary = do
408− len <- choose (0, 10)
463+ len <- chooseFrom' (NormalD { mean = 5, stdDev = 10 }) (0, 100)
409464 xs <- replicateM len arbitrary
410465 return (pack xs)
466+
467+--------------------------------------------------------------------------------
468+-- Draw random values from probability distributions --
469+--------------------------------------------------------------------------------
470+
471+data NormalD = NormalD { mean :: Double , stdDev :: Double }
472+
473+class Distribution d where
474+ probabilityOf :: d -> Double -> Double
475+
476+instance Distribution NormalD where
477+ probabilityOf d x = a * exp (-0.5 * b * b)
478+ where
479+ a = 1 / (stdDev d * sqrt (2 * pi))
480+ b = (x - mean d) / stdDev d
481+
482+-- | Choose from a distribution
483+chooseFrom :: Distribution d => d -> (Double, Double) -> Gen Double
484+chooseFrom d (lo, hi) = findCandidate
485+ where
486+ findCandidate :: Gen Double
487+ findCandidate = do
488+ candidate <- choose (lo, hi)
489+ uniformSample <- choose (0, 1)
490+ if uniformSample < probabilityOf d candidate
491+ then return candidate
492+ else findCandidate
493+
494+chooseFrom' :: Distribution d => d -> (Int, Int) -> Gen Int
495+chooseFrom' d (lo, hi) =
496+ round <$> chooseFrom d (fromIntegral lo, fromIntegral hi)