Propagate ApplyOpts to tests and executables

ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs

@@ -129,24 +129,35 @@ storeLedgerParser = do
     (  long "store-ledger"
     <> metavar "SLOT_NUMBER"
     <> help "Store ledger state at specific slot number" )
-  ledgerValidation <- flag LedgerReapply LedgerApply
-    (  long "full-ledger-validation"
-    <> help (  "Use full block application while applying blocks to ledger states, "
-            <> "also validating signatures and scripts. "
-            <> "This is much slower than block reapplication (the default)."
-            )
-    )
+  opts <- pApplyOpts
   doChecksum <- flag DoDiskSnapshotChecksum NoDoDiskSnapshotChecksum
     (mconcat [ long "no-snapshot-checksum-on-write"
              , help (unlines [ "Don't calculate the checksum and"
                              , "write the '.checksum' file"
                              , "when taking a ledger snapshot"
                              ])
              ])
-  pure $ StoreLedgerStateAt slot ledgerValidation doChecksum
+  pure $ StoreLedgerStateAt slot opts doChecksum
+
+pApplyOpts :: Parser ApplyOpts
+pApplyOpts = do
+  val <- flag ValidationOn ValidationOff
+    (  long "full-ledger-validation"
+    <> help (  "Use full block application while applying blocks to ledger states, "
+            <> "also validating signatures and scripts. "
+            <> "This is much slower than block reapplication (the default)."
+            )
+    )
+  evs <- flag ComputeLedgerEvents OmitLedgerEvents
+    (  long "compute-ledger-events"
+    <> help (  "Although the events will not be emitted anywhere (yet), "
+            <> "this switch tells the ledger to compute such events"
+            )
+    )
+  pure (ApplyOpts val evs)
 
 checkNoThunksParser :: Parser AnalysisName
-checkNoThunksParser = CheckNoThunksEvery <$> option auto
+checkNoThunksParser = CheckNoThunksEvery <$> pApplyOpts <*> option auto
   (  long "checkThunks"
   <> metavar "BLOCK_COUNT"
   <> help "Check the ledger state for thunks every n blocks" )
@@ -164,7 +175,7 @@ parseLimit = asum [
 benchmarkLedgerOpsParser :: Parser AnalysisName
 benchmarkLedgerOpsParser =
        benchmarkLedgerOpsFlagParser
-    *> (BenchmarkLedgerOps <$> pMaybeOutputFile <*> pApplyMode)
+    *> (BenchmarkLedgerOps <$> pMaybeOutputFile <*> pApplyOpts)
   where
     benchmarkLedgerOpsFlagParser =
       flag' BenchmarkLedgerOps $ mconcat [
@@ -174,12 +185,6 @@ benchmarkLedgerOpsParser =
                   <> " (defaults to stdout)."
           ]
 
-    pApplyMode =
-      flag LedgerApply LedgerReapply $ mconcat [
-            long "reapply"
-          , help $ "Measure header/block *re*application instead of full application."
-          ]
-
 getBlockApplicationMetrics :: Parser AnalysisName
 getBlockApplicationMetrics =  do
   fGetBlockApplicationMetrics <- partialGetBlockApplicationMetricsParser

ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs

@@ -122,7 +122,7 @@ exampleBlock =
       cfg
       (BlockNo 1)
       (SlotNo 1)
-      (applyChainTick ledgerConfig (SlotNo 1) ledgerStateAfterEBB)
+      (applyChainTick OmitLedgerEvents ledgerConfig (SlotNo 1) ledgerStateAfterEBB)
       [ValidatedByronTx exampleGenTx]
       (fakeMkIsLeader leaderCredentials)
   where
