Ledger Integration for cardano-node 10.7

cabal.project

@@ -53,8 +53,8 @@ if impl (ghc >= 9.10)
 source-repository-package
   type: git
   location: https://github.com/IntersectMBO/cardano-ledger
-  tag: fb09078fa55015c881303a2ddb609c024cec258f
-  --sha256: sha256-9Y9CRiyMn0AWD+C4aNVMaJgrj3FDAYfCX4VrLvtoMaI=
+  tag: c9cd2e7e9eed58320b252b92edbe6afe276a10a5
+  --sha256: sha256-0HM06cQfij8OFAjlcqIXkvKQYpT/is383BPzGJAJgqc=
   subdir:
     eras/allegra/impl
     eras/alonzo/impl

ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal

@@ -142,16 +142,16 @@ library
     cardano-ledger-allegra ^>=1.9,
     cardano-ledger-alonzo ^>=1.15,
     cardano-ledger-api ^>=1.13,
-    cardano-ledger-babbage ^>=1.12,
-    cardano-ledger-binary ^>=1.7,
-    cardano-ledger-byron ^>=1.2,
+    cardano-ledger-babbage ^>=1.13,
+    cardano-ledger-binary ^>=1.8,
+    cardano-ledger-byron ^>=1.3,
     cardano-ledger-conway ^>=1.21,
     cardano-ledger-core ^>=1.19,
     cardano-ledger-dijkstra ^>=0.2,
-    cardano-ledger-mary ^>=1.9,
-    cardano-ledger-shelley ^>=1.17,
+    cardano-ledger-mary ^>=1.10,
+    cardano-ledger-shelley ^>=1.18,
     cardano-prelude,
-    cardano-protocol-tpraos ^>=1.4.1,
+    cardano-protocol-tpraos ^>=1.5,
     cardano-slotting,
     cardano-strict-containers,
     cborg ^>=0.2.2,
@@ -238,8 +238,7 @@ library unstable-byron-testlib
     cardano-binary,
     cardano-crypto,
     cardano-crypto-class,
-    cardano-crypto-test,
-    cardano-crypto-wrapper,
+    cardano-crypto-wrapper:{cardano-crypto-wrapper, testlib},
     cardano-ledger-binary:{cardano-ledger-binary, testlib},
     cardano-ledger-byron:{cardano-ledger-byron, testlib},
     cardano-ledger-core,
@@ -570,7 +569,7 @@ library unstable-cardano-tools
     cardano-ledger-mary,
     cardano-ledger-shelley,
     cardano-prelude,
-    cardano-protocol-tpraos ^>=1.4.1,
+    cardano-protocol-tpraos ^>=1.5,
     cardano-slotting,
     cardano-strict-containers,
     cborg ^>=0.2.2,

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

@@ -123,11 +123,11 @@ class
     SL.LedgerEnv era ->
     SL.LedgerState era ->
     WhetherToIntervene ->
-    Core.Tx era ->
+    Core.Tx TopTx era ->
     Except
       (SL.ApplyTxError era)
       ( SL.LedgerState era
-      , SL.Validated (Core.Tx era)
+      , SL.Validated (Core.Tx TopTx era)
       )
 
   -- | Whether the era has an instance of 'CG.ConwayEraGov'
@@ -148,11 +148,11 @@ defaultApplyShelleyBasedTx ::
   SL.LedgerEnv era ->
   SL.LedgerState era ->
   WhetherToIntervene ->
-  Core.Tx era ->
+  Core.Tx TopTx era ->
   Except
     (SL.ApplyTxError era)
     ( SL.LedgerState era
-    , SL.Validated (Core.Tx era)
+    , SL.Validated (Core.Tx TopTx era)
     )
 defaultApplyShelleyBasedTx globals ledgerEnv mempoolState _wti tx =
   liftEither $
@@ -210,11 +210,11 @@ applyAlonzoBasedTx ::
   SL.LedgerEnv era ->
   SL.LedgerState era ->
   WhetherToIntervene ->
