From b524f6486cbe8952c126338116a7a18e29518ad1 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` Stylish, hlint, add changelog entries --- .../app/DBAnalyser/Parsers.hs | 12 +- ...orgy.lukyanov_892_checksum_snaphot_file.md | 3 + .../Cardano/Tools/DBAnalyser/Analysis.hs | 5 +- .../Cardano/Tools/DBAnalyser/Run.hs | 3 +- .../Cardano/Tools/DBAnalyser/Types.hs | 15 +- .../test/tools-test/Main.hs | 5 + ...orgy.lukyanov_892_checksum_snaphot_file.md | 13 ++ .../Consensus/Storage/ChainDB/Impl/LgrDB.hs | 1 + .../Ouroboros/Consensus/Storage/LedgerDB.hs | 10 +- .../Consensus/Storage/LedgerDB/Init.hs | 28 +++- .../Consensus/Storage/LedgerDB/Snapshots.hs | 146 +++++++++++++++--- .../Ouroboros/Consensus/Util.hs | 18 +++ .../Ouroboros/Consensus/Util/CBOR.hs | 24 +-- .../Test/Util/Orphans/ToExpr.hs | 2 + .../Test/Ouroboros/Storage/LedgerDB/OnDisk.hs | 13 +- .../Storage/LedgerDB/OrphanArbitrary.hs | 6 + 16 files changed, 245 insertions(+), 59 deletions(-) create mode 100644 ouroboros-consensus-cardano/changelog.d/20241129_122139_georgy.lukyanov_892_checksum_snaphot_file.md 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..d25a29da38 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.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 = diff --git a/ouroboros-consensus-cardano/changelog.d/20241129_122139_georgy.lukyanov_892_checksum_snaphot_file.md b/ouroboros-consensus-cardano/changelog.d/20241129_122139_georgy.lukyanov_892_checksum_snaphot_file.md new file mode 100644 index 0000000000..296522338a --- /dev/null +++ b/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 `.checksum` file to be present. This behaviour is disabled by default for backwards compatibility. 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..e97ca25a19 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 @@ -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 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..fd66dcc7c0 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, 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 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..23b7e54756 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 + , diskSnapshotChecksum :: Flag "DiskSnapshotChecksum" } data AnalysisName = diff --git a/ouroboros-consensus-cardano/test/tools-test/Main.hs b/ouroboros-consensus-cardano/test/tools-test/Main.hs index 0ff98843e6..115b47373a 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.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) 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..0689399a40 --- /dev/null +++ b/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` 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..86654cc4ac 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 @@ -285,6 +285,7 @@ takeSnapshot lgrDB@LgrDB{ cfg, tracer, hasFS } = wrapFailure (Proxy @blk) $ do LedgerDB.takeSnapshot tracer hasFS + LedgerDB.DiskSnapshotChecksum (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..463fbdcb11 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 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 (..), 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..0931336f28 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,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 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..12c99c7ba6 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,9 +1,12 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -12,9 +15,12 @@ module Ouroboros.Consensus.Storage.LedgerDB.Snapshots ( DiskSnapshot (..) -- * Read from disk + , ReadSnapshotErr (..) , SnapshotFailure (..) , diskSnapshotIsTemporary , listSnapshots + , pattern DiskSnapshotChecksum + , pattern NoDiskSnapshotChecksum , readSnapshot -- * Write to disk , takeSnapshot @@ -34,13 +40,19 @@ 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.Coerce (coerce) 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 @@ -50,12 +62,14 @@ import Ouroboros.Consensus.Block import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy +import Ouroboros.Consensus.Util (Flag (..)) import Ouroboros.Consensus.Util.CBOR (ReadIncrementalErr, decodeWithOrigin, readIncremental) 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 +80,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 +96,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 +124,10 @@ takeSnapshot :: forall m blk. (MonadThrow m, MonadMonotonicTime m, IsLedger (LedgerState blk)) => Tracer m (TraceSnapshotEvent blk) -> SomeHasFS m + -> Flag "DiskSnapshotChecksum" -> (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 +139,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 +166,9 @@ trimSnapshots tracer hasFS DiskPolicy{..} = do Internal: reading from disk -------------------------------------------------------------------------------} +-- | Name of a disk snapshot. +-- +-- The snapshot itself does not have to exist. data DiskSnapshot = DiskSnapshot { -- | Snapshots are numbered. We will try the snapshots with the highest -- number first. @@ -169,7 +189,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 +203,114 @@ 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) + +pattern DiskSnapshotChecksum, NoDiskSnapshotChecksum :: Flag "DiskSnapshotChecksum" +pattern DiskSnapshotChecksum = Flag True +pattern NoDiskSnapshotChecksum = Flag False + +-- | 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 "DiskSnapshotChecksum" -> 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 (coerce doChecksum) decoder (snapshotToPath snapshotName) + when (coerce 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 "DiskSnapshotChecksum" -> (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 (coerce 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 +318,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 +331,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..6d119bf357 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,17 @@ 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. +-- Use 'coerce' to unwrap for use in e.g. if-statements. +-- +-- See 'Ouroboros.Consensus.Storage.LedgerDB.Snapshots.DiskSnapshotChecksum' +-- for an example. +newtype Flag (name :: Symbol) = Flag 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/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/OnDisk.hs b/ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/LedgerDB/OnDisk.hs index c408566390..4599214068 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 @@ -111,7 +111,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,7 +292,7 @@ data Cmd ss = | Switch Word64 [TestBlock] -- | Take a snapshot (write to disk) - | Snap + | Snap (Flag "DiskSnapshotChecksum") -- | Restore the DB from on-disk, then return it along with the init log | Restore @@ -504,7 +504,7 @@ runMock cmd initMock = 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) @@ -750,12 +750,13 @@ 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 @@ -941,7 +942,7 @@ generator secParam (Model mock hs) = Just $ QC.oneof $ concat [ numNewBlocks (lastAppliedPoint . ledgerState . mockCurrent $ afterRollback) return $ Switch numRollback blocks - , fmap At $ return Snap + , fmap At $ Snap <$> QC.arbitrary , fmap At $ return Restore , fmap At $ Drop <$> QC.choose (0, mockChainLength mock) ] @@ -968,7 +969,7 @@ shrinker _ (At cmd) = case cmd of Current -> [] Push _b -> [] - Snap -> [] + Snap{} -> [] Restore -> [] Switch 0 [b] -> [At $ Push b] Switch n bs -> if length bs > fromIntegral n 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)