Merge #4117

4117: Restructure the namespace r=jutaro a=jutaro

Restructure the namespace of trace messages to get some logic into it.

Co-authored-by: Yupanqui <[email protected]>
Co-authored-by: Kosyrev Serge <[email protected]>

Author: 3 people

Diff for: bench/locli/locli.cabal

@@ -91,6 +91,7 @@ library
                      , containers
                      , deepseq
                      , directory
+                     , extra
                      , filepath
                      , file-embed
                      , gnuplot

Diff for: bench/locli/src/Cardano/Analysis/Run.hs

@@ -73,7 +73,7 @@ renderAnchorDomains Anchor{..} = mconcat $
 renderAnchorNoRuns :: Anchor -> Text
 renderAnchorNoRuns a@Anchor{..} = mconcat
   [ renderAnchorFiltersAndDomains a
-  , renderProgramAndVersion aVersion
+  , ", ", renderProgramAndVersion aVersion
   , ", analysed at ", renderAnchorDate a
   ]
 

Diff for: bench/locli/src/Cardano/Unlog/LogObject.hs

@@ -10,7 +10,7 @@
 
 module Cardano.Unlog.LogObject (module Cardano.Unlog.LogObject) where
 
-import Prelude (head, id, show)
+import Prelude (head, id, show, unzip3)
 import Cardano.Prelude hiding (Text, head, show)
 
 import Control.Monad (fail)
@@ -24,6 +24,7 @@ import Data.Text qualified as LText
 import Data.Text.Short qualified as Text
 import Data.Text.Short (ShortText, fromText, toText)
 import Data.Time.Clock (NominalDiffTime, UTCTime)
+import Data.Tuple.Extra (fst3, snd3, thd3)
 import Data.Map qualified as Map
 import Data.Vector (Vector)
 import Data.Vector qualified as V
@@ -83,48 +84,47 @@ deriving instance NFData a => NFData (Resources a)
 --
 -- LogObject stream interpretation
 --
+type Threeple t = (t, t, t)
 