-  Core.Tx era ->
+  Core.Tx TopTx era ->
   Except
     (SL.ApplyTxError era)
     ( SL.LedgerState era
-    , SL.Validated (Core.Tx era)
+    , SL.Validated (Core.Tx TopTx era)
     )
 applyAlonzoBasedTx globals ledgerEnv mempoolState wti tx = do
   (mempoolState', vtx) <-

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

@@ -62,6 +62,7 @@ import Cardano.Protocol.Crypto (Crypto)
 import qualified Cardano.Protocol.TPraos.BHeader as SL
 import qualified Data.ByteString.Lazy as Lazy
 import Data.Coerce (coerce)
+import Data.Either (fromRight)
 import Data.Typeable (Typeable)
 import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks (..))
@@ -311,7 +312,9 @@ decodeShelleyBlock ::
   ShelleyCompatible proto era =>
   forall s.
   Plain.Decoder s (Lazy.ByteString -> ShelleyBlock proto era)
-decodeShelleyBlock = eraDecoder @era $ (. Full) . runAnnotator <$> decCBOR
+decodeShelleyBlock =
+  eraDecoder @era $
+    (. Full) . (fromRight (error "TODO(geo2a): remove fromRight") .) . runAnnotator <$> decCBOR
 
 shelleyBinaryBlockInfo ::
   forall proto era. ShelleyCompatible proto era => ShelleyBlock proto era -> BinaryBlockInfo
@@ -335,7 +338,9 @@ decodeShelleyHeader ::
   ShelleyCompatible proto era =>
   forall s.
   Plain.Decoder s (Lazy.ByteString -> Header (ShelleyBlock proto era))
