trace-dispatcher: forwarder-test with unique message ids

IntersectMBO · Nov 1, 2022 · 0f1eb47 · 0f1eb47
1 parent ef258b1
commit 0f1eb47
Show file tree

Hide file tree

Showing 5 changed files with 22 additions and 17 deletions.
diff --git a/trace-dispatcher/bench/trace-dispatcher-bench.hs b/trace-dispatcher/bench/trace-dispatcher-bench.hs
@@ -10,7 +10,6 @@ import           Cardano.Logging.Test.Tracer
 import           Cardano.Logging.Test.Types
 import           System.Remote.Monitoring (forkServer)
 
-import           Debug.Trace
 
 -- Can be run with:
 -- cabal bench trace-dispatcher-bench --benchmark-option='-o benchmark-trace.html'

diff --git a/trace-dispatcher/test/Cardano/Logging/ForwardingStressTest/Script.hs b/trace-dispatcher/test/Cardano/Logging/ForwardingStressTest/Script.hs
@@ -37,6 +37,9 @@ import           Cardano.Logging.Test.Messages
 import           Cardano.Logging.Test.Types
 
 
+import           Debug.Trace
+
+
 data TestSetup a
   = TestSetup
   { tsTime         :: !(a Double)
@@ -111,7 +114,8 @@ runScriptForwarding ::
   -> Trace IO FormattedMessage
   -> IORef Int
   -> Property
-runScriptForwarding TestSetup{..} fwdTracer stdoutTracer' accumulationCounter = do
+runScriptForwarding ts@TestSetup{..} fwdTracer stdoutTracer' accumulationCounter =
+    trace ("Test setup " ++ show ts) $ do
       let generator :: Gen [Script] = vectorOf (runIdentity tsThreads) $
             case runIdentity tsMessages of
               Nothing -> scale (* 1000) arbitrary
@@ -127,14 +131,16 @@ runScriptForwarding TestSetup{..} fwdTracer stdoutTracer' accumulationCounter =
                       severityForMessage
                       privacyForMessage
           configureTracers simpleTestConfig docMessage [tr]
-          let scripts' = map (\ (Script sc) ->
-                Script (sort sc))  scripts
-              scripts'' = map (\ (Script sc) ->
-                Script (withMessageIds 0 sc)) scripts'
-              scripts''' = map (\ (Script sc) ->
-                Script $ map (withTimeFactor (runIdentity tsTime)) sc) scripts''
-              scripts'''' = map (\ (Script sc) ->
-                Script $ filter (\(ScriptedMessage _ msg) -> namesForMessage msg /= ["Message2"]) sc) scripts'''
+          let scripts' = map (\ (Script sc) -> Script
+                             $ filter (\(ScriptedMessage _ msg) ->
+                                namesForMessage msg /= ["Message2"]) sc) scripts
+              scripts'' = map (\ (Script sc) -> Script (sort sc))  scripts'
+              scripts''' = zipWith (\ (Script sc) ind -> Script (
+                            withMessageIds (runIdentity tsThreads) ind sc)) scripts'' [0..]
+              scripts'''' = map (\ (Script sc) -> Script
+                              $ map (withTimeFactor (runIdentity tsTime)) sc) scripts'''
+
+
           -- putStrLn ("runTest " ++ show scripts)
           children :: MVar [MVar (Either SomeException ())] <- newMVar []
           mapM_ (\sc -> forkChild children (playIt sc tr 0.0)) scripts''''
@@ -150,7 +156,7 @@ runScriptForwarding TestSetup{..} fwdTracer stdoutTracer' accumulationCounter =
               let numMsg = sum (map (\ (Script sc) -> length sc) scripts'''')
               in if numMsg > 0 then do
                 -- TODO mutiple files
-                contents <- readFile "/tmp/cardano-tracer-logs/tmp-tracersock@0/node.json"
+                contents <- readFile "/tmp/cardano-forwarder-test-logs/tmp-tracersock@0/node.json"
                 let lineLength = length (lines contents) - 1
                 putStrLn $ "Line length " ++ show lineLength
                 putStrLn $ "Msg length " ++ show numMsg
@@ -198,12 +204,12 @@ playIt (Script (ScriptedMessage d1 m1 : rest)) tr d = do
 -- MessageId gives the id to start with.
 -- Returns a tuple with the messages with ids and
 -- the successor of the last used messageId
-withMessageIds :: MessageID -> [ScriptedMessage] -> [ScriptedMessage]
-withMessageIds mid sMsgs = go mid sMsgs []
+withMessageIds :: Int -> MessageID -> [ScriptedMessage] -> [ScriptedMessage]
+withMessageIds numThreads mid sMsgs = go mid sMsgs []
   where
     go _mid' [] acc = reverse acc
     go mid' (ScriptedMessage time msg : tl) acc =
-      go (mid' + 1) tl (ScriptedMessage time (setMessageID msg mid') : acc)
+      go (mid' + numThreads) tl (ScriptedMessage time (setMessageID msg mid') : acc)
 
 withTimeFactor :: Double -> ScriptedMessage -> ScriptedMessage
 withTimeFactor factor (ScriptedMessage time msg) =

diff --git a/trace-dispatcher/test/Cardano/Logging/Test/Types.hs b/trace-dispatcher/test/Cardano/Logging/Test/Types.hs
@@ -39,7 +39,7 @@ instance LogFormatting Message where
             ]
   forMachine _dtal (Message3 mid d) =
     mconcat [ "kind" .= String "Message3"
-            , "mid" .= String (showT mid)
+            , "mid" .= String ("<" <> showT mid <> ">")
             , "workload" .= String (showT d)
             ]
   forHuman (Message1 mid i) =

diff --git a/trace-dispatcher/test/cardano-tracer-config.yaml b/trace-dispatcher/test/cardano-tracer-config.yaml
@@ -4,6 +4,6 @@ network:
   tag: AcceptAt
   contents: "/tmp/tracer.sock"
 logging:
-- logRoot: "/tmp/cardano-tracer-logs"
+- logRoot: "/tmp/cardano-forwarder-test-logs"
   logMode: FileMode
   logFormat: ForMachine
diff --git a/trace-dispatcher/test/trace-dispatcher-test.hs b/trace-dispatcher/test/trace-dispatcher-test.hs
@@ -23,7 +23,7 @@ import           Ouroboros.Network.NodeToClient (withIOManager)
 main :: IO ()
 main = do
     ts <- getTestSetup
-    let logPath = "/tmp/cardano-tracer-logs"
+    let logPath = "/tmp/cardano-forwarder-test-logs"
     fe <- fileExist logPath
     when fe
         (removeDirectoryRecursive logPath)