@@ -180,14 +180,14 @@ emptyLedgerState = ByronLedgerState {
 
 ledgerStateAfterEBB :: LedgerState ByronBlock
 ledgerStateAfterEBB =
-      reapplyLedgerBlock ledgerConfig exampleEBB
-    . applyChainTick ledgerConfig (SlotNo 0)
+      reapplyLedgerBlock OmitLedgerEvents ledgerConfig exampleEBB
+    . applyChainTick OmitLedgerEvents ledgerConfig (SlotNo 0)
     $ emptyLedgerState
 
 exampleLedgerState :: LedgerState ByronBlock
 exampleLedgerState =
-      reapplyLedgerBlock ledgerConfig exampleBlock
-    . applyChainTick ledgerConfig (SlotNo 1)
+      reapplyLedgerBlock OmitLedgerEvents ledgerConfig exampleBlock
+    . applyChainTick OmitLedgerEvents ledgerConfig (SlotNo 1)
     $ ledgerStateAfterEBB
 
 exampleHeaderState :: HeaderState ByronBlock

ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Ledger.hs

@@ -33,7 +33,7 @@ import qualified Ouroboros.Consensus.ByronSpec.Ledger.Rules as Rules
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.CommonProtocolParams
 import           Ouroboros.Consensus.Ticked
-import           Ouroboros.Consensus.Util ((..:))
+import           Ouroboros.Consensus.Util
 
 {-------------------------------------------------------------------------------
   State
@@ -103,7 +103,7 @@ instance IsLedger (LedgerState ByronSpecBlock) where
   type AuxLedgerEvent (LedgerState ByronSpecBlock) =
     VoidLedgerEvent (LedgerState ByronSpecBlock)
 
-  applyChainTickLedgerResult cfg slot (ByronSpecLedgerState tip state) =
+  applyChainTickLedgerResult _evs cfg slot (ByronSpecLedgerState tip state) =
         pureLedgerResult
       $ TickedByronSpecLedgerState {
             untickedByronSpecLedgerTip = tip
@@ -118,7 +118,7 @@ instance IsLedger (LedgerState ByronSpecBlock) where
 -------------------------------------------------------------------------------}
 
 instance ApplyBlock (LedgerState ByronSpecBlock) ByronSpecBlock where
-  applyBlockLedgerResult cfg block (TickedByronSpecLedgerState _tip state) =
+  applyBlockLedgerResultWithOpts _opts cfg block (TickedByronSpecLedgerState _tip state) =
         withExcept ByronSpecLedgerError
       $ fmap (pureLedgerResult . ByronSpecLedgerState (Just (blockSlot block)))
       $ -- Note that the CHAIN rule also applies the chain tick. So even
@@ -133,7 +133,7 @@ instance ApplyBlock (LedgerState ByronSpecBlock) ByronSpecBlock where
 
   reapplyBlockLedgerResult =
       -- The spec doesn't have a "reapply" mode
-      dontExpectError ..: applyBlockLedgerResult
+      dontExpectError ...: (applyBlockLedgerResultWithOpts . ApplyOpts ValidationOff)
     where
       dontExpectError :: Except a b -> b
       dontExpectError mb = case runExcept mb of

ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/TxGen/Cardano.hs

@@ -41,8 +41,8 @@ import           Ouroboros.Consensus.HardFork.Combinator.Ledger
                      (tickedHardForkLedgerStatePerEra)
 import           Ouroboros.Consensus.HardFork.Combinator.State.Types
                      (currentState, getHardForkState)
-import           Ouroboros.Consensus.Ledger.Basics (LedgerConfig, LedgerState,
-                     applyChainTick)
+import           Ouroboros.Consensus.Ledger.Basics (ComputeLedgerEvents (..),
+                     LedgerConfig, LedgerState, applyChainTick)
 import           Ouroboros.Consensus.NodeId (CoreNodeId (..))
 import           Ouroboros.Consensus.Protocol.TPraos (TPraos)
 import           Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock, mkShelleyTx)
@@ -211,7 +211,7 @@ migrateUTxO migrationInfo curSlot lcfg lst
     mbUTxO =
         fmap getUTxOShelley $
         ejectShelleyTickedLedgerState $
-        applyChainTick lcfg curSlot $
+        applyChainTick OmitLedgerEvents lcfg curSlot $
         lst
 
     MigrationInfo

ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs

@@ -16,12 +16,14 @@ module Cardano.Tools.DBAnalyser.Analysis (
   , AnalysisName (..)
   , AnalysisResult (..)
   , AnalysisStartFrom (..)
-  , LedgerApplicationMode (..)
+  , ApplyOpts (..)
+  , ComputeLedgerEvents (..)
   , Limit (..)
   , NumberOfBlocks (..)
   , SStartFrom (..)
   , SomeAnalysis (..)
   , StartFrom (..)
+  , Validation (..)
   , runAnalysis
   ) where
 
@@ -53,9 +55,11 @@ import           Ouroboros.Consensus.HeaderValidation (HasAnnTip (..),
                      HeaderState (..), headerStatePoint, revalidateHeader,
                      tickHeaderState, validateHeader)
 import           Ouroboros.Consensus.Ledger.Abstract
-                     (ApplyBlock (reapplyBlockLedgerResult), LedgerCfg,
-                     LedgerConfig, applyBlockLedgerResult, applyChainTick,
-                     tickThenApply, tickThenApplyLedgerResult, tickThenReapply)
+                     (ApplyBlock (reapplyBlockLedgerResult), ApplyOpts (..),
+                     ComputeLedgerEvents (..), LedgerCfg, LedgerConfig,
+                     Validation (..), applyBlockLedgerResultWithOpts,
+                     applyChainTick, tickThenApplyLedgerResultWithOpts,
+                     tickThenApplyWithOpts, tickThenReapply)
 import           Ouroboros.Consensus.Ledger.Basics (LedgerResult (..),
                      LedgerState, getTipSlot)
 import           Ouroboros.Consensus.Ledger.Extended
@@ -74,7 +78,7 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
 import           Ouroboros.Consensus.Storage.LedgerDB (DiskSnapshot (..),
                      writeSnapshot)
 import           Ouroboros.Consensus.Storage.Serialisation (encodeDisk)
-import           Ouroboros.Consensus.Util (Flag (..), (..:))
+import           Ouroboros.Consensus.Util (Flag (..))
 import qualified Ouroboros.Consensus.Util.IOLike as IOLike
 import           Ouroboros.Network.SizeInBytes
 import           System.FS.API (SomeHasFS (..))
@@ -110,7 +114,7 @@ runAnalysis analysisName = case go analysisName of
     go OnlyValidation                                    = mkAnalysis @StartFromPoint $ \_ -> pure Nothing
     go (StoreLedgerStateAt slotNo lgrAppMode doChecksum) = mkAnalysis $ storeLedgerStateAt slotNo lgrAppMode doChecksum
     go CountBlocks                                       = mkAnalysis $ countBlocks
-    go (CheckNoThunksEvery nBks)                         = mkAnalysis $ checkNoThunksEvery nBks
+    go (CheckNoThunksEvery lgrAppMode nBks)              = mkAnalysis $ checkNoThunksEvery lgrAppMode nBks
     go TraceLedgerProcessing                             = mkAnalysis $ traceLedgerProcessing
     go (ReproMempoolAndForge nBks)                       = mkAnalysis $ reproMempoolForge nBks
     go (BenchmarkLedgerOps mOutfile lgrAppMode)          = mkAnalysis $ benchmarkLedgerOps mOutfile lgrAppMode
@@ -381,10 +385,10 @@ storeLedgerStateAt ::
      , LedgerSupportsProtocol blk
      )
   => SlotNo