-decodeShelleyHeader = eraDecoder @era $ (. Full) . runAnnotator <$> decCBOR
+decodeShelleyHeader =
+  eraDecoder @era $
+    (. Full) . (fromRight (error "TODO(geo2a): remove fromRight") .) . runAnnotator <$> decCBOR
 
 {-------------------------------------------------------------------------------
   Condense

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

@@ -6,7 +6,7 @@
 
 module Ouroboros.Consensus.Shelley.Ledger.Forge (forgeShelleyBlock) where
 
-import qualified Cardano.Ledger.Core as Core (Tx)
+import qualified Cardano.Ledger.Core as Core (TopTx, Tx)
 import qualified Cardano.Ledger.Core as SL (hashBlockBody, mkBasicBlockBody, txSeqBlockBodyL)
 import qualified Cardano.Ledger.Shelley.API as SL (Block (..), extractTx)
 import qualified Cardano.Ledger.Shelley.BlockBody as SL (bBodySize)
@@ -85,7 +85,7 @@ forgeShelleyBlock
 
     actualBodySize = SL.bBodySize protocolVersion body
 
-    extractTx :: Validated (GenTx (ShelleyBlock proto era)) -> Core.Tx era
+    extractTx :: Validated (GenTx (ShelleyBlock proto era)) -> Core.Tx Core.TopTx era
     extractTx (ShelleyValidatedTx _txid vtx) = SL.extractTx vtx
 
     prevHash :: SL.PrevHash

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

@@ -45,6 +45,7 @@ import qualified Cardano.Crypto.Hash as Hash
 import qualified Cardano.Ledger.Allegra.Rules as AllegraEra
 import Cardano.Ledger.Alonzo.Core
   ( BlockBody
+  , TopTx
   , Tx
   , allInputsTxBodyF
   , bodyTxL
@@ -86,6 +87,7 @@ import Control.Monad (guard)
 import Control.Monad.Except (Except, liftEither)
 import Control.Monad.Identity (Identity (..))
 import Data.DerivingVia (InstantiatedAt (..))
+import Data.Either (fromRight)
 import Data.Foldable (toList)
 import Data.Measure (Measure)
 import Data.Typeable (Typeable)
@@ -112,7 +114,7 @@ import Ouroboros.Consensus.Util (ShowProxy (..), coerceSet)
 import Ouroboros.Consensus.Util.Condense
 import Ouroboros.Network.Block (unwrapCBORinCBOR, wrapCBORinCBOR)
 
-data instance GenTx (ShelleyBlock proto era) = ShelleyTx !SL.TxId !(Tx era)
+data instance GenTx (ShelleyBlock proto era) = ShelleyTx !SL.TxId !(Tx TopTx era)
   deriving stock Generic
 
 deriving instance ShelleyBasedEra era => NoThunks (GenTx (ShelleyBlock proto era))
@@ -126,7 +128,7 @@ instance
 data instance Validated (GenTx (ShelleyBlock proto era))
   = ShelleyValidatedTx
       !SL.TxId
-      !(SL.Validated (Tx era))
+      !(SL.Validated (Tx TopTx era))
   deriving stock Generic
 
 deriving instance ShelleyBasedEra era => NoThunks (Validated (GenTx (ShelleyBlock proto era)))
@@ -186,13 +188,14 @@ instance
         coerceSet
           (tx ^. bodyTxL . allInputsTxBodyF)
 
-mkShelleyTx :: forall era proto. ShelleyBasedEra era => Tx era -> GenTx (ShelleyBlock proto era)
+mkShelleyTx ::
+  forall era proto. ShelleyBasedEra era => Tx TopTx era -> GenTx (ShelleyBlock proto era)
 mkShelleyTx tx = ShelleyTx (txIdTx tx) tx
 
 mkShelleyValidatedTx ::
   forall era proto.
   ShelleyBasedEra era =>
-  SL.Validated (Tx era) ->
+  SL.Validated (Tx TopTx era) ->
   Validated (GenTx (ShelleyBlock proto era))
 mkShelleyValidatedTx vtx = ShelleyValidatedTx txid vtx
  where
@@ -202,7 +205,7 @@ newtype instance TxId (GenTx (ShelleyBlock proto era)) = ShelleyTxId SL.TxId
   deriving newtype (Eq, Ord, NoThunks)
 
 deriving newtype instance
-  (Typeable era, Typeable proto, Crypto (ProtoCrypto proto)) =>
+  Crypto (ProtoCrypto proto) =>
   EncCBOR (TxId (GenTx (ShelleyBlock proto era)))
 deriving newtype instance
   (Typeable era, Typeable proto, Crypto (ProtoCrypto proto)) =>
@@ -226,7 +229,7 @@ instance ShelleyBasedEra era => HasTxs (ShelleyBlock proto era) where
       . SL.blockBody
       . shelleyBlockRaw
    where
-    blockBodyToTxList :: BlockBody era -> [Tx era]
+    blockBodyToTxList :: BlockBody era -> [Tx TopTx era]
     blockBodyToTxList blockBody = toList $ blockBody ^. txSeqBlockBodyL
 
 {-------------------------------------------------------------------------------
@@ -243,7 +246,7 @@ instance ShelleyCompatible proto era => FromCBOR (GenTx (ShelleyBlock proto era)
     fmap mkShelleyTx $
       unwrapCBORinCBOR $
         eraDecoder @era $
-          (. Full) . runAnnotator <$> decCBOR
+          (. Full) . (fromRight (error "TODO(geo2a): remove fromRight") .) . runAnnotator <$> decCBOR
 
 {-------------------------------------------------------------------------------
   Pretty-printing

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

@@ -37,6 +37,14 @@ instance SL.EraCertState era => LedgerSupportsPeerSelection (ShelleyBlock proto
     poolDistr :: SL.PoolDistr
     poolDistr = SL.nesPd shelleyLedgerState
 
+    futurePoolParams
+      , poolParams ::
+        Map (SL.KeyHash 'SL.StakePool) SL.StakePoolParams
+    (futurePoolParams, poolParams) =
+      ( SL.psFutureStakePoolParams pstate
+      , Map.mapWithKey SL.stakePoolStateToStakePoolParams (SL.psStakePools pstate)
+      )
+
     -- Sort stake pools by descending stake
     orderByStake ::
       SL.PoolDistr ->
@@ -72,14 +80,14 @@ instance SL.EraCertState era => LedgerSupportsPeerSelection (ShelleyBlock proto
     -- Note that a stake pool can have multiple registered relays
     pparamsLedgerRelayAccessPoints ::
       (LedgerRelayAccessPoint -> StakePoolRelay) ->
-      SL.StakePoolState ->
+      SL.StakePoolParams ->
       Maybe (NonEmpty StakePoolRelay)
     pparamsLedgerRelayAccessPoints injStakePoolRelay =
       NE.nonEmpty
         . force
         . mapMaybe (fmap injStakePoolRelay . relayToLedgerRelayAccessPoint)
         . toList
-        . SL.spsRelays
+        . SL.sppRelays
 
     -- Combine the stake pools registered in the future and the current pool
     -- parameters, and remove duplicates.
@@ -88,8 +96,8 @@ instance SL.EraCertState era => LedgerSupportsPeerSelection (ShelleyBlock proto
     poolLedgerRelayAccessPoints =
       Map.unionWith
         (\futureRelays currentRelays -> NE.nub (futureRelays <> currentRelays))
-        (Map.mapMaybe (pparamsLedgerRelayAccessPoints FutureRelay) (SL.psStakePools pstate))
-        (Map.mapMaybe (pparamsLedgerRelayAccessPoints CurrentRelay) (SL.psFutureStakePools pstate))
+        (Map.mapMaybe (pparamsLedgerRelayAccessPoints FutureRelay) futurePoolParams)
+        (Map.mapMaybe (pparamsLedgerRelayAccessPoints CurrentRelay) poolParams)
 
     pstate :: SL.PState era
     pstate =

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

@@ -232,7 +232,7 @@ data instance BlockQuery (ShelleyBlock proto era) fp result where
     BlockQuery
       (ShelleyBlock proto era)
       QFNoTables
-      (Map (SL.KeyHash 'SL.StakePool) SL.PoolParams)
+      (Map (SL.KeyHash 'SL.StakePool) SL.StakePoolParams)
   GetRewardInfoPools ::
     BlockQuery
       (ShelleyBlock proto era)

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

@@ -391,30 +391,30 @@ translateShelleyTables (LedgerTables utxoTable) =
 
 instance
   ( ShelleyBasedEra era
-  , SL.TranslateEra era SL.Tx
+  , SL.TranslateEra era (SL.Tx SL.TopTx)
   ) =>
   SL.TranslateEra era (GenTx :.: ShelleyBlock proto)
   where
-  type TranslationError era (GenTx :.: ShelleyBlock proto) = SL.TranslationError era SL.Tx
+  type TranslationError era (GenTx :.: ShelleyBlock proto) = SL.TranslationError era (SL.Tx SL.TopTx)
   translateEra ctxt (Comp (ShelleyTx _txId tx)) =
     Comp . mkShelleyTx
       <$> SL.translateEra ctxt tx
 
 instance
   ( ShelleyBasedEra era
-  , SL.TranslateEra era SL.Tx
+  , SL.TranslateEra era (SL.Tx SL.TopTx)
   ) =>
   SL.TranslateEra era (WrapValidatedGenTx :.: ShelleyBlock proto)
   where
   type
     TranslationError era (WrapValidatedGenTx :.: ShelleyBlock proto) =
-      SL.TranslationError era SL.Tx
+      SL.TranslationError era (SL.Tx SL.TopTx)
   translateEra ctxt (Comp (WrapValidatedGenTx (ShelleyValidatedTx _txId vtx))) =
     Comp
       . WrapValidatedGenTx
       . mkShelleyValidatedTx
       . SL.coerceValidated
-      <$> SL.translateValidated @era @SL.Tx ctxt (SL.coerceValidated vtx)
+      <$> SL.translateValidated @era @(SL.Tx SL.TopTx) ctxt (SL.coerceValidated vtx)
 
 {-------------------------------------------------------------------------------
   Canonical TxIn

ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs

@@ -188,7 +188,7 @@ type ShelleyBasedHardForkConstraints proto1 era1 proto2 era2 =
   , TranslateTxMeasure (TxMeasure (ShelleyBlock proto1 era1)) (TxMeasure (ShelleyBlock proto2 era2))
   , SL.PreviousEra era2 ~ era1
   , SL.TranslateEra era2 SL.NewEpochState
-  , SL.TranslateEra era2 SL.Tx
+  , SL.TranslateEra era2 (SL.Tx SL.TopTx)
   , SL.TranslationError era2 SL.NewEpochState ~ Void
   , -- At the moment, fix the protocols together
     ProtoCrypto proto1 ~ ProtoCrypto proto2

ouroboros-consensus-cardano/src/unstable-cardano-testlib/Test/ThreadNet/TxGen/Cardano.hs

@@ -176,7 +176,7 @@ migrateUTxO migrationInfo curSlot lcfg lst
             assert (pickedCoin > spentCoin) $
               pickedCoin <-> spentCoin
 
-          body :: SL.TxBody ShelleyEra
+          body :: SL.TxBody SL.TopTx ShelleyEra
           body =
             SL.mkBasicTxBody
               & SL.certsTxBodyL
@@ -256,19 +256,19 @@ migrateUTxO migrationInfo curSlot lcfg lst
       (SL.StakeRefBase $ Shelley.mkCredential stakingSK)
 
   -- A simplistic individual pool
-  poolParams :: SL.Coin -> SL.PoolParams
+  poolParams :: SL.Coin -> SL.StakePoolParams
   poolParams pledge =
-    SL.PoolParams
-      { SL.ppCost = SL.Coin 1
-      , SL.ppMetadata = SL.SNothing
-      , SL.ppMargin = minBound
-      , SL.ppOwners = Set.singleton $ Shelley.mkKeyHash poolSK
-      , SL.ppPledge = pledge
-      , SL.ppId = Shelley.mkKeyHash poolSK
-      , SL.ppRewardAccount =
+    SL.StakePoolParams
+      { SL.sppCost = SL.Coin 1
+      , SL.sppMetadata = SL.SNothing
+      , SL.sppMargin = minBound
+      , SL.sppOwners = Set.singleton $ Shelley.mkKeyHash poolSK
+      , SL.sppPledge = pledge
+      , SL.sppId = Shelley.mkKeyHash poolSK
+      , SL.sppRewardAccount =
           SL.RewardAccount Shelley.networkId $ Shelley.mkCredential poolSK
-      , SL.ppRelays = StrictSeq.empty
-      , SL.ppVrf = Shelley.mkKeyHashVrf @c vrfSK
+      , SL.sppRelays = StrictSeq.empty
+      , SL.sppVrf = Shelley.mkKeyHashVrf @c vrfSK
       }
 
 -----

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

@@ -65,7 +65,7 @@ instance
   countTxOutputs blk = case Shelley.shelleyBlockRaw blk of
     SL.Block _ body -> getSum $ foldMap (Sum . countOutputs) (body ^. Core.txSeqBlockBodyL)
    where
-    countOutputs :: Core.Tx era -> Int
+    countOutputs :: Core.Tx Core.TopTx era -> Int
     countOutputs tx = length $ tx ^. Core.bodyTxL . Core.outputsTxBodyL
 
   blockTxSizes blk = case Shelley.shelleyBlockRaw blk of
@@ -100,7 +100,7 @@ instance
          | f <- maybeToList txExUnitsSteps
          ]
    where
-    txs :: StrictSeq (Core.Tx era)
+    txs :: StrictSeq (Core.Tx Core.TopTx era)
     txs = case Shelley.shelleyBlockRaw blk of
       SL.Block _ body -> body ^. Core.txSeqBlockBodyL
 
@@ -109,7 +109,7 @@ instance
   blockApplicationMetrics = []
 
 class PerEraAnalysis era where
-  txExUnitsSteps :: Maybe (Core.Tx era -> Word64)
+  txExUnitsSteps :: Maybe (Core.Tx Core.TopTx era -> Word64)
 
 instance PerEraAnalysis ShelleyEra where txExUnitsSteps = Nothing
 instance PerEraAnalysis AllegraEra where txExUnitsSteps = Nothing

ouroboros-consensus-cardano/src/unstable-shelley-testlib/Test/Consensus/Shelley/Examples.hs

@@ -94,7 +94,7 @@ codecConfig = ShelleyCodecConfig
 mkLedgerTables ::
   forall proto era.
   ShelleyCompatible proto era =>
-  LC.Tx era ->
+  LC.Tx LC.TopTx era ->
   LedgerTables (LedgerState (ShelleyBlock proto era)) ValuesMK
 mkLedgerTables tx =
   LedgerTables $