Translate tables if needed when pushing diffs in V2

cabal.project

@@ -14,7 +14,7 @@ repository cardano-haskell-packages
 -- update either of these.
 index-state:
   -- Bump this if you need newer packages from Hackage
-  , hackage.haskell.org 2024-12-31T10:16:13Z
+  , hackage.haskell.org 2025-01-14T03:16:27Z
   -- Bump this if you need newer packages from CHaP
   , cardano-haskell-packages 2025-01-04T13:50:25Z
 

ouroboros-consensus-cardano/app/snapshot-converter.hs

@@ -39,6 +39,7 @@ import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.BackingStore.Impl.LMDB
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.DbChangelog as V1
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Lock as V1
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Snapshots as V1
+import qualified Ouroboros.Consensus.Storage.LedgerDB.V2 as V2
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as V2
 import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.LedgerSeq as V2
 import           Ouroboros.Consensus.Util.CRC
@@ -178,6 +179,7 @@ load ::
        ( LedgerDbSerialiseConstraints blk
        , CanStowLedgerTables (LedgerState blk)
        , LedgerSupportsProtocol blk
+       , V2.LedgerSupportsV2LedgerDB blk
        )
     => Config
     -> ResourceRegistry IO
@@ -226,6 +228,7 @@ store ::
        ( LedgerDbSerialiseConstraints blk
        , CanStowLedgerTables (LedgerState blk)
        , LedgerSupportsProtocol blk
+       , V2.LedgerSupportsV2LedgerDB blk
        )
     => Config
     -> CodecConfig blk

ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs

