git.iko.soy/distributed-process
on master help sign in
Write a test that exposes a bug in receiveWait
5732cf1Edsko de Vries
distributed-process/src/Control/Distributed/Process/Node.hs+10−2
compare with master
unifiedsplit
@@ -211,13 +211,21 @@ handleIncomingMessages node = go [] Map.empty Set.empty
211 (Map.insert cid proc procConns)
211 (Map.insert cid proc procConns)
212 ctrlConns
212 ctrlConns
213 Nothing ->
213 Nothing ->
214− fail "handleIncomingMessages: TODO 1"
214+ -- Request for an unknown process.
215+ -- TODO: We should close the incoming connection here, but
216+ -- we cannot! Network.Transport does not provide this
217+ -- functionality. Not sure what the right approach is.
218+ -- For now, we just drop the incoming messages
219+ go (List.delete cid uninitConns)
220+ procConns
221+ ctrlConns
215 Nothing ->
222 Nothing ->
216 go (List.delete cid uninitConns)
223 go (List.delete cid uninitConns)
217 procConns
224 procConns
218 (Set.insert cid ctrlConns)
225 (Set.insert cid ctrlConns)
219 _ ->
226 _ ->
220− fail "handleIncomingMessages: TODO 2"
227+ -- Unexpected message. We just drop it.
228+ go uninitConns procConns ctrlConns
221 NT.ConnectionClosed cid ->
229 NT.ConnectionClosed cid ->
222 go (List.delete cid uninitConns)
230 go (List.delete cid uninitConns)
223 (Map.delete cid procConns)
231 (Map.delete cid procConns)
distributed-process/tests/TestCH.hs+71−4
@@ -295,6 +295,39 @@ testMath transport = do
295
295
296 takeMVar clientDone
296 takeMVar clientDone
297
297
298+-- | Send first message (i.e. connect) to an already terminated process
299+-- (without monitoring); then send another message to a second process on
300+-- the same remote node (we're checking that the remote node did not die)
301+testSendToTerminated :: NT.Transport -> IO ()
302+testSendToTerminated transport = do
303+ serverAddr1 <- newEmptyMVar
304+ serverAddr2 <- newEmptyMVar
305+ clientDone <- newEmptyMVar
306+
307+ forkIO $ do
308+ terminated <- newEmptyMVar
309+ localNode <- newLocalNode transport initRemoteTable
310+ addr1 <- forkProcess localNode $ liftIO $ putMVar terminated ()
311+ addr2 <- forkProcess localNode $ ping
312+ readMVar terminated
313+ putMVar serverAddr1 addr1
314+ putMVar serverAddr2 addr2
315+
316+ forkIO $ do
317+ localNode <- newLocalNode transport initRemoteTable
318+ server1 <- readMVar serverAddr1
319+ server2 <- readMVar serverAddr2
320+ runProcess localNode $ do
321+ pid <- getSelfPid
322+ send server1 "Hi"
323+ send server2 (Pong pid)
324+ Ping pid' <- expect
325+ True <- return $ pid' == server2
326+ liftIO $ putMVar clientDone ()
327+
328+ takeMVar clientDone
329+
330+-- | Test (non-zero) timeout
298testTimeout :: NT.Transport -> IO ()
331testTimeout :: NT.Transport -> IO ()
299testTimeout transport = do
332testTimeout transport = do
300 localNode <- newLocalNode transport initRemoteTable
333 localNode <- newLocalNode transport initRemoteTable
@@ -302,15 +335,49 @@ testTimeout transport = do
302 Nothing <- receiveTimeout 1000000 [match (\(Add _ _ _) -> return ())]
335 Nothing <- receiveTimeout 1000000 [match (\(Add _ _ _) -> return ())]
303 return ()
336 return ()
304
337
305−-- TODO: test timeout
338+-- | Test zero timeout
339+testTimeout0 :: NT.Transport -> IO ()
340+testTimeout0 transport = do
341+ serverAddr <- newEmptyMVar
342+ clientDone <- newEmptyMVar
343+ messagesSent <- newEmptyMVar
344+
345+ forkIO $ do
346+ localNode <- newLocalNode transport initRemoteTable
347+ addr <- forkProcess localNode $ do
348+ liftIO $ readMVar messagesSent >> threadDelay 1000000
349+ -- Variation on the venerable ping server which uses a zero timeout
350+ -- Since we wait for all messages to be sent before doing this receive,
351+ -- we should nevertheless find the right message immediately
352+ Just partner <- receiveTimeout 0 [match (\(Pong partner) -> return partner)]
353+ self <- getSelfPid
354+ send partner (Ping self)
355+ putMVar serverAddr addr
356+
357+ forkIO $ do
358+ localNode <- newLocalNode transport initRemoteTable
359+ server <- readMVar serverAddr
360+ runProcess localNode $ do
361+ pid <- getSelfPid
362+ -- Send a bunch of messages. A large number of messages that the server
363+ -- is not interested in, and then a single message that it wants
364+ replicateM_ 10000 $ send server "Irrelevant message"
365+ send server (Pong pid)
366+ liftIO $ putMVar messagesSent ()
367+ Ping _ <- expect
368+ liftIO $ putMVar clientDone ()
369+
370+ takeMVar clientDone
306
371
307main :: IO ()
372main :: IO ()
308main = do
373main = do
309 Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
374 Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
310 runTests
375 runTests
311− [ ("Ping", testPing transport)
376+ [ ("Ping", testPing transport)
312− , ("Math", testMath transport)
377+ , ("Math", testMath transport)
313− , ("Timeout", testTimeout transport)
378+ , ("Timeout", testTimeout transport)
379+ , ("Timeout0", testTimeout0 transport)
380+ , ("SendToTerminated", testSendToTerminated transport)
314 -- The "missing" combinations in the list below don't make much sense, as
381 -- The "missing" combinations in the list below don't make much sense, as
315 -- we cannot guarantee that the monitor reply or link exception will not
382 -- we cannot guarantee that the monitor reply or link exception will not
316 -- happen before the unmonitor or unlink
383 -- happen before the unmonitor or unlink