Publish MxUnregistered when a registered name dies

Author: hyperthunk

.travis.yml

@@ -6,11 +6,11 @@ matrix:
   include:
   - env: ARGS="--stack-yaml stack-ghc-7.10.3.yaml"
     addons: {apt: {packages: [libgmp-dev]}}
-
-  - env: ARGS="--stack-yaml stack-ghc-8.0.2.yaml"
+  - env: ARGS="--stack-yaml stack-ghc-8.2.2.yaml"
     addons: {apt: {packages: [libgmp-dev]}}
-
-  - env: ARGS=
+  - env: ARGS="--stack-yaml stack-ghc-8.4.4.yaml"
+    addons: {apt: {packages: [libgmp-dev]}}
+  - env: ARGS="--stack-yaml stack-nightly.yaml --resolver nightly"
     addons: {apt: {packages: [libgmp-dev]}}
 
 cache:
@@ -34,5 +34,10 @@ script:
 - stack ${ARGS} test $ARG='--plain -t "!Flaky"' ${TEST_PACKAGE}TestCHInTCP
 - stack ${ARGS} test $ARG='--plain -t "!SpawnReconnect"' ${TEST_PACKAGE}TestClosure
 - stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestStats
-- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestMx
-- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestTracing
+- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestMxInMemory
+- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestMxInTCP
+- stack ${ARGS} test $ARG='--plain' ${TEST_PACKAGE}TestTracingInMemory
+
+notifications:
+  slack:
+    secure: LbqbNjK1KiHNiQo/i/Za4vkMD9l9mhmN+PWYFBQkNvGFWffSRayRKFrTqt4znV2p7h4dY1XZFoC7T5RemBVQLq2ppZAUWxkITeu1OUlnmVLDfJLeVYGTR/fn90nP6Y5ITE7T3A07nKmWaRbKpIgFBAOjzgqaM0csscDx3z0WW18=

distributed-process-tests/distributed-process-tests.cabal

@@ -114,8 +114,7 @@ Test-Suite TestStats
   ghc-options:       -Wall -eventlog -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
   HS-Source-Dirs:    tests
 
-
-Test-Suite TestMx
+Test-Suite TestMxInMemory
   Type:              exitcode-stdio-1.0
   Main-Is:           runInMemory.hs
   CPP-Options:       -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Mx
@@ -129,7 +128,7 @@ Test-Suite TestMx
   ghc-options:       -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
   HS-Source-Dirs:    tests
 
-Test-Suite TestTracing
+Test-Suite TestTracingInMemory
   Type:              exitcode-stdio-1.0
   Main-Is:           runInMemory.hs
   CPP-Options:       -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Tracing
@@ -142,3 +141,17 @@ Test-Suite TestTracing
   Extensions:        CPP
   ghc-options:       -Wall -eventlog -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
   HS-Source-Dirs:    tests
+
+Test-Suite TestMxInTCP
+  Type:              exitcode-stdio-1.0
+  Main-Is:           runInMemory.hs
+  CPP-Options:       -DTEST_SUITE_MODULE=Control.Distributed.Process.Tests.Mx
+  Build-Depends:     base >= 4.4 && < 5,
+                     distributed-process-tests,
+                     network >= 2.3 && < 2.9,
+                     network-transport >= 0.4.1.0 && < 0.6,
+                     network-transport-inmemory >= 0.5,
+                     test-framework >= 0.6 && < 0.9
+  Extensions:        CPP
+  ghc-options:       -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind
+  HS-Source-Dirs:    tests

distributed-process-tests/src/Control/Distributed/Process/Tests/CH.hs

@@ -37,6 +37,9 @@ import Control.Distributed.Process.Internal.Types
   , createUnencodedMessage
   )
 import Control.Distributed.Process.Node
+import Control.Distributed.Process.Debug
+import Control.Distributed.Process.Management.Internal.Types
+import Control.Distributed.Process.Tests.Internal.Utils (shouldBe)
 import Control.Distributed.Process.Serializable (Serializable)
 
 import Test.HUnit (Assertion, assertBool, assertFailure)
@@ -1476,6 +1479,68 @@ testExitRemote TestTransport{..} = do
   takeMVar supervisedDone
   takeMVar supervisorDone
 