-type ACouple t = (t, t)
-
-interpreters :: ACouple (Map Text (Object -> Parser LOBody))
-interpreters = (Map.fromList *** Map.fromList) . unzip . fmap ent $
-  [ (,,) "TraceStartLeadershipCheck" "Forge.StartLeadershipCheck" $
+interpreters :: Threeple (Map Text (Object -> Parser LOBody))
+interpreters = map3ple Map.fromList . unzip3 . fmap ent $
+  [ (,,,) "TraceStartLeadershipCheck" "Forge.StartLeadershipCheck" "Forge.Loop.StartLeadershipCheck" $
     \v -> LOTraceStartLeadershipCheck
             <$> v .: "slot"
             <*> (v .:? "utxoSize"     <&> fromMaybe 0)
             <*> (v .:? "chainDensity" <&> fromMaybe 0)
 
-  , (,,) "TraceBlockContext" "Forge.BlockContext" $
+  , (,,,) "TraceBlockContext" "Forge.BlockContext" "Forge.Loop.BlockContext" $
     \v -> LOBlockContext
             <$> v .: "tipBlockNo"
 
-  , (,,) "TraceNodeIsLeader" "Forge.NodeIsLeader" $
+  , (,,,) "TraceNodeIsLeader" "Forge.NodeIsLeader" "Forge.Loop.NodeIsLeader" $
     \v -> LOTraceLeadershipDecided
             <$> v .: "slot"
             <*> pure True
 
-  , (,,) "TraceNodeNotLeader" "Forge.NodeNotLeader" $
+  , (,,,) "TraceNodeNotLeader" "Forge.NodeNotLeader" "Forge.Loop.NodeNotLeader" $
     \v -> LOTraceLeadershipDecided
             <$> v .: "slot"
             <*> pure False
 
-  , (,,) "TraceMempoolAddedTx" "Mempool.AddedTx" $
+  , (,,,) "TraceMempoolAddedTx" "Mempool.AddedTx" "Mempool.AddedTx" $
     \v -> do
       x :: Object <- v .: "mempoolSize"
       LOMempoolTxs <$> x .: "numTxs"
 
-  , (,,) "TraceMempoolRemoveTxs" "Mempool.RemoveTxs" $
+  , (,,,) "TraceMempoolRemoveTxs" "Mempool.RemoveTxs" "Mempool.RemoveTxs" $
     \v -> do
       x :: Object <- v .: "mempoolSize"
       LOMempoolTxs <$> x .: "numTxs"
 
-  , (,,) "TraceMempoolRejectedTx" "Mempool.RejectedTx" $
+  , (,,,) "TraceMempoolRejectedTx" "Mempool.RejectedTx" "Mempool.RejectedTx" $
     \_ -> pure LOMempoolRejectedTx
 
-  , (,,) "TraceLedgerEvent.TookSnapshot" "LedgerEvent.TookSnapshot" $
+  , (,,,) "TraceLedgerEvent.TookSnapshot" "LedgerEvent.TookSnapshot" "ChainDB.LedgerEvent.TookSnapshot" $
     \_ -> pure LOLedgerTookSnapshot
 
-  , (,,) "TraceBenchTxSubSummary" "TraceBenchTxSubSummary" $
+  , (,,,) "TraceBenchTxSubSummary" "TraceBenchTxSubSummary" "TraceBenchTxSubSummary" $
     \v -> do
        x :: Object <- v .: "summary"
        LOGeneratorSummary
@@ -134,77 +134,81 @@ interpreters = (Map.fromList *** Map.fromList) . unzip . fmap ent $
          <*> x .: "ssElapsed"
          <*> x .: "ssThreadwiseTps"
 
-  , (,,) "TraceBenchTxSubServAck" "TraceBenchTxSubServAck" $
+  , (,,,) "TraceBenchTxSubServAck" "TraceBenchTxSubServAck" "TraceBenchTxSubServAck" $
     \v -> LOTxsAcked <$> v .: "txIds"
 
-  , (,,) "Resources" "Resources" $
+  , (,,,) "Resources" "Resources" "" $
     \v -> LOResources <$> parsePartialResourceStates (Object v)
 
-  , (,,) "TraceTxSubmissionCollected" "TraceTxSubmissionCollected" $
+  , (,,,) "TraceTxSubmissionCollected" "TraceTxSubmissionCollected" "TraceTxSubmissionCollected" $
     \v -> LOTxsCollected
             <$> v .: "count"
 
-  , (,,) "TraceTxSubmissionProcessed" "TraceTxSubmissionProcessed" $
+  , (,,,) "TraceTxSubmissionProcessed" "TraceTxSubmissionProcessed" "TraceTxSubmissionProcessed" $
     \v -> LOTxsProcessed
             <$> v .: "accepted"
             <*> v .: "rejected"
 
-  , (,,) "TraceForgedBlock" "Forge.ForgedBlock" $
+  , (,,,) "TraceForgedBlock" "Forge.ForgedBlock" "Forge.Loop.ForgedBlock" $
     \v -> LOBlockForged
             <$> v .: "block"
             <*> v .: "blockPrev"
             <*> v .: "blockNo"
             <*> v .: "slot"
-  , (,,) "TraceAddBlockEvent.AddedToCurrentChain" "ChainDB.AddBlockEvent.AddedToCurrentChain" $
+  , (,,,) "TraceAddBlockEvent.AddedToCurrentChain" "ChainDB.AddBlockEvent.AddedToCurrentChain" "ChainDB.AddBlockEvent.AddedToCurrentChain" $
     \v -> LOBlockAddedToCurrentChain
             <$> ((v .: "newtip")     <&> hashFromPoint)
             <*> pure Nothing
             <*> (v .:? "chainLengthDelta"
                 -- Compat for node versions 1.27 and older:
                  <&> fromMaybe 1)
   -- TODO: we should clarify the distinction between the two cases (^ and v).
-  , (,,) "TraceAdoptedBlock" "Forge.AdoptedBlock" $
+  , (,,,) "TraceAdoptedBlock" "Forge.AdoptedBlock" "Forge.Loop.AdoptedBlock" $
     \v -> LOBlockAddedToCurrentChain
             <$> v .: "blockHash"
             <*> ((v .: "blockSize") <&> Just)
             <*> pure 1
-  , (,,) "ChainSyncServerEvent.TraceChainSyncServerRead.AddBlock" "ChainSyncServerHeader.ChainSyncServerEvent.ServerRead.AddBlock" $
+  , (,,,) "ChainSyncServerEvent.TraceChainSyncServerRead.AddBlock" "ChainSyncServerHeader.ChainSyncServerEvent.ServerRead.AddBlock" "" $
     \v -> LOChainSyncServerSendHeader
             <$> v .: "block"
             <*> v .: "blockNo"
             <*> v .: "slot"
-  , (,,) "ChainSyncServerEvent.TraceChainSyncServerReadBlocked.AddBlock" "ChainSyncServerHeader.ChainSyncServerEvent.ServerReadBlocked.AddBlock" $
+  , (,,,) "ChainSyncServerEvent.TraceChainSyncServerReadBlocked.AddBlock" "ChainSyncServerHeader.ChainSyncServerEvent.ServerReadBlocked.AddBlock" "ChainSync.ServerHeader.ChainSyncServerEvent.ServerReadBlocked.AddBlock" $
     \v -> LOChainSyncServerSendHeader
             <$> v .: "block"
             <*> v .: "blockNo"
             <*> v .: "slot"
   -- v, but not ^ -- how is that possible?
-  , (,,) "TraceBlockFetchServerSendBlock" "BlockFetchServer.SendBlock" $
+  , (,,,) "TraceBlockFetchServerSendBlock" "BlockFetchServer.SendBlock" "BlockFetch.Server.SendBlock" $
     \v -> LOBlockFetchServerSending
             <$> v .: "block"
-  , (,,) "SendFetchRequest" "BlockFetchClient.SendFetchRequest" $
+  , (,,,) "SendFetchRequest" "BlockFetchClient.SendFetchRequest" "BlockFetch.Client.SendFetchRequest" $
     \v -> LOBlockFetchClientRequested
             <$> v .: "head"
             <*> v .: "length"
-  , (,,) "ChainSyncClientEvent.TraceDownloadedHeader" "ChainSyncClient.ChainSyncClientEvent.DownloadedHeader" $
+  , (,,,) "ChainSyncClientEvent.TraceDownloadedHeader" "ChainSyncClient.ChainSyncClientEvent.DownloadedHeader" "ChainSync.Client.DownloadedHeader" $
     \v -> LOChainSyncClientSeenHeader
             <$> v .: "block"
             <*> v .: "blockNo"
             <*> v .: "slot"
-  , (,,) "CompletedBlockFetch" "BlockFetchClient.CompletedBlockFetch" $
+  , (,,,) "CompletedBlockFetch" "BlockFetchClient.CompletedBlockFetch" "BlockFetch.Client.CompletedBlockFetch" $
     \v -> LOBlockFetchClientCompletedFetch
             <$> v .: "block"
   ]
  where
    hashFromPoint :: LText.Text -> Hash
    hashFromPoint = Hash . fromText . Prelude.head . LText.splitOn "@"
 
-   ent :: (a,b,c) -> ((a,c), (b,c))
-   ent (a,b,c) = ((a,c), (b,c))
+   ent :: (a,b,c,d) -> ((a,d), (b,d), (c, d))
+   ent (a,b,c,d) = ((a,d), (b,d), (c, d))
+
+   map3ple :: (a -> b) -> (a,a,a) -> (b,b,b)
+   map3ple f (x,y,z) = (f x, f y, f z)
 
-logObjectStreamInterpreterKeysLegacy, logObjectStreamInterpreterKeys :: [Text]
-logObjectStreamInterpreterKeysLegacy = Map.keys (fst interpreters)
-logObjectStreamInterpreterKeys       = Map.keys (snd interpreters)
+logObjectStreamInterpreterKeysLegacy, logObjectStreamInterpreterKeysOldOrg, logObjectStreamInterpreterKeys :: [Text]
+logObjectStreamInterpreterKeysLegacy = Map.keys (interpreters & fst3)
+logObjectStreamInterpreterKeysOldOrg = Map.keys (interpreters & snd3)
+logObjectStreamInterpreterKeys       = Map.keys (interpreters & thd3)
 
 data LOBody
   = LOTraceStartLeadershipCheck !SlotNo !Word64 !Double
@@ -273,11 +277,12 @@ instance FromJSON LogObject where
       <*> pure kind
       <*> v .: "host"
       <*> v .: "thread"
-      <*> case Map.lookup  ns                                       (snd interpreters) <|>
+      <*> case Map.lookup  ns                                       (thd3 interpreters) <|>
+               Map.lookup  ns                                       (snd3 interpreters) <|>
                Map.lookup (ns
                            & Text.stripPrefix "Cardano.Node."
-                           & fromMaybe "")                          (snd interpreters) <|>
-               Map.lookup  kind                                     (fst interpreters) of
+                           & fromMaybe "")                          (snd3 interpreters) <|>
+               Map.lookup  kind                                     (fst3 interpreters) of
             Just interp -> interp unwrapped
             Nothing -> pure $ LOAny unwrapped
    where