@@ -1,23 +1,26 @@
1−import Test.Framework (defaultMain, testGroup)
1+module Main (main, logShow) where
2+
3+import Test.Framework (Test, defaultMain, testGroup)
24import Test.Framework.Providers.QuickCheck2 (testProperty)
3−import Test.QuickCheck (Gen, choose, suchThatMaybe, forAll)
5+import Test.QuickCheck (Gen, choose, suchThatMaybe, forAllShrink, Property)
46import Test.QuickCheck.Property (morallyDubiousIOProperty, Result(..), result)
57import Data.Map (Map)
68import qualified Data.Map as Map
7−import Control.Applicative ((<$>))
9+import Control.Exception (Exception, throwIO)
810import Control.Concurrent (forkIO, threadDelay)
911import Control.Concurrent.Chan (Chan, newChan, writeChan, readChan)
10−import Control.Monad (forM_, replicateM)
11−import Data.Either (rights)
12+import Data.List (inits)
1213
1314import Network.Transport
1415import Network.Transport.TCP (createTransport, defaultTCPParameters)
1516
1617data ScriptCmd =
17− Connect Int Int Reliability ConnectHints
18+ NewEndPoint
19+ | Connect Int Int Reliability ConnectHints
1820 | Close Int
1921
2022instance Show ScriptCmd where
23+ show NewEndPoint = "NewEndPoint"
2124 show (Connect fr to _ _) = "Connect " ++ show fr ++ " " ++ show to
2225 show (Close i) = "Close " ++ show i
2326
@@ -26,8 +29,37 @@ type Script = [ScriptCmd]
2629logShow :: Show a => a -> IO ()
2730logShow = appendFile "log" . (++ "\n") . show
2831
29−connectCloseScript :: Int -> Gen Script
30−connectCloseScript numEndPoints = go Map.empty
32+throwIfLeft :: Exception a => IO (Either a b) -> IO b
33+throwIfLeft p = do
34+ mb <- p
35+ case mb of
36+ Left a -> throwIO a
37+ Right b -> return b
38+
39+script_NewEndPoint :: Int -> Gen Script
40+script_NewEndPoint numEndPoints = return (replicate numEndPoints NewEndPoint)
41+
42+script_Connect :: Int -> Gen Script
43+script_Connect numEndPoints = do
44+ script <- go
45+ return (replicate numEndPoints NewEndPoint ++ script)
46+ where
47+ go :: Gen Script
48+ go = do
49+ next <- choose (0, 1) :: Gen Int
50+ case next of
51+ 0 -> do
52+ fr <- choose (0, numEndPoints - 1)
53+ to <- choose (0, numEndPoints - 1)
54+ cmds <- go
55+ return (Connect fr to ReliableOrdered defaultConnectHints : cmds)
56+ _ ->
57+ return []
58+
59+script_ConnectClose :: Int -> Gen Script
60+script_ConnectClose numEndPoints = do
61+ script <- go Map.empty
62+ return (replicate numEndPoints NewEndPoint ++ script)
3163 where
3264 go :: Map Int Bool -> Gen Script
3365 go conns = do
@@ -51,85 +83,98 @@ connectCloseScript numEndPoints = go Map.empty
5183 isOpen :: Map Int Bool -> Int -> Bool
5284 isOpen conns connIx = connIx `Map.member` conns && conns Map.! connIx
5385
54−execScript :: Transport -> Int -> Script -> IO (Map Int [Event])
55−execScript transport numEndPoints script = do
56− endPoints <- rights <$> replicateM numEndPoints (newEndPoint transport)
86+execScript :: Transport -> Script -> IO (Map Int [Event])
87+execScript transport script = do
5788 chan <- newChan
58− forM_ (zip [0..] endPoints) $ forkIO . forwardTo chan
59− forkIO $ runScript endPoints [] script
60− collectAll chan 0
89+ runScript chan script
90+ collectAll chan
6191 where
62− runScript :: [EndPoint] -> [Connection] -> Script -> IO ()
63− runScript endPoints = go
92+ runScript :: Chan (Maybe (Int, Event)) -> Script -> IO ()
93+ runScript chan = go [] []
6494 where
65− go :: [Connection] -> Script -> IO ()
66− go _ [] = threadDelay 500000 >> mapM_ closeEndPoint endPoints
67− go conns cmd@(Connect fr to rel hints : cmds) = do
68− Right conn <- connect (endPoints !! fr) (address (endPoints !! to)) rel hints
69− go (conns ++ [conn]) cmds
70− go conns cmd@(Close connIx : cmds) = do
95+ go :: [EndPoint] -> [Connection] -> Script -> IO ()
96+ go _endPoints _conns [] = do
97+ threadDelay 100000
98+ writeChan chan Nothing
99+ go endPoints conns (NewEndPoint : cmds) = do
100+ endPoint <- throwIfLeft $ newEndPoint transport
101+ let endPointIx = length endPoints
102+ _tid <- forkIO $ forwardTo chan (endPointIx, endPoint)
103+ threadDelay 10000
104+ go (endPoints ++ [endPoint]) conns cmds
105+ go endPoints conns (Connect fr to rel hints : cmds) = do
106+ conn <- throwIfLeft $ connect (endPoints !! fr) (address (endPoints !! to)) rel hints
107+ threadDelay 10000
108+ go endPoints (conns ++ [conn]) cmds
109+ go endPoints conns (Close connIx : cmds) = do
71110 close (conns !! connIx)
72− go conns cmds
111+ threadDelay 10000
112+ go endPoints conns cmds
73113
74− forwardTo :: Chan (Int, Event) -> (Int, EndPoint) -> IO ()
114+ forwardTo :: Chan (Maybe (Int, Event)) -> (Int, EndPoint) -> IO ()
75115 forwardTo chan (ix, endPoint) = go
76116 where
77117 go :: IO ()
78118 go = do
79119 ev <- receive endPoint
80− writeChan chan (ix, ev)
81120 case ev of
82121 EndPointClosed -> return ()
83− _ -> go
122+ _ -> writeChan chan (Just (ix, ev)) >> go
84123
85− collectAll :: Chan (Int, Event) -> Int -> IO (Map Int [Event])
86− collectAll chan = go (Map.fromList (zip [0 .. numEndPoints - 1] (repeat [])))
124+ collectAll :: Chan (Maybe (Int, Event)) -> IO (Map Int [Event])
125+ collectAll chan = go Map.empty
87126 where
88− go :: Map Int [Event] -> Int -> IO (Map Int [Event])
89− go acc numDone | numDone == numEndPoints = return $ Map.map reverse acc
90− go acc numDone = do
91− logShow acc
92− (ix, ev) <- readChan chan
93− let acc' = Map.adjust (ev :) ix acc
94− numDone' = case ev of EndPointClosed -> numDone + 1
95− _ -> numDone
96− go acc' numDone'
97−
98−verify :: Int -> Script -> Map Int [Event] -> Result
99−verify numEndPoints script evs =
100− case go script [] evs of
101− Nothing -> result { ok = Just True
102− }
103− Just err -> result { ok = Just False
104− , reason = err
105− }
127+ go :: Map Int [Event] -> IO (Map Int [Event])
128+ go acc = do
129+ mEv <- readChan chan
130+ case mEv of
131+ Nothing -> return $ Map.map reverse acc
132+ Just (ix, ev) -> go (Map.alter (insertEvent ev) ix acc)
133+
134+ insertEvent :: Event -> Maybe [Event] -> Maybe [Event]
135+ insertEvent ev Nothing = Just [ev]
136+ insertEvent ev (Just evs) = Just (ev : evs)
137+
138+verify :: Script -> Map Int [Event] -> Result
139+verify script = \evs -> case go script [] evs of
140+ Nothing -> result { ok = Just True
141+ }
142+ Just err -> result { ok = Just False
143+ , reason = '\n' : err ++ "\nAll events: " ++ show evs
144+ }
106145 where
107146 go :: Script -> [(Int, ConnectionId)] -> Map Int [Event] -> Maybe String
108− go [] conns evs =
109− let closed = Map.fromList (zip [0 .. numEndPoints - 1] (repeat [EndPointClosed])) in
110− if evs == closed then Nothing
111− else Just $ "Expected " ++ show closed ++ "; got " ++ show evs
112− go (Connect fr to rel hints : cmds) conns evs =
147+ go [] _conns evs =
148+ if concat (Map.elems evs) == []
149+ then Nothing
150+ else Just $ "Unexpected events: " ++ show evs
151+ go (NewEndPoint : cmds) conns evs =
152+ go cmds conns evs
153+ go (Connect _fr to rel _hints : cmds) conns evs =
113154 case evs Map.! to of
114− (ConnectionOpened connId rel' addr : epEvs) | rel' == rel ->
155+ (ConnectionOpened connId rel' _addr : epEvs) | rel' == rel ->
115156 go cmds (conns ++ [(to, connId)]) (Map.insert to epEvs evs)
116− _ -> Just $ "Missing ConnectionOpened event in " ++ show evs
157+ _ -> Just $ "Missing (ConnectionOpened <<connId>> " ++ show rel ++ " <<addr>>) event in " ++ show evs
117158 go (Close connIx : cmds) conns evs =
118159 let (epIx, connId) = conns !! connIx in
119160 case evs Map.! epIx of
120161 (ConnectionClosed connId' : epEvs) | connId' == connId ->
121162 go cmds conns (Map.insert epIx epEvs evs)
122− _ -> Just $ "Missing ConnectionClosed event in " ++ show evs
163+ _ -> Just $ "Missing (ConnectionClosed " ++ show connId ++ ") event in " ++ show evs
123164
124−prop_connect_close transport = forAll (connectCloseScript 2) $ \script ->
125− morallyDubiousIOProperty $ do
126− logShow script
127− evs <- execScript transport 2 script
128− return (verify 2 script evs)
165+genericProp :: Transport -> Int -> (Int -> Gen Script) -> Property
166+genericProp transport numEndPoints scriptGen =
167+ forAllShrink (scriptGen numEndPoints) inits $ \script ->
168+ morallyDubiousIOProperty $ do
169+ evs <- execScript transport script
170+ return (verify script evs)
129171
172+tests :: Transport -> [Test]
130173tests transport = [
131174 testGroup "Unidirectional" [
132− testProperty "ConnectClose" (prop_connect_close transport)
175+ testProperty "NewEndPoint" (genericProp transport 2 script_NewEndPoint)
176+ , testProperty "Connect" (genericProp transport 2 script_Connect)
177+ , testProperty "ConnectClose" (genericProp transport 2 script_ConnectClose)
133178 ]
134179 ]
135180