From 2eef54393bb05b6edf12e1b36121bd453c7cc558 Mon Sep 17 00:00:00 2001 From: Georgy Lukyanov Date: Thu, 21 Nov 2024 15:36:00 +0100 Subject: [PATCH] Checksum the data when writing and reading ledger snapshots - Allow skipping snapshot checksum check - Generalise `Test/Ouroboros/Storage/LedgerDB/OnDisk.hs` - Restrict `Ord` instance for `DiskSnapshot` to `dsNumber` - Use the `Ord` instance in `listSnapshots` - Connect snapshot checksum with the node interface: - Add `Flag "DoDiskSnapshotChecksum"` to `DiskPolicyArgs` - Expose `(No)DoDiskSnapshotChecksum` in Ouroboros.Consensus.Node - Re-export `Flag` from `DiskPolicy` - `db-analyser` changes: - use checksums by default as that's what `cardano-node` will do - Allow independently disabling checksum on reading and writing --- .../app/DBAnalyser/Parsers.hs | 21 ++- .../Cardano/Tools/DBAnalyser/Analysis.hs | 33 +++-- .../Cardano/Tools/DBAnalyser/Run.hs | 3 +- .../Cardano/Tools/DBAnalyser/Types.hs | 17 ++- .../test/tools-test/Main.hs | 17 ++- .../Ouroboros/Consensus/Node.hs | 6 +- ...orgy.lukyanov_892_checksum_snaphot_file.md | 14 ++ .../Consensus/Storage/ChainDB/Impl/LgrDB.hs | 5 +- .../Ouroboros/Consensus/Storage/LedgerDB.hs | 8 +- .../Consensus/Storage/LedgerDB/DiskPolicy.hs | 34 ++++- .../Consensus/Storage/LedgerDB/Init.hs | 35 +++-- .../Consensus/Storage/LedgerDB/Snapshots.hs | 137 +++++++++++++++--- .../Ouroboros/Consensus/Util.hs | 17 +++ .../Ouroboros/Consensus/Util/CBOR.hs | 24 +-- .../Test/Util/ChainDB.hs | 2 +- .../Test/Util/Orphans/ToExpr.hs | 2 + .../Ouroboros/Storage/LedgerDB/DiskPolicy.hs | 6 +- .../Test/Ouroboros/Storage/LedgerDB/OnDisk.hs | 41 ++++-- .../Storage/LedgerDB/OrphanArbitrary.hs | 6 + 19 files changed, 324 insertions(+), 104 deletions(-) create mode 100644 ouroboros-consensus/changelog.d/20241128_084625_georgy.lukyanov_892_checksum_snaphot_file.md diff --git a/ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs b/ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs index b09448ade6..bf0f73b3f6 100644 --- a/ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs +++ b/ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} module DBAnalyser.Parsers ( BlockType (..) @@ -21,6 +22,7 @@ import Options.Applicative import Ouroboros.Consensus.Block import Ouroboros.Consensus.Byron.Node (PBftSignatureThreshold (..)) import Ouroboros.Consensus.Shelley.Node (Nonce (..)) +import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (pattern DoDiskSnapshotChecksum, pattern NoDoDiskSnapshotChecksum) {------------------------------------------------------------------------------- Parsing @@ -44,6 +46,10 @@ parseDBAnalyserConfig = DBAnalyserConfig <*> parseValidationPolicy <*> parseAnalysis <*> parseLimit + <*> flag DoDiskSnapshotChecksum NoDoDiskSnapshotChecksum (mconcat [ + long "no-snapshot-checksum-on-read" + , help "Don't check the '.checksum' file when reading a ledger snapshot" + ]) parseSelectDB :: Parser SelectDB parseSelectDB = @@ -130,7 +136,14 @@ storeLedgerParser = do <> "This is much slower than block reapplication (the default)." ) ) - pure $ StoreLedgerStateAt slot ledgerValidation + 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 checkNoThunksParser :: Parser AnalysisName checkNoThunksParser = CheckNoThunksEvery <$> option auto 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 b96b2226ba..6dfd65d6b2 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 @@ -74,7 +74,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 ((..:)) +import Ouroboros.Consensus.Util (Flag (..), (..:)) import qualified Ouroboros.Consensus.Util.IOLike as IOLike import Ouroboros.Network.SizeInBytes import System.FS.API (SomeHasFS (..)) @@ -102,19 +102,19 @@ runAnalysis analysisName = case go analysisName of pure result where go :: AnalysisName -> SomeAnalysis blk - go ShowSlotBlockNo = mkAnalysis $ showSlotBlockNo - go CountTxOutputs = mkAnalysis $ countTxOutputs - go ShowBlockHeaderSize = mkAnalysis $ showHeaderSize - go ShowBlockTxsSize = mkAnalysis $ showBlockTxsSize - go ShowEBBs = mkAnalysis $ showEBBs - go OnlyValidation = mkAnalysis @StartFromPoint $ \_ -> pure Nothing - go (StoreLedgerStateAt slotNo lgrAppMode) = mkAnalysis $ storeLedgerStateAt slotNo lgrAppMode - go CountBlocks = mkAnalysis $ countBlocks - go (CheckNoThunksEvery nBks) = mkAnalysis $ checkNoThunksEvery nBks - go TraceLedgerProcessing = mkAnalysis $ traceLedgerProcessing - go (ReproMempoolAndForge nBks) = mkAnalysis $ reproMempoolForge nBks - go (BenchmarkLedgerOps mOutfile lgrAppMode) = mkAnalysis $ benchmarkLedgerOps mOutfile lgrAppMode - go (GetBlockApplicationMetrics nrBlocks mOutfile) = mkAnalysis $ getBlockApplicationMetrics nrBlocks mOutfile + go ShowSlotBlockNo = mkAnalysis $ showSlotBlockNo + go CountTxOutputs = mkAnalysis $ countTxOutputs + go ShowBlockHeaderSize = mkAnalysis $ showHeaderSize + go ShowBlockTxsSize = mkAnalysis $ showBlockTxsSize + go ShowEBBs = mkAnalysis $ showEBBs + 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 TraceLedgerProcessing = mkAnalysis $ traceLedgerProcessing + go (ReproMempoolAndForge nBks) = mkAnalysis $ reproMempoolForge nBks + go (BenchmarkLedgerOps mOutfile lgrAppMode) = mkAnalysis $ benchmarkLedgerOps mOutfile lgrAppMode + go (GetBlockApplicationMetrics nrBlocks mOutfile) = mkAnalysis $ getBlockApplicationMetrics nrBlocks mOutfile mkAnalysis :: forall startFrom. SingI startFrom @@ -382,8 +382,9 @@ storeLedgerStateAt :: ) => SlotNo -> LedgerApplicationMode + -> Flag "DoDiskSnapshotChecksum" -> Analysis blk StartFromLedgerState -storeLedgerStateAt slotNo ledgerAppMode env = do +storeLedgerStateAt slotNo ledgerAppMode doChecksum env = do void $ processAllUntil db registry GetBlock startFrom limit initLedger process pure Nothing where @@ -422,7 +423,7 @@ storeLedgerStateAt slotNo ledgerAppMode env = do storeLedgerState ledgerState = case pointSlot pt of NotOrigin slot -> do let snapshot = DiskSnapshot (unSlotNo slot) (Just "db-analyser") - writeSnapshot ledgerDbFS encLedger snapshot ledgerState + writeSnapshot ledgerDbFS doChecksum encLedger snapshot ledgerState traceWith tracer $ SnapshotStoredEvent slot Origin -> pure () where 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 f896ef4e01..e0667020bf 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} args = +analyse DBAnalyserConfig{analysis, confLimit, dbDir, selectDB, validation, verbose, diskSnapshotChecksumOnRead} args = withRegistry $ \registry -> do lock <- newMVar () chainDBTracer <- mkTracer lock verbose @@ -92,6 +92,7 @@ analyse DBAnalyserConfig{analysis, confLimit, dbDir, selectDB, validation, verbo ledgerDbFS (decodeDiskExtLedgerState $ configCodec cfg) decode + diskSnapshotChecksumOnRead (DiskSnapshot slot (Just "db-analyser")) -- TODO @readSnapshot@ has type @ExceptT ReadIncrementalErr m -- (ExtLedgerState blk)@ but it also throws exceptions! This makes 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 d0ba0cddfe..ddea8b5347 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 @@ -1,20 +1,23 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Cardano.Tools.DBAnalyser.Types (module Cardano.Tools.DBAnalyser.Types) where import Data.Word import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Util (Flag) data SelectDB = SelectImmutableDB (WithOrigin SlotNo) data DBAnalyserConfig = DBAnalyserConfig { - dbDir :: FilePath - , verbose :: Bool - , selectDB :: SelectDB - , validation :: Maybe ValidateBlocks - , analysis :: AnalysisName - , confLimit :: Limit + dbDir :: FilePath + , verbose :: Bool + , selectDB :: SelectDB + , validation :: Maybe ValidateBlocks + , analysis :: AnalysisName + , confLimit :: Limit + , diskSnapshotChecksumOnRead :: Flag "DoDiskSnapshotChecksum" } data AnalysisName = @@ -24,7 +27,7 @@ data AnalysisName = | ShowBlockTxsSize | ShowEBBs | OnlyValidation - | StoreLedgerStateAt SlotNo LedgerApplicationMode + | StoreLedgerStateAt SlotNo LedgerApplicationMode (Flag "DoDiskSnapshotChecksum") | CountBlocks | CheckNoThunksEvery Word64 | TraceLedgerProcessing diff --git a/ouroboros-consensus-cardano/test/tools-test/Main.hs b/ouroboros-consensus-cardano/test/tools-test/Main.hs index 0ff98843e6..2b556a6ba9 100644 --- a/ouroboros-consensus-cardano/test/tools-test/Main.hs +++ b/ouroboros-consensus-cardano/test/tools-test/Main.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PatternSynonyms #-} + module Main (main) where import qualified Cardano.Tools.DBAnalyser.Block.Cardano as Cardano @@ -8,6 +10,8 @@ import qualified Cardano.Tools.DBSynthesizer.Run as DBSynthesizer import Cardano.Tools.DBSynthesizer.Types import Ouroboros.Consensus.Block import Ouroboros.Consensus.Cardano.Block +import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy + (pattern NoDoDiskSnapshotChecksum) import qualified Test.Cardano.Tools.Headers import Test.Tasty import Test.Tasty.HUnit @@ -62,12 +66,13 @@ testImmutaliserConfig = testAnalyserConfig :: DBAnalyserConfig testAnalyserConfig = DBAnalyserConfig { - dbDir = chainDB - , verbose = False - , selectDB = SelectImmutableDB Origin - , validation = Just ValidateAllBlocks - , analysis = CountBlocks - , confLimit = Unlimited + dbDir = chainDB + , verbose = False + , selectDB = SelectImmutableDB Origin + , validation = Just ValidateAllBlocks + , analysis = CountBlocks + , confLimit = Unlimited + , diskSnapshotChecksumOnRead = NoDoDiskSnapshotChecksum } testBlockArgs :: Cardano.Args (CardanoBlock StandardCrypto) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs index 2f7427958b..dd391f519d 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs @@ -6,6 +6,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -51,6 +52,8 @@ module Ouroboros.Consensus.Node ( , RunNodeArgs (..) , Tracers , Tracers' (..) + , pattern DoDiskSnapshotChecksum + , pattern NoDoDiskSnapshotChecksum -- * Internal helpers , mkNodeKernelArgs , nodeKernelArgsEnforceInvariants @@ -107,7 +110,8 @@ import Ouroboros.Consensus.Storage.ChainDB (ChainDB, ChainDbArgs, import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy - (DiskPolicyArgs (..)) + (DiskPolicyArgs (..), pattern DoDiskSnapshotChecksum, + pattern NoDoDiskSnapshotChecksum) import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () diff --git a/ouroboros-consensus/changelog.d/20241128_084625_georgy.lukyanov_892_checksum_snaphot_file.md b/ouroboros-consensus/changelog.d/20241128_084625_georgy.lukyanov_892_checksum_snaphot_file.md new file mode 100644 index 0000000000..bdb249bed3 --- /dev/null +++ b/ouroboros-consensus/changelog.d/20241128_084625_georgy.lukyanov_892_checksum_snaphot_file.md @@ -0,0 +1,14 @@ +### Breaking + +- When writing a ledger state snapshot to disk, calculate the state's CRC32 checksum and write it to a separate file, which is named the same as the snapshot file, plus the `.checksum` extension. +- When reading a snapshot file in `readSnapshot`, calculate its checksum and compare it to the value in the corresponding `.checksum` file. Return an error if the checksum is different or invalid. Issue a warning if the checksum file does not exist, but still initialise the ledger DB. +- To support the previous item, change the error type of the `readSnapshot` from `ReadIncrementalErr` to the extended `ReadSnaphotErr`. +- Checksumming the snapshots is controlled via the `doChecksum :: Flag "DoDiskSnapshotChecksum"` parameter of `initFromSnapshot`. Ultimately, this parameter comes from the Node's configuration file via the `DiskPolicy` data type. +- Extend the `DiskPolicyArgs` data type to enable the node to pass `Flag "DoDiskSnapshotChecksum"` to Consensus. + +### Non-breaking + +- Make `Ouroboros.Consensus.Util.CBOR.readIncremental` optionally compute the checksum of the data as it is read. +- Introduce an explicit `Ord` instance for `DiskSnapshot` that compares the values on `dsNumber`. +- Introduce a new utility newtype `Flag` to represent type-safe boolean flags. See ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util.hs. +- Use `Flag "DoDiskSnapshotChecksum"` to control the check of the snapshot checksum file in `takeSnapshot`, `readSnapshot` and `writeSnapshot`. diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs index e27c047e46..c3d6ae008a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs @@ -232,9 +232,11 @@ initFromDisk LgrDbArgs { lgrHasFS = hasFS, .. } lgrConfig lgrGenesis (streamAPI immutableDB) + doDiskSnapshotChecksum return (db, replayed) where ccfg = configCodec $ getExtLedgerCfg $ LedgerDB.ledgerDbCfg lgrConfig + LedgerDB.DiskPolicyArgs _ _ doDiskSnapshotChecksum = lgrDiskPolicyArgs -- | For testing purposes mkLgrDB :: StrictTVar m (LedgerDB' blk) @@ -280,11 +282,12 @@ takeSnapshot :: , IsLedger (LedgerState blk) ) => LgrDB m blk -> m (Maybe (LedgerDB.DiskSnapshot, RealPoint blk)) -takeSnapshot lgrDB@LgrDB{ cfg, tracer, hasFS } = wrapFailure (Proxy @blk) $ do +takeSnapshot lgrDB@LgrDB{ cfg, tracer, hasFS, diskPolicy } = wrapFailure (Proxy @blk) $ do ledgerDB <- LedgerDB.ledgerDbAnchor <$> atomically (getCurrent lgrDB) LedgerDB.takeSnapshot tracer hasFS + (LedgerDB.onDiskShouldChecksumSnapshots diskPolicy) (encodeDiskExtLedgerState ccfg) ledgerDB where diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs index 7e970703d9..abfad3fdc6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE PatternSynonyms #-} + -- | The Ledger DB is responsible for the following tasks: -- -- - __Maintaining the in-memory ledger state at the tip__: When we try to @@ -134,6 +136,8 @@ module Ouroboros.Consensus.Storage.LedgerDB ( , SnapshotFailure (..) , diskSnapshotIsTemporary , listSnapshots + , pattern DoDiskSnapshotChecksum + , pattern NoDoDiskSnapshotChecksum , readSnapshot -- ** Write to disk , takeSnapshot @@ -160,7 +164,9 @@ module Ouroboros.Consensus.Storage.LedgerDB ( import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy (DiskPolicy (..), DiskPolicyArgs (..), NumOfDiskSnapshots (..), SnapshotInterval (..), - TimeSinceLast (..), defaultDiskPolicyArgs, mkDiskPolicy) + TimeSinceLast (..), defaultDiskPolicyArgs, mkDiskPolicy, + pattern DoDiskSnapshotChecksum, + pattern NoDoDiskSnapshotChecksum) import Ouroboros.Consensus.Storage.LedgerDB.Init (InitLog (..), ReplayGoal (..), ReplayStart (..), TraceReplayEvent (..), decorateReplayTracerWithGoal, diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/DiskPolicy.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/DiskPolicy.hs index 8b25ed1b68..44c17b06ed 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/DiskPolicy.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/DiskPolicy.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} module Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy ( @@ -13,6 +14,10 @@ module Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy ( , TimeSinceLast (..) , defaultDiskPolicyArgs , mkDiskPolicy + , pattern DoDiskSnapshotChecksum + , pattern NoDoDiskSnapshotChecksum + -- * Re-exports + , Flag (..) ) where import Control.Monad.Class.MonadTime.SI @@ -21,12 +26,13 @@ import Data.Word import GHC.Generics import NoThunks.Class (NoThunks, OnlyCheckWhnf (..)) import Ouroboros.Consensus.Config.SecurityParam +import Ouroboros.Consensus.Util (Flag (..)) -- | Length of time, requested by the user, that has to pass after which -- a snapshot is taken. It can be: -- -- 1. either explicitly provided by user in seconds --- 2. or default value can be requested - the specific DiskPolicy determines +-- 2. or default value can be requested - the specific @'DiskPolicy'@ determines -- what that is exactly, see `mkDiskPolicy` as an example data SnapshotInterval = DefaultSnapshotInterval @@ -34,14 +40,22 @@ data SnapshotInterval = deriving stock (Eq, Generic, Show) -- | Number of snapshots to be stored on disk. This is either the default value --- as determined by the DiskPolicy, or it is provided by the user. See the --- `DiskPolicy` documentation for more information. +-- as determined by the @'DiskPolicy'@, or it is provided by the user. See the +-- @'DiskPolicy'@ documentation for more information. data NumOfDiskSnapshots = DefaultNumOfDiskSnapshots | RequestedNumOfDiskSnapshots Word deriving stock (Eq, Generic, Show) -data DiskPolicyArgs = DiskPolicyArgs SnapshotInterval NumOfDiskSnapshots +-- | Type-safe flag to regulate the checksum policy of the ledger state snapshots. +-- +-- These patterns are exposed to cardano-node and will be passed as part of @'DiskPolicy'@. +pattern DoDiskSnapshotChecksum, NoDoDiskSnapshotChecksum :: Flag "DoDiskSnapshotChecksum" +pattern DoDiskSnapshotChecksum = Flag True +pattern NoDoDiskSnapshotChecksum = Flag False + +-- | The components used by cardano-node to construct a @'DiskPolicy'@. +data DiskPolicyArgs = DiskPolicyArgs SnapshotInterval NumOfDiskSnapshots (Flag "DoDiskSnapshotChecksum") -- | On-disk policy -- @@ -67,7 +81,7 @@ data DiskPolicy = DiskPolicy { -- the next snapshot, we delete the oldest one, leaving the middle -- one available in case of truncation of the write. This is -- probably a sane value in most circumstances. - onDiskNumSnapshots :: Word + onDiskNumSnapshots :: Word -- | Should we write a snapshot of the ledger state to disk? -- @@ -87,7 +101,11 @@ data DiskPolicy = DiskPolicy { -- blocks had to be replayed. -- -- See also 'mkDiskPolicy' - , onDiskShouldTakeSnapshot :: TimeSinceLast DiffTime -> Word64 -> Bool + , onDiskShouldTakeSnapshot :: TimeSinceLast DiffTime -> Word64 -> Bool + + -- | Whether or not to checksum the ledger snapshots to detect data corruption on disk. + -- "yes" if @'DoDiskSnapshotChecksum'@; "no" if @'NoDoDiskSnapshotChecksum'@. + , onDiskShouldChecksumSnapshots :: Flag "DoDiskSnapshotChecksum" } deriving NoThunks via OnlyCheckWhnf DiskPolicy @@ -97,10 +115,10 @@ data TimeSinceLast time = NoSnapshotTakenYet | TimeSinceLast time -- | Default on-disk policy arguments suitable to use with cardano-node -- defaultDiskPolicyArgs :: DiskPolicyArgs -defaultDiskPolicyArgs = DiskPolicyArgs DefaultSnapshotInterval DefaultNumOfDiskSnapshots +defaultDiskPolicyArgs = DiskPolicyArgs DefaultSnapshotInterval DefaultNumOfDiskSnapshots DoDiskSnapshotChecksum mkDiskPolicy :: SecurityParam -> DiskPolicyArgs -> DiskPolicy -mkDiskPolicy (SecurityParam k) (DiskPolicyArgs reqInterval reqNumOfSnapshots) = +mkDiskPolicy (SecurityParam k) (DiskPolicyArgs reqInterval reqNumOfSnapshots onDiskShouldChecksumSnapshots) = DiskPolicy {..} where onDiskNumSnapshots :: Word diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Init.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Init.hs index 3c4245b74e..3b76c4efe6 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Init.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Init.hs @@ -1,5 +1,7 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -31,10 +33,13 @@ import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Storage.ImmutableDB.Stream +import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy + (pattern NoDoDiskSnapshotChecksum) import Ouroboros.Consensus.Storage.LedgerDB.LedgerDB import Ouroboros.Consensus.Storage.LedgerDB.Query import Ouroboros.Consensus.Storage.LedgerDB.Snapshots import Ouroboros.Consensus.Storage.LedgerDB.Update +import Ouroboros.Consensus.Util (Flag) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Network.Block (Point (Point)) import System.FS.API @@ -102,6 +107,7 @@ initLedgerDB :: -> LedgerDbCfg (ExtLedgerState blk) -> m (ExtLedgerState blk) -- ^ Genesis ledger state -> StreamAPI m blk blk + -> Flag "DoDiskSnapshotChecksum" -> m (InitLog blk, LedgerDB' blk, Word64) initLedgerDB replayTracer tracer @@ -110,14 +116,16 @@ initLedgerDB replayTracer decHash cfg getGenesisLedger - stream = do + stream + doDoDiskSnapshotChecksum = do snapshots <- listSnapshots hasFS - tryNewestFirst id snapshots + tryNewestFirst doDoDiskSnapshotChecksum id snapshots where - tryNewestFirst :: (InitLog blk -> InitLog blk) + tryNewestFirst :: Flag "DoDiskSnapshotChecksum" + -> (InitLog blk -> InitLog blk) -> [DiskSnapshot] -> m (InitLog blk, LedgerDB' blk, Word64) - tryNewestFirst acc [] = do + tryNewestFirst _ acc [] = do -- We're out of snapshots. Start at genesis traceWith replayTracer ReplayFromGenesis initDb <- ledgerDbWithAnchor <$> getGenesisLedger @@ -126,8 +134,7 @@ initLedgerDB replayTracer case ml of Left _ -> error "invariant violation: invalid current chain" Right (l, replayed) -> return (acc InitFromGenesis, l, replayed) - tryNewestFirst acc (s:ss) = do - -- If we fail to use this snapshot, delete it and try an older one + tryNewestFirst doChecksum acc allSnapshot@(s:ss) = do ml <- runExceptT $ initFromSnapshot replayTracer hasFS @@ -136,14 +143,23 @@ initLedgerDB replayTracer cfg stream s + doChecksum case ml of + -- If a checksum file is missing for a snapshot, + -- issue a warning and retry the same snapshot + -- ignoring the checksum + Left (InitFailureRead ReadSnapshotNoChecksumFile{}) -> do + traceWith tracer $ SnapshotMissingChecksum s + tryNewestFirst NoDoDiskSnapshotChecksum acc allSnapshot + -- If we fail to use this snapshot for any other reason, delete it and try an older one Left err -> do when (diskSnapshotIsTemporary s) $ -- We don't delete permanent snapshots, even if we couldn't parse -- them deleteSnapshot hasFS s traceWith tracer $ InvalidSnapshot s err - tryNewestFirst (acc . InitFailure s err) ss + -- reset checksum flag to the initial state after failure + tryNewestFirst doChecksum (acc . InitFailure s err) ss Right (r, l, replayed) -> return (acc (InitFromSnapshot s r), l, replayed) @@ -170,10 +186,11 @@ initFromSnapshot :: -> LedgerDbCfg (ExtLedgerState blk) -> StreamAPI m blk blk -> DiskSnapshot + -> Flag "DoDiskSnapshotChecksum" -> ExceptT (SnapshotFailure blk) m (RealPoint blk, LedgerDB' blk, Word64) -initFromSnapshot tracer hasFS decLedger decHash cfg stream ss = do +initFromSnapshot tracer hasFS decLedger decHash cfg stream ss doChecksum = do initSS <- withExceptT InitFailureRead $ - readSnapshot hasFS decLedger decHash ss + readSnapshot hasFS decLedger decHash doChecksum ss let replayStart = castPoint $ getTip initSS case pointToWithOriginRealPoint replayStart of Origin -> throwError InitFailureGenesis diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Snapshots.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Snapshots.hs index 970cac6abd..e3c335b065 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Snapshots.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Snapshots.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -12,6 +14,7 @@ module Ouroboros.Consensus.Storage.LedgerDB.Snapshots ( DiskSnapshot (..) -- * Read from disk + , ReadSnapshotErr (..) , SnapshotFailure (..) , diskSnapshotIsTemporary , listSnapshots @@ -34,13 +37,18 @@ import qualified Codec.CBOR.Write as CBOR import Codec.Serialise.Decoding (Decoder) import qualified Codec.Serialise.Decoding as Dec import Codec.Serialise.Encoding (Encoding) -import Control.Monad (forM, void) -import Control.Monad.Except (ExceptT (..)) +import Control.Monad (forM, void, when) +import Control.Monad.Except (ExceptT (..), throwError, withExceptT) import Control.Tracer +import Data.Bits +import qualified Data.ByteString.Builder as BS +import qualified Data.ByteString.Char8 as BSC +import qualified Data.ByteString.Lazy as BSL +import Data.Char (ord) import Data.Functor.Contravariant ((>$<)) import qualified Data.List as List import Data.Maybe (isJust, mapMaybe) -import Data.Ord (Down (..)) +import Data.Ord (Down (..), comparing) import Data.Set (Set) import qualified Data.Set as Set import Data.Word @@ -56,6 +64,7 @@ import Ouroboros.Consensus.Util.Enclose import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Versioned import System.FS.API.Lazy +import System.FS.CRC (CRC (..), hPutAllCRC) import Text.Read (readMaybe) {------------------------------------------------------------------------------- @@ -66,7 +75,7 @@ data SnapshotFailure blk = -- | We failed to deserialise the snapshot -- -- This can happen due to data corruption in the ledger DB. - InitFailureRead ReadIncrementalErr + InitFailureRead ReadSnapshotErr -- | This snapshot is too recent (ahead of the tip of the chain) | InitFailureTooRecent (RealPoint blk) @@ -82,7 +91,9 @@ data TraceSnapshotEvent blk | TookSnapshot DiskSnapshot (RealPoint blk) EnclosingTimed -- ^ A snapshot was written to disk. | DeletedSnapshot DiskSnapshot - -- ^ An old or invalid on-disk snapshot was deleted + -- ^ An old or invalid on-disk snapshot was deleted. + | SnapshotMissingChecksum DiskSnapshot + -- ^ The checksum file for a snapshot was missing and was not checked deriving (Generic, Eq, Show) -- | Take a snapshot of the /oldest ledger state/ in the ledger DB @@ -108,9 +119,10 @@ takeSnapshot :: forall m blk. (MonadThrow m, MonadMonotonicTime m, IsLedger (LedgerState blk)) => Tracer m (TraceSnapshotEvent blk) -> SomeHasFS m + -> Flag "DoDiskSnapshotChecksum" -> (ExtLedgerState blk -> Encoding) -> ExtLedgerState blk -> m (Maybe (DiskSnapshot, RealPoint blk)) -takeSnapshot tracer hasFS encLedger oldest = +takeSnapshot tracer hasFS doChecksum encLedger oldest = case pointToWithOriginRealPoint (castPoint (getTip oldest)) of Origin -> return Nothing @@ -122,7 +134,7 @@ takeSnapshot tracer hasFS encLedger oldest = return Nothing else do encloseTimedWith (TookSnapshot snapshot tip >$< tracer) - $ writeSnapshot hasFS encLedger snapshot oldest + $ writeSnapshot hasFS doChecksum encLedger snapshot oldest return $ Just (snapshot, tip) -- | Trim the number of on disk snapshots so that at most 'onDiskNumSnapshots' @@ -149,6 +161,9 @@ trimSnapshots tracer hasFS DiskPolicy{..} = do Internal: reading from disk -------------------------------------------------------------------------------} +-- | Name of a disk snapshot. +-- +-- The snapshot itself might not yet exist on disk. data DiskSnapshot = DiskSnapshot { -- | Snapshots are numbered. We will try the snapshots with the highest -- number first. @@ -169,7 +184,10 @@ data DiskSnapshot = DiskSnapshot { -- /not be trimmed/. , dsSuffix :: Maybe String } - deriving (Show, Eq, Ord, Generic) + deriving (Show, Eq, Generic) + +instance Ord DiskSnapshot where + compare = comparing dsNumber -- | Named snapshot are permanent, they will never be deleted when trimming. diskSnapshotIsPermanent :: DiskSnapshot -> Bool @@ -180,39 +198,110 @@ diskSnapshotIsPermanent = isJust . dsSuffix diskSnapshotIsTemporary :: DiskSnapshot -> Bool diskSnapshotIsTemporary = not . diskSnapshotIsPermanent --- | Read snapshot from disk +data ReadSnapshotErr = + -- | Error while de-serialising data + ReadSnapshotFailed ReadIncrementalErr + -- | Checksum of read snapshot differs from the one tracked by + -- the corresponding '.checksum' file + | ReadSnapshotDataCorruption + -- | A '.checksum' file does not exist for a @'DiskSnapshot'@ + | ReadSnapshotNoChecksumFile FsPath + -- | A '.checksum' file exists for a @'DiskSnapshot'@, but its contents is invalid + | ReadSnapshotInvalidChecksumFile FsPath + deriving (Eq, Show) + +-- | Read snapshot from disk. +-- +-- Fail on data corruption, i.e. when the checksum of the read data differs +-- from the one tracked by @'DiskSnapshot'@. readSnapshot :: forall m blk. IOLike m => SomeHasFS m -> (forall s. Decoder s (ExtLedgerState blk)) -> (forall s. Decoder s (HeaderHash blk)) + -> Flag "DoDiskSnapshotChecksum" -> DiskSnapshot - -> ExceptT ReadIncrementalErr m (ExtLedgerState blk) -readSnapshot hasFS decLedger decHash = - ExceptT - . readIncremental hasFS decoder - . snapshotToPath + -> ExceptT ReadSnapshotErr m (ExtLedgerState blk) +readSnapshot someHasFS decLedger decHash doChecksum snapshotName = do + (ledgerState, mbChecksumAsRead) <- withExceptT ReadSnapshotFailed . ExceptT $ + readIncremental someHasFS (getFlag doChecksum) decoder (snapshotToPath snapshotName) + when (getFlag doChecksum) $ do + !snapshotCRC <- readCRC someHasFS (snapshotToChecksumPath snapshotName) + when (mbChecksumAsRead /= Just snapshotCRC) $ + throwError ReadSnapshotDataCorruption + pure ledgerState where decoder :: Decoder s (ExtLedgerState blk) decoder = decodeSnapshotBackwardsCompatible (Proxy @blk) decLedger decHash --- | Write snapshot to disk + readCRC :: + SomeHasFS m + -> FsPath + -> ExceptT ReadSnapshotErr m CRC + readCRC (SomeHasFS hasFS) crcPath = ExceptT $ do + crcExists <- doesFileExist hasFS crcPath + if not crcExists + then pure (Left $ ReadSnapshotNoChecksumFile crcPath) + else do + withFile hasFS crcPath ReadMode $ \h -> do + str <- BSL.toStrict <$> hGetAll hasFS h + if not (BSC.length str == 8 && BSC.all isHexDigit str) + then pure (Left $ ReadSnapshotInvalidChecksumFile crcPath) + else pure . Right . CRC $ fromIntegral (hexdigitsToInt str) + -- TODO: remove the functions in the where clause when we start depending on lsm-tree + where + isHexDigit :: Char -> Bool + isHexDigit c = (c >= '0' && c <= '9') + || (c >= 'a' && c <= 'f') --lower case only + + -- Precondition: BSC.all isHexDigit + hexdigitsToInt :: BSC.ByteString -> Word + hexdigitsToInt = + BSC.foldl' accumdigit 0 + where + accumdigit :: Word -> Char -> Word + accumdigit !a !c = + (a `shiftL` 4) .|. hexdigitToWord c + + + -- Precondition: isHexDigit + hexdigitToWord :: Char -> Word + hexdigitToWord c + | let !dec = fromIntegral (ord c - ord '0') + , dec <= 9 = dec + + | let !hex = fromIntegral (ord c - ord 'a' + 10) + , otherwise = hex + +-- | Write a ledger state snapshot to disk +-- +-- This function writes two files: +-- * the snapshot file itself, with the name generated by @'snapshotToPath'@ +-- * the checksum file, with the name generated by @'snapshotToChecksumPath'@ writeSnapshot :: forall m blk. MonadThrow m => SomeHasFS m + -> Flag "DoDiskSnapshotChecksum" -> (ExtLedgerState blk -> Encoding) -> DiskSnapshot -> ExtLedgerState blk -> m () -writeSnapshot (SomeHasFS hasFS) encLedger ss cs = do - withFile hasFS (snapshotToPath ss) (WriteMode MustBeNew) $ \h -> - void $ hPut hasFS h $ CBOR.toBuilder (encode cs) +writeSnapshot (SomeHasFS hasFS) doChecksum encLedger ss cs = do + crc <- withFile hasFS (snapshotToPath ss) (WriteMode MustBeNew) $ \h -> + snd <$> hPutAllCRC hasFS h (CBOR.toLazyByteString $ encode cs) + when (getFlag doChecksum) $ + withFile hasFS (snapshotToChecksumPath ss) (WriteMode MustBeNew) $ \h -> + void $ hPutAll hasFS h . BS.toLazyByteString . BS.word32HexFixed $ getCRC crc where encode :: ExtLedgerState blk -> Encoding encode = encodeSnapshot encLedger -- | Delete snapshot from disk -deleteSnapshot :: HasCallStack => SomeHasFS m -> DiskSnapshot -> m () -deleteSnapshot (SomeHasFS HasFS{..}) = removeFile . snapshotToPath +deleteSnapshot :: Monad m => HasCallStack => SomeHasFS m -> DiskSnapshot -> m () +deleteSnapshot (SomeHasFS hasFS) snapshot = do + removeFile hasFS (snapshotToPath snapshot) + checksumFileExists <- doesFileExist hasFS (snapshotToChecksumPath snapshot) + when checksumFileExists $ + removeFile hasFS (snapshotToChecksumPath snapshot) -- | List on-disk snapshots, highest number first. listSnapshots :: Monad m => SomeHasFS m -> m [DiskSnapshot] @@ -220,7 +309,10 @@ listSnapshots (SomeHasFS HasFS{..}) = aux <$> listDirectory (mkFsPath []) where aux :: Set String -> [DiskSnapshot] - aux = List.sortOn (Down . dsNumber) . mapMaybe snapshotFromPath . Set.toList + aux = List.sortOn Down . mapMaybe snapshotFromPath . Set.toList + +snapshotToChecksumFileName :: DiskSnapshot -> String +snapshotToChecksumFileName = (<> ".checksum") . snapshotToFileName snapshotToFileName :: DiskSnapshot -> String snapshotToFileName DiskSnapshot { dsNumber, dsSuffix } = @@ -230,6 +322,9 @@ snapshotToFileName DiskSnapshot { dsNumber, dsSuffix } = Nothing -> "" Just s -> "_" <> s +snapshotToChecksumPath :: DiskSnapshot -> FsPath +snapshotToChecksumPath = mkFsPath . (:[]) . snapshotToChecksumFileName + snapshotToPath :: DiskSnapshot -> FsPath snapshotToPath = mkFsPath . (:[]) . snapshotToFileName diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util.hs index 7e566c2502..8165cab848 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} @@ -77,6 +78,8 @@ module Ouroboros.Consensus.Util ( , electric , newFuse , withFuse + -- * Type-safe boolean flags + , Flag (..) ) where import Cardano.Crypto.Hash (Hash, HashAlgorithm, hashFromBytes, @@ -102,6 +105,7 @@ import Data.Void import Data.Word (Word64) import GHC.Generics (Generic) import GHC.Stack +import GHC.TypeLits (Symbol) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Network.Protocol.LocalStateQuery.Codec (Some (..)) import Ouroboros.Network.Util.ShowProxy (ShowProxy (..)) @@ -450,3 +454,16 @@ withFuse (Fuse name m) (Electric io) = do newtype FuseBlownException = FuseBlownException Text deriving (Show) deriving anyclass (Exception) + +{------------------------------------------------------------------------------- + Type-safe boolean flags +-------------------------------------------------------------------------------} + +-- | Type-safe boolean flags with type level tags +-- +-- It is recommended to create pattern synonyms for the true and false values. +-- +-- See 'Ouroboros.Consensus.Storage.LedgerDB.Snapshots.DiskSnapshotChecksum' +-- for an example. +newtype Flag (name :: Symbol) = Flag {getFlag :: Bool} + deriving (Eq, Show, Generic) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/CBOR.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/CBOR.hs index 2d7bad2811..c734edac34 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/CBOR.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/CBOR.hs @@ -55,6 +55,7 @@ import qualified Streaming as S import qualified Streaming.Prelude as S import Streaming.Prelude (Of (..), Stream) import System.FS.API +import System.FS.CRC (CRC (..), initCRC, updateCRC) {------------------------------------------------------------------------------- Incremental parsing in I/O @@ -172,7 +173,7 @@ data ReadIncrementalErr = | TrailingBytes ByteString deriving (Eq, Show) --- | Read a file incrementally +-- | Read a file incrementally, optionally calculating the CRC checksum. -- -- NOTE: The 'MonadThrow' constraint is only needed for 'bracket'. This -- function does not actually throw anything. @@ -184,26 +185,29 @@ data ReadIncrementalErr = -- 'withStreamIncrementalOffsets'. readIncremental :: forall m a. IOLike m => SomeHasFS m + -> Bool -> CBOR.D.Decoder (U.PrimState m) a -> FsPath - -> m (Either ReadIncrementalErr a) -readIncremental = \(SomeHasFS hasFS) decoder fp -> do + -> m (Either ReadIncrementalErr (a, Maybe CRC)) +readIncremental = \(SomeHasFS hasFS) doChecksum decoder fp -> do + let mbInitCRC = if doChecksum then Just initCRC else Nothing withFile hasFS fp ReadMode $ \h -> - go hasFS h =<< U.stToIO (CBOR.R.deserialiseIncremental decoder) + go hasFS h mbInitCRC =<< U.stToIO (CBOR.R.deserialiseIncremental decoder) where go :: HasFS m h -> Handle h + -> Maybe CRC -> CBOR.R.IDecode (U.PrimState m) a - -> m (Either ReadIncrementalErr a) - go hasFS@HasFS{..} h (CBOR.R.Partial k) = do + -> m (Either ReadIncrementalErr (a, Maybe CRC)) + go hasFS@HasFS{..} h !checksum (CBOR.R.Partial k) = do bs <- hGetSome h (fromIntegral defaultChunkSize) dec' <- U.stToIO $ k (checkEmpty bs) - go hasFS h dec' - go _ _ (CBOR.R.Done leftover _ a) = + go hasFS h (updateCRC bs <$> checksum) dec' + go _ _ !checksum (CBOR.R.Done leftover _ a) = return $ if BS.null leftover - then Right a + then Right (a, checksum) else Left $ TrailingBytes leftover - go _ _ (CBOR.R.Fail _ _ err) = + go _ _ _ (CBOR.R.Fail _ _ err) = return $ Left $ ReadFailed err checkEmpty :: ByteString -> Maybe ByteString 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 b81819ecd6..493bc743c8 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs @@ -111,7 +111,7 @@ fromMinimalChainDbArgs MinimalChainDbArgs {..} = ChainDbArgs { , volValidationPolicy = VolatileDB.ValidateAll } , cdbLgrDbArgs = LgrDbArgs { - lgrDiskPolicyArgs = LedgerDB.DiskPolicyArgs LedgerDB.DefaultSnapshotInterval LedgerDB.DefaultNumOfDiskSnapshots + lgrDiskPolicyArgs = LedgerDB.DiskPolicyArgs LedgerDB.DefaultSnapshotInterval LedgerDB.DefaultNumOfDiskSnapshots LedgerDB.DoDiskSnapshotChecksum -- Keep 2 ledger snapshots, and take a new snapshot at least every 2 * -- k seconds, where k is the security parameter. , lgrGenesis = return mcdbInitLedger diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs index fc76d4036c..3774a47bcb 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/ToExpr.hs @@ -29,6 +29,7 @@ import Ouroboros.Network.Mock.Chain import Ouroboros.Network.Mock.ProducerState import Ouroboros.Network.Point import System.FS.API +import System.FS.CRC (CRC (..)) import Test.Cardano.Slotting.TreeDiff () import Test.Util.ToExpr () @@ -65,6 +66,7 @@ instance ( ToExpr (TipInfo blk) ) => ToExpr (AnnTip blk) instance ToExpr SecurityParam +instance ToExpr CRC instance ToExpr DiskSnapshot instance ToExpr ChunkSize diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/DiskPolicy.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/DiskPolicy.hs index 3c320ad973..707e3330f8 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/DiskPolicy.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/DiskPolicy.hs @@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TypeApplications #-} module Test.Ouroboros.Storage.LedgerDB.DiskPolicy (tests) where @@ -13,7 +14,8 @@ import Ouroboros.Consensus.Storage.LedgerDB (DiskPolicy (..), NumOfDiskSnapshots (..), SnapshotInterval (..), TimeSinceLast (..), mkDiskPolicy) import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy - (DiskPolicyArgs (DiskPolicyArgs)) + (DiskPolicyArgs (DiskPolicyArgs), + pattern DoDiskSnapshotChecksum) import Test.QuickCheck import Test.Tasty import Test.Tasty.QuickCheck @@ -49,7 +51,7 @@ toDiskPolicy :: TestSetup -> DiskPolicy toDiskPolicy ts = mkDiskPolicy (tsK ts) diskPolicyArgs where diskPolicyArgs = - DiskPolicyArgs (tsSnapshotInterval ts) DefaultNumOfDiskSnapshots + DiskPolicyArgs (tsSnapshotInterval ts) DefaultNumOfDiskSnapshots DoDiskSnapshotChecksum -- | The result of the represented call to 'onDiskShouldTakeSnapshot' shouldTakeSnapshot :: TestSetup -> Bool 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 c408566390..37f2092dd3 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 @@ -10,6 +10,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -65,7 +66,8 @@ import Ouroboros.Consensus.Config import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Storage.ImmutableDB.Stream -import Ouroboros.Consensus.Storage.LedgerDB +import Ouroboros.Consensus.Storage.LedgerDB hiding + (pattern NoDoDiskSnapshotChecksum) import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.IOLike import Prelude hiding (elem) @@ -111,7 +113,7 @@ type TestBlock = TestBlockWith Tx data Tx = Tx { -- | Input that the transaction consumes. consumed :: Token - -- | Ouptupt that the transaction produces. + -- | Output that the transaction produces. , produced :: (Token, TValue) } deriving stock (Show, Eq, Ord, Generic) @@ -292,10 +294,10 @@ data Cmd ss = | Switch Word64 [TestBlock] -- | Take a snapshot (write to disk) - | Snap + | Snap (Flag "DoDiskSnapshotChecksum") -- | Restore the DB from on-disk, then return it along with the init log - | Restore + | Restore (Flag "DoDiskSnapshotChecksum") -- | Corrupt a previously taken snapshot | Corrupt Corruption ss @@ -500,11 +502,11 @@ runMock cmd initMock = go Current mock = (Ledger (cur (mockLedger mock)), mock) go (Push b) mock = first MaybeErr $ mockUpdateLedger (push b) mock go (Switch n bs) mock = first MaybeErr $ mockUpdateLedger (switch n bs) mock - go Restore mock = (Restored (initLog, cur (mockLedger mock')), mock') + go Restore{} mock = (Restored (initLog, cur (mockLedger mock')), mock') where initLog = mockInitLog mock mock' = applyMockLog initLog mock - go Snap mock = case mbSnapshot of + go Snap{} mock = case mbSnapshot of Just pt | let mockSnap = MockSnap (unSlotNo (realPointSlot pt)) , Map.notMember mockSnap (mockSnaps mock) @@ -568,7 +570,9 @@ runMock cmd initMock = Delete -> Nothing Truncate -> Just (ref, SnapCorrupted) go (Drop n) mock = - go Restore $ mock { + -- the model does not track checksums, but ask for it for + -- consistency with the real thing + go (Restore DoDiskSnapshotChecksum) $ mock { mockLedger = drop (fromIntegral n) (mockLedger mock) } @@ -750,15 +754,16 @@ runDB standalone@DB{..} cmd = (const $ pure ()) (map ApplyVal bs) db - go hasFS Snap = do + go hasFS (Snap doChecksum) = do (_, db) <- atomically (readTVar dbState) Snapped <$> takeSnapshot nullTracer hasFS + doChecksum S.encode (ledgerDbAnchor db) - go hasFS Restore = do + go hasFS (Restore doChecksum) = do (initLog, db, _replayed) <- initLedgerDB nullTracer @@ -769,6 +774,7 @@ runDB standalone@DB{..} cmd = dbLedgerDbCfg (return (testInitExtLedgerWithState initialTestLedgerState)) stream + doChecksum atomically $ modifyTVar dbState (\(rs, _) -> (rs, db)) return $ Restored (fromInitLog initLog, ledgerDbCurrent db) go hasFS (Corrupt c ss) = @@ -785,7 +791,10 @@ runDB standalone@DB{..} cmd = atomically $ do (rs, _db) <- readTVar dbState writeTVar dbState (drop (fromIntegral n) rs, error "ledger DB not initialized") - go hasFS Restore + -- always attempt to check the snapshot checksum. The current implementation + -- will successfully restore even if the checksum is missing + -- (producing a warning trace). + go hasFS (Restore DoDiskSnapshotChecksum) push :: TestBlock @@ -941,8 +950,8 @@ generator secParam (Model mock hs) = Just $ QC.oneof $ concat [ numNewBlocks (lastAppliedPoint . ledgerState . mockCurrent $ afterRollback) return $ Switch numRollback blocks - , fmap At $ return Snap - , fmap At $ return Restore + , fmap At $ Snap <$> QC.arbitrary + , fmap At $ Restore <$> QC.arbitrary , fmap At $ Drop <$> QC.choose (0, mockChainLength mock) ] @@ -968,8 +977,8 @@ shrinker _ (At cmd) = case cmd of Current -> [] Push _b -> [] - Snap -> [] - Restore -> [] + Snap{} -> [] + Restore{} -> [] Switch 0 [b] -> [At $ Push b] Switch n bs -> if length bs > fromIntegral n then [At $ Switch n (init bs)] @@ -1165,8 +1174,8 @@ tagEvents k = C.classify [ fmap (TagRestore mST . rangeK k) $ C.maximum $ \ev -> let mock = modelMock (eventBefore ev) in case eventCmd ev of - At Restore | mockRecentSnap mock == mST -> Just (mockChainLength mock) - _otherwise -> Nothing + At (Restore{}) | mockRecentSnap mock == mST -> Just (mockChainLength mock) + _otherwise -> Nothing {------------------------------------------------------------------------------- Inspecting the labelling function diff --git a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OrphanArbitrary.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OrphanArbitrary.hs index a515ab81db..328e0efaa3 100644 --- a/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OrphanArbitrary.hs +++ b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OrphanArbitrary.hs @@ -1,8 +1,12 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -Wno-orphans #-} module Test.Ouroboros.Storage.LedgerDB.OrphanArbitrary () where import Ouroboros.Consensus.Config.SecurityParam (SecurityParam (..)) +import Ouroboros.Consensus.Util (Flag (..)) import Test.QuickCheck {------------------------------------------------------------------------------- @@ -12,3 +16,5 @@ import Test.QuickCheck instance Arbitrary SecurityParam where arbitrary = SecurityParam <$> choose (0, 6) shrink (SecurityParam k) = SecurityParam <$> shrink k + +deriving newtype instance Arbitrary (Flag symbol)