-  -> LedgerApplicationMode
+  -> ApplyOpts
   -> Flag "DoDiskSnapshotChecksum"
   -> Analysis blk StartFromLedgerState
-storeLedgerStateAt slotNo ledgerAppMode doChecksum env = do
+storeLedgerStateAt slotNo appOpts doChecksum env = do
     void $ processAllUntil db registry GetBlock startFrom limit initLedger process
     pure Nothing
   where
@@ -405,9 +409,7 @@ storeLedgerStateAt slotNo ledgerAppMode doChecksum env = do
           storeLedgerState oldLedger
           pure (Stop, oldLedger)
 
-    tickThenXApply = case ledgerAppMode of
-        LedgerReapply -> pure ..: tickThenReapply
-        LedgerApply   -> tickThenApply
+    tickThenXApply = tickThenApplyWithOpts appOpts
 
     continue :: blk -> NextStep
     continue blk
@@ -458,9 +460,11 @@ checkNoThunksEvery ::
   ( HasAnalysis blk,
     LedgerSupportsProtocol blk
   ) =>
+  ApplyOpts ->
   Word64 ->
   Analysis blk StartFromLedgerState
 checkNoThunksEvery
+  applyOpts
   nBlocks
   (AnalysisEnv {db, registry, startFrom, cfg, limit}) = do
     putStrLn $
@@ -473,7 +477,7 @@ checkNoThunksEvery
     process :: ExtLedgerState blk -> blk -> IO (ExtLedgerState blk)
     process oldLedger blk = do
       let ledgerCfg     = ExtLedgerCfg cfg
-          appliedResult = tickThenApplyLedgerResult ledgerCfg blk oldLedger
+          appliedResult = tickThenApplyLedgerResultWithOpts applyOpts ledgerCfg blk oldLedger
           newLedger     = either (error . show) lrResult $ runExcept $ appliedResult
           bn            = blockNo blk
       when (unBlockNo bn `mod` nBlocks == 0 ) $ IOLike.evaluate (ledgerState newLedger) >>= checkNoThunks bn
