Avoid loop when tracing received messages.

facundominguez · facundominguez · commit d8c36b547c17 · 2016-01-22T23:12:24.000-03:00
When a trace message was sent to "trace.logger", the NC would produce
a trace message to indicate the arrival of it, this new trace message
would in turn have the NC produce another trace message and so on.

In this patch the NC does not produce a trace message when the
destination is the "trace.logger" process.
diff --git a/distributed-process-tests/distributed-process-tests.cabal b/distributed-process-tests/distributed-process-tests.cabal
@@ -35,6 +35,7 @@ library
                      network >= 2.5 && < 2.7,
                      random >= 1.0 && < 1.2,
                      rematch >= 0.1.2.1,
+                     setenv >= 0.1.1.3,
                      test-framework >= 0.6 && < 0.9,
                      test-framework-hunit >= 0.2.0 && < 0.4,
                      stm
diff --git a/distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs b/distributed-process-tests/src/Control/Distributed/Process/Tests/Tracing.hs
@@ -5,6 +5,7 @@ module Control.Distributed.Process.Tests.Tracing (tests) where
 import Control.Distributed.Process.Tests.Internal.Utils
 import Network.Transport.Test (TestTransport(..))
 
+import Control.Applicative ((<*))
 import Control.Concurrent (threadDelay)
 import Control.Concurrent.MVar
   ( MVar
@@ -19,16 +20,24 @@ import Control.Distributed.Process.Debug
 import Control.Distributed.Process.Management
   ( MxEvent(..)
   )
+import qualified Control.Exception as IO (bracket)
+import Data.List (isPrefixOf, isSuffixOf)
 
 #if ! MIN_VERSION_base(4,6,0)
 import Prelude hiding (catch, log)
+#else
+import Prelude hiding ((<*))
 #endif
 
 import Test.Framework
   ( Test
   , testGroup
   )
 import Test.Framework.Providers.HUnit (testCase)
+import System.Environment (getEnvironment)
+-- These are available in System.Environment only since base 4.7
+import System.SetEnv (setEnv, unsetEnv)
+
 
 testSpawnTracing :: TestResult Bool -> Process ()
 testSpawnTracing result = do
@@ -282,6 +291,82 @@ testRemoteTraceRelay TestTransport{..} result =
     -- and just to be polite...
     liftIO $ closeLocalNode node2
 
+-- | Sets the value of an environment variable while executing the given IO
+-- computation and restores the preceeding value upon completion.
+withEnv :: String -> String -> IO a -> IO a
+withEnv var val =
+    IO.bracket (fmap (lookup var) getEnvironment <* setEnv var val)
+               (maybe (unsetEnv var) (setEnv var))
+    . const
+
+-- | Tests that one and only one interesting trace message is produced when a
+-- given action is performed. A message is considered interesting when the given
+-- function return @True@.
+testSystemLoggerMsg :: TestTransport
+                    -> Process a
+                    -> (a -> String -> Bool)
+                    -> IO ()
+testSystemLoggerMsg t action interestingMessage =
+    withEnv "DISTRIBUTED_PROCESS_TRACE_CONSOLE" "yes" $
+    withEnv "DISTRIBUTED_PROCESS_TRACE_FLAGS" "pdnusrl" $ do
+    n <- newLocalNode (testTransport t) initRemoteTable
+
+    runProcess n $ do
+      self <- getSelfPid
+      reregister "trace.logger" self
+      a <- action
+      let interestingMessage' (_ :: String, msg) = interestingMessage a msg
+      -- Wait for the trace message.
+      receiveWait [ matchIf interestingMessage' $ const $ return () ]
+      -- Only one interesting message should arrive.
+      Nothing <- receiveTimeout 100000
+                   [ matchIf interestingMessage' $ const $ return () ]
+      return ()
+
+
+-- | Tests that one and only one trace message is produced when a message is
+-- received.
+testSystemLoggerMxReceive :: TestTransport -> IO ()
+testSystemLoggerMxReceive t = testSystemLoggerMsg t
+    (getSelfPid >>= flip send ())
+    (\_ msg -> "MxReceived" `isPrefixOf` msg
+             -- discard traces of internal messages
+          && not (":: RegisterReply" `isSuffixOf` msg)
+    )
+
+-- | Tests that one and only one trace message is produced when a message is
+-- sent.
+testSystemLoggerMxSent :: TestTransport -> IO ()
+testSystemLoggerMxSent t = testSystemLoggerMsg t
+    (getSelfPid >>= flip send ())
+    (const $ isPrefixOf "MxSent")
+
+-- | Tests that one and only one trace message is produced when a process dies.
+testSystemLoggerMxProcessDied :: TestTransport -> IO ()
+testSystemLoggerMxProcessDied t = testSystemLoggerMsg t
+    (spawnLocal $ return ())
+    (\pid -> isPrefixOf $ "MxProcessDied " ++ show pid)
+
+-- | Tests that one and only one trace message appears when a process spawns.
+testSystemLoggerMxSpawned :: TestTransport -> IO ()
+testSystemLoggerMxSpawned t = testSystemLoggerMsg t
+    (spawnLocal $ return ())
+    (\pid -> isPrefixOf $ "MxSpawned " ++ show pid)
+
+-- | Tests that one and only one trace message appears when a process is
+-- registered.
+testSystemLoggerMxRegistered :: TestTransport -> IO ()
+testSystemLoggerMxRegistered t = testSystemLoggerMsg t
+    (getSelfPid >>= register "a" >> getSelfPid)
+    (\self -> isPrefixOf $ "MxRegistered " ++ show self ++ " " ++ show "a")
+
+-- | Tests that one and only one trace message appears when a process is
+-- unregistered.
+testSystemLoggerMxUnRegistered :: TestTransport -> IO ()
+testSystemLoggerMxUnRegistered t = testSystemLoggerMsg t
+    (getSelfPid >>= register "a" >> unregister "a" >> getSelfPid)
+    (\self -> isPrefixOf $ "MxUnRegistered " ++ show self ++ " " ++ show "a")
+
 tests :: TestTransport -> IO [Test]
 tests testtrans@TestTransport{..} = do
   node1 <- newLocalNode testTransport initRemoteTable
@@ -323,4 +408,12 @@ tests testtrans@TestTransport{..} = do
               (synchronisedAssertion
                "expected blah"
                node1 True (testRemoteTraceRelay testtrans) lock)
+         , testGroup "SystemLoggerTracer"
+           [ testCase "MxReceive" $ testSystemLoggerMxReceive testtrans
+           , testCase "MxSent" $ testSystemLoggerMxSent testtrans
+           , testCase "MxProcessDied" $ testSystemLoggerMxProcessDied testtrans
+           , testCase "MxSpawned" $ testSystemLoggerMxSpawned testtrans
+           , testCase "MxRegistered" $ testSystemLoggerMxRegistered testtrans
+           , testCase "MxUnRegistered" $ testSystemLoggerMxUnRegistered testtrans
+           ]
          ] ]
diff --git a/src/Control/Distributed/Process/Node.hs b/src/Control/Distributed/Process/Node.hs
@@ -662,10 +662,13 @@ instance Show ProcessKillException where
     "killed-by=" ++ show pid ++ ",reason=" ++ reason
 
 ncSendToProcess :: ProcessId -> Message -> NC ()
-ncSendToProcess pid msg = do
+ncSendToProcess = ncSendToProcessAndTrace True
+
+ncSendToProcessAndTrace :: Bool -> ProcessId -> Message -> NC ()
+ncSendToProcessAndTrace shouldTrace pid msg = do
     node <- ask
     if processNodeId pid == localNodeId node
-      then ncEffectLocalSend node pid msg
+      then ncEffectLocalSendAndTrace shouldTrace node pid msg
       else liftIO $ sendBinary node
              (NodeIdentifier $ localNodeId node)
              (NodeIdentifier $ processNodeId pid)
@@ -946,14 +949,20 @@ ncEffectNamedSend :: String -> Message -> NC ()
 ncEffectNamedSend label msg = do
   mPid <- gets (^. registeredHereFor label)
   -- If mPid is Nothing, we just ignore the named send (as per Table 14)
-  forM_ mPid (`ncSendToProcess` msg)
+  forM_ mPid $ \to ->
+    -- If this is a trace message we don't trace it to avoid entering a loop
+    -- where trace messages produce more trace messages.
+    ncSendToProcessAndTrace (label /= "trace.logger") to msg
 
 -- [Issue #DP-20]
 ncEffectLocalSend :: LocalNode -> ProcessId -> Message -> NC ()
-ncEffectLocalSend node to msg =
+ncEffectLocalSend = ncEffectLocalSendAndTrace True
+
+ncEffectLocalSendAndTrace :: Bool -> LocalNode -> ProcessId -> Message -> NC ()
+ncEffectLocalSendAndTrace shouldTrace node to msg =
   liftIO $ withLocalProc node to $ \p -> do
     enqueue (processQueue p) msg
-    trace node (MxReceived to msg)
+    when shouldTrace $ trace node (MxReceived to msg)
 
 -- [Issue #DP-20]
 ncEffectLocalPortSend :: SendPortId -> Message -> NC ()
