From 4a648fd18a3e6b251478023764f7cf2fe77c9d96 Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Wed, 10 Apr 2024 17:32:49 +0200 Subject: [PATCH] Define `(en|de)codeExtLedgerState'` in `Extended.hs` --- .../Cardano/Tools/DBAnalyser/Run.hs | 12 +------- .../Ouroboros/Consensus/Ledger/Extended.hs | 29 +++++++++++++++++++ .../Consensus/Storage/ChainDB/Impl/LgrDB.hs | 18 ++---------- 3 files changed, 32 insertions(+), 27 deletions(-) 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 9dc848d0f8..5f45c342d6 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 @@ -8,7 +8,6 @@ module Cardano.Tools.DBAnalyser.Run (analyse) where import Cardano.Tools.DBAnalyser.Analysis import Cardano.Tools.DBAnalyser.HasAnalysis import Cardano.Tools.DBAnalyser.Types -import Codec.CBOR.Decoding (Decoder) import Codec.Serialise (Serialise (decode)) import Control.Monad.Except (runExceptT) import Control.Tracer (Tracer (..), nullTracer) @@ -26,7 +25,6 @@ import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import Ouroboros.Consensus.Storage.ChainDB.Impl.Args (fromChainDbArgs) import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import Ouroboros.Consensus.Storage.LedgerDB (readSnapshot) -import Ouroboros.Consensus.Storage.Serialisation (DecodeDisk (..)) import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () @@ -76,7 +74,7 @@ analyse DBAnalyserConfig{analysis, confLimit, dbDir, selectDB, validation, verbo -- how to do it. initLedgerErr <- runExceptT $ case initializeFrom of Nothing -> pure genesisLedger - Just snapshot -> readSnapshot ledgerDbFS (decodeExtLedgerState' cfg) decode snapshot + Just snapshot -> readSnapshot ledgerDbFS (decodeDiskExtLedgerState $ configCodec cfg) decode snapshot -- TODO @readSnapshot@ has type @ExceptT ReadIncrementalErr m -- (ExtLedgerState blk)@ but it also throws exceptions! This makes -- error handling more challenging than it ought to be. Maybe we @@ -138,11 +136,3 @@ analyse DBAnalyserConfig{analysis, confLimit, dbDir, selectDB, validation, verbo (_, Just MinimumBlockValidation) -> VolatileDB.NoValidation (OnlyValidation, _ ) -> VolatileDB.ValidateAll _ -> VolatileDB.NoValidation - - decodeExtLedgerState' :: forall s . TopLevelConfig blk -> Decoder s (ExtLedgerState blk) - decodeExtLedgerState' cfg = - let ccfg = configCodec cfg - in decodeExtLedgerState - (decodeDisk ccfg) - (decodeDisk ccfg) - (decodeDisk ccfg) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs index 69a6361498..c39c1919db 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs @@ -20,6 +20,8 @@ module Ouroboros.Consensus.Ledger.Extended ( , ExtLedgerState (..) , ExtValidationError (..) -- * Serialisation + , decodeDiskExtLedgerState + , encodeDiskExtLedgerState , decodeExtLedgerState , encodeExtLedgerState -- * Casts @@ -43,6 +45,7 @@ import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Protocol.Abstract +import Ouroboros.Consensus.Storage.Serialisation {------------------------------------------------------------------------------- Extended ledger state @@ -194,6 +197,19 @@ encodeExtLedgerState encodeLedgerState encodeChainDepState encodeAnnTip +encodeDiskExtLedgerState :: + forall blk. + (EncodeDisk blk (LedgerState blk), + EncodeDisk blk (ChainDepState (BlockProtocol blk)), + EncodeDisk blk (AnnTip blk) + ) + => (CodecConfig blk -> ExtLedgerState blk -> Encoding) +encodeDiskExtLedgerState cfg = + encodeExtLedgerState + (encodeDisk cfg) + (encodeDisk cfg) + (encodeDisk cfg) + decodeExtLedgerState :: (forall s. Decoder s (LedgerState blk)) -> (forall s. Decoder s (ChainDepState (BlockProtocol blk))) -> (forall s. Decoder s (AnnTip blk)) @@ -210,6 +226,19 @@ decodeExtLedgerState decodeLedgerState decodeChainDepState decodeAnnTip +decodeDiskExtLedgerState :: + forall blk. + (DecodeDisk blk (LedgerState blk), + DecodeDisk blk (ChainDepState (BlockProtocol blk)), + DecodeDisk blk (AnnTip blk) + ) + => (CodecConfig blk -> forall s. Decoder s (ExtLedgerState blk)) +decodeDiskExtLedgerState cfg = + decodeExtLedgerState + (decodeDisk cfg) + (decodeDisk cfg) + (decodeDisk cfg) + {------------------------------------------------------------------------------- Casts -------------------------------------------------------------------------------} 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 3d0be05f05..4463c3789b 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 @@ -48,8 +48,6 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.LgrDB ( , mkLgrDB ) where -import Codec.CBOR.Decoding (Decoder) -import Codec.CBOR.Encoding (Encoding) import Codec.Serialise (Serialise (decode)) import Control.Monad.Trans.Class import Control.Tracer @@ -236,7 +234,7 @@ initFromDisk LgrDbArgs { lgrHasFS = hasFS, .. } replayTracer lgrTracer hasFS - decodeExtLedgerState' + (decodeDiskExtLedgerState ccfg) decode (LedgerDB.configLedgerDb lgrTopLevelConfig) lgrGenesis @@ -245,12 +243,6 @@ initFromDisk LgrDbArgs { lgrHasFS = hasFS, .. } where ccfg = configCodec lgrTopLevelConfig - decodeExtLedgerState' :: forall s. Decoder s (ExtLedgerState blk) - decodeExtLedgerState' = decodeExtLedgerState - (decodeDisk ccfg) - (decodeDisk ccfg) - (decodeDisk ccfg) - -- | For testing purposes mkLgrDB :: StrictTVar m (LedgerDB' blk) -> StrictTVar m (Set (RealPoint blk)) @@ -300,17 +292,11 @@ takeSnapshot lgrDB@LgrDB{ cfg, tracer, hasFS } = wrapFailure (Proxy @blk) $ do LedgerDB.takeSnapshot tracer hasFS - encodeExtLedgerState' + (encodeDiskExtLedgerState ccfg) ledgerDB where ccfg = configCodec cfg - encodeExtLedgerState' :: ExtLedgerState blk -> Encoding - encodeExtLedgerState' = encodeExtLedgerState - (encodeDisk ccfg) - (encodeDisk ccfg) - (encodeDisk ccfg) - trimSnapshots :: forall m blk. (MonadCatch m, HasHeader blk) => LgrDB m blk