@@ -511,7 +515,7 @@ traceLedgerProcessing
       -> IO (ExtLedgerState blk)
     process oldLedger blk = do
       let ledgerCfg     = ExtLedgerCfg cfg
-          appliedResult = tickThenApplyLedgerResult ledgerCfg blk oldLedger
+          appliedResult = tickThenApplyLedgerResultWithOpts (ApplyOpts ValidationOn OmitLedgerEvents) ledgerCfg blk oldLedger
           newLedger     = either (error . show) lrResult $ runExcept $ appliedResult
           traces        =
             (HasAnalysis.emitTraces $
@@ -542,14 +546,14 @@ benchmarkLedgerOps ::
      , LedgerSupportsProtocol blk
      )
   => Maybe FilePath
-  -> LedgerApplicationMode
+  -> ApplyOpts
   -> Analysis blk StartFromLedgerState
-benchmarkLedgerOps mOutfile ledgerAppMode AnalysisEnv {db, registry, startFrom, cfg, limit} = do
+benchmarkLedgerOps mOutfile applyOpts AnalysisEnv {db, registry, startFrom, cfg, limit} = do
     -- We default to CSV when the no output file is provided (and thus the results are output to stdout).
     outFormat <- F.getOutputFormat mOutfile
 
     withFile mOutfile $ \outFileHandle -> do
-      F.writeMetadata outFileHandle outFormat ledgerAppMode
+      F.writeMetadata outFileHandle outFormat applyOpts
       F.writeHeader   outFileHandle outFormat
 
       void $ processAll