+testRegistryMonitoring :: TestTransport -> Assertion
+testRegistryMonitoring TestTransport{..} = do
+  node1 <- newLocalNode testTransport initRemoteTable
+  node2 <- newLocalNode testTransport initRemoteTable
+  waitH <- newEmptyMVar
+
+  let nid = localNodeId node2
+  pid <- forkProcess node1 $ do
+    getSelfPid >>= runUntilRegistered nid
+    liftIO $ takeMVar waitH
+
+  runProcess node2 $ do
+    register regName pid
+    res <- whereis regName
+    us <- getSelfPid
+    liftIO $ do
+      putMVar waitH ()
+      assertBool "expected (Just pid)" $ res == (Just pid)
+
+    -- This delay isn't essential!
+    -- The test case passes perfectly fine without it (feel free to comment out
+    -- and see), however waiting a few seconds here, makes it much more likely
+    -- that in delayUntilMaybeUnregistered we will hit the match case right
+    -- away, and thus not be subjected to a 20 second delay. The value of 4
+    -- seconds appears to work optimally on osx and across several linux distros
+    -- running in virtual machines (which is essentially what we do in CI)
+    void $ receiveTimeout 4000000 [ matchAny return ]
+
+  -- This delay doesn't serve much purpose in the happy path, however if some
+  -- future patch breaks the cooperative behaviour of node controllers viz
+  -- remote process registration and notification taking place via ncEffectDied,
+  -- there would be the possibility of a race in the test case should we attempt
+  -- to evaluate `whereis regName` on node2 right away. In case the name is still
+  -- erroneously registered, observing the 20 second delay (or lack of), could at
+  -- least give a hint that something is wrong, and we give up our time slice
+  -- so that there's a higher change the registrations have been cleaned up
+  -- in either case.
+  runProcess node2 $ delayUntilMaybeUnregistered nid pid
+
+  regHere <- newEmptyMVar
+  runProcess node2 $ whereis regName >>= liftIO . putMVar regHere
+  res <- takeMVar regHere
+  assertBool "expected Nothing, but process still registered" (res == Nothing)
+
+  where
+    runUntilRegistered nid us = do
+      whereisRemoteAsync nid regName
+      receiveWait [
+          matchIf (\(WhereIsReply n (Just p)) -> n == regName && p == us)
+                  (const $ return ())
+        ]
+
+    delayUntilMaybeUnregistered nid p = do
+      whereisRemoteAsync nid regName
+      receiveTimeout 20000000 {- 20 sec delay -} [
+          matchIf (\(WhereIsReply n p) -> n == regName && p == Nothing)
+                  (const $ return ())
+        ]
+      return ()
+
+    regName = "testRegisterRemote"
+
 testUnsafeSend :: TestTransport -> Assertion
 testUnsafeSend TestTransport{..} = do
   serverAddr <- newEmptyMVar
@@ -1677,6 +1742,7 @@ tests testtrans = return [
       , testCase "MaskRestoreScope"    (testMaskRestoreScope    testtrans)
       , testCase "ExitLocal"           (testExitLocal           testtrans)
       , testCase "ExitRemote"          (testExitRemote          testtrans)
+      , testCase "RegistryMonitoring"  (testRegistryMonitoring  testtrans)
       , testCase "TextCallLocal"       (testCallLocal           testtrans)
       -- Unsafe Primitives
       , testCase "TestUnsafeSend"      (testUnsafeSend          testtrans)

distributed-process-tests/src/Control/Distributed/Process/Tests/Internal/Utils.hs

@@ -20,6 +20,7 @@ module Control.Distributed.Process.Tests.Internal.Utils
   -- ping !
   , Ping(Ping)
   , ping
+  , pause
   , shouldBe
   , shouldMatch
   , shouldContain
@@ -78,10 +79,10 @@ import Control.Distributed.Process.Node
 import Control.Distributed.Process.Serializable()
 
 import Control.Exception (AsyncException(ThreadKilled), SomeException)
-import Control.Monad (forever)
+import Control.Monad (forever, void)
 import Control.Monad.STM (atomically)
 import Control.Rematch hiding (match)
-import Control.Rematch.Run 
+import Control.Rematch.Run
 import Data.Binary
 import Data.Typeable (Typeable)
 
@@ -107,10 +108,18 @@ data TestProcessControl = Stop | Go | Report ProcessId
 
 instance Binary TestProcessControl where
 
+data Private = Private
+  deriving (Typeable, Generic)
+instance Binary Private where
+
 -- | Does exactly what it says on the tin, doing so in the @Process@ monad.
 noop :: Process ()
 noop = return ()
 
+pause :: Int -> Process ()
+pause delay =
+  void $ receiveTimeout delay [ match (\Private -> return ()) ]
+
 synchronisedAssertion :: Eq a
                       => String
                       -> LocalNode
@@ -229,4 +238,3 @@ tryForkProcess :: LocalNode -> Process () -> IO ProcessId
 tryForkProcess node p = do
   tid <- liftIO myThreadId
   forkProcess node $ catch p (\e -> liftIO $ throwTo tid (e::SomeException))
-