From 199d9e308113dc32970549ffe533b967f6e82fe2 Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Fri, 27 Oct 2023 12:15:11 +0200 Subject: [PATCH] Cardano --- ...boros-consensus-cardano-legacy-block.cabal | 2 +- .../src/Legacy/Cardano.hs | 5 +- .../src/Legacy/Cardano/Block.hs | 78 +++- .../src/Legacy/Cardano/CanHardFork.hs | 48 +-- .../src/Legacy/Cardano/Ledger.hs | 13 + .../src/Legacy/Cardano/Node.hs | 345 ++++++++++++++++++ .../src/Ouroboros/Consensus/HardFork/Trans.hs | 55 +++ .../src/Ouroboros/Consensus/Legacy/Block.hs | 12 +- 8 files changed, 512 insertions(+), 46 deletions(-) create mode 100644 ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano/Node.hs diff --git a/ouroboros-consensus-cardano-legacy-block/ouroboros-consensus-cardano-legacy-block.cabal b/ouroboros-consensus-cardano-legacy-block/ouroboros-consensus-cardano-legacy-block.cabal index 7c763da788..7be3191448 100644 --- a/ouroboros-consensus-cardano-legacy-block/ouroboros-consensus-cardano-legacy-block.cabal +++ b/ouroboros-consensus-cardano-legacy-block/ouroboros-consensus-cardano-legacy-block.cabal @@ -54,6 +54,7 @@ library Legacy.Cardano.CanHardFork Legacy.Cardano.CanonicalTxIn Legacy.Cardano.Ledger + Legacy.Cardano.Node Legacy.Convert Legacy.Shelley Legacy.Shelley.Ledger @@ -67,7 +68,6 @@ library , bytestring , cardano-binary , cardano-crypto-class - , cardano-ledger-allegra , cardano-ledger-alonzo , cardano-ledger-babbage , cardano-ledger-byron diff --git a/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano.hs b/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano.hs index f8e864d280..7a8546e718 100644 --- a/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano.hs +++ b/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano.hs @@ -5,8 +5,9 @@ module Legacy.Cardano ( , LegacyCardanoShelleyEras ) where -import Legacy.Byron.Ledger () +import Legacy.Byron () import Legacy.Cardano.Block import Legacy.Cardano.CanHardFork import Legacy.Cardano.Ledger () -import Legacy.Shelley.Ledger () +import Legacy.Cardano.Node () +import Legacy.Shelley () diff --git a/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano/Block.hs b/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano/Block.hs index 786f994c1b..92c61c0bec 100644 --- a/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano/Block.hs +++ b/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano/Block.hs @@ -1,20 +1,44 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} module Legacy.Cardano.Block ( - LegacyCardanoBlock - , LegacyCardanoEras + -- * The eras of the Cardano blockchain + LegacyCardanoEras , LegacyCardanoShelleyEras + -- * The block type of the Cardano blockchain + , LegacyCardanoBlock + , pattern LegacyCardanoBlock + -- * Generalised transactions + , LegacyCardanoApplyTxErr + , LegacyCardanoGenTx + , LegacyCardanoGenTxId + , pattern LegacyCardanoApplyTxErr + , pattern LegacyCardanoGenTx + , pattern LegacyCardanoGenTxId + -- * LedgerConfig + , LegacyCardanoLedgerConfig + , pattern LegacyCardanoLedgerConfig ) where import Data.Kind +import Data.SOP.Strict import Ouroboros.Consensus.Byron.Ledger.Block import Ouroboros.Consensus.Cardano.Block +import Ouroboros.Consensus.HardFork.Combinator +import Ouroboros.Consensus.HardFork.Trans +import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Legacy.Block import Ouroboros.Consensus.Protocol.Praos import Ouroboros.Consensus.Protocol.TPraos import Ouroboros.Consensus.Shelley.Ledger +import Ouroboros.Consensus.TypeFamilyWrappers + +{------------------------------------------------------------------------------- + The eras of the Cardano blockchain +-------------------------------------------------------------------------------} type LegacyCardanoEras :: Type -> [Type] type LegacyCardanoEras c = LegacyBlock ByronBlock @@ -30,4 +54,54 @@ type LegacyCardanoShelleyEras c = , LegacyBlock (ShelleyBlock (Praos c) (ConwayEra c)) ] +{------------------------------------------------------------------------------- + The block type of the Cardano blockchain +-------------------------------------------------------------------------------} + type LegacyCardanoBlock c = LegacyBlock (HardForkBlock (LegacyCardanoEras c)) + +{-# COMPLETE LegacyCardanoBlock #-} + +pattern LegacyCardanoBlock :: CardanoBlock c -> LegacyCardanoBlock c +pattern LegacyCardanoBlock b <- ( hcoerce_HardForkBlock . getLegacyBlock -> b) + where LegacyCardanoBlock b = LegacyBlock . hcoerce_HardForkBlock $ b + +{------------------------------------------------------------------------------- + Generalised transactions +-------------------------------------------------------------------------------} + +type LegacyCardanoGenTx c = GenTx (LegacyCardanoBlock c) + +{-# COMPLETE LegacyCardanoGenTx #-} + +pattern LegacyCardanoGenTx :: CardanoGenTx c -> LegacyCardanoGenTx c +pattern LegacyCardanoGenTx gentx <- (hcoerce_GenTx . getLegacyGenTx -> gentx) + where LegacyCardanoGenTx gentx = LegacyGenTx . hcoerce_GenTx $ gentx + +type LegacyCardanoGenTxId c = GenTxId (LegacyCardanoBlock c) + +{-# COMPLETE LegacyCardanoGenTxId #-} + +pattern LegacyCardanoGenTxId :: CardanoGenTxId c -> LegacyCardanoGenTxId c +pattern LegacyCardanoGenTxId gtxid <- (hcoerce_GenTxId . getLegacyGenTxId -> gtxid) + where LegacyCardanoGenTxId gtxid = LegacyGenTxId . hcoerce_GenTxId $ gtxid + +type LegacyCardanoApplyTxErr c = HardForkApplyTxErr (LegacyCardanoEras c) + +{-# COMPLETE LegacyCardanoApplyTxErr #-} + +pattern LegacyCardanoApplyTxErr :: CardanoApplyTxErr c -> LegacyCardanoApplyTxErr c +pattern LegacyCardanoApplyTxErr err <- (hcoerce_ApplyTxErr -> err) + where LegacyCardanoApplyTxErr err = hcoerce_ApplyTxErr err + +{------------------------------------------------------------------------------- + LedgerConfig +-------------------------------------------------------------------------------} + +type LegacyCardanoLedgerConfig c = HardForkLedgerConfig (LegacyCardanoEras c) + +{-# COMPLETE LegacyCardanoLedgerConfig #-} + +pattern LegacyCardanoLedgerConfig :: CardanoLedgerConfig c -> LegacyCardanoLedgerConfig c +pattern LegacyCardanoLedgerConfig cfg <- (hcoerce_LedgerConfig -> cfg) + where LegacyCardanoLedgerConfig cfg = hcoerce_LedgerConfig cfg diff --git a/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano/CanHardFork.hs b/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano/CanHardFork.hs index 6e8b81734c..ee69c83dec 100644 --- a/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano/CanHardFork.hs +++ b/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano/CanHardFork.hs @@ -17,8 +17,6 @@ module Legacy.Cardano.CanHardFork (LegacyCardanoHardForkConstraints) where import Cardano.Crypto.Hash.Blake2b (Blake2b_224, Blake2b_256) -import Cardano.Ledger.Allegra.Translation - (shelleyToAllegraAVVMsToDelete) import Cardano.Ledger.Alonzo.Translation () import Cardano.Ledger.Babbage.Translation () import Cardano.Ledger.Conway.Translation () @@ -337,36 +335,14 @@ translateLedgerStateShelleyToAllegraWrapper :: translateLedgerStateShelleyToAllegraWrapper = ignoringBoth $ TranslateLedgerState { - translateLedgerStateWith = \_epochNo (LegacyLedgerState ls) -> LegacyLedgerState $ - -- In the Shelley to Allegra transition, the AVVM addresses have - -- to be deleted, and their balance has to be moved to the - -- reserves. For this matter, the Ledger keeps track of these - -- small set of entries since the Byron to Shelley transition and - -- provides them to us through 'shelleyToAllegraAVVMsToDelete'. - -- - -- In the long run, the ledger will already use ledger states - -- parametrized by the map kind and therefore will already provide - -- the differences in this translation. - let avvms = SL.unUTxO - $ shelleyToAllegraAVVMsToDelete - $ shelleyLedgerState ls - - -- This 'stowLedgerTables' + 'withLedgerTables' injects the - -- values provided by the Ledger so that the translation - -- operation finds those entries in the UTxO and destroys - -- them, modifying the reserves accordingly. - stowedState = stowLedgerTables - . withLedgerTables ls - . LedgerTables - . ValuesMK - $ avvms - - resultingState = unFlip . unComp - . SL.translateEra' () - . Comp . Flip - $ stowedState - - in resultingState `withLedgerTables` emptyLedgerTables + translateLedgerStateWith = \_epochNo -> + LegacyLedgerState + . unFlip + . unComp + . SL.translateEra' () + . Comp + . Flip + . getLegacyLedgerState } translateTxShelleyToAllegraWrapper :: @@ -415,8 +391,6 @@ translateLedgerStateAllegraToMaryWrapper = TranslateLedgerState { translateLedgerStateWith = \_epochNo -> LegacyLedgerState - . forgetLedgerTables - . noNewTickingDiffs . unFlip . unComp . SL.translateEra' () @@ -471,8 +445,6 @@ translateLedgerStateMaryToAlonzoWrapper = TranslateLedgerState { translateLedgerStateWith = \_epochNo -> LegacyLedgerState - . forgetLedgerTables - . noNewTickingDiffs . unFlip . unComp . SL.translateEra' (getAlonzoTranslationContext cfgAlonzo) @@ -536,8 +508,6 @@ translateLedgerStateAlonzoToBabbageWrapper = TranslateLedgerState { translateLedgerStateWith = \_epochNo -> LegacyLedgerState - . forgetLedgerTables - . noNewTickingDiffs . unFlip . unComp . SL.translateEra' () @@ -623,8 +593,6 @@ translateLedgerStateBabbageToConwayWrapper = TranslateLedgerState { translateLedgerStateWith = \_epochNo -> LegacyLedgerState - . forgetLedgerTables - . noNewTickingDiffs . unFlip . unComp . SL.translateEra' (getConwayTranslationContext cfgConway) diff --git a/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano/Ledger.hs b/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano/Ledger.hs index c54b12f9c7..0e555278e3 100644 --- a/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano/Ledger.hs +++ b/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano/Ledger.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} @@ -20,6 +21,8 @@ import Ouroboros.Consensus.Block import Ouroboros.Consensus.Cardano () import Ouroboros.Consensus.Cardano.Block import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.Ledger.Query + (BlockSupportsLedgerQuery (..)) import Ouroboros.Consensus.Ledger.Tables.Utils import Ouroboros.Consensus.Legacy.Block @@ -133,3 +136,13 @@ instance LegacyCardanoHardForkConstraints c LegacyCardanoBlock c -> LedgerTables (LedgerState (LegacyCardanoBlock c)) KeysMK getBlockKeySets = const trivialLedgerTables + +{------------------------------------------------------------------------------- + Queries +-------------------------------------------------------------------------------} + +instance LegacyCardanoHardForkConstraints c + => BlockSupportsLedgerQuery (LegacyCardanoBlock c) where + answerPureBlockQuery _ = undefined -- TODO + answerBlockQueryLookup _cfg q _dlv = case q of {} + answerBlockQueryTraverse _cfg q _dlv = case q of {} diff --git a/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano/Node.hs b/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano/Node.hs new file mode 100644 index 0000000000..c9a08d2f71 --- /dev/null +++ b/ouroboros-consensus-cardano-legacy-block/src/Legacy/Cardano/Node.hs @@ -0,0 +1,345 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +{- HLINT ignore "Use camelCase" -} + +module Legacy.Cardano.Node ( + protocolClientInfoLegacyCardano + , protocolInfoLegacyCardano + ) where + +import Cardano.Chain.Slotting (EpochSlots) +import Codec.CBOR.Decoding (Decoder) +import Codec.CBOR.Encoding (Encoding) +import Data.Bifunctor +import qualified Data.ByteString.Lazy as Lazy +import Data.ByteString.Short (ShortByteString) +import Data.Coerce +import qualified Data.Map.Strict as Map +import Data.Proxy +import Data.SOP.Classes +import Data.SOP.Functors (Flip (..)) +import Data.SOP.Strict hiding (Shape (..)) +import Legacy.Byron.Node () +import Legacy.Cardano.Block +import Legacy.Cardano.CanHardFork +import Legacy.Cardano.CanonicalTxIn () +import Legacy.Shelley.Node () +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Cardano +import Ouroboros.Consensus.Cardano.Block +import Ouroboros.Consensus.Cardano.Node +import Ouroboros.Consensus.Config +import Ouroboros.Consensus.HardFork.Combinator +import Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common +import Ouroboros.Consensus.HardFork.Trans +import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.Legacy.Block +import Ouroboros.Consensus.Legacy.Util +import Ouroboros.Consensus.Node.NetworkProtocolVersion + (BlockNodeToClientVersion, + SupportedNetworkProtocolVersion (..)) +import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolClientInfo (..), + ProtocolInfo (..)) +import Ouroboros.Consensus.Node.Serialisation + (SerialiseNodeToClient (..)) +import Ouroboros.Consensus.Protocol.Abstract (ConsensusProtocol (..)) +import Ouroboros.Consensus.Shelley.Node.Praos (ProtocolParamsBabbage, + ProtocolParamsConway) +import Ouroboros.Consensus.Storage.Serialisation +import Ouroboros.Consensus.TypeFamilyWrappers +import Ouroboros.Consensus.Util.IOLike (IOLike) + +{------------------------------------------------------------------------------- + EncodeDisk & DecodeDisk +-------------------------------------------------------------------------------} + +instance EncodeDisk blk (HardForkChainDepState xs) + => EncodeDisk (LegacyBlock blk) (HardForkChainDepState xs) where + encodeDisk :: + CodecConfig (LegacyBlock blk) + -> HardForkChainDepState xs + -> Encoding + encodeDisk ccfg = coerce $ + encodeDisk @blk @(HardForkChainDepState xs) (coerce ccfg) + +instance DecodeDisk blk (HardForkChainDepState xs) + => DecodeDisk (LegacyBlock blk) (HardForkChainDepState xs) where + decodeDisk :: + CodecConfig (LegacyBlock blk) + -> forall s. Decoder s (HardForkChainDepState xs) + decodeDisk ccfg = coerce $ + decodeDisk @blk @(HardForkChainDepState xs) (coerce ccfg) + +{------------------------------------------------------------------------------- + SerialiseNodeToClient +-------------------------------------------------------------------------------} + +instance SerialiseNodeToClient blk (HardForkApplyTxErr xs) + => SerialiseNodeToClient (LegacyBlock blk) (HardForkApplyTxErr xs) where + encodeNodeToClient :: + CodecConfig (LegacyBlock blk) + -> BlockNodeToClientVersion (LegacyBlock blk) + -> HardForkApplyTxErr xs -> Encoding + encodeNodeToClient ccfg version = coerce $ + encodeNodeToClient + @blk + @(HardForkApplyTxErr xs) + (coerce ccfg) + version + + decodeNodeToClient :: + CodecConfig (LegacyBlock blk) + -> BlockNodeToClientVersion (LegacyBlock blk) + -> forall s. Decoder s (HardForkApplyTxErr xs) + decodeNodeToClient ccfg version = coerce $ + decodeNodeToClient + @blk + @(HardForkApplyTxErr xs) + (coerce ccfg) + version + +{------------------------------------------------------------------------------- + SerialiseHFC +-------------------------------------------------------------------------------} + +instance LegacyCardanoHardForkConstraints c + => SerialiseHFC (LegacyCardanoEras c) where + + encodeDiskHfcBlock :: + CodecConfig (HardForkBlock (LegacyCardanoEras c)) + -> HardForkBlock (LegacyCardanoEras c) + -> Encoding + encodeDiskHfcBlock ccfg b = + encodeDiskHfcBlock + @(CardanoEras c) + (hcoerce_CodecConfig ccfg) + (hcoerce_HardForkBlock b) + + decodeDiskHfcBlock :: + CodecConfig (HardForkBlock (LegacyCardanoEras c)) + -> forall s. Decoder s (Lazy.ByteString -> HardForkBlock (LegacyCardanoEras c)) + decodeDiskHfcBlock ccfg = + (hcoerce_HardForkBlock .) + <$> decodeDiskHfcBlock + @(CardanoEras c) + (hcoerce_CodecConfig ccfg) + + reconstructHfcPrefixLen :: + proxy (Header (HardForkBlock (LegacyCardanoEras c))) + -> PrefixLen + reconstructHfcPrefixLen _ = + reconstructHfcPrefixLen + (Proxy @(Header (HardForkBlock (CardanoEras c)))) + + reconstructHfcNestedCtxt :: + proxy (Header (HardForkBlock (LegacyCardanoEras c))) + -> ShortByteString + -> SizeInBytes + -> SomeSecond (NestedCtxt Header) (HardForkBlock (LegacyCardanoEras c)) + reconstructHfcNestedCtxt _ sbs sib = + conv + $ reconstructHfcNestedCtxt + (Proxy @(Header (HardForkBlock (CardanoEras c)))) + sbs + sib + where + conv :: + SomeSecond (NestedCtxt Header) (HardForkBlock (CardanoEras c)) + -> SomeSecond (NestedCtxt Header) (HardForkBlock (LegacyCardanoEras c)) + conv (SomeSecond ctxt) = SomeSecond $ + castNestedCtxt hcoerce_NestedCtxt_ ctxt + + getHfcBinaryBlockInfo :: + HardForkBlock (LegacyCardanoEras c) + -> BinaryBlockInfo + getHfcBinaryBlockInfo = getHfcBinaryBlockInfo @(CardanoEras c) . hcoerce_HardForkBlock + + estimateHfcBlockSize :: + Header (HardForkBlock (LegacyCardanoEras c)) + -> SizeInBytes + estimateHfcBlockSize = estimateHfcBlockSize @(CardanoEras c) . hcoerce_Header + +{------------------------------------------------------------------------------- + SupportedNetworkProtocolVersion +-------------------------------------------------------------------------------} + +instance LegacyCardanoHardForkConstraints c + => SupportedNetworkProtocolVersion (HardForkBlock (LegacyCardanoEras c)) where + supportedNodeToNodeVersions _ = Map.map conv + $ supportedNodeToNodeVersions (Proxy @(CardanoBlock c)) + where + conv :: + HardForkNodeToNodeVersion (CardanoEras c) + -> HardForkNodeToNodeVersion (LegacyCardanoEras c) + conv (HardForkNodeToNodeDisabled x) = HardForkNodeToNodeDisabled x + conv (HardForkNodeToNodeEnabled x y) = + HardForkNodeToNodeEnabled x (htrans (Proxy @ToLegacyBlock) conv' y) + + conv' :: EraNodeToNodeVersion blk -> EraNodeToNodeVersion (LegacyBlock blk) + conv' (EraNodeToNodeEnabled x) = EraNodeToNodeEnabled x + conv' EraNodeToNodeDisabled = EraNodeToNodeDisabled + + supportedNodeToClientVersions _ = Map.map conv + $ supportedNodeToClientVersions (Proxy @(CardanoBlock c)) + where + conv :: + HardForkNodeToClientVersion (CardanoEras c) + -> HardForkNodeToClientVersion (LegacyCardanoEras c) + conv (HardForkNodeToClientDisabled x) = HardForkNodeToClientDisabled x + conv (HardForkNodeToClientEnabled x y) = + HardForkNodeToClientEnabled x (htrans (Proxy @ToLegacyBlock) conv' y) + + conv' :: EraNodeToClientVersion blk -> EraNodeToClientVersion (LegacyBlock blk) + conv' (EraNodeToClientEnabled x) = EraNodeToClientEnabled x + conv' EraNodeToClientDisabled = EraNodeToClientDisabled + + latestReleasedNodeVersion _ = + latestReleasedNodeVersion (Proxy @(CardanoBlock c)) + +{------------------------------------------------------------------------------- + ProtocolInfo +-------------------------------------------------------------------------------} + +-- | Only used in 'protocolInfoLegacyCardano'. +class (ToLegacyBlock x y, CanStowLedgerTables (LedgerState x)) => C x y +instance CanStowLedgerTables (LedgerState x) => C x (LegacyBlock x) + +protocolInfoLegacyCardano :: + forall c m. (IOLike m, LegacyCardanoHardForkConstraints c) + => ProtocolParamsByron + -> ProtocolParamsShelleyBased (ShelleyEra c) + -> ProtocolParamsShelley c + -> ProtocolParamsAllegra c + -> ProtocolParamsMary c + -> ProtocolParamsAlonzo c + -> ProtocolParamsBabbage c + -> ProtocolParamsConway c + -> ProtocolTransitionParamsShelleyBased (ShelleyEra c) + -> ProtocolTransitionParamsShelleyBased (AllegraEra c) + -> ProtocolTransitionParamsShelleyBased (MaryEra c) + -> ProtocolTransitionParamsShelleyBased (AlonzoEra c) + -> ProtocolTransitionParamsShelleyBased (BabbageEra c) + -> ProtocolTransitionParamsShelleyBased (ConwayEra c) + -> ( ProtocolInfo (LegacyCardanoBlock c) + , m [BlockForging m (LegacyCardanoBlock c)] + ) +protocolInfoLegacyCardano p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 p11 p12 p13 p14 = + ( ProtocolInfo { + pInfoConfig = castTopLevelConfig (pInfoConfig pinfo') + , pInfoInitLedger = + castExtLedgerState (coerce . stowLedgerTables) (pInfoInitLedger pinfo') + } + , fmap (fmap convBlockForging) forging + ) + where + pinfo :: ProtocolInfo (CardanoBlock c) + forging :: m [BlockForging m (CardanoBlock c)] + (pinfo, forging) = + protocolInfoCardano @c @m p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 p11 p12 p13 p14 + + pinfo' :: ProtocolInfo (HardForkBlock (LegacyCardanoEras c)) + pinfo' = + htrans_ProtocolInfo + (Proxy @C) + coerce + coerce + coerce + coerce + coerce + coerce + (Flip . coerce . stowLedgerTables . unFlip) + coerce + coerce + pinfo + + convBlockForging :: + BlockForging m (CardanoBlock c) + -> BlockForging m (LegacyCardanoBlock c) + convBlockForging bf = BlockForging { + forgeLabel + , canBeLeader = hcoerce_CanBeLeader canBeLeader + , updateForgeState = updateForgeState' + , checkCanForge = checkCanForge' + , forgeBlock = forgeBlock' + } + where + BlockForging { + forgeLabel + , canBeLeader + , updateForgeState + , checkCanForge + , forgeBlock + } = bf + + updateForgeState' :: + TopLevelConfig (LegacyCardanoBlock c) + -> SlotNo + -> Ticked (ChainDepState (BlockProtocol (LegacyCardanoBlock c))) + -> m (ForgeStateUpdateInfo (LegacyCardanoBlock c)) + updateForgeState' tlcfg sl tcdst = castForgeStateUpdateInfo + . hcoerce_ForgeStateUpdateInfo <$> + updateForgeState + (hcoerce_TopLevelConfig $ castTopLevelConfig tlcfg) + sl + (hcoerce_TickedChainDepState tcdst) + + checkCanForge' :: + TopLevelConfig (LegacyCardanoBlock c) + -> SlotNo + -> Ticked (ChainDepState (BlockProtocol (LegacyCardanoBlock c))) + -> IsLeader (BlockProtocol (LegacyCardanoBlock c)) + -> ForgeStateInfo (LegacyCardanoBlock c) + -> Either (CannotForge (LegacyCardanoBlock c)) () + checkCanForge' tlcfg sl tcdst il fsi = first hcoerce_CannotForge $ + checkCanForge + (hcoerce_TopLevelConfig $ castTopLevelConfig tlcfg) + sl + (hcoerce_TickedChainDepState tcdst) + (hcoerce_IsLeader il) + (hcoerce_ForgeStateInfo fsi) + + + forgeBlock' :: + TopLevelConfig (LegacyCardanoBlock c) + -> BlockNo + -> SlotNo + -> TickedLedgerState (LegacyCardanoBlock c) EmptyMK + -> [Validated (GenTx (LegacyCardanoBlock c))] + -> IsLeader (BlockProtocol (LegacyCardanoBlock c)) + -> m (LegacyCardanoBlock c) + forgeBlock' tlcfg bl sl tlst vgts il = LegacyBlock + . hcoerce_HardForkBlock <$> + forgeBlock + (hcoerce_TopLevelConfig $ castTopLevelConfig tlcfg) + bl + sl + ( hcoerce_TickedLedgerState + . getTickedLegacyLedgerState + $ tlst + ) + (fmap (hcoerce_ValidatedGenTx . getLegacyValidatedGenTx) vgts) + (hcoerce_IsLeader il) + +protocolClientInfoLegacyCardano :: + forall c. + EpochSlots + -> ProtocolClientInfo (LegacyBlock (HardForkBlock (LegacyCardanoEras c))) +protocolClientInfoLegacyCardano epochslots = ProtocolClientInfo { + pClientInfoCodecConfig = LegacyCodecConfig $ pClientInfoCodecConfig pcinfo' + } + where + pcinfo :: ProtocolClientInfo (CardanoBlock c) + pcinfo = protocolClientInfoCardano epochslots + + pcinfo' :: ProtocolClientInfo (HardForkBlock (LegacyCardanoEras c)) + pcinfo' = hcoerce_ProtocolClientInfo pcinfo diff --git a/ouroboros-consensus-cardano-legacy-block/src/Ouroboros/Consensus/HardFork/Trans.hs b/ouroboros-consensus-cardano-legacy-block/src/Ouroboros/Consensus/HardFork/Trans.hs index 9d928c88e5..b70832673f 100644 --- a/ouroboros-consensus-cardano-legacy-block/src/Ouroboros/Consensus/HardFork/Trans.hs +++ b/ouroboros-consensus-cardano-legacy-block/src/Ouroboros/Consensus/HardFork/Trans.hs @@ -84,6 +84,12 @@ module Ouroboros.Consensus.HardFork.Trans ( -- * ProtocolInfo , hcoerce_ProtocolInfo , htrans_ProtocolInfo + -- * ApplyTxErr + , hcoerce_ApplyTxErr + -- * GenTxId + , hcoerce_GenTxId + -- * GenTx + , hcoerce_GenTx ) where import Data.Coerce @@ -98,6 +104,7 @@ import Ouroboros.Consensus.HardFork.History import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Node.ProtocolInfo import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.TypeFamilyWrappers @@ -861,6 +868,54 @@ htrans_ProtocolInfo p f1 f2 f3 f4 f5 f6 f7 f8 f9 pinfo = ProtocolInfo { , pInfoInitLedger } = pinfo +{------------------------------------------------------------------------------- + ApplyTxErr +-------------------------------------------------------------------------------} +hcoerce_ApplyTxErr :: + ( AllZip (LiftedCoercible WrapApplyTxErr WrapApplyTxErr) xs ys + , AllZip (LiftedCoercible LedgerEraInfo LedgerEraInfo) xs ys + ) + => ApplyTxErr (HardForkBlock xs) + -> ApplyTxErr (HardForkBlock ys) +hcoerce_ApplyTxErr = \case + HardForkApplyTxErrFromEra err -> HardForkApplyTxErrFromEra + . OneEraApplyTxErr + . hcoerce + . getOneEraApplyTxErr + $ err + HardForkApplyTxErrWrongEra err -> HardForkApplyTxErrWrongEra + . MismatchEraInfo + . hcoerce + . getMismatchEraInfo + $ err +{------------------------------------------------------------------------------- + GenTxId +-------------------------------------------------------------------------------} +hcoerce_GenTxId :: + AllZip (LiftedCoercible WrapGenTxId WrapGenTxId) xs ys + => GenTxId (HardForkBlock xs) + -> GenTxId (HardForkBlock ys) +hcoerce_GenTxId = + HardForkGenTxId + . OneEraGenTxId + . hcoerce + . getOneEraGenTxId + . getHardForkGenTxId + +{------------------------------------------------------------------------------- + GenTx +-------------------------------------------------------------------------------} + +hcoerce_GenTx :: + AllZip (LiftedCoercible GenTx GenTx) xs ys + => GenTx (HardForkBlock xs) + -> GenTx (HardForkBlock ys) +hcoerce_GenTx = + HardForkGenTx + . OneEraGenTx + . hcoerce + . getOneEraGenTx + . getHardForkGenTx diff --git a/ouroboros-consensus-cardano-legacy-block/src/Ouroboros/Consensus/Legacy/Block.hs b/ouroboros-consensus-cardano-legacy-block/src/Ouroboros/Consensus/Legacy/Block.hs index 8ca9ef6e20..45fc5e8477 100644 --- a/ouroboros-consensus-cardano-legacy-block/src/Ouroboros/Consensus/Legacy/Block.hs +++ b/ouroboros-consensus-cardano-legacy-block/src/Ouroboros/Consensus/Legacy/Block.hs @@ -25,6 +25,7 @@ module Ouroboros.Consensus.Legacy.Block ( BlockConfig (..) , BlockQuery (..) , CodecConfig (..) + , FromLegacyBlock , GenTx (..) , Header (..) , LedgerState (..) @@ -33,6 +34,7 @@ module Ouroboros.Consensus.Legacy.Block ( , NestedCtxt_ (..) , StorageConfig (..) , Ticked1 (..) + , ToLegacyBlock , TxId (..) , Validated (..) ) where @@ -119,6 +121,12 @@ newtype LegacyBlock (blk :: Type) = LegacyBlock { getLegacyBlock :: blk } deriving newtype Show deriving newtype (BlockSupportsMetrics, ConfigSupportsNode) +class blk' ~ LegacyBlock blk => ToLegacyBlock blk blk' +instance blk' ~ LegacyBlock blk => ToLegacyBlock blk blk' + +class blk ~ LegacyBlock blk' => FromLegacyBlock blk blk' +instance blk ~ LegacyBlock blk' => FromLegacyBlock blk blk' + {------------------------------------------------------------------------------- LegacyBlock: data/type family instances -------------------------------------------------------------------------------} @@ -162,7 +170,9 @@ instance (forall fp'. ShowQuery (BlockQuery blk fp')) => ShowQuery (BlockQuery ( type instance ApplyTxErr (LegacyBlock blk) = ApplyTxErr blk -newtype instance TxId (GenTx (LegacyBlock blk)) = LegacyTxId (TxId (GenTx blk)) +newtype instance TxId (GenTx (LegacyBlock blk)) = LegacyGenTxId { + getLegacyGenTxId :: TxId (GenTx blk) + } deriving newtype instance NoThunks (TxId (GenTx blk)) => NoThunks (TxId (GenTx (LegacyBlock blk))) deriving newtype instance Eq (TxId (GenTx blk))