@@ -1481,113 +1481,66 @@ testExitRemote TestTransport{..} = do
1482testRegistryMonitoring :: TestTransport -> Assertion
1482testRegistryMonitoring :: TestTransport -> Assertion
1483testRegistryMonitoring TestTransport{..} = do
1483testRegistryMonitoring TestTransport{..} = do
1484− localNode <- newLocalNode testTransport initRemoteTable
1484+ node1 <- newLocalNode testTransport initRemoteTable
1485− remoteNode <- newLocalNode testTransport initRemoteTable
1485+ node2 <- newLocalNode testTransport initRemoteTable
1486− return ()
1486+ waitH <- newEmptyMVar
1488− -- Local process. Test if local process will be removed from
1488+ let nid = localNodeId node2
1489− -- registry when it dies.
1489+ pid <- forkProcess node1 $ do
1490− box <- newEmptyMVar
1490+ getSelfPid >>= runUntilRegistered nid
1491− runProcess localNode $ do
1491+ liftIO $ takeMVar waitH
1492− pid <- spawnLocal $ do
1494− register "test" pid
1495− tpid <- whereis "test"
1496− if tpid == Just pid
1497− then do _ <- monitor pid
1499− ProcessMonitorNotification{} <- expect
1500− tpid1 <- whereis "test"
1501− liftIO $ putMVar box (Nothing == tpid1)
1502− else liftIO $ putMVar box False
1504− takeMVar box >>= assertBool "expected local process to not be registered"
1507− -- Remote process. Test if remote process entry is removed
1508− -- from registry when process dies.
1509− remote1 <- testRemote remoteNode
1510− runProcess localNode $
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))
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 $
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
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
1545− liftIO $ threadDelay 50000 -- XXX: racy
1548− ProcessMonitorNotification{} <- expect
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
1559− match (\(RegisterReply _ True _) -> return ())
1562− whereisRemoteAsync (localNodeId remoteNode) "test"
1564− match (\(WhereIsReply _ mr) -> forM_ mr (const waitpoll))
1568− -- Add remote process to remote registry and checks if
1493+ runProcess node2 $ do
1569− -- entry is removed then process is dead.
1494+ register regName pid
1570− remote6 <- testRemote localNode
1495+ res <- whereis regName
1571− runProcess localNode $ do
1496+ us <- getSelfPid
1572− registerRemoteAsync (localNodeId remoteNode) "test" remote6
1497+ liftIO $ do
1573− receiveWait [
1498+ putMVar waitH ()
1574− match (\(RegisterReply _ True _) -> return ())
1499+ assertBool "expected (Just pid)" $ res == (Just pid)
1575− ] >>= send remote6
1500+
1576− let waitpoll = do
1501+ -- This delay isn't essential!
1577− whereisRemoteAsync (localNodeId remoteNode) "test"
1502+ -- The test case passes perfectly fine without it (feel free to comment out
1578− receiveWait [
1503+ -- and see), however waiting a few seconds here, makes it much more likely
1579− match (\(WhereIsReply _ mr) -> forM_ mr (const waitpoll))
1504+ -- that in delayUntilMaybeUnregistered we will hit the match case right
1580− ]
1505+ -- away, and thus not be subjected to a 20 second delay. The value of 4
1581− waitpoll
1506+ -- seconds appears to work optimally on osx and across several linux distros
1507+ -- running in virtual machines (which is essentially what we do in CI)
1508+ receiveTimeout 4000000 [ matchAny return ]
1511+ -- This delay doesn't serve much purpose in the happy path, however if some
1512+ -- future patch breaks the cooperative behaviour of node controllers viz
1513+ -- remote process registration and notification taking place via ncEffectDied,
1514+ -- there would be the possibility of a race in the test case should we attempt
1515+ -- to evaluate `whereis regName` on node2 right away. In case the name is still
1516+ -- erroneously registered, observing the 20 second delay (or lack of), could at
1517+ -- least give a hint that something is wrong, and we give up our time slice
1518+ -- so that there's a higher change the registrations have been cleaned up
1520+ runProcess node2 $ delayUntilMaybeUnregistered nid pid
1522+ regHere <- newEmptyMVar
1523+ runProcess node2 $ whereis regName >>= liftIO . putMVar regHere
1524+ res <- takeMVar regHere
1525+ assertBool "expected Nothing, but process still registered" (res == Nothing)
1583− testRemote node = do
1528+ runUntilRegistered nid us = do
1584− -- test many labels
1529+ whereisRemoteAsync nid regName
1585− pidBox <- newEmptyMVar
1530+ receiveWait [
1586− forkProcess node $ do
1531+ matchIf (\(WhereIsReply n (Just p)) -> n == regName && p == us)
1587− us <- getSelfPid
1532+ (const $ return ())
1588− liftIO $ putMVar pidBox us
1533+ ]
1589− expect :: Process ()
1534+
1590− takeMVar pidBox
1535+ delayUntilMaybeUnregistered nid p = do
1536+ whereisRemoteAsync nid regName
1537+ receiveTimeout 20000000 {- 20 sec delay -} [
1538+ matchIf (\(WhereIsReply n p) -> n == regName && p == Nothing)
1539+ (const $ return ())
1543+ regName = "testRegisterRemote"
1592testUnsafeSend :: TestTransport -> Assertion
1545testUnsafeSend :: TestTransport -> Assertion
1593testUnsafeSend TestTransport{..} = do
1546testUnsafeSend TestTransport{..} = do
@@ -1790,7 +1743,7 @@ tests testtrans = return [
1790 , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)
1743 , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)
1791 , testCase "ExitLocal" (testExitLocal testtrans)
1744 , testCase "ExitLocal" (testExitLocal testtrans)
1792 , testCase "ExitRemote" (testExitRemote testtrans)
1745 , testCase "ExitRemote" (testExitRemote testtrans)
1793− , testCase "TestRegistryMonitor" (testRegistryMonitoring testtrans)
1746+ , testCase "RegistryMonitoring" (testRegistryMonitoring testtrans)
1794 , testCase "TextCallLocal" (testCallLocal testtrans)
1747 , testCase "TextCallLocal" (testCallLocal testtrans)
1795 -- Unsafe Primitives
1748 -- Unsafe Primitives
1796 , testCase "TestUnsafeSend" (testUnsafeSend testtrans)
1749 , testCase "TestUnsafeSend" (testUnsafeSend testtrans)