@@ -86,6 +86,7 @@ import           Ouroboros.Consensus.Ledger.Query
 import           Ouroboros.Consensus.Ledger.SupportsPeerSelection
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.Ledger.Tables.Utils
+import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as V2
 import           Ouroboros.Consensus.Util (ShowProxy (..))
 
 {-------------------------------------------------------------------------------
@@ -527,3 +528,6 @@ decodeByronResult :: BlockQuery ByronBlock fp result
                   -> forall s. Decoder s result
 decodeByronResult query = case query of
     GetUpdateInterfaceState -> fromByronCBOR
+
+instance V2.CanUpgradeLedgerTables (LedgerState ByronBlock) where
+  upgradeTables _ _ = id

ouroboros-consensus-cardano/src/shelley/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs

@@ -108,6 +108,7 @@ import           Ouroboros.Consensus.Shelley.Ledger.Config
 import           Ouroboros.Consensus.Shelley.Ledger.Protocol ()
 import           Ouroboros.Consensus.Shelley.Protocol.Abstract
                      (EnvelopeCheckError, envelopeChecks, mkHeaderView)
+import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory as V2
 import           Ouroboros.Consensus.Util.CBOR (decodeWithOrigin,
                      encodeWithOrigin)
 import           Ouroboros.Consensus.Util.Versioned
@@ -754,3 +755,6 @@ decodeShelleyLedgerState = decodeVersion [
         , shelleyLedgerTransition
         , shelleyLedgerTables = emptyLedgerTables
         }
+
+instance V2.CanUpgradeLedgerTables (LedgerState (ShelleyBlock proto era)) where
+  upgradeTables _ _ = id

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs

@@ -82,6 +82,7 @@ import           Ouroboros.Consensus.Node.Run
 import           Ouroboros.Consensus.Node.Serialisation
 import           Ouroboros.Consensus.Protocol.Abstract
 import           Ouroboros.Consensus.Storage.ImmutableDB (simpleChunkInfo)
+import           Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory
 import           Ouroboros.Consensus.Storage.Serialisation
 import           Ouroboros.Consensus.Util (repeatedlyM)
 import           Ouroboros.Consensus.Util.Condense
@@ -211,6 +212,9 @@ deriving via TrivialLedgerTables (Ticked (LedgerState BlockA))
     instance HasLedgerTables (Ticked (LedgerState BlockA))
 deriving via TrivialLedgerTables (LedgerState BlockA)
     instance CanStowLedgerTables (LedgerState BlockA)
+deriving via TrivialLedgerTables (LedgerState BlockA)
+    instance CanUpgradeLedgerTables (LedgerState BlockA)
+
 
 data PartialLedgerConfigA = LCfgA {
       lcfgA_k           :: SecurityParam

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs

@@ -68,6 +68,7 @@ import           Ouroboros.Consensus.Node.Run
 import           Ouroboros.Consensus.Node.Serialisation
 import           Ouroboros.Consensus.Protocol.Abstract
 import           Ouroboros.Consensus.Storage.ImmutableDB (simpleChunkInfo)
+import           Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory
 import           Ouroboros.Consensus.Storage.Serialisation
 import           Ouroboros.Consensus.Util.Condense
 import           Ouroboros.Consensus.Util.Orphans ()
@@ -186,6 +187,8 @@ deriving via TrivialLedgerTables (Ticked (LedgerState BlockB))
     instance HasLedgerTables (Ticked (LedgerState BlockB))
 deriving via TrivialLedgerTables (LedgerState BlockB)
     instance CanStowLedgerTables (LedgerState BlockB)
+deriving via TrivialLedgerTables (LedgerState BlockB)
+    instance CanUpgradeLedgerTables (LedgerState BlockB)
 
 type instance LedgerCfg (LedgerState BlockB) = ()
 

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs

@@ -49,6 +49,7 @@ import           Control.Monad.Except (throwError, withExcept)
 import           Data.Functor ((<&>))
 import           Data.Functor.Product
 import           Data.Kind (Type)
+import qualified Data.Map.Strict as Map
 import           Data.Maybe (fromMaybe)
 import           Data.MemPack
 import           Data.Proxy
@@ -89,6 +90,7 @@ import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.Inspect
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.Ledger.Tables.Utils
+import           Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory
 import           Ouroboros.Consensus.TypeFamilyWrappers
 import           Ouroboros.Consensus.Util.Condense
 
@@ -1110,6 +1112,43 @@ class ( Show (HardForkTxOut xs)
   default txOutEjections :: CanHardFork xs => NP (K (NS WrapTxOut xs) -.-> WrapTxOut) xs
   txOutEjections = composeTxOutTranslations $ ipTranslateTxOut hardForkEraTranslation
 
+instance (CanHardFork xs, HasHardForkTxOut xs)
+      => CanUpgradeLedgerTables (LedgerState (HardForkBlock xs)) where
+  upgradeTables
+    (HardForkLedgerState (HardForkState hs0))
+    (HardForkLedgerState (HardForkState hs1))
+    orig@(LedgerTables (ValuesMK vs)) =
+      if (nsToIndex $ Telescope.tip hs0) /= (nsToIndex t1)
+      then LedgerTables $ ValuesMK $ extendTables (hmap (const (K ())) t1) vs
+      else orig
+   where
+     t1 = Telescope.tip hs1
+
+extendTables ::
+        forall xs.
+        (CanHardFork xs, HasHardForkTxOut xs)
+     => NS (K ()) xs
+     -> Map.Map
+          (TxIn (LedgerState (HardForkBlock xs)))
+          (TxOut (LedgerState (HardForkBlock xs)))
+     -> Map.Map
+          (TxIn (LedgerState (HardForkBlock xs)))
+          (TxOut (LedgerState (HardForkBlock xs)))
+extendTables st =
+    Map.map
+      (\txout ->
+          hcollapse
+        $ hcimap
+            proxySingle
+            (\idxTarget (K ()) ->
+                 K
+               . injectHardForkTxOut idxTarget
+               . ejectHardForkTxOut idxTarget
+               $ txout)
+            st
+      )
+
+
 injectHardForkTxOutDefault ::
      Index xs x
   -> TxOut (LedgerState x)

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs

@@ -61,6 +61,7 @@ module Ouroboros.Consensus.Ledger.Dual (
   , encodeDualLedgerState
   ) where
 
+import Ouroboros.Consensus.Storage.LedgerDB.V2.InMemory
 import           Cardano.Binary (enforceSize)
 import           Codec.CBOR.Decoding (Decoder)
 import           Codec.CBOR.Encoding (Encoding, encodeListLen)
@@ -948,6 +949,9 @@ decodeDualLedgerState decodeMain = do
 type instance TxIn  (LedgerState (DualBlock m a)) = TxIn  (LedgerState m)
 type instance TxOut (LedgerState (DualBlock m a)) = TxOut (LedgerState m)
 
+instance CanUpgradeLedgerTables (LedgerState (DualBlock m a)) where
+  upgradeTables _ _ = id
+
 instance (
     Bridge m a
 #if __GLASGOW_HASKELL__ >= 906

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables.hs

@@ -9,8 +9,6 @@
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-{-# OPTIONS_GHC -Wno-orphans #-}
-
 -- | This module defines the 'LedgerTables', a portion of the Ledger notion of a
 -- /ledger state/ (not to confuse with our
 -- 'Ouroboros.Consensus.Ledger.Basics.LedgerState') that together with it,
@@ -184,7 +182,7 @@ import           Data.ByteString (ByteString)
 import           Data.Kind (Constraint, Type)
 import qualified Data.Map.Strict as Map
 import           Data.MemPack
-import           Data.Void (Void, absurd)
+import           Data.Void (Void)
 import           NoThunks.Class (NoThunks (..))
 import           Ouroboros.Consensus.Ledger.Tables.Basics
 import           Ouroboros.Consensus.Ledger.Tables.Combinators
@@ -301,18 +299,6 @@ valuesMKDecoder = do
     ValuesMK . Map.fromList
       <$> replicateM len (unpackError @(TxIn l, TxOut l) @ByteString <$> fromCBOR)
 
--- TODO these instances will be gone once we update our ref for mempack which
--- @lehins will have to release.
---
--- Remove also the Wno-orphans above!
-instance MemPack Void where
-  packedByteCount = absurd
-  {-# INLINE packedByteCount #-}
-  packM = absurd
-  {-# INLINE packM #-}
-  unpackM = error "absurd"
-  {-# INLINE unpackM #-}
-
 {-------------------------------------------------------------------------------
   Special classes of ledger states
 -------------------------------------------------------------------------------}

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Node/Run.hs

@@ -36,6 +36,7 @@ import           Ouroboros.Consensus.Storage.ChainDB
                      (ImmutableDbSerialiseConstraints,
                      LedgerDbSerialiseConstraints, SerialiseDiskConstraints,
                      VolatileDbSerialiseConstraints)
+import           Ouroboros.Consensus.Storage.LedgerDB.V2
 import           Ouroboros.Consensus.Storage.Serialisation
 import           Ouroboros.Consensus.Util (ShowProxy)
 import           Ouroboros.Network.Block (Serialised)
@@ -106,6 +107,7 @@ class ( LedgerSupportsProtocol            blk
       , ShowProxy             (BlockQuery blk)
       , ShowProxy            (TxId (GenTx blk))
       , (forall fp. ShowQuery (BlockQuery blk fp))
+      , LedgerSupportsV2LedgerDB          blk
       ) => RunNode blk
   -- This class is intentionally empty. It is not necessarily compositional - ie
   -- the instance for 'HardForkBlock' might do more than merely delegate to the

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

@@ -65,6 +65,8 @@ import           Ouroboros.Consensus.Storage.ChainDB.Impl.Types
 import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
 import qualified Ouroboros.Consensus.Storage.ImmutableDB.Stream as ImmutableDB
 import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
+import           Ouroboros.Consensus.Storage.LedgerDB.V2
+                     (LedgerSupportsV2LedgerDB)
 import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB
 import           Ouroboros.Consensus.Util (newFuse, whenJust, withFuse)
 import           Ouroboros.Consensus.Util.Args
@@ -88,6 +90,7 @@ withDB ::
      , HasHardForkHistory blk
      , ConvertRawHash blk
      , SerialiseDiskConstraints blk
+     , LedgerSupportsV2LedgerDB blk
      )
   => Complete Args.ChainDbArgs m blk
   -> (ChainDB m blk -> m a)
@@ -103,6 +106,7 @@ openDB ::
      , HasHardForkHistory blk
      , ConvertRawHash blk
      , SerialiseDiskConstraints blk
+     , LedgerDB.LedgerSupportsV2LedgerDB blk
      )
   => Complete Args.ChainDbArgs m blk
   -> m (ChainDB m blk)
@@ -118,6 +122,7 @@ openDBInternal ::
      , ConvertRawHash blk
      , SerialiseDiskConstraints blk
      , HasCallStack
+     , LedgerDB.LedgerSupportsV2LedgerDB blk
      )
   => Complete Args.ChainDbArgs m blk
   -> Bool -- ^ 'True' = Launch background tasks

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

@@ -12,6 +12,7 @@ module Ouroboros.Consensus.Storage.LedgerDB (
   , module Ouroboros.Consensus.Storage.LedgerDB.Forker
   , module Ouroboros.Consensus.Storage.LedgerDB.TraceEvent
     -- * Impl
+  , V2.LedgerSupportsV2LedgerDB
   , openDB
   , openDBInternal
   ) where
@@ -43,6 +44,7 @@ openDB ::
   , InspectLedger blk
   , HasCallStack
   , HasHardForkHistory blk
+  , V2.LedgerSupportsV2LedgerDB blk
   )
   => Complete LedgerDbArgs m blk
   -- ^ Stateless initializaton arguments

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

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
@@ -15,7 +16,10 @@
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-module Ouroboros.Consensus.Storage.LedgerDB.V2 (mkInitDb) where
+module Ouroboros.Consensus.Storage.LedgerDB.V2 (
+    LedgerSupportsV2LedgerDB
+  , mkInitDb
+  ) where
 
 import           Control.Arrow ((>>>))
 import qualified Control.Monad as Monad (void, (>=>))
@@ -63,11 +67,15 @@ import           Ouroboros.Network.Protocol.LocalStateQuery.Type
 import           Prelude hiding (read)
 import           System.FS.API
 
+type LedgerSupportsV2LedgerDB blk =
+  (InMemory.CanUpgradeLedgerTables (LedgerState blk))
+
 mkInitDb :: forall m blk.
             ( LedgerSupportsProtocol blk
             , IOLike m
             , LedgerDbSerialiseConstraints blk
             , HasHardForkHistory blk
+            , InMemory.CanUpgradeLedgerTables (LedgerState blk)
             )
          => Complete LedgerDbArgs m blk
          -> Complete V2.LedgerDbFlavorArgs m

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB/V2/Forker.hs

@@ -114,13 +114,15 @@ implForkerPush ::
 implForkerPush env newState = do
   traceWith (foeTracer env) ForkerPushStart
   lseq <- readTVarIO (foeLedgerSeq env)
-  let (st, tbs) = (forgetLedgerTables newState, ltprj newState)
+
+  let st0 = current lseq
+      st = forgetLedgerTables newState
 
   bracketOnError
     (duplicate (tables $ currentHandle lseq))
     close
     (\newtbs -> do
-        pushDiffs newtbs tbs
+        pushDiffs newtbs st0 newState
 
         let lseq' = extend (StateRef st newtbs) lseq