@@ -654,31 +658,31 @@ benchmarkLedgerOps mOutfile ledgerAppMode AnalysisEnv {db, registry, startFrom,
              LedgerView (BlockProtocol blk)
           -> Ticked (HeaderState blk)
           -> IO (HeaderState blk)
-        applyTheHeader ledgerView tickedHeaderState = case ledgerAppMode of
-          LedgerApply ->
+        applyTheHeader ledgerView tickedHeaderState = case validation applyOpts of
+          ValidationOn ->
             case runExcept $ validateHeader cfg ledgerView (getHeader blk) tickedHeaderState of
               Left err -> fail $ "benchmark doesn't support invalid headers: " <> show rp <> " " <> show err
               Right x -> pure x
-          LedgerReapply ->
+          ValidationOff ->
             pure $! revalidateHeader cfg ledgerView (getHeader blk) tickedHeaderState
 
         tickTheLedgerState ::
              SlotNo
           -> ExtLedgerState blk
           -> IO (Ticked (LedgerState blk))
         tickTheLedgerState slot st =
-            pure $ applyChainTick lcfg slot (ledgerState st)
+            pure $ applyChainTick (events applyOpts) lcfg slot (ledgerState st)
 
         applyTheBlock ::
              Ticked (LedgerState blk)
           -> IO (LedgerState blk)
-        applyTheBlock tickedLedgerSt = case ledgerAppMode of
-          LedgerApply ->
-            case runExcept (lrResult <$> applyBlockLedgerResult lcfg blk tickedLedgerSt) of
+        applyTheBlock tickedLedgerSt = case validation applyOpts of
+          ValidationOn ->
+            case runExcept (lrResult <$> applyBlockLedgerResultWithOpts applyOpts lcfg blk tickedLedgerSt) of
               Left err -> fail $ "benchmark doesn't support invalid blocks: " <> show rp <> " " <> show err
               Right x  -> pure x
-          LedgerReapply ->
-            pure $! lrResult $ reapplyBlockLedgerResult lcfg blk tickedLedgerSt
+          ValidationOff ->
+            pure $! lrResult $ reapplyBlockLedgerResult (events applyOpts) lcfg blk tickedLedgerSt
 
 withFile :: Maybe FilePath -> (IO.Handle -> IO r) -> IO r
 withFile (Just outfile) = IO.withFile outfile IO.WriteMode
@@ -707,7 +711,7 @@ getBlockApplicationMetrics (NumberOfBlocks nrBlocks) mOutFile env = do
 
     process :: IO.Handle -> ExtLedgerState blk -> blk -> IO (ExtLedgerState blk)
     process outFileHandle currLedgerSt blk = do
-      let nextLedgerSt = tickThenReapply (ExtLedgerCfg cfg) blk currLedgerSt
+      let nextLedgerSt = tickThenReapply OmitLedgerEvents (ExtLedgerCfg cfg) blk currLedgerSt
       when (unBlockNo (blockNo blk) `mod` nrBlocks == 0) $ do
           let blockApplication =
                 HasAnalysis.WithLedgerState blk
@@ -830,7 +834,7 @@ reproMempoolForge numBlks env = do
           do
             let slot = blockSlot blk
             (ticked, durTick, mutTick, gcTick) <- timed $ IOLike.evaluate $
-              applyChainTick lCfg slot (ledgerState st)
+              applyChainTick OmitLedgerEvents lCfg slot (ledgerState st)
             ((), durSnap, mutSnap, gcSnap) <- timed $ IOLike.atomically $ do
               snap <- Mempool.getSnapshotFor mempool $ Mempool.ForgeInKnownSlot slot ticked
 
@@ -858,7 +862,7 @@ reproMempoolForge numBlks env = do
           -- since it currently matches the call in the forging thread, which is
           -- the primary intention of this Analysis. Maybe GHC's CSE is already
           -- doing this sharing optimization?
-          IOLike.atomically $ IOLike.writeTVar ref $! tickThenReapply elCfg blk st
+          IOLike.atomically $ IOLike.writeTVar ref $! tickThenReapply OmitLedgerEvents elCfg blk st
 
           -- this flushes blk from the mempool, since every tx in it is now on the chain
           void $ Mempool.syncWithLedger mempool

ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis/BenchmarkLedgerOps/FileWriting.hs

@@ -16,9 +16,9 @@ import           Cardano.Tools.DBAnalyser.Analysis.BenchmarkLedgerOps.SlotDataPo
                      (SlotDataPoint)
 import qualified Cardano.Tools.DBAnalyser.Analysis.BenchmarkLedgerOps.SlotDataPoint as DP
 import qualified Cardano.Tools.DBAnalyser.CSV as CSV
-import           Cardano.Tools.DBAnalyser.Types (LedgerApplicationMode)
 import           Data.Aeson as Aeson
 import qualified Data.ByteString.Lazy as BSL
+import           Ouroboros.Consensus.Ledger.Abstract
 import           System.FilePath.Posix (takeExtension)
 import qualified System.IO as IO
 import qualified Text.Builder as Builder
@@ -87,7 +87,7 @@ writeDataPoint outFileHandle JSON slotDataPoint =
 
 -- | Write metadata to a JSON file if this is the selected
 -- format. Perform a no-op otherwise.
-writeMetadata :: IO.Handle -> OutputFormat -> LedgerApplicationMode -> IO ()
+writeMetadata :: IO.Handle -> OutputFormat -> ApplyOpts -> IO ()
 writeMetadata _outFileHandle CSV _lgrAppMode = pure ()
 writeMetadata  outFileHandle JSON lgrAppMode =
   BenchmarkLedgerOps.Metadata.getMetadata lgrAppMode

ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis/BenchmarkLedgerOps/Metadata.hs

@@ -15,7 +15,6 @@ module Cardano.Tools.DBAnalyser.Analysis.BenchmarkLedgerOps.Metadata (
   , getMetadata
   ) where
 
-import           Cardano.Tools.DBAnalyser.Types (LedgerApplicationMode (..))
 import           Cardano.Tools.GitRev (gitRev)
 import           Data.Aeson (ToJSON)
 import qualified Data.Aeson as Aeson
@@ -24,6 +23,7 @@ import qualified Data.Version
 import           Data.Word (Word32, Word64)
 import           GHC.Generics (Generic)
 import qualified GHC.RTS.Flags as RTS
+import           Ouroboros.Consensus.Ledger.Abstract
 import qualified System.Info
 
 data Metadata = Metadata {
@@ -42,7 +42,7 @@ data Metadata = Metadata {
 instance ToJSON Metadata where
   toEncoding = Aeson.genericToEncoding Aeson.defaultOptions
 
-getMetadata :: LedgerApplicationMode -> IO Metadata
+getMetadata :: ApplyOpts -> IO Metadata
 getMetadata lgrAppMode = do
   rtsFlags <- RTS.getRTSFlags
   pure $ Metadata {
@@ -55,7 +55,7 @@ getMetadata lgrAppMode = do
     , operatingSystem             = System.Info.os
     , machineArchitecture         = System.Info.arch
     , gitRevison                  = T.unpack gitRev
-    , ledgerApplicationMode       = case lgrAppMode of
-        LedgerApply   -> "full-application"
-        LedgerReapply -> "reapplication"
+    , ledgerApplicationMode       = case validation lgrAppMode of
+        ValidationOn  -> "full-application"
+        ValidationOff -> "reapplication"
     }