From ef95f0ae1ec6a6c178e40a00abbff2a15e5762bf Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Fri, 14 Feb 2025 12:08:20 +0100 Subject: [PATCH] Propagate ApplyOpts to tests and executables --- .../app/DBAnalyser/Parsers.hs | 37 +++++++----- .../Test/Consensus/Byron/Examples.hs | 10 ++-- .../Consensus/ByronSpec/Ledger/Ledger.hs | 8 +-- .../Test/ThreadNet/TxGen/Cardano.hs | 6 +- .../Cardano/Tools/DBAnalyser/Analysis.hs | 60 ++++++++++--------- .../BenchmarkLedgerOps/FileWriting.hs | 4 +- .../Analysis/BenchmarkLedgerOps/Metadata.hs | 10 ++-- .../Cardano/Tools/DBAnalyser/Run.hs | 5 +- .../Cardano/Tools/DBAnalyser/Types.hs | 14 ++--- .../Cardano/Tools/DBSynthesizer/Forging.hs | 1 + .../Cardano/Tools/DBSynthesizer/Run.hs | 3 +- .../Test/ThreadNet/TxGen/Shelley.hs | 2 +- .../byron-test/Test/ThreadNet/DualByron.hs | 2 +- .../shelley-test/Test/ThreadNet/Shelley.hs | 2 +- .../test/tools-test/Main.hs | 2 +- .../Test/ThreadNet/Network.hs | 7 ++- .../Test/Consensus/HardFork/Combinator/A.hs | 8 +-- .../Test/Consensus/HardFork/Combinator/B.hs | 6 +- .../Ouroboros/Consensus/Ledger/Dual.hs | 33 +++++----- .../Test/Util/ChainDB.hs | 3 +- .../Test/Util/TestBlock.hs | 6 +- .../Ouroboros/Consensus/Mock/Ledger/Block.hs | 9 ++- .../Ouroboros/Consensus/Tutorial/Simple.lhs | 34 +++++------ .../Consensus/Tutorial/WithEpoch.lhs | 54 ++++++++--------- .../MiniProtocol/ChainSync/Client.hs | 2 +- .../MiniProtocol/LocalStateQuery/Server.hs | 3 +- .../Test/Ouroboros/Storage/ChainDB/Model.hs | 3 +- .../Ouroboros/Storage/LedgerDB/InMemory.hs | 5 +- .../Test/Ouroboros/Storage/LedgerDB/OnDisk.hs | 3 +- .../Test/Ouroboros/Storage/TestBlock.hs | 6 +- 30 files changed, 182 insertions(+), 166 deletions(-) diff --git a/ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs b/ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs index bf0f73b3f6..4c069ee055 100644 --- a/ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs +++ b/ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs @@ -129,13 +129,7 @@ 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" @@ -143,10 +137,27 @@ storeLedgerParser = do , "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 diff --git a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs b/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs index 9626d98aa9..1176d0f5b3 100644 --- a/ouroboros-consensus-cardano/src/unstable-byron-testlib/Test/Consensus/Byron/Examples.hs +++ b/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 diff --git a/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Ledger.hs b/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Ledger.hs index 685056d3f3..7cae39eedc 100644 --- a/ouroboros-consensus-cardano/src/unstable-byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Ledger.hs +++ b/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 diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/TxGen/Cardano.hs b/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/TxGen/Cardano.hs index 961a7b5555..52ad5f1921 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/TxGen/Cardano.hs +++ b/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 diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs index 6dfd65d6b2..0e359f464f 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs +++ b/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,12 +658,12 @@ 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 :: @@ -667,18 +671,18 @@ benchmarkLedgerOps mOutfile ledgerAppMode AnalysisEnv {db, registry, startFrom, -> 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 diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis/BenchmarkLedgerOps/FileWriting.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis/BenchmarkLedgerOps/FileWriting.hs index eedac27b88..d7cfcfdd20 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis/BenchmarkLedgerOps/FileWriting.hs +++ b/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 diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis/BenchmarkLedgerOps/Metadata.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis/BenchmarkLedgerOps/Metadata.hs index d55a31ac1f..0b66654b5c 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis/BenchmarkLedgerOps/Metadata.hs +++ b/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" } diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs index e0667020bf..de26bdce68 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs @@ -51,7 +51,7 @@ analyse :: => DBAnalyserConfig -> Args blk -> IO (Maybe AnalysisResult) -analyse DBAnalyserConfig{analysis, confLimit, dbDir, selectDB, validation, verbose, diskSnapshotChecksumOnRead} args = +analyse DBAnalyserConfig{analysis, confLimit, dbDir, selectDB, dbValidation, verbose, diskSnapshotChecksumOnRead} args = withRegistry $ \registry -> do lock <- newMVar () chainDBTracer <- mkTracer lock verbose @@ -70,6 +70,7 @@ analyse DBAnalyserConfig{analysis, confLimit, dbDir, selectDB, validation, verbo (const True) (Node.stdMkChainDbHasFS dbDir) (Node.stdMkChainDbHasFS dbDir) + (ApplyOpts ValidationOff OmitLedgerEvents) $ defaultArgs immutableDbArgs = ChainDB.cdbImmDbArgs chainDbArgs ledgerDbFS = lgrHasFS $ ChainDB.cdbLgrDbArgs chainDbArgs @@ -138,7 +139,7 @@ analyse DBAnalyserConfig{analysis, confLimit, dbDir, selectDB, validation, verbo where withLock = bracket_ (takeMVar lock) (putMVar lock ()) - maybeValidateAll = case (analysis, validation) of + maybeValidateAll = case (analysis, dbValidation) of (_, Just ValidateAllBlocks) -> ensureValidateAll (_, Just MinimumBlockValidation) -> id (OnlyValidation, _ ) -> ensureValidateAll diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Types.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Types.hs index ddea8b5347..4992c5e1cf 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Types.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Types.hs @@ -5,6 +5,7 @@ module Cardano.Tools.DBAnalyser.Types (module Cardano.Tools.DBAnalyser.Types) wh import Data.Word import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Util (Flag) data SelectDB = @@ -14,7 +15,7 @@ data DBAnalyserConfig = DBAnalyserConfig { dbDir :: FilePath , verbose :: Bool , selectDB :: SelectDB - , validation :: Maybe ValidateBlocks + , dbValidation :: Maybe ValidateBlocks , analysis :: AnalysisName , confLimit :: Limit , diskSnapshotChecksumOnRead :: Flag "DoDiskSnapshotChecksum" @@ -27,11 +28,11 @@ data AnalysisName = | ShowBlockTxsSize | ShowEBBs | OnlyValidation - | StoreLedgerStateAt SlotNo LedgerApplicationMode (Flag "DoDiskSnapshotChecksum") + | StoreLedgerStateAt SlotNo ApplyOpts (Flag "DoDiskSnapshotChecksum") | CountBlocks - | CheckNoThunksEvery Word64 + | CheckNoThunksEvery ApplyOpts Word64 | TraceLedgerProcessing - | BenchmarkLedgerOps (Maybe FilePath) LedgerApplicationMode + | BenchmarkLedgerOps (Maybe FilePath) ApplyOpts | ReproMempoolAndForge Int -- | Compute different block application metrics every 'NumberOfBlocks'. -- @@ -53,8 +54,3 @@ data Limit = Limit Int | Unlimited -- | The extent of the ChainDB on-disk files validation. This is completely -- unrelated to validation of the ledger rules. data ValidateBlocks = ValidateAllBlocks | MinimumBlockValidation - --- | Whether to apply blocks to a ledger state via /reapplication/ (eg skipping --- signature checks/Plutus scripts) or full /application/ (much slower). -data LedgerApplicationMode = LedgerReapply | LedgerApply - deriving (Eq, Show) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs index f49771ea4a..1b15158cb9 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Forging.hs @@ -160,6 +160,7 @@ runForge epochSize_ nextSlot opts chainDB blockForging cfg genTxs = do let tickedLedgerState :: Ticked (LedgerState blk) tickedLedgerState = applyChainTick + OmitLedgerEvents (configLedger cfg) currentSlot (ledgerState unticked) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs index cc88fbd694..d677fff3e7 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs @@ -26,6 +26,7 @@ import qualified Data.Set as Set import Ouroboros.Consensus.Cardano.Block import Ouroboros.Consensus.Cardano.Node import Ouroboros.Consensus.Config (TopLevelConfig, configStorage) +import Ouroboros.Consensus.Ledger.Abstract import qualified Ouroboros.Consensus.Node as Node (stdMkChainDbHasFS) import qualified Ouroboros.Consensus.Node.InitStorage as Node (nodeImmutableDbChunkInfo) @@ -41,7 +42,6 @@ import Ouroboros.Network.Point (WithOrigin (..)) import System.Directory import System.FilePath (takeDirectory, ()) - initialize :: NodeFilePaths -> NodeCredentials @@ -132,6 +132,7 @@ synthesize genTxs DBSynthesizerConfig{confOptions, confShelleyGenesis, confDbDir (const True) (Node.stdMkChainDbHasFS confDbDir) (Node.stdMkChainDbHasFS confDbDir) + (ApplyOpts ValidationOn OmitLedgerEvents) $ ChainDB.defaultArgs forgers <- blockForging diff --git a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/TxGen/Shelley.hs b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/TxGen/Shelley.hs index 90d8dd5dad..9e47eb74bc 100644 --- a/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/TxGen/Shelley.hs +++ b/ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/ThreadNet/TxGen/Shelley.hs @@ -62,7 +62,7 @@ instance HashAlgorithm h => TxGen (ShelleyBlock (TPraos (MockCrypto h)) (MockShe then pure [] else do n <- choose (0, 20) - go [] n $ applyChainTick lcfg curSlotNo lst + go [] n $ applyChainTick OmitLedgerEvents lcfg curSlotNo lst where ShelleyTxGenExtra { stgeGenEnv diff --git a/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/DualByron.hs b/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/DualByron.hs index d06d4ef4dc..f0daf083ad 100644 --- a/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/DualByron.hs +++ b/ouroboros-consensus-cardano/test/byron-test/Test/ThreadNet/DualByron.hs @@ -257,7 +257,7 @@ byronPBftParams ByronSpecGenesis{..} = instance TxGen DualByronBlock where testGenTxs _coreNodeId _numCoreNodes curSlotNo cfg () = \st -> do n <- choose (0, 20) - go [] n $ applyChainTick (configLedger cfg) curSlotNo st + go [] n $ applyChainTick OmitLedgerEvents (configLedger cfg) curSlotNo st where -- Attempt to produce @n@ transactions -- Stops when the transaction generator cannot produce more txs diff --git a/ouroboros-consensus-cardano/test/shelley-test/Test/ThreadNet/Shelley.hs b/ouroboros-consensus-cardano/test/shelley-test/Test/ThreadNet/Shelley.hs index c75fb66f8f..fadf7e5a03 100644 --- a/ouroboros-consensus-cardano/test/shelley-test/Test/ThreadNet/Shelley.hs +++ b/ouroboros-consensus-cardano/test/shelley-test/Test/ThreadNet/Shelley.hs @@ -314,7 +314,7 @@ prop_simple_real_tpraos_convergence TestSetup -- slots to reach the epoch transition but the last several -- slots end up empty. Shelley.tickedShelleyLedgerState $ - applyChainTick ledgerConfig sentinel lsUnticked + applyChainTick OmitLedgerEvents ledgerConfig sentinel lsUnticked msg = "The ticked final ledger state of " <> show nid <> diff --git a/ouroboros-consensus-cardano/test/tools-test/Main.hs b/ouroboros-consensus-cardano/test/tools-test/Main.hs index 2b556a6ba9..f8f1695e45 100644 --- a/ouroboros-consensus-cardano/test/tools-test/Main.hs +++ b/ouroboros-consensus-cardano/test/tools-test/Main.hs @@ -69,7 +69,7 @@ testAnalyserConfig = dbDir = chainDB , verbose = False , selectDB = SelectImmutableDB Origin - , validation = Just ValidateAllBlocks + , dbValidation = Just ValidateAllBlocks , analysis = CountBlocks , confLimit = Unlimited , diskSnapshotChecksumOnRead = NoDoDiskSnapshotChecksum diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs index d7dd9e75cc..f62e6748b5 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs @@ -622,11 +622,11 @@ runThreadNetwork systemTime ThreadNetworkArgs snap1 <- getSnapshotFor mempool $ -- This node would include these crucial txs if it leads in -- this slot. - ForgeInKnownSlot slot $ applyChainTick lcfg slot ledger + ForgeInKnownSlot slot $ applyChainTick OmitLedgerEvents lcfg slot ledger snap2 <- getSnapshotFor mempool $ -- Other nodes might include these crucial txs when leading -- in the next slot. - ForgeInKnownSlot (succ slot) $ applyChainTick lcfg (succ slot) ledger + ForgeInKnownSlot (succ slot) $ applyChainTick OmitLedgerEvents lcfg (succ slot) ledger -- This loop will repeat for the next slot, so we only need to -- check for this one and the next. pure (snap1, snap2) @@ -887,10 +887,11 @@ runThreadNetwork systemTime ThreadNetworkArgs -- fail if the EBB is invalid -- if it is valid, we retick to the /same/ slot - let apply = applyLedgerBlock (configLedger pInfoConfig) + let apply = applyLedgerBlockWithOpts (ApplyOpts ValidationOn OmitLedgerEvents) (configLedger pInfoConfig) tickedLdgSt' <- case Exc.runExcept $ apply ebb tickedLdgSt of Left e -> Exn.throw $ JitEbbError @blk e Right st -> pure $ applyChainTick + OmitLedgerEvents (configLedger pInfoConfig) currentSlot st diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs index 4aa3b65074..cf895e0f8e 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs @@ -81,7 +81,7 @@ import Ouroboros.Consensus.Node.Serialisation import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ImmutableDB (simpleChunkInfo) import Ouroboros.Consensus.Storage.Serialisation -import Ouroboros.Consensus.Util (repeatedlyM, (..:), (.:)) +import Ouroboros.Consensus.Util (repeatedlyM, (...:), (.:)) import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.Orphans () import Ouroboros.Network.Block (Serialised, unwrapCBORinCBOR, @@ -213,10 +213,10 @@ instance IsLedger (LedgerState BlockA) where type AuxLedgerEvent (LedgerState BlockA) = VoidLedgerEvent (LedgerState BlockA) - applyChainTickLedgerResult _ _ = pureLedgerResult . TickedLedgerStateA + applyChainTickLedgerResult _ _ _ = pureLedgerResult . TickedLedgerStateA instance ApplyBlock (LedgerState BlockA) BlockA where - applyBlockLedgerResult cfg blk = + applyBlockLedgerResultWithOpts _opts cfg blk = fmap (pureLedgerResult . setTip) . repeatedlyM (fmap fst .: applyTx cfg DoNotIntervene (blockSlot blk)) @@ -226,7 +226,7 @@ instance ApplyBlock (LedgerState BlockA) BlockA where setTip (TickedLedgerStateA st) = st { lgrA_tip = blockPoint blk } reapplyBlockLedgerResult = - dontExpectError ..: applyBlockLedgerResult + dontExpectError ...: (applyBlockLedgerResultWithOpts . ApplyOpts ValidationOff) where dontExpectError :: Except a b -> b dontExpectError mb = case runExcept mb of diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs index 7c45c64137..e0dc9fee15 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs @@ -186,11 +186,11 @@ instance IsLedger (LedgerState BlockB) where type AuxLedgerEvent (LedgerState BlockB) = VoidLedgerEvent (LedgerState BlockB) - applyChainTickLedgerResult _ _ = pureLedgerResult . TickedLedgerStateB + applyChainTickLedgerResult _ _ _ = pureLedgerResult . TickedLedgerStateB instance ApplyBlock (LedgerState BlockB) BlockB where - applyBlockLedgerResult = \_ b _ -> return $ pureLedgerResult $ LgrB (blockPoint b) - reapplyBlockLedgerResult = \_ b _ -> pureLedgerResult $ LgrB (blockPoint b) + applyBlockLedgerResultWithOpts = \_ _ b _ -> return $ pureLedgerResult $ LgrB (blockPoint b) + reapplyBlockLedgerResult = \_ _ b _ -> pureLedgerResult $ LgrB (blockPoint b) instance UpdateLedger BlockB diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs index a5dc517634..812ece8228 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs @@ -359,12 +359,13 @@ instance Bridge m a => IsLedger (LedgerState (DualBlock m a)) where -- any events. So we make this easy choice for for now. type AuxLedgerEvent (LedgerState (DualBlock m a)) = AuxLedgerEvent (LedgerState m) - applyChainTickLedgerResult DualLedgerConfig{..} + applyChainTickLedgerResult evs + DualLedgerConfig{..} slot DualLedgerState{..} = castLedgerResult ledgerResult <&> \main -> TickedDualLedgerState { tickedDualLedgerStateMain = main - , tickedDualLedgerStateAux = applyChainTick + , tickedDualLedgerStateAux = applyChainTick evs dualLedgerConfigAux slot dualLedgerStateAux @@ -372,23 +373,23 @@ instance Bridge m a => IsLedger (LedgerState (DualBlock m a)) where , tickedDualLedgerStateBridge = dualLedgerStateBridge } where - ledgerResult = applyChainTickLedgerResult + ledgerResult = applyChainTickLedgerResult evs dualLedgerConfigMain slot dualLedgerStateMain instance Bridge m a => ApplyBlock (LedgerState (DualBlock m a)) (DualBlock m a) where - applyBlockLedgerResult cfg + applyBlockLedgerResultWithOpts opts cfg block@DualBlock{..} TickedDualLedgerState{..} = do (ledgerResult, aux') <- agreeOnError DualLedgerError ( - applyBlockLedgerResult + applyBlockLedgerResultWithOpts opts (dualLedgerConfigMain cfg) dualBlockMain tickedDualLedgerStateMain - , applyMaybeBlock + , applyMaybeBlock opts (dualLedgerConfigAux cfg) dualBlockAux tickedDualLedgerStateAux @@ -402,12 +403,12 @@ instance Bridge m a => ApplyBlock (LedgerState (DualBlock m a)) (DualBlock m a) tickedDualLedgerStateBridge } - reapplyBlockLedgerResult cfg + reapplyBlockLedgerResult evs cfg block@DualBlock{..} TickedDualLedgerState{..} = castLedgerResult ledgerResult <&> \main' -> DualLedgerState { dualLedgerStateMain = main' - , dualLedgerStateAux = reapplyMaybeBlock + , dualLedgerStateAux = reapplyMaybeBlock evs (dualLedgerConfigAux cfg) dualBlockAux tickedDualLedgerStateAux @@ -417,7 +418,7 @@ instance Bridge m a => ApplyBlock (LedgerState (DualBlock m a)) (DualBlock m a) tickedDualLedgerStateBridge } where - ledgerResult = reapplyBlockLedgerResult + ledgerResult = reapplyBlockLedgerResult evs (dualLedgerConfigMain cfg) dualBlockMain tickedDualLedgerStateMain @@ -766,25 +767,27 @@ type instance ForgeStateUpdateError (DualBlock m a) = ForgeStateUpdateError m -- -- Returns state unchanged on 'Nothing' applyMaybeBlock :: UpdateLedger blk - => LedgerConfig blk + => ApplyOpts + -> LedgerConfig blk -> Maybe blk -> TickedLedgerState blk -> LedgerState blk -> Except (LedgerError blk) (LedgerState blk) -applyMaybeBlock _ Nothing _ st = return st -applyMaybeBlock cfg (Just block) tst _ = applyLedgerBlock cfg block tst +applyMaybeBlock _ _ Nothing _ st = return st +applyMaybeBlock opts cfg (Just block) tst _ = applyLedgerBlockWithOpts opts cfg block tst -- | Lift 'reapplyLedgerBlock' to @Maybe blk@ -- -- See also 'applyMaybeBlock' reapplyMaybeBlock :: UpdateLedger blk - => LedgerConfig blk + => ComputeLedgerEvents + -> LedgerConfig blk -> Maybe blk -> TickedLedgerState blk -> LedgerState blk -> LedgerState blk -reapplyMaybeBlock _ Nothing _ st = st -reapplyMaybeBlock cfg (Just block) tst _ = reapplyLedgerBlock cfg block tst +reapplyMaybeBlock _ _ Nothing _ st = st +reapplyMaybeBlock evs cfg (Just block) tst _ = reapplyLedgerBlock evs cfg block tst -- | Used when the concrete and abstract implementation should agree on errors -- diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs index 493bc743c8..9da885b3fa 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs @@ -19,6 +19,7 @@ import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Config (TopLevelConfig (topLevelConfigLedger), configCodec) import Ouroboros.Consensus.HardFork.History.EraParams (eraEpochSize) +import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended (ExtLedgerState) import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ChainDB hiding @@ -117,7 +118,7 @@ fromMinimalChainDbArgs MinimalChainDbArgs {..} = ChainDbArgs { , lgrGenesis = return mcdbInitLedger , lgrHasFS = SomeHasFS $ simHasFS (nodeDBsLgr mcdbNodeDBs) , lgrTracer = nullTracer - , lgrConfig = configLedgerDb mcdbTopLevelConfig + , lgrConfig = configLedgerDb mcdbTopLevelConfig (ApplyOpts ValidationOn OmitLedgerEvents) } , cdbsArgs = ChainDbSpecificArgs { cdbsBlocksToAddSize = 1 diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs index 5ed7674f03..02f5d91d9b 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/TestBlock.hs @@ -490,7 +490,7 @@ instance ( Typeable ptype instance PayloadSemantics ptype => ApplyBlock (LedgerState (TestBlockWith ptype)) (TestBlockWith ptype) where - applyBlockLedgerResult _ tb@TestBlockWith{..} (TickedTestLedger TestLedger{..}) + applyBlockLedgerResultWithOpts _opts _ tb@TestBlockWith{..} (TickedTestLedger TestLedger{..}) | blockPrevHash tb /= pointHash lastAppliedPoint = throwError $ InvalidHash (pointHash lastAppliedPoint) (blockPrevHash tb) | tbValid == Invalid @@ -504,7 +504,7 @@ instance PayloadSemantics ptype , payloadDependentState = st' } - reapplyBlockLedgerResult _ tb@TestBlockWith{..} (TickedTestLedger TestLedger{..}) = + reapplyBlockLedgerResult _evs _ tb@TestBlockWith{..} (TickedTestLedger TestLedger{..}) = case applyPayload payloadDependentState tbPayload of Left err -> error $ "Found an error when reapplying a block: " ++ show err Right st' -> pureLedgerResult @@ -573,7 +573,7 @@ instance PayloadSemantics ptype => IsLedger (LedgerState (TestBlockWith ptype)) type AuxLedgerEvent (LedgerState (TestBlockWith ptype)) = VoidLedgerEvent (LedgerState (TestBlockWith ptype)) - applyChainTickLedgerResult _ _ = pureLedgerResult . TickedTestLedger + applyChainTickLedgerResult _opts _ _ = pureLedgerResult . TickedTestLedger instance PayloadSemantics ptype => UpdateLedger (TestBlockWith ptype) diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs index f6db8e90cf..49cff3b2dd 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs @@ -94,8 +94,7 @@ import Ouroboros.Consensus.Mock.Ledger.State import qualified Ouroboros.Consensus.Mock.Ledger.UTxO as Mock import Ouroboros.Consensus.Storage.Common (BinaryBlockInfo (..), SizeInBytes) -import Ouroboros.Consensus.Util (ShowProxy (..), hashFromBytesShortE, - (..:)) +import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.Condense import Test.Util.Orphans.Serialise () @@ -351,14 +350,14 @@ instance MockProtocolSpecific c ext type AuxLedgerEvent (LedgerState (SimpleBlock c ext)) = VoidLedgerEvent (SimpleBlock c ext) - applyChainTickLedgerResult _ _ = pureLedgerResult . TickedSimpleLedgerState + applyChainTickLedgerResult _ _ _ = pureLedgerResult . TickedSimpleLedgerState instance MockProtocolSpecific c ext => ApplyBlock (LedgerState (SimpleBlock c ext)) (SimpleBlock c ext) where - applyBlockLedgerResult = fmap pureLedgerResult ..: updateSimpleLedgerState + applyBlockLedgerResultWithOpts _opts = fmap pureLedgerResult ..: updateSimpleLedgerState reapplyBlockLedgerResult = - (mustSucceed . runExcept) ..: applyBlockLedgerResult + (mustSucceed . runExcept) ...: (applyBlockLedgerResultWithOpts . ApplyOpts ValidationOff) where mustSucceed (Left err) = error ("reapplyBlockLedgerResult: unexpected error: " <> show err) mustSucceed (Right st) = st diff --git a/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/Simple.lhs b/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/Simple.lhs index 69af4e6f8d..311329d390 100644 --- a/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/Simple.lhs +++ b/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/Simple.lhs @@ -130,34 +130,34 @@ Next, we instantiate the `ConsensusProtocol` for `SP`: > instance ConsensusProtocol SP where > type SelectView SP = BlockNo -> + > type LedgerView SP = () -> + > type IsLeader SP = SP_IsLeader > type CanBeLeader SP = SP_CanBeLeader -> + > type ChainDepState SP = () > type ValidateView SP = () > type ValidationErr SP = Void -> + > checkIsLeader cfg SP_CanBeLeader slot _tcds = > if slot `Set.member` cfgsp_slotsLedByMe cfg > then Just SP_IsLeader > else Nothing -> + > protocolSecurityParam _cfg = k -> + > tickChainDepState _ _ _ _ = TickedTrivial -> + > updateChainDepState _ _ _ _ = return () -> + > reupdateChainDepState _ _ _ _ = () Finally we define a few extra things used in this instantiation: > data SP_CanBeLeader = SP_CanBeLeader -- Evidence that we /can/ be a leader > data SP_IsLeader = SP_IsLeader -- Evidence that we /are/ leader -> + > k :: SecurityParam > k = SecurityParam { maxRollbacks = 1 } @@ -523,7 +523,7 @@ number, we materialize that number in the `LedgerState`. We'll also need to keep track of some information about the most recent block we have seen. > data instance LedgerState BlockC = -> + > LedgerC > -- the hash and slot number of the most recent block > { lsbc_tip :: Point BlockC @@ -558,8 +558,8 @@ types for a ledger. Though we are here using > instance IsLedger (LedgerState BlockC) where > type instance LedgerErr (LedgerState BlockC) = Void > type instance AuxLedgerEvent (LedgerState BlockC) = Void -> -> applyChainTickLedgerResult _cfg _slot ldgrSt = + +> applyChainTickLedgerResult _evs _cfg _slot ldgrSt = > LedgerResult { lrEvents = [] > , lrResult = TickedLedgerStateC ldgrSt > } @@ -609,17 +609,17 @@ The interface used by the rest of the ledger infrastructure to access this is the `ApplyBlock` typeclass: > instance ApplyBlock (LedgerState BlockC) BlockC where -> applyBlockLedgerResult _ldgrCfg block tickedLdgrSt = +> applyBlockLedgerResultWithOpts _opts _ldgrCfg block tickedLdgrSt = > pure $ LedgerResult { lrEvents = [] > , lrResult = block `applyBlockTo` tickedLdgrSt > } -> -> reapplyBlockLedgerResult _ldgrCfg block tickedLdgrSt = + +> reapplyBlockLedgerResult _evs _ldgrCfg block tickedLdgrSt = > LedgerResult { lrEvents = [] > , lrResult = block `applyBlockTo` tickedLdgrSt > } -> -> + + `applyBlockLedgerResult` tries to apply a block to the ledger and fails with a `LedgerErr` corresponding to the particular `LedgerState blk` if for whatever diff --git a/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/WithEpoch.lhs b/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/WithEpoch.lhs index bc8345b871..c951952e75 100644 --- a/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/WithEpoch.lhs +++ b/ouroboros-consensus/src/unstable-tutorials/Ouroboros/Consensus/Tutorial/WithEpoch.lhs @@ -73,16 +73,16 @@ And imports, of course: > (BlockSupportsProtocol (..)) > import Ouroboros.Consensus.Protocol.Abstract > (ConsensusConfig, SecurityParam, ConsensusProtocol (..)) -> + > import Ouroboros.Consensus.Ticked (Ticked) > import Ouroboros.Consensus.Ledger.Abstract > (LedgerState, LedgerCfg, GetTip, LedgerResult (..), ApplyBlock (..), > UpdateLedger, IsLedger (..)) -> + > import Ouroboros.Consensus.Ledger.SupportsMempool () > import Ouroboros.Consensus.Ledger.SupportsProtocol > (LedgerSupportsProtocol (..)) -> + > import Ouroboros.Consensus.HeaderValidation > (ValidateEnvelope, BasicEnvelopeValidation, HasAnnTip) > import Ouroboros.Consensus.Forecast @@ -235,10 +235,10 @@ As before, we to implement a few type families to fully specify the header - > instance GetHeader BlockD where > getHeader = bd_header -> + > blockMatchesHeader hdr blk = > hbd_Hash hdr == computeBlockHash blk -> + > headerIsEBB _ = Nothing > instance GetPrevHash BlockD where @@ -353,7 +353,7 @@ intervening blocks are applied: > } > else > ldgrSt -> + > where > isNewEpoch = > case compare @@ -373,8 +373,8 @@ We can now use `tickLedgerStateD` to instantiate `IsLedger`: > instance IsLedger (LedgerState BlockD) where > type instance LedgerErr (LedgerState BlockD) = String > type instance AuxLedgerEvent (LedgerState BlockD) = () -> -> applyChainTickLedgerResult _cfg slot ldgrSt = + +> applyChainTickLedgerResult _evs _cfg slot ldgrSt = > LedgerResult { lrEvents = [] > , lrResult = tickLedgerStateD slot ldgrSt > } @@ -403,12 +403,12 @@ applying each individual transaction - exactly as it was in for `BlockC`: > Dec -> i - 1 > instance ApplyBlock (LedgerState BlockD) BlockD where -> applyBlockLedgerResult _ldgrCfg b tickedLdgrSt = +> applyBlockLedgerResultWithOpts _opts _ldgrCfg b tickedLdgrSt = > pure LedgerResult { lrResult = b `applyBlockTo` tickedLdgrSt > , lrEvents = [] > } -> -> reapplyBlockLedgerResult _ldgrCfg b tickedLdgrSt = + +> reapplyBlockLedgerResult _evs _ldgrCfg b tickedLdgrSt = > LedgerResult { lrResult = b `applyBlockTo` tickedLdgrSt > , lrEvents = [] > } @@ -454,7 +454,7 @@ instance of the `ConsensusProtocol` should be running as: > PrtclD_Config > { ccpd_securityParam :: SecurityParam -- ^ i.e., 'k' > , ccpd_mbCanBeLeader :: Maybe PrtclD_CanBeLeader -> + > -- ^ To lead, a node must have a 'ccpd_mbCanBeLeader' equal to > -- `Just (PrtclD_CanBeLeader nodeid)`. > -- We expect this value would be extracted from a config file. @@ -513,24 +513,24 @@ Now we can instantiate `ConsensusProtocol PrtclD` proper with the types and functions defined above: > instance ConsensusProtocol PrtclD where -> + > type ChainDepState PrtclD = ChainDepStateD > type IsLeader PrtclD = PrtclD_IsLeader > type CanBeLeader PrtclD = PrtclD_CanBeLeader -> + > -- | View on a block header required for chain selection. Here, BlockNo is > -- sufficient. (BlockNo is also the default type for this type family.) > type SelectView PrtclD = BlockNo -> + > -- | View on the ledger required by the protocol > type LedgerView PrtclD = LedgerViewD -> + > -- | View on a block header required for header validation > type ValidateView PrtclD = NodeId -- need this for the leader check > -- currently not doing other checks -> + > type ValidationErr PrtclD = String -> + > -- | checkIsLeader - Am I the leader this slot? > checkIsLeader cfg _cbl slot tcds = > case ccpd_mbCanBeLeader cfg of @@ -538,23 +538,23 @@ functions defined above: > -- not providing any cryptographic proof > | isLeader nodeId slot (tickedChainDepLV tcds) -> Just PrtclD_IsLeader > _ -> Nothing -> + > protocolSecurityParam = ccpd_securityParam -> + > tickChainDepState _cfg lv _slot _cds = TickedChainDepStateD lv -> + > -- | apply the header (hdrView) and do a header check. > -- > -- Here we check the block's claim to lead the slot (though in Protocol D, > -- this doesn't give us too much confidence, as there is nothing that > -- precludes a node from masquerading as any other node). -> + > updateChainDepState _cfg hdrView slot tcds = > if isLeader hdrView slot (tickedChainDepLV tcds) then > return ChainDepStateD > else > throwError $ "leader check failed: " ++ show (hdrView,slot) -> + > reupdateChainDepState _ _ _ _ = ChainDepStateD Integration @@ -569,7 +569,7 @@ from the block header, and `selectView` projecting out the block number: > instance BlockSupportsProtocol BlockD where > validateView _bcfg hdr = hbd_nodeId hdr -> + > selectView _bcfg hdr = blockNo hdr All that remains is to establish `PrtclD` as the protocol for @@ -590,7 +590,7 @@ ledger view: (1) the slot (`for` in the code below) is in the current epoch and > protocolLedgerView _ldgrCfg (TickedLedgerStateD ldgrSt) = > LVD $ lsbd_snapshot2 ldgrSt > -- note that we use the snapshot from 2 epochs ago. -> + > -- | Borrowing somewhat from Ouroboros/Consensus/Byron/Ledger/Ledger.hs > ledgerViewForecastAt _lccf ldgrSt = > Forecast { forecastAt = at @@ -617,12 +617,12 @@ ledger view: (1) the slot (`for` in the code below) is in the current epoch and > -- we can forecast into the following epoch because > -- we have the snapshot from 1 epoch ago. > } -> + > where > -- | the current slot that the ledger reflects > at :: WithOrigin SlotNo > at = pointSlot $ lsbd_tip ldgrSt -> + > -- | 'maxFor' is the "exclusive upper bound on the range of the forecast" > -- (the name "max" does seem wrong, but we are following suit with the names > -- and terminology in the 'Ouroboros.Consensus.Forecast' module) diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs index 63e810a572..b07cababbc 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs @@ -776,7 +776,7 @@ computePastLedger cfg pt chain | castPoint (getTip st) == pt = st | blk:blks' <- blks - = go (tickThenReapply (ExtLedgerCfg cfg) blk st) blks' + = go (tickThenReapply OmitLedgerEvents (ExtLedgerCfg cfg) blk st) blks' | otherwise = error "point not in the list of blocks" diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs index 5310647fd7..418c6c7914 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/LocalStateQuery/Server.hs @@ -29,6 +29,7 @@ import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.Config import qualified Ouroboros.Consensus.HardFork.History as HardFork +import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Query (Query (..)) import Ouroboros.Consensus.MiniProtocol.LocalStateQuery.Server @@ -216,7 +217,7 @@ initLgrDB k chain = do blockMapping = Map.fromList [(blockRealPoint b, b) | b <- Chain.toOldestFirst chain] - cfg = configLedgerDb $ testCfg k + cfg = configLedgerDb (testCfg k) (ApplyOpts ValidationOn OmitLedgerEvents) genesisLedgerDB = LgrDB.ledgerDbWithAnchor testInitExtLedger diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs index 0e277dde9d..f3052a9e39 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/Model.hs @@ -352,6 +352,7 @@ getLedgerDB cfg m@Model{..} = ledgerDbCfg = LedgerDbCfg { ledgerDbCfgSecParam = k , ledgerDbCfg = ExtLedgerCfg cfg + , ledgerDbApplyOpts = ApplyOpts ValidationOn OmitLedgerEvents } getLoEFragment :: Model blk -> LoE (AnchoredFragment blk) @@ -741,7 +742,7 @@ validate cfg Model { initLedger, invalid } chain = go ledger validPrefix = \case -- Return 'mbFinal' if it contains an "earlier" result [] -> ValidatedChain validPrefix ledger invalid - b:bs' -> case runExcept (tickThenApply (ExtLedgerCfg cfg) b ledger) of + b:bs' -> case runExcept (tickThenApplyWithOpts (ApplyOpts ValidationOn OmitLedgerEvents) (ExtLedgerCfg cfg) b ledger) of -- Invalid block according to the ledger Left e -> ValidatedChain diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/InMemory.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/InMemory.hs index 2904da9c0a..c6d9bf53a4 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/InMemory.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/InMemory.hs @@ -140,7 +140,7 @@ prop_pushExpectedLedger :: ChainSetup -> Property prop_pushExpectedLedger setup@ChainSetup{..} = classify (chainSetupSaturated setup) "saturated" $ conjoin [ - l === refoldLedger cfg (expectedChain o) testInitLedger + l === refoldLedger OmitLedgerEvents cfg (expectedChain o) testInitLedger | (o, l) <- ledgerDbSnapshots csPushed ] where @@ -206,7 +206,7 @@ prop_switchExpectedLedger :: SwitchSetup -> Property prop_switchExpectedLedger setup@SwitchSetup{..} = classify (switchSetupSaturated setup) "saturated" $ conjoin [ - l === refoldLedger cfg (expectedChain o) testInitLedger + l === refoldLedger OmitLedgerEvents cfg (expectedChain o) testInitLedger | (o, l) <- ledgerDbSnapshots ssSwitched ] where @@ -278,6 +278,7 @@ csBlockConfig' secParam = LedgerDbCfg { , ledgerDbCfg = testBlockLedgerConfigFrom $ HardFork.defaultEraParams secParam slotLength + , ledgerDbApplyOpts = ApplyOpts ValidationOn OmitLedgerEvents } where slotLength = slotLengthFromSec 20 diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs index 37f2092dd3..6ffda50b0b 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs @@ -258,6 +258,7 @@ extLedgerDbConfig :: SecurityParam -> LedgerDbCfg (ExtLedgerState TestBlock) extLedgerDbConfig secParam = LedgerDbCfg { ledgerDbCfgSecParam = secParam , ledgerDbCfg = ExtLedgerCfg $ singleNodeTestConfigWith TestBlockCodecConfig TestBlockStorageConfig secParam (GenesisWindow (2 * maxRollbacks secParam)) + , ledgerDbApplyOpts = ApplyOpts ValidationOn OmitLedgerEvents } @@ -579,7 +580,7 @@ runMock cmd initMock = push :: TestBlock -> StateT MockLedger (Except (ExtValidationError TestBlock)) () push b = do ls <- State.get - l' <- State.lift $ tickThenApply (ledgerDbCfg cfg) b (cur ls) + l' <- State.lift $ tickThenApplyWithOpts (ApplyOpts ValidationOn OmitLedgerEvents) (ledgerDbCfg cfg) b (cur ls) State.put ((b, l'):ls) switch :: Word64 diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs index 979dabf525..ce612e4bf7 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/TestBlock.hs @@ -556,10 +556,10 @@ instance IsLedger (LedgerState TestBlock) where type AuxLedgerEvent (LedgerState TestBlock) = VoidLedgerEvent (LedgerState TestBlock) - applyChainTickLedgerResult _ _ = pureLedgerResult . TickedTestLedger + applyChainTickLedgerResult _ _ _ = pureLedgerResult . TickedTestLedger instance ApplyBlock (LedgerState TestBlock) TestBlock where - applyBlockLedgerResult _ tb@TestBlock{..} (TickedTestLedger TestLedger{..}) + applyBlockLedgerResultWithOpts _ _ tb@TestBlock{..} (TickedTestLedger TestLedger{..}) | blockPrevHash tb /= lastAppliedHash = throwError $ InvalidHash lastAppliedHash (blockPrevHash tb) | not $ tbIsValid testBody @@ -567,7 +567,7 @@ instance ApplyBlock (LedgerState TestBlock) TestBlock where | otherwise = return $ pureLedgerResult $ TestLedger (Chain.blockPoint tb) (BlockHash (blockHash tb)) - reapplyBlockLedgerResult _ tb _ = + reapplyBlockLedgerResult _ _ tb _ = pureLedgerResult $ TestLedger (Chain.blockPoint tb) (BlockHash (blockHash tb)) data instance LedgerState TestBlock =