Merge pull request haskell-distributed#267 from haskell-distributed/fd/trace-loop

facundominguez · facundominguez · commit d59ac1188eb5 · 2016-01-29T09:19:41.000-03:00
Avoid loop when tracing received messages.
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 ()
