@@ -37,9 +37,11 @@ import Control.Distributed.Process.Internal.Types
3737 , createUnencodedMessage
3838 )
3939import Control.Distributed.Process.Node
40+import Control.Distributed.Process.Debug
41+import Control.Distributed.Process.Management.Internal.Types
4042import Control.Distributed.Process.Serializable (Serializable)
4143
42−import Test.HUnit (Assertion, assertFailure)
44+import Test.HUnit (Assertion, assertFailure, assertBool)
4345import Test.Framework (Test, testGroup)
4446import Test.Framework.Providers.HUnit (testCase)
4547import Control.Rematch hiding (match)
@@ -1369,6 +1371,113 @@ testExitRemote TestTransport{..} = do
13691371 takeMVar supervisedDone
13701372 takeMVar supervisorDone
13711373
1374+testRegistryMonitoring :: TestTransport -> Assertion
1375+testRegistryMonitoring TestTransport{..} = do
1376+ localNode <- newLocalNode testTransport initRemoteTable
1377+ remoteNode <- newLocalNode testTransport initRemoteTable
1378+ return ()
1379+
1380+ -- Local process. Test if local process will be removed from
1381+ -- registry when it dies.
1382+ box <- newEmptyMVar
1383+ runProcess localNode $ do
1384+ pid <- spawnLocal $ do
1385+ expect
1386+ register "test" pid
1387+ tpid <- whereis "test"
1388+ if tpid == Just pid
1389+ then do _ <- monitor pid
1390+ send pid ()
1391+ ProcessMonitorNotification{} <- expect
1392+ tpid1 <- whereis "test"
1393+ liftIO $ putMVar box (Nothing == tpid1)
1394+ else liftIO $ putMVar box False
1395+
1396+ takeMVar box >>= assertBool "expected local process to not be registered"
1397+ return ()
1398+
1399+ -- Remote process. Test if remote process entry is removed
1400+ -- from registry when process dies.
1401+ remote1 <- testRemote remoteNode
1402+ runProcess localNode $
1403+ let waitpoll = do
1404+ w <- whereis "test" :: Process (Maybe ProcessId)
1405+ forM_ w (const waitpoll)
1406+ in do register "test" remote1
1407+ send remote1 ()
1408+ waitpoll
1409+ return ()
1410+ return ()
1411+
1412+ -- Many labels. Test if all labels associated with process
1413+ -- are removed from registry when it dies.
1414+ remote2 <- testRemote remoteNode
1415+ runProcess localNode $
1416+ let waitpoll = do
1417+ w1 <- whereis "test-3" :: Process (Maybe ProcessId)
1418+ w2 <- whereis "test-4" :: Process (Maybe ProcessId)
1419+ forM_ (w1 <|> w2) (const waitpoll)
1420+ in do register "test-3" remote2
1421+ register "test-4" remote2
1422+ send remote2 ()
1423+ waitpoll
1424+ return ()
1425+
1426+{- XXX: waiting including patch for nsend for remote process
1427+ remote3 <- testRemote remoteNode
1428+ remote4 <- testRemote remoteNode
1429+ -- test many labels
1430+ runProcess localNode $ do
1431+ register "test-3" remote3
1432+ reregister "test-3" remote4
1433+ send remote3 ()
1434+ liftIO $ threadDelay 50000 -- XXX: racy
1435+ monitor remote4
1436+ nsend "test-3" ()
1437+ ProcessMonitorNotification{} <- expect
1438+ return ()
1439+-}
1440+
1441+ -- Test registerRemoteAsync properties. Add a local process to
1442+ -- remote registry and checks that it is removed
1443+ -- when the process dies.
1444+ remote5 <- testRemote remoteNode
1445+ runProcess localNode $ do
1446+ registerRemoteAsync (localNodeId remoteNode) "test" remote5
1447+ receiveWait [
1448+ match (\(RegisterReply _ True _) -> return ())
1449+ ] >>= send remote5
1450+ let waitpoll = do
1451+ whereisRemoteAsync (localNodeId remoteNode) "test"
1452+ receiveWait [
1453+ match (\(WhereIsReply _ mr) -> forM_ mr (const waitpoll))
1454+ ]
1455+ waitpoll
1456+
1457+ -- Add remote process to remote registry and checks if
1458+ -- entry is removed then process is dead.
1459+ remote6 <- testRemote localNode
1460+ runProcess localNode $ do
1461+ registerRemoteAsync (localNodeId remoteNode) "test" remote6
1462+ receiveWait [
1463+ match (\(RegisterReply _ True _) -> return ())
1464+ ] >>= send remote6
1465+ let waitpoll = do
1466+ whereisRemoteAsync (localNodeId remoteNode) "test"
1467+ receiveWait [
1468+ match (\(WhereIsReply _ mr) -> forM_ mr (const waitpoll))
1469+ ]
1470+ waitpoll
1471+ where
1472+ testRemote node = do
1473+ -- test many labels
1474+ pidBox <- newEmptyMVar
1475+ forkProcess node $ do
1476+ us <- getSelfPid
1477+ liftIO $ putMVar pidBox us
1478+ expect :: Process ()
1479+ takeMVar pidBox
1480+
13721481testUnsafeSend :: TestTransport -> Assertion
13731482testUnsafeSend TestTransport{..} = do
13741483 serverAddr <- newEmptyMVar
@@ -1579,6 +1688,7 @@ tests testtrans = return [
15791688 , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans)
15801689 , testCase "ExitLocal" (testExitLocal testtrans)
15811690 , testCase "ExitRemote" (testExitRemote testtrans)
1691+ , testCase "TestRegistryMonitor" (testRegistryMonitoring testtrans)
15821692 , testCase "TextCallLocal" (testCallLocal testtrans)
15831693 -- Unsafe Primitives
15841694 , testCase "TestUnsafeSend" (testUnsafeSend testtrans)