git.iko.soy/distributed-process
on master help sign in
Continue work on script driven testing
f3d8221Edsko de Vries
network-transport-tcp/network-transport-tcp.cabal+1−1
compare with master
unifiedsplit
@@ -66,5 +66,5 @@ Test-Suite TestQC
66 network-transport,
66 network-transport,
67 network-transport-tcp,
67 network-transport-tcp,
68 containers
68 containers
69− ghc-options: -threaded
69+ ghc-options: -threaded -Wall
70 HS-Source-Dirs: tests
70 HS-Source-Dirs: tests
network-transport-tcp/src/Network/Transport/TCP/Mock/Socket.hs+43−15
@@ -41,6 +41,7 @@ import Control.Concurrent.Chan
41import System.IO.Unsafe (unsafePerformIO)
41import System.IO.Unsafe (unsafePerformIO)
42import Data.Accessor (Accessor, accessor, (^=), (^.))
42import Data.Accessor (Accessor, accessor, (^=), (^.))
43import qualified Data.Accessor.Container as DAC (mapMaybe)
43import qualified Data.Accessor.Container as DAC (mapMaybe)
44+import System.Timeout (timeout)
44
45
45--------------------------------------------------------------------------------
46--------------------------------------------------------------------------------
46-- Mock state --
47-- Mock state --
@@ -64,10 +65,10 @@ mockState :: MVar MockState
64mockState = unsafePerformIO $ newMVar initialMockState
65mockState = unsafePerformIO $ newMVar initialMockState
65
66
66get :: Accessor MockState a -> IO a
67get :: Accessor MockState a -> IO a
67−get acc = withMVar mockState $ return . (^. acc)
68+get acc = timeoutThrow mvarThreshold $ withMVar mockState $ return . (^. acc)
68
69
69set :: Accessor MockState a -> a -> IO ()
70set :: Accessor MockState a -> a -> IO ()
70−set acc val = modifyMVar_ mockState $ return . (acc ^= val)
71+set acc val = timeoutThrow mvarThreshold $ modifyMVar_ mockState $ return . (acc ^= val)
71
72
72boundSockets :: Accessor MockState (Map SockAddr Socket)
73boundSockets :: Accessor MockState (Map SockAddr Socket)
73boundSockets = accessor _boundSockets (\bs st -> st { _boundSockets = bs })
74boundSockets = accessor _boundSockets (\bs st -> st { _boundSockets = bs })
@@ -152,7 +153,7 @@ socket _ Stream _ = do
152
153
153bindSocket :: Socket -> SockAddr -> IO ()
154bindSocket :: Socket -> SockAddr -> IO ()
154bindSocket sock addr = do
155bindSocket sock addr = do
155− modifyMVar_ (socketState sock) $ \st -> case st of
156+ timeoutThrow mvarThreshold $ modifyMVar_ (socketState sock) $ \st -> case st of
156 Uninit -> do
157 Uninit -> do
157 backlog <- newChan
158 backlog <- newChan
158 return BoundSocket {
159 return BoundSocket {
@@ -174,7 +175,7 @@ setSocketOption _ _ _ = error "setSocketOption: unsupported arguments"
174
175
175accept :: Socket -> IO (Socket, SockAddr)
176accept :: Socket -> IO (Socket, SockAddr)
176accept serverSock = do
177accept serverSock = do
177− backlog <- withMVar (socketState serverSock) $ \st -> case st of
178+ backlog <- timeoutThrow mvarThreshold $ withMVar (socketState serverSock) $ \st -> case st of
178 BoundSocket {} ->
179 BoundSocket {} ->
179 return (socketBacklog st)
180 return (socketBacklog st)
180 _ ->
181 _ ->
@@ -189,28 +190,38 @@ accept serverSock = do
189 socketState = ourState
190 socketState = ourState
190 , socketDescription = ""
191 , socketDescription = ""
191 }
192 }
192− putMVar reply ourSocket
193+ timeoutThrow mvarThreshold $ putMVar reply ourSocket
193 return (ourSocket, theirAddress)
194 return (ourSocket, theirAddress)
194
195
195sClose :: Socket -> IO ()
196sClose :: Socket -> IO ()
196sClose sock = do
197sClose sock = do
198+ -- Close the peer socket
197 writeSocket sock CloseSocket
199 writeSocket sock CloseSocket
200+
201+ -- Close our socket
198− modifyMVar_ (socketState sock) $ const (return Closed)
202+ timeoutThrow mvarThreshold $ modifyMVar_ (socketState sock) $ \st ->
203+ case st of
204+ Connected {} -> do
205+ -- In case there is a parallel read stuck on a readChan
206+ writeChan (socketBuff st) CloseSocket
207+ return Closed
208+ _ ->
209+ return Closed
199
210
200connect :: Socket -> SockAddr -> IO ()
211connect :: Socket -> SockAddr -> IO ()
201connect us serverAddr = do
212connect us serverAddr = do
202 mServer <- get (boundSocketAt serverAddr)
213 mServer <- get (boundSocketAt serverAddr)
203 case mServer of
214 case mServer of
204 Just server -> do
215 Just server -> do
205− serverBacklog <- withMVar (socketState server) $ \st -> case st of
216+ serverBacklog <- timeoutThrow mvarThreshold $ withMVar (socketState server) $ \st -> case st of
206 BoundSocket {} ->
217 BoundSocket {} ->
207 return (socketBacklog st)
218 return (socketBacklog st)
208 _ ->
219 _ ->
209 throwSocketError "connect: server socket not bound"
220 throwSocketError "connect: server socket not bound"
210 reply <- newEmptyMVar
221 reply <- newEmptyMVar
211 writeChan serverBacklog (us, SockAddrInet "" "", reply)
222 writeChan serverBacklog (us, SockAddrInet "" "", reply)
212− them <- readMVar reply
223+ them <- timeoutThrow mvarThreshold $ readMVar reply
213− modifyMVar_ (socketState us) $ \st -> case st of
224+ timeoutThrow mvarThreshold $ modifyMVar_ (socketState us) $ \st -> case st of
214 Uninit -> do
225 Uninit -> do
215 buff <- newChan
226 buff <- newChan
216 return Connected {
227 return Connected {
@@ -227,7 +238,7 @@ sOMAXCONN = error "sOMAXCONN not implemented"
227shutdown :: Socket -> ShutdownCmd -> IO ()
238shutdown :: Socket -> ShutdownCmd -> IO ()
228shutdown sock ShutdownSend = do
239shutdown sock ShutdownSend = do
229 writeSocket sock CloseSocket
240 writeSocket sock CloseSocket
230− modifyMVar_ (socketState sock) $ \st -> case st of
241+ timeoutThrow mvarThreshold $ modifyMVar_ (socketState sock) $ \st -> case st of
231 Connected {} ->
242 Connected {} ->
232 return (Connected Nothing (socketBuff st))
243 return (Connected Nothing (socketBuff st))
233 _ ->
244 _ ->
@@ -239,13 +250,13 @@ shutdown sock ShutdownSend = do
239
250
240peerBuffer :: Socket -> IO (Either String (Chan Message))
251peerBuffer :: Socket -> IO (Either String (Chan Message))
241peerBuffer sock = do
252peerBuffer sock = do
242− mPeer <- withMVar (socketState sock) $ \st -> case st of
253+ mPeer <- timeoutThrow mvarThreshold $ withMVar (socketState sock) $ \st -> case st of
243 Connected {} ->
254 Connected {} ->
244 return (socketPeer st)
255 return (socketPeer st)
245 _ ->
256 _ ->
246 return Nothing
257 return Nothing
247 case mPeer of
258 case mPeer of
248− Just peer -> withMVar (socketState peer) $ \st -> case st of
259+ Just peer -> timeoutThrow mvarThreshold $ withMVar (socketState peer) $ \st -> case st of
249 Connected {} ->
260 Connected {} ->
250 return (Right (socketBuff st))
261 return (Right (socketBuff st))
251 _ ->
262 _ ->
@@ -266,20 +277,37 @@ writeSocket sock msg = do
266
277
267readSocket :: Socket -> IO (Maybe Word8)
278readSocket :: Socket -> IO (Maybe Word8)
268readSocket sock = do
279readSocket sock = do
269− mBuff <- withMVar (socketState sock) $ \st -> case st of
280+ mBuff <- timeoutThrow mvarThreshold $ withMVar (socketState sock) $ \st -> case st of
270 Connected {} ->
281 Connected {} ->
271 return (Just $ socketBuff st)
282 return (Just $ socketBuff st)
272 _ ->
283 _ ->
273 return Nothing
284 return Nothing
274 case mBuff of
285 case mBuff of
275 Just buff -> do
286 Just buff -> do
276− msg <- readChan buff
287+ msg <- timeoutThrow readSocketThreshold $ readChan buff
277 case msg of
288 case msg of
278 Payload w -> return (Just w)
289 Payload w -> return (Just w)
279− CloseSocket -> modifyMVar (socketState sock) $ \st -> case st of
290+ CloseSocket -> timeoutThrow mvarThreshold $ modifyMVar (socketState sock) $ \st -> case st of
280 Connected {} ->
291 Connected {} ->
281 return (Closed, Nothing)
292 return (Closed, Nothing)
282 _ ->
293 _ ->
283 throwSocketError "readSocket: socket in unexpected state"
294 throwSocketError "readSocket: socket in unexpected state"
284 Nothing ->
295 Nothing ->
285 return Nothing
296 return Nothing
297+
298+--------------------------------------------------------------------------------
299+-- Util --
300+--------------------------------------------------------------------------------
301+
302+mvarThreshold :: Int
303+mvarThreshold = 1000000
304+
305+readSocketThreshold :: Int
306+readSocketThreshold = 10000000
307+
308+timeoutThrow :: Int -> IO a -> IO a
309+timeoutThrow n p = do
310+ ma <- timeout n p
311+ case ma of
312+ Just a -> return a
313+ Nothing -> throwIO (userError "timeout")
network-transport-tcp/tests/TestQC.hs+105−60
@@ -1,23 +1,26 @@
1+module Main (main, logShow) where
2+
1−import Test.Framework (defaultMain, testGroup)
3+import Test.Framework (Test, defaultMain, testGroup)
2import Test.Framework.Providers.QuickCheck2 (testProperty)
4import Test.Framework.Providers.QuickCheck2 (testProperty)
3−import Test.QuickCheck (Gen, choose, suchThatMaybe, forAll)
5+import Test.QuickCheck (Gen, choose, suchThatMaybe, forAllShrink, Property)
4import Test.QuickCheck.Property (morallyDubiousIOProperty, Result(..), result)
6import Test.QuickCheck.Property (morallyDubiousIOProperty, Result(..), result)
5import Data.Map (Map)
7import Data.Map (Map)
6import qualified Data.Map as Map
8import qualified Data.Map as Map
7−import Control.Applicative ((<$>))
9+import Control.Exception (Exception, throwIO)
8import Control.Concurrent (forkIO, threadDelay)
10import Control.Concurrent (forkIO, threadDelay)
9import Control.Concurrent.Chan (Chan, newChan, writeChan, readChan)
11import Control.Concurrent.Chan (Chan, newChan, writeChan, readChan)
10−import Control.Monad (forM_, replicateM)
12+import Data.List (inits)
11−import Data.Either (rights)
12
13
13import Network.Transport
14import Network.Transport
14import Network.Transport.TCP (createTransport, defaultTCPParameters)
15import Network.Transport.TCP (createTransport, defaultTCPParameters)
15
16
16data ScriptCmd =
17data ScriptCmd =
18+ NewEndPoint
17− Connect Int Int Reliability ConnectHints
19+ | Connect Int Int Reliability ConnectHints
18 | Close Int
20 | Close Int
19
21
20instance Show ScriptCmd where
22instance Show ScriptCmd where
23+ show NewEndPoint = "NewEndPoint"
21 show (Connect fr to _ _) = "Connect " ++ show fr ++ " " ++ show to
24 show (Connect fr to _ _) = "Connect " ++ show fr ++ " " ++ show to
22 show (Close i) = "Close " ++ show i
25 show (Close i) = "Close " ++ show i
23
26
@@ -26,8 +29,37 @@ type Script = [ScriptCmd]
26logShow :: Show a => a -> IO ()
29logShow :: Show a => a -> IO ()
27logShow = appendFile "log" . (++ "\n") . show
30logShow = appendFile "log" . (++ "\n") . show
28
31
29−connectCloseScript :: Int -> Gen Script
32+throwIfLeft :: Exception a => IO (Either a b) -> IO b
30−connectCloseScript numEndPoints = go Map.empty
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)
31 where
63 where
32 go :: Map Int Bool -> Gen Script
64 go :: Map Int Bool -> Gen Script
33 go conns = do
65 go conns = do
@@ -51,85 +83,98 @@ connectCloseScript numEndPoints = go Map.empty
51 isOpen :: Map Int Bool -> Int -> Bool
83 isOpen :: Map Int Bool -> Int -> Bool
52 isOpen conns connIx = connIx `Map.member` conns && conns Map.! connIx
84 isOpen conns connIx = connIx `Map.member` conns && conns Map.! connIx
53
85
54−execScript :: Transport -> Int -> Script -> IO (Map Int [Event])
86+execScript :: Transport -> Script -> IO (Map Int [Event])
55−execScript transport numEndPoints script = do
87+execScript transport script = do
56− endPoints <- rights <$> replicateM numEndPoints (newEndPoint transport)
57 chan <- newChan
88 chan <- newChan
58− forM_ (zip [0..] endPoints) $ forkIO . forwardTo chan
59− forkIO $ runScript endPoints [] script
89+ runScript chan script
60− collectAll chan 0
90+ collectAll chan
61 where
91 where
62− runScript :: [EndPoint] -> [Connection] -> Script -> IO ()
92+ runScript :: Chan (Maybe (Int, Event)) -> Script -> IO ()
63− runScript endPoints = go
93+ runScript chan = go [] []
64 where
94 where
65− go :: [Connection] -> Script -> IO ()
95+ go :: [EndPoint] -> [Connection] -> Script -> IO ()
66− go _ [] = threadDelay 500000 >> mapM_ closeEndPoint endPoints
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
67− go conns cmd@(Connect fr to rel hints : cmds) = do
105+ go endPoints conns (Connect fr to rel hints : cmds) = do
68− Right conn <- connect (endPoints !! fr) (address (endPoints !! to)) rel hints
106+ conn <- throwIfLeft $ connect (endPoints !! fr) (address (endPoints !! to)) rel hints
107+ threadDelay 10000
69− go (conns ++ [conn]) cmds
108+ go endPoints (conns ++ [conn]) cmds
70− go conns cmd@(Close connIx : cmds) = do
109+ go endPoints conns (Close connIx : cmds) = do
71 close (conns !! connIx)
110 close (conns !! connIx)
111+ threadDelay 10000
72− go conns cmds
112+ go endPoints conns cmds
73
113
74− forwardTo :: Chan (Int, Event) -> (Int, EndPoint) -> IO ()
114+ forwardTo :: Chan (Maybe (Int, Event)) -> (Int, EndPoint) -> IO ()
75 forwardTo chan (ix, endPoint) = go
115 forwardTo chan (ix, endPoint) = go
76 where
116 where
77 go :: IO ()
117 go :: IO ()
78 go = do
118 go = do
79 ev <- receive endPoint
119 ev <- receive endPoint
80− writeChan chan (ix, ev)
81 case ev of
120 case ev of
82 EndPointClosed -> return ()
121 EndPointClosed -> return ()
83− _ -> go
122+ _ -> writeChan chan (Just (ix, ev)) >> go
84
123
85− collectAll :: Chan (Int, Event) -> Int -> IO (Map Int [Event])
124+ collectAll :: Chan (Maybe (Int, Event)) -> IO (Map Int [Event])
86− collectAll chan = go (Map.fromList (zip [0 .. numEndPoints - 1] (repeat [])))
125+ collectAll chan = go Map.empty
87 where
126 where
88− go :: Map Int [Event] -> Int -> IO (Map Int [Event])
127+ go :: Map Int [Event] -> IO (Map Int [Event])
89− go acc numDone | numDone == numEndPoints = return $ Map.map reverse acc
128+ go acc = do
90− go acc numDone = do
91− logShow acc
92− (ix, ev) <- readChan chan
129+ mEv <- readChan chan
93− let acc' = Map.adjust (ev :) ix acc
130+ case mEv of
94− numDone' = case ev of EndPointClosed -> numDone + 1
131+ Nothing -> return $ Map.map reverse acc
95− _ -> numDone
132+ Just (ix, ev) -> go (Map.alter (insertEvent ev) ix acc)
96− go acc' numDone'
133+
97−
134+ insertEvent :: Event -> Maybe [Event] -> Maybe [Event]
135+ insertEvent ev Nothing = Just [ev]
136+ insertEvent ev (Just evs) = Just (ev : evs)
137+
98−verify :: Int -> Script -> Map Int [Event] -> Result
138+verify :: Script -> Map Int [Event] -> Result
99−verify numEndPoints script evs =
100− case go script [] evs of
139+verify script = \evs -> case go script [] evs of
101− Nothing -> result { ok = Just True
140+ Nothing -> result { ok = Just True
102− }
141+ }
103− Just err -> result { ok = Just False
142+ Just err -> result { ok = Just False
104− , reason = err
143+ , reason = '\n' : err ++ "\nAll events: " ++ show evs
105− }
144+ }
106 where
145 where
107 go :: Script -> [(Int, ConnectionId)] -> Map Int [Event] -> Maybe String
146 go :: Script -> [(Int, ConnectionId)] -> Map Int [Event] -> Maybe String
108− go [] conns evs =
147+ go [] _conns evs =
109− let closed = Map.fromList (zip [0 .. numEndPoints - 1] (repeat [EndPointClosed])) in
148+ if concat (Map.elems evs) == []
110− if evs == closed then Nothing
149+ then Nothing
111− else Just $ "Expected " ++ show closed ++ "; got " ++ show evs
150+ else Just $ "Unexpected events: " ++ show evs
151+ go (NewEndPoint : cmds) conns evs =
152+ go cmds conns evs
112− go (Connect fr to rel hints : cmds) conns evs =
153+ go (Connect _fr to rel _hints : cmds) conns evs =
113 case evs Map.! to of
154 case evs Map.! to of
114− (ConnectionOpened connId rel' addr : epEvs) | rel' == rel ->
155+ (ConnectionOpened connId rel' _addr : epEvs) | rel' == rel ->
115 go cmds (conns ++ [(to, connId)]) (Map.insert to epEvs evs)
156 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
117 go (Close connIx : cmds) conns evs =
158 go (Close connIx : cmds) conns evs =
118 let (epIx, connId) = conns !! connIx in
159 let (epIx, connId) = conns !! connIx in
119 case evs Map.! epIx of
160 case evs Map.! epIx of
120 (ConnectionClosed connId' : epEvs) | connId' == connId ->
161 (ConnectionClosed connId' : epEvs) | connId' == connId ->
121 go cmds conns (Map.insert epIx epEvs evs)
162 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
123
164
124−prop_connect_close transport = forAll (connectCloseScript 2) $ \script ->
165+genericProp :: Transport -> Int -> (Int -> Gen Script) -> Property
166+genericProp transport numEndPoints scriptGen =
167+ forAllShrink (scriptGen numEndPoints) inits $ \script ->
125− morallyDubiousIOProperty $ do
168+ morallyDubiousIOProperty $ do
126− logShow script
127− evs <- execScript transport 2 script
169+ evs <- execScript transport script
128− return (verify 2 script evs)
170+ return (verify script evs)
129
171
172+tests :: Transport -> [Test]
130tests transport = [
173tests transport = [
131 testGroup "Unidirectional" [
174 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)
133 ]
178 ]
134 ]
179 ]
135
180