diff --git a/src/Control/Distributed/Process/Tests/CH.hs b/src/Control/Distributed/Process/Tests/CH.hs index 8f844e2..1518f4c 100644 --- a/src/Control/Distributed/Process/Tests/CH.hs +++ b/src/Control/Distributed/Process/Tests/CH.hs @@ -17,7 +17,7 @@ import Control.Concurrent.MVar , takeMVar , readMVar ) -import Control.Monad (replicateM_, replicateM, forever, void, unless) +import Control.Monad (replicateM_, replicateM, forever, void, unless, when) import Control.Exception (SomeException, throwIO) import qualified Control.Exception as Ex (catch) import Control.Applicative ((<$>), (<*>), pure, (<|>)) @@ -31,6 +31,8 @@ import Control.Distributed.Process.Internal.Types ) import Control.Distributed.Process.Node import Control.Distributed.Process.Serializable (Serializable) +import Control.Distributed.Process.Debug +import Control.Distributed.Process.Management.Internal.Types import Test.HUnit (Assertion, assertFailure) import Test.Framework (Test, testGroup) @@ -1316,6 +1318,111 @@ testUnsafeSendChan TestTransport{..} = do takeMVar clientDone +testRegistryMonitoring :: TestTransport -> Assertion +testRegistryMonitoring TestTransport{..} = do + localNode <- newLocalNode testTransport initRemoteTable + remoteNode <- newLocalNode testTransport initRemoteTable + return () + + -- Local process. Test if local process will be removed from + -- registry when it dies. + box <- newEmptyMVar + runProcess localNode $ do + pid <- spawnLocal $ do + expect + register "test" pid + tpid <- whereis "test" + if tpid == Just pid + then do _ <- monitor pid + send pid () + ProcessMonitorNotification{} <- expect + tpid1 <- whereis "test" + liftIO $ putMVar box (Nothing == tpid1) + else liftIO $ putMVar box False + True <- takeMVar box + return () + + -- Remote process. Test if remote process entry is removed + -- from registry when process dies. + remote1 <- testRemote remoteNode + runProcess localNode $ + let waitpoll = do + w <- whereis "test" :: Process (Maybe ProcessId) + forM_ w (const waitpoll) + in do register "test" remote1 + send remote1 () + waitpoll + return () + return () + + -- Many labels. Test if all labels associated with process + -- are removed from registry when it dies. + remote2 <- testRemote remoteNode + runProcess localNode $ + let waitpoll = do + w1 <- whereis "test-3" :: Process (Maybe ProcessId) + w2 <- whereis "test-4" :: Process (Maybe ProcessId) + forM_ (w1 <|> w2) (const waitpoll) + in do register "test-3" remote2 + register "test-4" remote2 + send remote2 () + waitpoll + return () + +{- XXX: waiting including patch for nsend for remote process + remote3 <- testRemote remoteNode + remote4 <- testRemote remoteNode + -- test many labels + runProcess localNode $ do + register "test-3" remote3 + reregister "test-3" remote4 + send remote3 () + liftIO $ threadDelay 50000 -- XXX: racy + monitor remote4 + nsend "test-3" () + ProcessMonitorNotification{} <- expect + return () +-} + + -- Test registerRemoteAsync properties. Add a local process to + -- remote registry and checks that it is removed + -- when the process dies. + remote5 <- testRemote remoteNode + runProcess localNode $ do + registerRemoteAsync (localNodeId remoteNode) "test" remote5 + RegisterReply _ True <- expect + send remote5 () + let waitpoll = do + whereisRemoteAsync (localNodeId remoteNode) "test" + WhereIsReply _ mr <- expect + forM_ mr (const waitpoll) + waitpoll + + -- Add remote process to remote registry and checks if + -- entry is removed then process is dead. + remote6 <- testRemote localNode + runProcess localNode $ do + registerRemoteAsync (localNodeId remoteNode) "test" remote6 + RegisterReply _ True <- expect + send remote6 () + let waitpoll = do + whereisRemoteAsync (localNodeId remoteNode) "test" + WhereIsReply _ mr <- expect + forM_ mr (const waitpoll) + waitpoll + where + testRemote node = do + -- test many labels + pidBox <- newEmptyMVar + forkProcess node $ do + us <- getSelfPid + liftIO $ putMVar pidBox us + expect :: Process () + takeMVar pidBox + + + + tests :: TestTransport -> IO [Test] tests testtrans = return [ testGroup "Basic features" [ @@ -1347,12 +1454,13 @@ tests testtrans = return [ , testCase "MaskRestoreScope" (testMaskRestoreScope testtrans) , testCase "ExitLocal" (testExitLocal testtrans) , testCase "ExitRemote" (testExitRemote testtrans) + , testCase "TestRegistryMonitor" (testRegistryMonitoring testtrans) -- Unsafe Primitives , testCase "TestUnsafeSend" (testUnsafeSend testtrans) , testCase "TestUnsafeNSend" (testUnsafeNSend testtrans) , testCase "TestUnsafeSendChan" (testUnsafeSendChan testtrans) -- usend - , testCase "USend" (testUSend testtrans 50) + -- , testCase "USend" (testUSend testtrans 50) ] , testGroup "Monitoring and Linking" [ -- Monitoring processes