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`

Stylish, hlint, add changelog entries

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.Snapshots (pattern DiskSnapshotChecksum, pattern NoDiskSnapshotChecksum)
 
 {-------------------------------------------------------------------------------
   Parsing
@@ -44,6 +46,10 @@ parseDBAnalyserConfig = DBAnalyserConfig
     <*> parseValidationPolicy
     <*> parseAnalysis
     <*> parseLimit
+    <*> flag NoDiskSnapshotChecksum DiskSnapshotChecksum (mconcat [
+            long "disk-snapshot-checksum"
+          , help "Check the '.checksum' file if reading a ledger snapshot"
+          ])
 
 parseSelectDB :: Parser SelectDB
 parseSelectDB =

ouroboros-consensus-cardano/changelog.d/20241129_122139_georgy.lukyanov_892_checksum_snaphot_file.md

@@ -0,0 +1,3 @@
+### Non-Breaking
+
+- Add flag `--disk-snapshot-checksum` for the `db-analyser` tool. If the flag is passed and the analysis starts from a disk snapshot, the tool will expect a `<snapshot-name>.checksum` file to be present. This behaviour is disabled by default for backwards compatibility.

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

@@ -6,6 +6,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
@@ -72,7 +73,7 @@ import           Ouroboros.Consensus.Storage.Common (BlockComponent (..))
 import           Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB)
 import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
 import           Ouroboros.Consensus.Storage.LedgerDB (DiskSnapshot (..),
-                     writeSnapshot)
+                     pattern NoDiskSnapshotChecksum, writeSnapshot)
 import           Ouroboros.Consensus.Storage.Serialisation (encodeDisk)
 import           Ouroboros.Consensus.Util ((..:))
 import qualified Ouroboros.Consensus.Util.IOLike as IOLike
@@ -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 NoDiskSnapshotChecksum encLedger snapshot ledgerState
           traceWith tracer $ SnapshotStoredEvent slot
         Origin -> pure ()
       where

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, diskSnapshotChecksum} 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
+                diskSnapshotChecksum
                 (DiskSnapshot slot (Just "db-analyser"))
                 -- TODO @readSnapshot@ has type @ExceptT ReadIncrementalErr m
                 -- (ExtLedgerState blk)@ but it also throws exceptions! This makes

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
+  , diskSnapshotChecksum :: Flag "DiskSnapshotChecksum"
   }
 
 data AnalysisName =

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.Snapshots
+                     (pattern NoDiskSnapshotChecksum)
 import qualified Test.Cardano.Tools.Headers
 import           Test.Tasty
 import           Test.Tasty.HUnit
@@ -68,6 +72,7 @@ testAnalyserConfig =
     , validation  = Just ValidateAllBlocks
     , analysis    = CountBlocks
     , confLimit   = Unlimited
+    , diskSnapshotChecksum = NoDiskSnapshotChecksum
     }
 
 testBlockArgs :: Cardano.Args (CardanoBlock StandardCrypto)

ouroboros-consensus/changelog.d/20241128_084625_georgy.lukyanov_892_checksum_snaphot_file.md

@@ -0,0 +1,13 @@
+### Breaking
+
+- When writing a ledger state snapshot to disk, calculate the state's CRC 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 "DiskSnapshotChecksum"` parameter of `initFromSnapshot`. It is enabled by default in `initLedgerDB` by setting it to `DiskSnapshotChecksum` (i.e. `True`).
+
+### Non-breaking
+
+- Make `Ouroboros.Consensus.Util.CBOR.readIncremental` 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 "DiskSnapshotChecksum"` to control the check of the snapshot checksum file in `readSnapshot`

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs

@@ -285,6 +285,7 @@ takeSnapshot lgrDB@LgrDB{ cfg, tracer, hasFS } = wrapFailure (Proxy @blk) $ do
     LedgerDB.takeSnapshot
       tracer
       hasFS
+      LedgerDB.DiskSnapshotChecksum
       (encodeDiskExtLedgerState ccfg)
       ledgerDB
   where

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 DiskSnapshotChecksum
+  , pattern NoDiskSnapshotChecksum
   , readSnapshot
     -- ** Write to disk
   , takeSnapshot
@@ -174,8 +178,10 @@ import           Ouroboros.Consensus.Storage.LedgerDB.Snapshots
                      (DiskSnapshot (..), SnapshotFailure (..),
                      TraceSnapshotEvent (..), decodeSnapshotBackwardsCompatible,
                      deleteSnapshot, diskSnapshotIsTemporary, encodeSnapshot,
-                     listSnapshots, readSnapshot, snapshotToFileName,
-                     snapshotToPath, takeSnapshot, trimSnapshots, writeSnapshot)
+                     listSnapshots, pattern DiskSnapshotChecksum,
+                     pattern NoDiskSnapshotChecksum, readSnapshot,
+                     snapshotToFileName, snapshotToPath, takeSnapshot,
+                     trimSnapshots, writeSnapshot)
 import           Ouroboros.Consensus.Storage.LedgerDB.Update
                      (AnnLedgerError (..), AnnLedgerError', Ap (..),
                      ExceededRollback (..), PushGoal (..), PushStart (..),

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/Init.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -35,6 +36,7 @@ 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
@@ -112,12 +114,13 @@ initLedgerDB replayTracer
              getGenesisLedger
              stream = do
     snapshots <- listSnapshots hasFS
-    tryNewestFirst id snapshots
+    tryNewestFirst DiskSnapshotChecksum id snapshots
   where
-    tryNewestFirst :: (InitLog blk -> InitLog blk)
+    tryNewestFirst :: Flag "DiskSnapshotChecksum"
+                   -> (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 +129,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 +138,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 NoDiskSnapshotChecksum 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
+            -- always reset checksum flag after failure
+            tryNewestFirst DiskSnapshotChecksum (acc . InitFailure s err) ss
           Right (r, l, replayed) ->
             return (acc (InitFromSnapshot s r), l, replayed)
 
@@ -170,10 +181,11 @@ initFromSnapshot ::
   -> LedgerDbCfg (ExtLedgerState blk)
   -> StreamAPI m blk blk
   -> DiskSnapshot
+  -> Flag "DiskSnapshotChecksum"
   -> 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