git.iko.soy/distributed-process
on master help sign in
attempt to stablise the tests a bit further
7cb5ca7Tim Watson
distributed-process-tests/src/Control/Distributed/Process/Tests/Internal/Utils.hs+3−1
compare with master
unifiedsplit
@@ -91,6 +91,7 @@ import Test.HUnit (Assertion, assertFailure)
91import Test.HUnit.Base (assertBool)
91import Test.HUnit.Base (assertBool)
92
92
93import GHC.Generics
93import GHC.Generics
94+import System.Timeout (timeout)
94
95
95-- | A mutable cell containing a test result.
96-- | A mutable cell containing a test result.
96type TestResult a = MVar a
97type TestResult a = MVar a
@@ -233,7 +234,8 @@ testProcessReport pid = do
233tryRunProcess :: LocalNode -> Process () -> IO ()
234tryRunProcess :: LocalNode -> Process () -> IO ()
234tryRunProcess node p = do
235tryRunProcess node p = do
235 tid <- liftIO myThreadId
236 tid <- liftIO myThreadId
237+ void $ timeout (1000000 * 60 * 5 :: Int) $
236− runProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException))
238+ runProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException))
237
239
238tryForkProcess :: LocalNode -> Process () -> IO ProcessId
240tryForkProcess :: LocalNode -> Process () -> IO ProcessId
239tryForkProcess node p = do
241tryForkProcess node p = do
distributed-process-tests/src/Control/Distributed/Process/Tests/Mx.hs+21−20
@@ -50,6 +50,7 @@ import Test.Framework
50 ( Test
50 ( Test
51 , testGroup
51 , testGroup
52 )
52 )
53+import Test.HUnit (Assertion)
53import Test.Framework.Providers.HUnit (testCase)
54import Test.Framework.Providers.HUnit (testCase)
54
55
55data Publish = Publish
56data Publish = Publish
@@ -329,9 +330,8 @@ ensure = flip finally
329
330
330testNSend :: (String -> () -> Process ())
331testNSend :: (String -> () -> Process ())
331 -> Maybe LocalNode
332 -> Maybe LocalNode
332− -> TestResult Bool
333 -> Process ()
333 -> Process ()
334−testNSend op n r = testMxSend n r $ \p1 sink -> do
334+testNSend op n = testMxSend n $ \p1 sink -> do
335 let delay = 5000000
335 let delay = 5000000
336 let label = "testMxSend"
336 let label = "testMxSend"
337 let isValid = isValidLabel n label
337 let isValid = isValidLabel n label
@@ -360,9 +360,8 @@ testNSend op n r = testMxSend n r $ \p1 sink -> do
360
360
361testSend :: (ProcessId -> () -> Process ())
361testSend :: (ProcessId -> () -> Process ())
362 -> Maybe LocalNode
362 -> Maybe LocalNode
363− -> TestResult Bool
364 -> Process ()
363 -> Process ()
365−testSend op n r = testMxSend n r $ \p1 sink -> do
364+testSend op n = testMxSend n $ \p1 sink -> do
366 -- initiate a send
365 -- initiate a send
367 op p1 ()
366 op p1 ()
368
367
@@ -376,9 +375,8 @@ testSend op n r = testMxSend n r $ \p1 sink -> do
376
375
377testChan :: (SendPort () -> () -> Process ())
376testChan :: (SendPort () -> () -> Process ())
378 -> Maybe LocalNode
377 -> Maybe LocalNode
379− -> TestResult Bool
380 -> Process ()
378 -> Process ()
381−testChan op n r = testMxSend n r $ \p1 sink -> do
379+testChan op n = testMxSend n $ \p1 sink -> do
382
380
383 us <- getSelfPid
381 us <- getSelfPid
384 send p1 us
382 send p1 us
@@ -404,8 +402,8 @@ testChan op n r = testMxSend n r $ \p1 sink -> do
404
402
405type SendTest = ProcessId -> ReceivePort MxEvent -> Process Bool
403type SendTest = ProcessId -> ReceivePort MxEvent -> Process Bool
406
404
407−testMxSend :: Maybe LocalNode -> TestResult Bool -> SendTest -> Process ()
405+testMxSend :: Maybe LocalNode -> SendTest -> Process ()
408−testMxSend mNode result test = do
406+testMxSend mNode test = do
409 us <- getSelfPid
407 us <- getSelfPid
410 (sp, rp) <- newChan
408 (sp, rp) <- newChan
411 (chan, sink) <- newChan
409 (chan, sink) <- newChan
@@ -431,12 +429,15 @@ testMxSend mNode result test = do
431
429
432 p1 <- receiveChan rp
430 p1 <- receiveChan rp
433 res <- try (test p1 sink)
431 res <- try (test p1 sink)
434− case res of
432+
435− Left (ProcessExitException _ m) -> (liftIO $ putStrLn $ "SomeException-" ++ show m) >> stash result False
436− Right tr -> stash result tr
437 kill agent "bye"
433 kill agent "bye"
438 kill p1 "bye"
434 kill p1 "bye"
439
435
436+ case res of
437+ Left (ProcessExitException _ m) -> (liftIO $ putStrLn $ "SomeException-" ++ show m) >> die m
438+ Right tr -> tr `shouldBe` equalTo True
439+
440+
440 where
441 where
441 label = "testMxSend"
442 label = "testMxSend"
442 agentLabel s = "mx-unsafe-check-agent-" ++ show s
443 agentLabel s = "mx-unsafe-check-agent-" ++ show s
@@ -452,7 +453,7 @@ testMxSend mNode result test = do
452 return r
453 return r
453
454
454tests :: TestTransport -> IO [Test]
455tests :: TestTransport -> IO [Test]
455−tests TestTransport{..} = do
456+tests tt@TestTransport{..} = do
456 node1 <- newLocalNode testTransport initRemoteTable
457 node1 <- newLocalNode testTransport initRemoteTable
457 node2 <- newLocalNode testTransport initRemoteTable
458 node2 <- newLocalNode testTransport initRemoteTable
458 return [
459 return [
@@ -489,12 +490,11 @@ tests TestTransport{..} = do
489 (delayedAssertion
490 (delayedAssertion
490 "expected process deaths to result in unregistration events"
491 "expected process deaths to result in unregistration events"
491 node1 () (testMxRegMon node2))
492 node1 () (testMxRegMon node2))
492− , testGroup "SendEvents" $ buildTestCases node1 node2
493+ , testGroup "SendEvents" $ buildTestCases tt node2
493 ]
494 ]
494 ]
495 ]
495 where
496 where
496− buildTestCases n1 n2 =
497− let nid = localNodeId n2 in build n2 [
497+ buildTestCases tt' n2 = let nid = localNodeId n2 in build tt' n2 [
498 ("NSend", [
498 ("NSend", [
499 ("nsend", testNSend nsend)
499 ("nsend", testNSend nsend)
500 , ("Unsafe.nsend", testNSend Unsafe.nsend)
500 , ("Unsafe.nsend", testNSend Unsafe.nsend)
@@ -515,14 +515,15 @@ tests TestTransport{..} = do
515 ])
515 ])
516 ]
516 ]
517
517
518+ build :: TestTransport
518− build :: LocalNode
519+ -> LocalNode
519− -> [(String, [(String, (Maybe LocalNode -> TestResult Bool -> Process ()))])]
520+ -> [(String, [(String, (Maybe LocalNode -> Process ()))])]
520 -> [Test]
521 -> [Test]
521− build ln specs =
522+ build TestTransport{..} ln specs =
522 [ testGroup (intercalate "-" [groupName, caseSuffix]) [
523 [ testGroup (intercalate "-" [groupName, caseSuffix]) [
523 testCase (intercalate "-" [caseName, caseSuffix])
524 testCase (intercalate "-" [caseName, caseSuffix])
524− (delayedAssertion "expected mx events failed"
525+ (newLocalNode testTransport initRemoteTable >>= \n ->
525− ln True (caseImpl caseNode))
526+ tryRunProcess n (caseImpl caseNode))
526 | (caseName, caseImpl) <- groupCases
527 | (caseName, caseImpl) <- groupCases
527 ]
528 ]
528 | (groupName, groupCases) <- specs
529 | (groupName, groupCases) <- specs