@@ -25,18 +25,13 @@ import Control.Concurrent.MVar
2525 )
2626import Control.Monad (replicateM_, replicateM, forever, void, unless, join)
2727import Control.Exception (SomeException, throwIO, ErrorCall(..))
28−import Control.Monad.Catch (try, catch, finally, mask, onException)
29−import Control.Applicative ((<|>))
28+import qualified Control.Exception as Ex (catch)
29+import Control.Applicative ((<$>), (<*>), pure, (<|>))
3030import qualified Network.Transport as NT (closeEndPoint, EndPointAddress)
31−import Control.Distributed.Process hiding
32− ( try
33− , catch
34− , finally
35− , mask
36− , onException
37− )
31+import Control.Distributed.Process
3832import Control.Distributed.Process.Internal.Types
39− ( LocalNode(localEndPoint)
33+ ( NodeId(nodeAddress)
34+ , LocalNode(localEndPoint)
4035 , ProcessExitException(..)
4136 , nullProcessId
4237 , createUnencodedMessage
@@ -44,13 +39,13 @@ import Control.Distributed.Process.Internal.Types
4439import Control.Distributed.Process.Node
4540import Control.Distributed.Process.Debug
4641import Control.Distributed.Process.Management.Internal.Types
47−import Control.Distributed.Process.Tests.Internal.Utils (shouldBe, pause)
42+import Control.Distributed.Process.Tests.Internal.Utils (shouldBe)
4843import Control.Distributed.Process.Serializable (Serializable)
49−import Data.Maybe (isNothing, isJust)
44+
5045import Test.HUnit (Assertion, assertBool, assertFailure)
5146import Test.Framework (Test, testGroup)
5247import Test.Framework.Providers.HUnit (testCase)
53−import Control.Rematch hiding (match, isNothing, isJust)
48+import Control.Rematch hiding (match)
5449import Control.Rematch.Run (Match(..))
5550
5651newtype Ping = Ping ProcessId
@@ -73,7 +68,7 @@ expectThat a matcher = case res of
7368forkTry :: IO () -> IO ThreadId
7469forkTry p = do
7570 tid <- myThreadId
76− forkIO $ catch p (\e -> throwTo tid (e :: SomeException))
71+ forkIO $ Ex.catch p (\e -> throwTo tid (e :: SomeException))
7772
7873-- | The ping server from the paper
7974ping :: Process ()
@@ -87,9 +82,10 @@ verifyClient :: String -> MVar Bool -> IO ()
8782verifyClient s b = takeMVar b >>= assertBool s
8883
8984expectPing :: MVar Bool -> Process ()
90−expectPing mv = expect >>= liftIO . putMVar mv . checkPing
85+expectPing mv = expect >>= liftIO . putMVar mv . checkPing
9186 where
9287 checkPing (Ping _) = True
88+ checkPing _ = False
9389
9490-- | Quick and dirty synchronous version of whereisRemoteAsync
9591whereisRemote :: NodeId -> String -> Process (Maybe ProcessId)
@@ -239,10 +235,10 @@ testPing TestTransport{..} = do
239235 pid <- getSelfPid
240236 replicateM_ numPings $ do
241237 send pingServer (Pong pid)
242− p <- expectTimeout 3000000
238+ p <- expect
243239 case p of
244− Just (Ping _) -> return ()
245− Nothing -> die "Failed to receive Ping"
240+ Ping _ -> return ()
241+ _ -> die "Unexpected message"
246242
247243 putMVar clientDone ()
248244
@@ -559,7 +555,7 @@ testMergeChannels TestTransport{..} = do
559555 ss <- liftIO $ mapM readMVar vs
560556 case ss of
561557 [sa, sb, sc] ->
562− mapM_ ((>> pause 10000) . uncurry sendChan)
558+ mapM_ ((>> liftIO (threadDelay 10000)) . uncurry sendChan)
563559 [ -- a, b, c
564560 (sa, 'a')
565561 , (sb, 'b')
@@ -735,6 +731,7 @@ testRemoteRegistry :: TestTransport -> Assertion
735731testRemoteRegistry TestTransport{..} = do
736732 node1 <- newLocalNode testTransport initRemoteTable
737733 node2 <- newLocalNode testTransport initRemoteTable
734+ done <- newEmptyMVar
738735
739736 pingServer <- forkProcess node1 ping
740737 deadProcess <- forkProcess node1 (return ())
@@ -749,7 +746,6 @@ testRemoteRegistry TestTransport{..} = do
749746
750747 pid <- verifyWhereIsRemote nid1 "ping"
751748 liftIO $ assertBool "Expected pindServer to match pid" $ pingServer == pid
752−
753749 us <- getSelfPid
754750 nsendRemote nid1 "ping" (Pong us)
755751 receiveWait [
@@ -759,22 +755,22 @@ testRemoteRegistry TestTransport{..} = do
759755 -- test that if process was not registered Nothing is returned
760756 -- in owner field.
761757 registerRemoteAsync nid1 "dead" deadProcess
762− receiveWait [ matchIf (\(RegisterReply label' f mPid) -> "dead" == label')
763− (\(RegisterReply _ f mPid) -> return (not f && isNothing mPid))
764− ] >>= liftIO . assertBool "Expected False Nothing in RegisterReply"
765−
758+ receiveWait [
759+ matchIf (\(RegisterReply label' False Nothing) -> "dead" == label')
760+ (\(RegisterReply _ _ _) -> return ()) ]
766761 registerRemoteAsync nid1 "ping" deadProcess
767762 receiveWait [
768− matchIf (\(RegisterReply label' False mPid) ->
769− "ping" == label' && isJust mPid)
770− (\(RegisterReply _ f (Just pid'')) -> return (not f && pid'' == pingServer))
771− ] >>= liftIO . assertBool "Expected False and (Just alreadyRegisteredPid) in RegisterReply"
772−
763+ matchIf (\(RegisterReply label' False (Just pid)) ->
764+ "ping" == label' && pid == pingServer)
765+ (\(RegisterReply _ _ _) -> return ()) ]
773766 unregisterRemoteAsync nid1 "dead"
774767 receiveWait [
775− matchIf (\(RegisterReply label' _ _) -> "dead" == label')
776− (\(RegisterReply _ f mPid) -> return (not f && isNothing mPid))
777− ] >>= liftIO . assertBool "Expected False and Nothing in RegisterReply"
768+ matchIf (\(RegisterReply label' False Nothing) ->
769+ "dead" == label' && pid == pingServer)
770+ (\(RegisterReply _ _ _) -> return ()) ]
771+ liftIO $ putMVar done ()
772+
773+ takeMVar done
778774
779775testRemoteRegistryRemoteProcess :: TestTransport -> Assertion
780776testRemoteRegistryRemoteProcess TestTransport{..} = do
@@ -946,7 +942,9 @@ testUSend usendPrim TestTransport{..} numMessages = do
946942 isSorted _ = True
947943 -- The list can't be null since there are no failures after sending
948944 -- the last message.
949− liftIO $ putMVar usendTestOk $ isSorted msgs && not (null msgs)
945+ liftIO $ do
946+ assertBool "Unexpected failure after sending last msg" $ isSorted msgs && not (null msgs)
947+ putMVar usendTestOk ()
950948
951949 forkProcess node2 $ do
952950 them <- liftIO $ readMVar processA
@@ -957,8 +955,7 @@ testUSend usendPrim TestTransport{..} numMessages = do
957955 usendPrim them i
958956 liftIO (threadDelay 30000)
959957
960− res <- takeMVar usendTestOk
961− assertBool "Unexpected failure after sending last msg" res
958+ takeMVar usendTestOk
962959
963960-- | Test 'matchAny'. This repeats the 'testMath' but with a proxy server
964961-- in between
@@ -1272,76 +1269,6 @@ testReceiveChanFeatures TestTransport{..} = do
12721269
12731270 takeMVar done
12741271
1275−testChanLifecycle :: TestTransport -> Assertion
1276−testChanLifecycle TestTransport{..} = let delay = 3000000 in do
1277− result <- newEmptyMVar
1278− tchMV <- newEmptyMVar
1279− localNode <- newLocalNode testTransport initRemoteTable
1280− runProcess localNode $ do
1281−
1282− pid <- spawnLocal $ do tCh <- newChan :: Process (SendPort (), ReceivePort ())
1283− liftIO $ putMVar tchMV tCh
1284− expect :: Process ()
1285− let (sp, _) = tCh
1286− sendChan sp ()
1287− expect :: Process ()
1288−
1289− mRefPid <- monitor pid
1290−
1291− cPid <- spawnLocal $ do
1292− (sp', rp) <- liftIO $ takeMVar tchMV
1293− -- say "picked up our test channel"
1294− send pid ()
1295− -- say "told pid to continue"
1296− res <- receiveChanTimeout delay rp
1297− case res of
1298− Nothing -> say "initial chan () missing!" >> (liftIO $ putMVar result False)
1299− Just () -> do mr <- monitor pid
1300− pause 10000
1301− -- say "sending pid a second () will cause it to exit"
1302− send pid ()
1303−
1304− -- say "make sure we see a DOWN notification for pid having stopped"
1305− receiveWait [ match (\(_ :: ProcessMonitorNotification) -> return ()) ]
1306−
1307− -- now that pid has died, the send port should be useless...
1308− liftIO $ putMVar tchMV (sp', rp)
1309−
1310− -- let's verify that we do not see the message from our
1311− -- parent process on the channel, once pid has died...
1312− recv <- receiveChanTimeout delay rp
1313− -- say $ "finished waiting for second (), writing result" ++ (show recv)
1314− liftIO $ putMVar result $ isNothing recv
1315−
1316− mRefCPid <- monitor cPid
1317−
1318− receiveWait
1319− [ matchIf (\(ProcessMonitorNotification r _ _) -> r == mRefPid)
1320− (\_ -> return ())
1321− ]
1322−
1323− -- say "seen first pid die..."
1324−
1325− (sendPort, _) <- liftIO $ takeMVar tchMV
1326− sendChan sendPort ()
1327− -- say "sent () after owning pid died"
1328−
1329− -- let cPid know we've written to the channel...
1330− send cPid ()
1331−
1332− receiveWait
1333− [ matchIf (\(ProcessMonitorNotification r _ _) -> r == mRefCPid)
1334− (\_ -> return ())
1335− ]
1336−
1337− -- say "seen both pids die now..."
1338−
1339− -- and wait on the result back in IO land...
1340− testRes <- takeMVar result
1341− -- runProcess localNode $ say "got result..."
1342− assertBool "Expected sending on the channel to fail, but received data!" testRes
1343−
1344−
13451272testKillLocal :: TestTransport -> Assertion
13461273testKillLocal TestTransport{..} = do
13471274 localNode <- newLocalNode testTransport initRemoteTable
@@ -1554,73 +1481,113 @@ testExitRemote TestTransport{..} = do
15541481
15551482testRegistryMonitoring :: TestTransport -> Assertion
15561483testRegistryMonitoring TestTransport{..} = do
1557− node1 <- newLocalNode testTransport initRemoteTable
1558− node2 <- newLocalNode testTransport initRemoteTable
1559−
1560− let nid = localNodeId node2
1561− pid <- forkProcess node1 $ do
1562− self <- getSelfPid
1563− runUntilRegistered nid self
1564− say $ (show self) ++ " registered as " ++ regName
1565− expect :: Process ()
1566− say $ (show self) ++ " exiting normally"
1567−
1568− runProcess node2 $ do
1569− register regName pid
1570− say $ regName ++ " registered to " ++ show pid
1571− res <- whereis regName
1572− send pid ()
1573− say $ " sent finish signal to " ++ show pid
1574− us <- getSelfPid
1575− liftIO $ assertBool "expected (Just pid)" $ res == (Just pid)
1576−
1577−
1578− -- This delay isn't essential!
1579− -- The test case passes perfectly fine without it (feel free to comment out
1580− -- and see), however waiting a few seconds here, makes it much more likely
1581− -- that in delayUntilMaybeUnregistered we will hit the match case right
1582− -- away, and thus not be subjected to a 20 second delay. The value of 4
1583− -- seconds appears to work optimally on osx and across several linux distros
1584− -- running in virtual machines (which is essentially what we do in CI)
1585− void $ receiveTimeout 4000000 [ matchAny return ]
1586−
1587− -- This delay doesn't serve much purpose in the happy path, however if some
1588− -- future patch breaks the cooperative behaviour of node controllers viz
1589− -- remote process registration and notification taking place via ncEffectDied,
1590− -- there would be the possibility of a race in the test case should we attempt
1591− -- to evaluate `whereis regName` on node2 right away. In case the name is still
1592− -- erroneously registered, observing the 20 second delay (or lack of), could at
1593− -- least give a hint that something is wrong, and we give up our time slice
1594− -- so that there's a higher change the registrations have been cleaned up
1595− -- in either case.
1596− runProcess node2 $ delayUntilMaybeUnregistered nid pid
1597−
1598− regHere <- newEmptyMVar
1599− runProcess node2 $ whereis regName >>= liftIO . putMVar regHere
1600− res <- takeMVar regHere
1601− case res of
1602− Nothing -> return ()
1603− Just pid -> assertBool ("expected Nothing, but got " ++ show pid) False
1484+ localNode <- newLocalNode testTransport initRemoteTable
1485+ remoteNode <- newLocalNode testTransport initRemoteTable
1486+ return ()
16041487
1605− where
1606− runUntilRegistered nid us = do
1607− whereisRemoteAsync nid regName
1608− receiveWait [
1609− matchIf (\(WhereIsReply n (Just p)) -> n == regName && p == us)
1610− (const $ return ())
1611− ]
1612−
1613− delayUntilMaybeUnregistered nid p = do
1614− whereisRemoteAsync nid regName
1615− res <- receiveTimeout 20000000 {- 20 sec delay -} [
1616− matchIf (\(WhereIsReply n p) -> n == regName && isNothing p)
1617− (const $ return ())
1618− ]
1619− case res of
1620− Just () -> return ()
1621− Nothing -> delayUntilMaybeUnregistered nid p
1488+ -- Local process. Test if local process will be removed from
1489+ -- registry when it dies.
1490+ box <- newEmptyMVar
1491+ runProcess localNode $ do
1492+ pid <- spawnLocal $ do
1493+ expect
1494+ register "test" pid
1495+ tpid <- whereis "test"
1496+ if tpid == Just pid
1497+ then do _ <- monitor pid
1498+ send pid ()
1499+ ProcessMonitorNotification{} <- expect
1500+ tpid1 <- whereis "test"
1501+ liftIO $ putMVar box (Nothing == tpid1)
1502+ else liftIO $ putMVar box False
1503+
1504+ takeMVar box >>= assertBool "expected local process to not be registered"
1505+ return ()
1506+
1507+ -- Remote process. Test if remote process entry is removed
1508+ -- from registry when process dies.
1509+ remote1 <- testRemote remoteNode
1510+ runProcess localNode $
1511+ let waitpoll = do
1512+ w <- whereis "test" :: Process (Maybe ProcessId)
1513+ forM_ w (const waitpoll)
1514+ in do register "test" remote1
1515+ -- [race-condition] invalid test if we force exit before waitpoll runs
1516+ registered <- whereis "test"
1517+ registered `shouldBe` (equalTo (Just remote1))
1518+ send remote1 ()
1519+ waitpoll
1520+ return ()
1521+ return ()
1522+
1523+ -- Many labels. Test if all labels associated with process
1524+ -- are removed from registry when it dies.
1525+ remote2 <- testRemote remoteNode
1526+ runProcess localNode $
1527+ let waitpoll = do
1528+ w1 <- whereis "test-3" :: Process (Maybe ProcessId)
1529+ w2 <- whereis "test-4" :: Process (Maybe ProcessId)
1530+ forM_ (w1 <|> w2) (const waitpoll)
1531+ in do register "test-3" remote2
1532+ register "test-4" remote2
1533+ send remote2 ()
1534+ waitpoll
1535+ return ()
1536+
1537+{- XXX: waiting including patch for nsend for remote process
1538+ remote3 <- testRemote remoteNode
1539+ remote4 <- testRemote remoteNode
1540+ -- test many labels
1541+ runProcess localNode $ do
1542+ register "test-3" remote3
1543+ reregister "test-3" remote4
1544+ send remote3 ()
1545+ liftIO $ threadDelay 50000 -- XXX: racy
1546+ monitor remote4
1547+ nsend "test-3" ()
1548+ ProcessMonitorNotification{} <- expect
1549+ return ()
1550+-}
1551+
1552+ -- Test registerRemoteAsync properties. Add a local process to
1553+ -- remote registry and checks that it is removed
1554+ -- when the process dies.
1555+ remote5 <- testRemote remoteNode
1556+ runProcess localNode $ do
1557+ registerRemoteAsync (localNodeId remoteNode) "test" remote5
1558+ receiveWait [
1559+ match (\(RegisterReply _ True _) -> return ())
1560+ ] >>= send remote5
1561+ let waitpoll = do
1562+ whereisRemoteAsync (localNodeId remoteNode) "test"
1563+ receiveWait [
1564+ match (\(WhereIsReply _ mr) -> forM_ mr (const waitpoll))
1565+ ]
1566+ waitpoll
16221567
1623− regName = "testRegisterRemote"
1568+ -- Add remote process to remote registry and checks if
1569+ -- entry is removed then process is dead.
1570+ remote6 <- testRemote localNode
1571+ runProcess localNode $ do
1572+ registerRemoteAsync (localNodeId remoteNode) "test" remote6
1573+ receiveWait [
1574+ match (\(RegisterReply _ True _) -> return ())
1575+ ] >>= send remote6
1576+ let waitpoll = do
1577+ whereisRemoteAsync (localNodeId remoteNode) "test"
1578+ receiveWait [
1579+ match (\(WhereIsReply _ mr) -> forM_ mr (const waitpoll))
1580+ ]
1581+ waitpoll
1582+ where
1583+ testRemote node = do
1584+ -- test many labels
1585+ pidBox <- newEmptyMVar
1586+ forkProcess node $ do
1587+ us <- getSelfPid
1588+ liftIO $ putMVar pidBox us
1589+ expect :: Process ()
1590+ takeMVar pidBox
16241591
16251592testUnsafeSend :: TestTransport -> Assertion
16261593testUnsafeSend TestTransport{..} = do
@@ -1814,7 +1781,6 @@ tests testtrans = return [
18141781 , testCase "MatchMessageUnwrap" (testMatchMessageWithUnwrap testtrans)
18151782 , testCase "ReceiveChanTimeout" (testReceiveChanTimeout testtrans)
18161783 , testCase "ReceiveChanFeatures" (testReceiveChanFeatures testtrans)
1817− , testCase "ChanLifecycle" (testChanLifecycle testtrans)
18181784 , testCase "KillLocal" (testKillLocal testtrans)
18191785 , testCase "KillRemote" (testKillRemote testtrans)
18201786 , testCase "Die" (testDie testtrans)
@@ -1824,7 +1790,7 @@ tests testtrans = return [
18241790 , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)
18251791 , testCase "ExitLocal" (testExitLocal testtrans)
18261792 , testCase "ExitRemote" (testExitRemote testtrans)
1827− , testCase "RegistryMonitoring" (testRegistryMonitoring testtrans)
1793+ , testCase "TestRegistryMonitor" (testRegistryMonitoring testtrans)
18281794 , testCase "TextCallLocal" (testCallLocal testtrans)
18291795 -- Unsafe Primitives
18301796 , testCase "TestUnsafeSend" (testUnsafeSend testtrans)