db-analyser: add the --quiet-analysis switch

IntersectMBO · Jan 17, 2022 · 7e33a09 · 7e33a09
1 parent 990f549
commit 7e33a09
Show file tree

Hide file tree

Showing 2 changed files with 42 additions and 15 deletions.
diff --git a/ouroboros-consensus-cardano/tools/db-analyser/Analysis.hs b/ouroboros-consensus-cardano/tools/db-analyser/Analysis.hs
@@ -11,6 +11,7 @@ module Analysis (
     AnalysisEnv (..)
   , AnalysisName (..)
   , Limit (..)
+  , isEssentialEvent
   , runAnalysis
   ) where
 
@@ -167,6 +168,24 @@ data TraceEvent blk =
     --   * number of transactions in the block
     --   * total size of transactions in the block
 
+-- | Is this event necessary to answer the query specified on the user's
+-- command line?
+isEssentialEvent :: TraceEvent blk -> Bool
+isEssentialEvent = \case
+    BlockSlotEvent{}                 -> True
+    BlockTxSizeEvent{}               -> True
+    CountTxOutputsEvent{}            -> True
+    CountedBlocksEvent{}             -> True
+    DoneEvent{}                      -> False
+    EbbEvent{}                       -> True
+    ExtractGenesisTxOutputIdsEvent{} -> True
+    ExtractTxOutputIdDeltasEvent{}   -> True
+    HeaderSizeEvent{}                -> True
+    MaxHeaderSizeEvent{}             -> True
+    SnapshotStoredEvent{}            -> True
+    SnapshotWarningEvent{}           -> True
+    StartedEvent{}                   -> False
+
 instance HasAnalysis blk => Show (TraceEvent blk) where
   show (StartedEvent analysisName)        = "Started " <> (show analysisName)
   show DoneEvent                          = "Done"

diff --git a/ouroboros-consensus-cardano/tools/db-analyser/Main.hs b/ouroboros-consensus-cardano/tools/db-analyser/Main.hs
@@ -14,7 +14,7 @@ import qualified Debug.Trace as Debug
 import           Options.Applicative
 import           System.IO
 
-import           Control.Tracer (Tracer (..), nullTracer)
+import           Control.Tracer (Tracer (..), condTracing, nullTracer, showTracing, traceWith)
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
@@ -63,6 +63,7 @@ data CmdLine = CmdLine {
   , blockType  :: BlockType
   , analysis   :: AnalysisName
   , limit      :: Limit
+  , quietly    :: Bool
   }
 
 data ValidateBlocks = ValidateAllBlocks | MinimumBlockValidation
@@ -85,13 +86,17 @@ parseCmdLine = CmdLine
           ])
     <*> switch (mconcat [
             long "verbose"
-          , help "Enable verbose logging"
+          , help "Enable verbose ChainDB logging"
           ])
     <*> parseSelectDB
     <*> parseValidationPolicy
     <*> blockTypeParser
     <*> parseAnalysis
     <*> parseLimit
+    <*> switch (mconcat [
+            long "quiet-analysis"
+          , help "Filter out non-essential trace events, which is useful for piping"
+          ])
 
 parseSelectDB :: Parser SelectDB
 parseSelectDB = asum [
@@ -238,8 +243,20 @@ analyse ::
 analyse CmdLine {..} args =
     withRegistry $ \registry -> do
 
-      chainDBTracer  <- mkTracer verbose
-      analysisTracer <- mkTracer True
+      tracer <- do
+        startTime <- getMonotonicTime
+        return $ Tracer $ \s -> do
+          traceTime <- getMonotonicTime
+          let diff = diffTime traceTime startTime
+          hPutStrLn stderr $ concat ["[", show diff, "] ", s]
+          hFlush stderr
+
+
+      let chainDBTracer  = if not verbose then nullTracer else showTracing tracer
+          analysisTracer =
+              condTracing (\ev -> isEssentialEvent ev || not quietly)
+            $ showTracing tracer
+          tipTracer      = if quietly then nullTracer else tracer
       ProtocolInfo { pInfoInitLedger = genesisLedger, pInfoConfig = cfg } <-
         mkProtocolInfo args
       let chunkInfo  = Node.nodeImmutableDbChunkInfo (configStorage cfg)
@@ -279,7 +296,7 @@ analyse CmdLine {..} args =
               , tracer = analysisTracer
               }
             tipPoint <- atomically $ ImmutableDB.getTipPoint immutableDB
-            putStrLn $ "ImmutableDB tip: " ++ show tipPoint
+            traceWith tipTracer $ "ImmutableDB tip: " ++ show tipPoint
         SelectChainDB ->
           ChainDB.withDB chainDbArgs $ \chainDB -> do
             runAnalysis analysis $ AnalysisEnv {
@@ -292,17 +309,8 @@ analyse CmdLine {..} args =
               , tracer = analysisTracer
               }
             tipPoint <- atomically $ ChainDB.getTipPoint chainDB
-            putStrLn $ "ChainDB tip: " ++ show tipPoint
+            traceWith tipTracer $ "ChainDB tip: " ++ show tipPoint
   where
-    mkTracer False = return nullTracer
-    mkTracer True  = do
-      startTime <- getMonotonicTime
-      return $ Tracer $ \ev -> do
-        traceTime <- getMonotonicTime
-        let diff = diffTime traceTime startTime
-        hPutStrLn stderr $ concat ["[", show diff, "] ", show ev]
-        hFlush stderr
-
     immValidationPolicy = case (analysis, validation) of
       (_, Just ValidateAllBlocks)      -> ImmutableDB.ValidateAllChunks
       (_, Just MinimumBlockValidation) -> ImmutableDB.ValidateMostRecentChunk