Define (en|de)codeExtLedgerState' in Extended.hs

IntersectMBO · Apr 16, 2024 · 4a648fd · 4a648fd
1 parent b33b860
commit 4a648fd
Show file tree

Hide file tree

Showing 3 changed files with 32 additions and 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
@@ -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
@@ -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/...boros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/LgrDB.hs b/...boros-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