From 0ac963b065a4b8ddd1fcb54adf671b5a78d3ce0f Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Tue, 18 Feb 2025 11:15:58 +0100 Subject: [PATCH] WIP --- .../src/Test/Consensus/Shelley/Examples.hs | 163 ----- .../src/Ouroboros/Consensus/Shelley/Node.hs | 605 ------------------ .../Consensus/Shelley/Node/Serialisation.hs | 183 ------ 3 files changed, 951 deletions(-) delete mode 100644 ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Examples.hs delete mode 100644 ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node.hs delete mode 100644 ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node/Serialisation.hs diff --git a/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Examples.hs b/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Examples.hs deleted file mode 100644 index d55732dad6..0000000000 --- a/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Examples.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DisambiguateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} - -module Test.Consensus.Shelley.Examples ( - -- * Setup - codecConfig - , testShelleyGenesis - -- * Examples - , examplesAllegra - , examplesAlonzo - , examplesMary - , examplesShelley - ) where - -import qualified Data.Set as Set - -import Cardano.Slotting.EpochInfo (fixedEpochInfo) -import Cardano.Slotting.Time (mkSlotLength) - -import qualified Cardano.Ledger.Era as Core -import Cardano.Ledger.Shelley.Genesis (mkShelleyGlobals) - -import Ouroboros.Network.Block (Serialised (..)) - -import Ouroboros.Consensus.Block -import Ouroboros.Consensus.HeaderValidation -import Ouroboros.Consensus.Ledger.Extended -import Ouroboros.Consensus.Ledger.SupportsMempool -import Ouroboros.Consensus.Storage.Serialisation -import Ouroboros.Consensus.Util.Time (secondsToNominalDiffTime) - -import Test.Cardano.Ledger.Shelley.Orphans () - -import Ouroboros.Consensus.Shelley.Eras -import Ouroboros.Consensus.Shelley.Ledger - -import Test.Util.Orphans.Arbitrary () -import Test.Util.Serialisation.Golden (labelled, unlabelled) -import qualified Test.Util.Serialisation.Golden as Golden -import Test.Util.Serialisation.Roundtrip (SomeResult (..)) - -import Ouroboros.Consensus.Protocol.TPraos (TPraosState (TPraosState)) - -import Test.Cardano.Ledger.Allegra.Examples.Consensus - (ledgerExamplesAllegra) -import Test.Cardano.Ledger.Alonzo.Examples.Consensus - (ledgerExamplesAlonzo) -import Test.Cardano.Ledger.Mary.Examples.Consensus - (ledgerExamplesMary) -import Test.Cardano.Ledger.Shelley.Examples.Consensus - (ShelleyLedgerExamples (..), ShelleyResultExamples (..), - ledgerExamplesShelley, testShelleyGenesis) - -{------------------------------------------------------------------------------- - Examples --------------------------------------------------------------------------------} - -codecConfig :: CodecConfig (ShelleyBlock Ouroboros.Consensus.Shelley.Eras.StandardShelley) -codecConfig = ShelleyCodecConfig - -fromShelleyLedgerExamples - :: ShelleyBasedEra era - => ShelleyLedgerExamples era - -> Golden.Examples (ShelleyBlock era) -fromShelleyLedgerExamples ShelleyLedgerExamples { - sleResultExamples = ShelleyResultExamples{..} - , ..} = - Golden.Examples { - exampleBlock = unlabelled blk - , exampleSerialisedBlock = unlabelled serialisedBlock - , exampleHeader = unlabelled $ getHeader blk - , exampleSerialisedHeader = unlabelled serialisedHeader - , exampleHeaderHash = unlabelled hash - , exampleGenTx = unlabelled tx - , exampleGenTxId = unlabelled $ txId tx - , exampleApplyTxErr = unlabelled sleApplyTxError - , exampleQuery = queries - , exampleResult = results - , exampleAnnTip = unlabelled annTip - , exampleLedgerConfig = unlabelled ledgerConfig - , exampleLedgerState = unlabelled ledgerState - , exampleChainDepState = unlabelled chainDepState - , exampleExtLedgerState = unlabelled extLedgerState - , exampleSlotNo = unlabelled slotNo - } - where - blk = mkShelleyBlock sleBlock - hash = ShelleyHash sleHashHeader - serialisedBlock = Serialised "" - tx = mkShelleyTx sleTx - slotNo = SlotNo 42 - serialisedHeader = - SerialisedHeaderFromDepPair $ GenDepPair (NestedCtxt CtxtShelley) (Serialised "
") - queries = labelled [ - ("GetLedgerTip", SomeSecond GetLedgerTip) - , ("GetEpochNo", SomeSecond GetEpochNo) - , ("GetCurrentPParams", SomeSecond GetCurrentPParams) - , ("GetProposedPParamsUpdates", SomeSecond GetProposedPParamsUpdates) - , ("GetStakeDistribution", SomeSecond GetStakeDistribution) - , ("GetNonMyopicMemberRewards", SomeSecond $ GetNonMyopicMemberRewards sleRewardsCredentials) - , ("GetGenesisConfig", SomeSecond GetGenesisConfig) - ] - results = labelled [ - ("LedgerTip", SomeResult GetLedgerTip (blockPoint blk)) - , ("EpochNo", SomeResult GetEpochNo 10) - , ("EmptyPParams", SomeResult GetCurrentPParams srePParams) - , ("ProposedPParamsUpdates", SomeResult GetProposedPParamsUpdates sreProposedPPUpdates) - , ("StakeDistribution", SomeResult GetStakeDistribution srePoolDistr) - , ("NonMyopicMemberRewards", SomeResult (GetNonMyopicMemberRewards Set.empty) - (NonMyopicMemberRewards $ sreNonMyopicRewards)) - , ("GenesisConfig", SomeResult GetGenesisConfig (compactGenesis sreShelleyGenesis)) - ] - annTip = AnnTip { - annTipSlotNo = SlotNo 14 - , annTipBlockNo = BlockNo 6 - , annTipInfo = hash - } - ledgerState = ShelleyLedgerState { - shelleyLedgerTip = NotOrigin ShelleyTip { - shelleyTipSlotNo = SlotNo 9 - , shelleyTipBlockNo = BlockNo 3 - , shelleyTipHash = hash - } - , shelleyLedgerState = sleNewEpochState - , shelleyLedgerTransition = ShelleyTransitionInfo {shelleyAfterVoting = 0} - } - chainDepState = TPraosState (NotOrigin 1) sleChainDepState - extLedgerState = ExtLedgerState - ledgerState - (genesisHeaderState chainDepState) - ledgerConfig = exampleShelleyLedgerConfig sleTranslationContext - -examplesShelley :: Golden.Examples (ShelleyBlock StandardShelley) -examplesShelley = fromShelleyLedgerExamples ledgerExamplesShelley - -examplesAllegra :: Golden.Examples (ShelleyBlock StandardAllegra) -examplesAllegra = fromShelleyLedgerExamples ledgerExamplesAllegra - -examplesMary :: Golden.Examples (ShelleyBlock StandardMary) -examplesMary = fromShelleyLedgerExamples ledgerExamplesMary - -examplesAlonzo :: Golden.Examples (ShelleyBlock StandardAlonzo) -examplesAlonzo = fromShelleyLedgerExamples ledgerExamplesAlonzo - -exampleShelleyLedgerConfig :: Core.TranslationContext era -> ShelleyLedgerConfig era -exampleShelleyLedgerConfig translationContext = ShelleyLedgerConfig { - shelleyLedgerCompactGenesis = compactGenesis testShelleyGenesis - , shelleyLedgerGlobals = mkShelleyGlobals - testShelleyGenesis - epochInfo - 26 - , shelleyLedgerTranslationContext = translationContext - } - where - epochInfo = fixedEpochInfo (EpochSize 4) slotLength - slotLength = mkSlotLength (secondsToNominalDiffTime 7) diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node.hs deleted file mode 100644 index 95646ff0a7..0000000000 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node.hs +++ /dev/null @@ -1,605 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DisambiguateRecordFields #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - -module Ouroboros.Consensus.Shelley.Node ( - MaxMajorProtVer (..) - , ProtocolParamsAllegra (..) - , ProtocolParamsAlonzo (..) - , ProtocolParamsMary (..) - , ProtocolParamsShelley (..) - , ProtocolParamsShelleyBased (..) - , SL.Nonce (..) - , SL.ProtVer (..) - , SL.ShelleyGenesis (..) - , SL.ShelleyGenesisStaking (..) - , SL.emptyGenesisStaking - , TPraosLeaderCredentials (..) - , protocolClientInfoShelley - , protocolInfoShelley - , protocolInfoShelleyBased - , registerGenesisStaking - , registerInitialFunds - , shelleyBlockForging - , shelleySharedBlockForging - , tpraosBlockIssuerVKey - , validateGenesis - ) where - -import Control.Monad.Except -import Data.Bifunctor (first) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.SOP.Strict -import Data.Text (Text) -import qualified Data.Text as Text -import GHC.Stack (HasCallStack) - -import qualified Cardano.Crypto.VRF as VRF -import Cardano.Slotting.EpochInfo -import Cardano.Slotting.Time (mkSlotLength) - -import Ouroboros.Consensus.Block -import Ouroboros.Consensus.Config -import Ouroboros.Consensus.Config.SupportsNode -import qualified Ouroboros.Consensus.HardFork.History as History -import Ouroboros.Consensus.HeaderValidation -import Ouroboros.Consensus.Ledger.Abstract -import Ouroboros.Consensus.Ledger.Extended -import Ouroboros.Consensus.Mempool.TxLimits (TxLimits) -import qualified Ouroboros.Consensus.Mempool.TxLimits as TxLimits -import Ouroboros.Consensus.Node.InitStorage -import Ouroboros.Consensus.Node.ProtocolInfo -import Ouroboros.Consensus.Node.Run -import Ouroboros.Consensus.Protocol.Abstract -import Ouroboros.Consensus.Storage.ImmutableDB (simpleChunkInfo) -import Ouroboros.Consensus.Util.Assert -import Ouroboros.Consensus.Util.IOLike - -import qualified Cardano.Ledger.Era as Core -import qualified Cardano.Ledger.Shelley.API as SL -import qualified Cardano.Ledger.Shelley.Constraints as SL (makeTxOut) -import qualified Cardano.Ledger.Shelley.LedgerState as SL - (incrementalStakeDistr, updateStakeDistribution) -import Cardano.Ledger.Val (coin, inject, (<->)) -import qualified Cardano.Protocol.TPraos.API as SL -import qualified Cardano.Protocol.TPraos.OCert as Absolute (KESPeriod (..)) -import qualified Cardano.Protocol.TPraos.OCert as SL - -import qualified Data.Compact.SplitMap as SplitMap -import qualified Data.UMap as UM -import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey) -import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey -import Ouroboros.Consensus.Protocol.TPraos -import Ouroboros.Consensus.Shelley.Eras -import Ouroboros.Consensus.Shelley.Ledger -import Ouroboros.Consensus.Shelley.Ledger.Inspect () -import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion () -import Ouroboros.Consensus.Shelley.Node.Serialisation () - -{------------------------------------------------------------------------------- - Credentials --------------------------------------------------------------------------------} - -data TPraosLeaderCredentials c = TPraosLeaderCredentials { - -- | The unevolved signing KES key (at evolution 0). - -- - -- Note that this is not inside 'TPraosCanBeLeader' since it gets evolved - -- automatically, whereas 'TPraosCanBeLeader' does not change. - tpraosLeaderCredentialsInitSignKey :: SL.SignKeyKES c - , tpraosLeaderCredentialsCanBeLeader :: TPraosCanBeLeader c - -- | Identifier for this set of credentials. - -- - -- Useful when the node is running with multiple sets of credentials. - , tpraosLeaderCredentialsLabel :: Text - } - -tpraosBlockIssuerVKey :: - TPraosLeaderCredentials c -> SL.VKey 'SL.BlockIssuer c -tpraosBlockIssuerVKey = - tpraosCanBeLeaderColdVerKey . tpraosLeaderCredentialsCanBeLeader - -{------------------------------------------------------------------------------- - BlockForging --------------------------------------------------------------------------------} - -type instance CannotForge (ShelleyBlock era) = TPraosCannotForge (EraCrypto era) - -type instance ForgeStateInfo (ShelleyBlock era) = HotKey.KESInfo - -type instance ForgeStateUpdateError (ShelleyBlock era) = HotKey.KESEvolutionError - --- | Create a 'BlockForging' record for a single era. --- --- In case the same credentials should be shared across multiple Shelley-based --- eras, use 'shelleySharedBlockForging'. -shelleyBlockForging :: - forall m era. (ShelleyBasedEra era, TxLimits (ShelleyBlock era), IOLike m) - => TPraosParams - -> TxLimits.Overrides (ShelleyBlock era) - -> TPraosLeaderCredentials (EraCrypto era) - -> m (BlockForging m (ShelleyBlock era)) -shelleyBlockForging tpraosParams maxTxCapacityOverrides credentials = - aux <$> shelleySharedBlockForging - (Proxy @'[era]) - tpraosParams - credentials - (Comp maxTxCapacityOverrides :* Nil) - where - aux :: - NP (BlockForging m :.: ShelleyBlock) '[era] - -> BlockForging m (ShelleyBlock era) - aux = unComp . hd - --- | Needed in 'shelleySharedBlockForging' because we can't partially apply --- equality constraints. -class (ShelleyBasedEra era, TxLimits (ShelleyBlock era), EraCrypto era ~ c) => ShelleyEraWithCrypto c era -instance (ShelleyBasedEra era, TxLimits (ShelleyBlock era), EraCrypto era ~ c) => ShelleyEraWithCrypto c era - --- | Create a 'BlockForging' record for each of the given Shelley-based eras, --- safely sharing the same set of credentials for all of them. --- --- The name of the era (separated by a @_@) will be appended to each --- 'forgeLabel'. -shelleySharedBlockForging :: - forall m c eras. - ( PraosCrypto c - , All (ShelleyEraWithCrypto c) eras - , IOLike m - ) - => Proxy eras - -> TPraosParams - -> TPraosLeaderCredentials c - -> NP (TxLimits.Overrides :.: ShelleyBlock) eras - -> m (NP (BlockForging m :.: ShelleyBlock) eras) -shelleySharedBlockForging - _ - TPraosParams {..} - TPraosLeaderCredentials { - tpraosLeaderCredentialsInitSignKey = initSignKey - , tpraosLeaderCredentialsCanBeLeader = canBeLeader - , tpraosLeaderCredentialsLabel = label - } - maxTxCapacityOverridess = do - hotKey <- HotKey.mkHotKey @m @c initSignKey startPeriod tpraosMaxKESEvo - return $ - hcmap - (Proxy @(ShelleyEraWithCrypto c)) - (aux hotKey) - maxTxCapacityOverridess - where - aux :: - forall era. ShelleyEraWithCrypto c era - => HotKey c m - -> (TxLimits.Overrides :.: ShelleyBlock) era - -> (BlockForging m :.: ShelleyBlock) era - aux hotKey (Comp maxTxCapacityOverrides) = Comp $ BlockForging { - forgeLabel = label <> "_" <> shelleyBasedEraName (Proxy @era) - , canBeLeader = canBeLeader - , updateForgeState = \_ curSlot _ -> - forgeStateUpdateInfoFromUpdateInfo <$> - HotKey.evolve hotKey (slotToPeriod curSlot) - , checkCanForge = \cfg curSlot _tickedChainDepState -> - tpraosCheckCanForge - (configConsensus cfg) - forgingVRFHash - curSlot - , forgeBlock = \cfg -> - forgeShelleyBlock - hotKey - canBeLeader - cfg - maxTxCapacityOverrides - } - - forgingVRFHash :: SL.Hash c (SL.VerKeyVRF c) - forgingVRFHash = - SL.hashVerKeyVRF - . VRF.deriveVerKeyVRF - . tpraosCanBeLeaderSignKeyVRF - $ canBeLeader - - startPeriod :: Absolute.KESPeriod - startPeriod = SL.ocertKESPeriod $ tpraosCanBeLeaderOpCert canBeLeader - - slotToPeriod :: SlotNo -> Absolute.KESPeriod - slotToPeriod (SlotNo slot) = - SL.KESPeriod $ fromIntegral $ slot `div` tpraosSlotsPerKESPeriod - -{------------------------------------------------------------------------------- - ProtocolInfo --------------------------------------------------------------------------------} - --- | Check the validity of the genesis config. To be used in conjunction with --- 'assertWithMsg'. -validateGenesis :: - ShelleyBasedEra era - => SL.ShelleyGenesis era -> Either String () -validateGenesis = first errsToString . SL.validateGenesis - where - errsToString :: [SL.ValidationErr] -> String - errsToString errs = - Text.unpack $ Text.unlines - ("Invalid genesis config:" : map SL.describeValidationErr errs) - --- | Parameters common to all Shelley-based ledgers. --- --- When running a chain with multiple Shelley-based eras, in addition to the --- per-era protocol parameters, one value of 'ProtocolParamsShelleyBased' will --- be needed, which is shared among all Shelley-based eras. --- --- The @era@ parameter determines from which era the genesis config will be --- used. -data ProtocolParamsShelleyBased era = ProtocolParamsShelleyBased { - shelleyBasedGenesis :: SL.ShelleyGenesis era - -- | The initial nonce, typically derived from the hash of Genesis - -- config JSON file. - -- - -- WARNING: chains using different values of this parameter will be - -- mutually incompatible. - , shelleyBasedInitialNonce :: SL.Nonce - , shelleyBasedLeaderCredentials :: [TPraosLeaderCredentials (EraCrypto era)] - } - --- | Parameters needed to run Shelley -data ProtocolParamsShelley c = ProtocolParamsShelley { - shelleyProtVer :: SL.ProtVer - , shelleyMaxTxCapacityOverrides :: TxLimits.Overrides (ShelleyBlock (ShelleyEra c)) - } - --- | Parameters needed to run Allegra -data ProtocolParamsAllegra c = ProtocolParamsAllegra { - allegraProtVer :: SL.ProtVer - , allegraMaxTxCapacityOverrides :: TxLimits.Overrides (ShelleyBlock (AllegraEra c)) - } - --- | Parameters needed to run Mary -data ProtocolParamsMary c = ProtocolParamsMary { - maryProtVer :: SL.ProtVer - , maryMaxTxCapacityOverrides :: TxLimits.Overrides (ShelleyBlock (MaryEra c)) - } - --- | Parameters needed to run Alonzo -data ProtocolParamsAlonzo c = ProtocolParamsAlonzo { - alonzoProtVer :: SL.ProtVer - , alonzoMaxTxCapacityOverrides :: TxLimits.Overrides (ShelleyBlock (AlonzoEra c)) - } - -protocolInfoShelley :: - forall m c. (IOLike m, ShelleyBasedEra (ShelleyEra c), TxLimits (ShelleyBlock (ShelleyEra c))) - => ProtocolParamsShelleyBased (ShelleyEra c) - -> ProtocolParamsShelley c - -> ProtocolInfo m (ShelleyBlock (ShelleyEra c)) -protocolInfoShelley protocolParamsShelleyBased - ProtocolParamsShelley { - shelleyProtVer = protVer - , shelleyMaxTxCapacityOverrides = maxTxCapacityOverrides - } = - protocolInfoShelleyBased - protocolParamsShelleyBased - () -- trivial translation context - protVer - maxTxCapacityOverrides - -protocolInfoShelleyBased :: - forall m era. (IOLike m, ShelleyBasedEra era, TxLimits (ShelleyBlock era)) - => ProtocolParamsShelleyBased era - -> Core.TranslationContext era - -> SL.ProtVer - -> TxLimits.Overrides (ShelleyBlock era) - -> ProtocolInfo m (ShelleyBlock era) -protocolInfoShelleyBased ProtocolParamsShelleyBased { - shelleyBasedGenesis = genesis - , shelleyBasedInitialNonce = initialNonce - , shelleyBasedLeaderCredentials = credentialss - } - transCtxt - protVer - maxTxCapacityOverrides = - assertWithMsg (validateGenesis genesis) $ - ProtocolInfo { - pInfoConfig = topLevelConfig - , pInfoInitLedger = initExtLedgerState - , pInfoBlockForging = - traverse - (shelleyBlockForging tpraosParams maxTxCapacityOverrides) - credentialss - } - where - - -- | Currently for all existing eras in ledger-specs (Shelley, Allegra, Mary - -- and Alonzo) it happens to be the case that AdditionalGenesisConfig and - -- TranslationContext are instantiated to the same type. - -- We take advantage of this fact below to simplify our code, but we are - -- aware that this might change in future (for new eras), breaking this - -- code. - -- - -- see type equality constraint in - -- Ouroboros.Consensus.Shelley.Eras.ShelleyBasedEra - additionalGenesisConfig :: SL.AdditionalGenesisConfig era - additionalGenesisConfig = transCtxt - - maxMajorProtVer :: MaxMajorProtVer - maxMajorProtVer = MaxMajorProtVer $ SL.pvMajor protVer - - topLevelConfig :: TopLevelConfig (ShelleyBlock era) - topLevelConfig = TopLevelConfig { - topLevelConfigProtocol = consensusConfig - , topLevelConfigLedger = ledgerConfig - , topLevelConfigBlock = blockConfig - , topLevelConfigCodec = ShelleyCodecConfig - , topLevelConfigStorage = storageConfig - } - - consensusConfig :: ConsensusConfig (BlockProtocol (ShelleyBlock era)) - consensusConfig = TPraosConfig { - tpraosParams - , tpraosEpochInfo = epochInfo - } - - ledgerConfig :: LedgerConfig (ShelleyBlock era) - ledgerConfig = mkShelleyLedgerConfig genesis transCtxt epochInfo maxMajorProtVer - - epochInfo :: EpochInfo (Except History.PastHorizonException) - epochInfo = - fixedEpochInfo - (SL.sgEpochLength genesis) - (mkSlotLength $ SL.sgSlotLength genesis) - - tpraosParams :: TPraosParams - tpraosParams = mkTPraosParams maxMajorProtVer initialNonce genesis - - blockConfig :: BlockConfig (ShelleyBlock era) - blockConfig = - mkShelleyBlockConfig - protVer - genesis - (tpraosBlockIssuerVKey <$> credentialss) - - storageConfig :: StorageConfig (ShelleyBlock era) - storageConfig = ShelleyStorageConfig { - shelleyStorageConfigSlotsPerKESPeriod = tpraosSlotsPerKESPeriod tpraosParams - , shelleyStorageConfigSecurityParam = tpraosSecurityParam tpraosParams - } - - initLedgerState :: LedgerState (ShelleyBlock era) - initLedgerState = ShelleyLedgerState { - shelleyLedgerTip = Origin - , shelleyLedgerState = - registerGenesisStaking (SL.sgStaking genesis) $ - SL.initialState genesis additionalGenesisConfig - , shelleyLedgerTransition = ShelleyTransitionInfo {shelleyAfterVoting = 0} - } - - initChainDepState :: TPraosState (EraCrypto era) - initChainDepState = TPraosState Origin $ - SL.initialChainDepState initialNonce (SL.sgGenDelegs genesis) - - initExtLedgerState :: ExtLedgerState (ShelleyBlock era) - initExtLedgerState = ExtLedgerState { - ledgerState = initLedgerState - , headerState = genesisHeaderState initChainDepState - } - -protocolClientInfoShelley :: ProtocolClientInfo (ShelleyBlock era) -protocolClientInfoShelley = - ProtocolClientInfo { - -- No particular codec configuration is needed for Shelley - pClientInfoCodecConfig = ShelleyCodecConfig - } - -{------------------------------------------------------------------------------- - ConfigSupportsNode instance --------------------------------------------------------------------------------} - -instance ConfigSupportsNode (ShelleyBlock era) where - getSystemStart = shelleySystemStart - getNetworkMagic = shelleyNetworkMagic - -{------------------------------------------------------------------------------- - NodeInitStorage instance --------------------------------------------------------------------------------} - -instance ShelleyBasedEra era => NodeInitStorage (ShelleyBlock era) where - -- We fix the chunk size to @10k@ so that we have the same chunk size as - -- Byron. Consequently, a Shelley net will have the same chunk size as the - -- Byron-to-Shelley net with the same @k@. - nodeImmutableDbChunkInfo = - simpleChunkInfo - . EpochSize - . (* 10) - . maxRollbacks - . shelleyStorageConfigSecurityParam - - nodeCheckIntegrity cfg = - verifyBlockIntegrity (shelleyStorageConfigSlotsPerKESPeriod cfg) - -{------------------------------------------------------------------------------- - RunNode instance --------------------------------------------------------------------------------} - -instance ShelleyBasedEra era => BlockSupportsMetrics (ShelleyBlock era) where - isSelfIssued cfg hdr = - case csvSelfIssued $ selectView cfg hdr of - SelfIssued -> IsSelfIssued - NotSelfIssued -> IsNotSelfIssued - -instance ( SerialiseNodeToClientConstraints (ShelleyBlock era) - , ShelleyBasedEra era - ) => RunNode (ShelleyBlock era) - -{------------------------------------------------------------------------------- - Register genesis staking --------------------------------------------------------------------------------} - --- | Register the initial staking information in the 'SL.NewEpochState'. --- --- HERE BE DRAGONS! This function is intended to help in testing. --- --- In production, the genesis should /not/ contain any initial staking. --- --- Any existing staking information is overridden, but the UTxO is left --- untouched. --- --- TODO adapt and reuse @registerGenesisStaking@ from @cardano-ledger-specs@. -registerGenesisStaking :: - forall era. ShelleyBasedEra era - => SL.ShelleyGenesisStaking (EraCrypto era) - -> SL.NewEpochState era - -> SL.NewEpochState era -registerGenesisStaking staking nes = nes { - SL.nesEs = epochState { - SL.esLState = ledgerState { - SL._delegationState = dpState { - SL._dstate = dState' - , SL._pstate = pState' - } - } - , SL.esSnapshots = (SL.esSnapshots epochState) { - SL._pstakeMark = initSnapShot - } - } - - -- Note that this is only applicable in the initial configuration where - -- there is no existing stake distribution, since it would completely - -- overwrite any such thing. - , SL.nesPd = SL.calculatePoolDistr initSnapShot - } - where - SL.ShelleyGenesisStaking { sgsPools, sgsStake } = staking - SL.NewEpochState { nesEs = epochState } = nes - ledgerState = SL.esLState epochState - dpState = SL._delegationState ledgerState - - -- New delegation state. Since we're using base addresses, we only care - -- about updating the '_delegations' field. - -- - -- See STS DELEG for details - dState' :: SL.DState (EraCrypto era) - dState' = (SL._dstate dpState) { - SL._unified = UM.unify - ( Map.map (const $ SL.Coin 0) - . Map.mapKeys SL.KeyHashObj - $ sgsStake) - ( Map.mapKeys SL.KeyHashObj sgsStake ) - mempty - } - -- We consider pools as having been registered in slot 0 - -- See STS POOL for details - pState' :: SL.PState (EraCrypto era) - pState' = (SL._pstate dpState) { - SL._pParams = sgsPools - } - - -- The new stake distribution is made on the basis of a snapshot taken - -- during the previous epoch. We create a "fake" snapshot in order to - -- establish an initial stake distribution. - initSnapShot :: SL.SnapShot (EraCrypto era) - initSnapShot = - -- Since we build a stake from nothing, we first initialise an - -- 'IncrementalStake' as empty, and then: - -- - -- 1. Add the initial UTxO, whilst deleting nothing. - -- 2. Update the stake map given the initial delegation. - SL.incrementalStakeDistr - -- Note that 'updateStakeDistribution' takes first the set of UTxO to - -- delete, and then the set to add. In our case, there is nothing to - -- delete, since this is an initial UTxO set. - (SL.updateStakeDistribution mempty mempty (SL._utxo (SL._utxoState ledgerState))) - dState' - pState' - --- | Register the initial funds in the 'SL.NewEpochState'. --- --- HERE BE DRAGONS! This function is intended to help in testing. --- --- In production, the genesis should /not/ contain any initial funds. --- --- The given funds are /added/ to the existing UTxO. --- --- PRECONDITION: the given funds must not be part of the existing UTxO. --- > forall (addr, _) in initialFunds. --- > Map.notElem (SL.initialFundsPseudoTxIn addr) existingUTxO --- --- PROPERTY: --- > genesisUTxO genesis --- > == (sgInitialFunds genesis) --- > == (registerInitialFunds (sgInitialFunds genesis) --- > ) --- --- TODO move to @cardano-ledger-specs@. -registerInitialFunds :: - forall era. - ( ShelleyBasedEra era - , HasCallStack - ) - => Map (SL.Addr (EraCrypto era)) SL.Coin - -> SL.NewEpochState era - -> SL.NewEpochState era -registerInitialFunds initialFunds nes = nes { - SL.nesEs = epochState { - SL.esAccountState = accountState' - , SL.esLState = ledgerState' - } - } - where - epochState = SL.nesEs nes - accountState = SL.esAccountState epochState - ledgerState = SL.esLState epochState - utxoState = SL._utxoState ledgerState - utxo = SL._utxo utxoState - reserves = SL._reserves accountState - - initialFundsUtxo :: SL.UTxO era - initialFundsUtxo = SL.UTxO $ SplitMap.fromList [ - (txIn, txOut) - | (addr, amount) <- Map.toList initialFunds - , let txIn = SL.initialFundsPseudoTxIn addr - txOut = SL.makeTxOut (Proxy @era) addr (inject amount) - ] - - utxo' = mergeUtxoNoOverlap utxo initialFundsUtxo - - -- Update the reserves - accountState' = accountState { - SL._reserves = reserves <-> coin (SL.balance initialFundsUtxo) - } - - -- Since we only add entries to our UTxO, rather than spending them, there - -- is nothing to delete in the incremental update. - utxoToDel = SL.UTxO mempty - ledgerState' = ledgerState { - SL._utxoState = utxoState { - SL._utxo = utxo', - -- Normally we would incrementally update here. But since we pass - -- the full UTxO as "toAdd" rather than a delta, we simply - -- reinitialise the full incremental stake. - SL._stakeDistro = SL.updateStakeDistribution mempty utxoToDel utxo' - } - } - - -- | Merge two UTxOs, throw an 'error' in case of overlap - mergeUtxoNoOverlap :: - HasCallStack - => SL.UTxO era -> SL.UTxO era -> SL.UTxO era - mergeUtxoNoOverlap (SL.UTxO m1) (SL.UTxO m2) = SL.UTxO $ - SplitMap.unionWithKey - (\k _ _ -> error $ "initial fund part of UTxO: " <> show k) - m1 - m2 diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node/Serialisation.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node/Serialisation.hs deleted file mode 100644 index 018eaf6ab7..0000000000 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node/Serialisation.hs +++ /dev/null @@ -1,183 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} - -{-# OPTIONS_GHC -Wno-orphans #-} -module Ouroboros.Consensus.Shelley.Node.Serialisation () where - -import Control.Exception (Exception, throw) -import qualified Data.ByteString.Lazy as Lazy -import Data.Typeable (Typeable) - -import Cardano.Binary (fromCBOR, toCBOR) -import Codec.Serialise (decode, encode) - -import Ouroboros.Network.Block (Serialised, unwrapCBORinCBOR, - wrapCBORinCBOR) - -import Ouroboros.Consensus.Block -import Ouroboros.Consensus.HeaderValidation -import Ouroboros.Consensus.Ledger.SupportsMempool (GenTxId) -import Ouroboros.Consensus.Node.Run -import Ouroboros.Consensus.Node.Serialisation -import Ouroboros.Consensus.Storage.Serialisation - -import qualified Cardano.Ledger.Shelley.API as SL -import qualified Cardano.Protocol.TPraos.BHeader as SL - -import Ouroboros.Consensus.Protocol.TPraos -import Ouroboros.Consensus.Shelley.Eras -import Ouroboros.Consensus.Shelley.Ledger -import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion () - -{------------------------------------------------------------------------------- - EncodeDisk & DecodeDisk --------------------------------------------------------------------------------} - -instance ShelleyBasedEra era => HasBinaryBlockInfo (ShelleyBlock era) where - getBinaryBlockInfo = shelleyBinaryBlockInfo - -instance ShelleyBasedEra era => SerialiseDiskConstraints (ShelleyBlock era) - -instance ShelleyBasedEra era => EncodeDisk (ShelleyBlock era) (ShelleyBlock era) where - encodeDisk _ = encodeShelleyBlock -instance ShelleyBasedEra era => DecodeDisk (ShelleyBlock era) (Lazy.ByteString -> ShelleyBlock era) where - decodeDisk _ = decodeShelleyBlock - -instance ShelleyBasedEra era => EncodeDisk (ShelleyBlock era) (Header (ShelleyBlock era)) where - encodeDisk _ = encodeShelleyHeader -instance ShelleyBasedEra era => DecodeDisk (ShelleyBlock era) (Lazy.ByteString -> Header (ShelleyBlock era)) where - decodeDisk _ = decodeShelleyHeader - -instance ShelleyBasedEra era => EncodeDisk (ShelleyBlock era) (LedgerState (ShelleyBlock era)) where - encodeDisk _ = encodeShelleyLedgerState -instance ShelleyBasedEra era => DecodeDisk (ShelleyBlock era) (LedgerState (ShelleyBlock era)) where - decodeDisk _ = decodeShelleyLedgerState - --- | @'ChainDepState' ('BlockProtocol' ('ShelleyBlock' era))@ -instance (ShelleyBasedEra era, EraCrypto era ~ c) => EncodeDisk (ShelleyBlock era) (TPraosState c) where - encodeDisk _ = encode --- | @'ChainDepState' ('BlockProtocol' ('ShelleyBlock' era))@ -instance (ShelleyBasedEra era, EraCrypto era ~ c) => DecodeDisk (ShelleyBlock era) (TPraosState c) where - decodeDisk _ = decode - -instance ShelleyBasedEra era => EncodeDisk (ShelleyBlock era) (AnnTip (ShelleyBlock era)) where - encodeDisk _ = encodeShelleyAnnTip -instance ShelleyBasedEra era => DecodeDisk (ShelleyBlock era) (AnnTip (ShelleyBlock era)) where - decodeDisk _ = decodeShelleyAnnTip - -{------------------------------------------------------------------------------- - SerialiseNodeToNode --------------------------------------------------------------------------------} - -instance ShelleyBasedEra era => SerialiseNodeToNodeConstraints (ShelleyBlock era) where - estimateBlockSize hdr = overhead + hdrSize + bodySize - where - -- The maximum block size is 65536, the CBOR-in-CBOR tag for this block - -- is: - -- - -- > D8 18 # tag(24) - -- > 1A 00010000 # bytes(65536) - -- - -- Which is 7 bytes, enough for up to 4294967295 bytes. - overhead = 7 {- CBOR-in-CBOR -} + 1 {- encodeListLen -} - bodySize = fromIntegral . SL.bsize . SL.bhbody . shelleyHeaderRaw $ hdr - hdrSize = fromIntegral . SL.bHeaderSize . shelleyHeaderRaw $ hdr - --- | CBOR-in-CBOR for the annotation. This also makes it compatible with the --- wrapped ('Serialised') variant. -instance ShelleyBasedEra era => SerialiseNodeToNode (ShelleyBlock era) (ShelleyBlock era) where - encodeNodeToNode _ _ = wrapCBORinCBOR encodeShelleyBlock - decodeNodeToNode _ _ = unwrapCBORinCBOR decodeShelleyBlock - --- | 'Serialised' uses CBOR-in-CBOR by default. -instance SerialiseNodeToNode (ShelleyBlock era) (Serialised (ShelleyBlock era)) - -- Default instance - --- | CBOR-in-CBOR to be compatible with the wrapped ('Serialised') variant. -instance ShelleyBasedEra era => SerialiseNodeToNode (ShelleyBlock era) (Header (ShelleyBlock era)) where - encodeNodeToNode _ _ = wrapCBORinCBOR encodeShelleyHeader - decodeNodeToNode _ _ = unwrapCBORinCBOR decodeShelleyHeader - --- | We use CBOR-in-CBOR -instance SerialiseNodeToNode (ShelleyBlock era) (SerialisedHeader (ShelleyBlock era)) where - encodeNodeToNode _ _ = encodeTrivialSerialisedHeader - decodeNodeToNode _ _ = decodeTrivialSerialisedHeader - --- | The @To/FromCBOR@ instances defined in @cardano-ledger-specs@ use --- CBOR-in-CBOR to get the annotation. -instance ShelleyBasedEra era => SerialiseNodeToNode (ShelleyBlock era) (GenTx (ShelleyBlock era)) where - encodeNodeToNode _ _ = toCBOR - decodeNodeToNode _ _ = fromCBOR - -instance ShelleyBasedEra era => SerialiseNodeToNode (ShelleyBlock era) (GenTxId (ShelleyBlock era)) where - encodeNodeToNode _ _ = toCBOR - decodeNodeToNode _ _ = fromCBOR - -{------------------------------------------------------------------------------- - SerialiseNodeToClient --------------------------------------------------------------------------------} - --- | Exception thrown in the encoders -data ShelleyEncoderException era = - -- | A query was submitted that is not supported by the given - -- 'ShelleyNodeToClientVersion'. - ShelleyEncoderUnsupportedQuery - (SomeSecond BlockQuery (ShelleyBlock era)) - ShelleyNodeToClientVersion - deriving (Show) - -instance Typeable era => Exception (ShelleyEncoderException era) - --- | CBOR-in-CBOR for the annotation. This also makes it compatible with the --- wrapped ('Serialised') variant. -instance ShelleyBasedEra era => SerialiseNodeToClient (ShelleyBlock era) (ShelleyBlock era) where - encodeNodeToClient _ _ = wrapCBORinCBOR encodeShelleyBlock - decodeNodeToClient _ _ = unwrapCBORinCBOR decodeShelleyBlock - --- | 'Serialised' uses CBOR-in-CBOR by default. -instance SerialiseNodeToClient (ShelleyBlock era) (Serialised (ShelleyBlock era)) - -- Default instance - --- | Uses CBOR-in-CBOR in the @To/FromCBOR@ instances to get the annotation. -instance ShelleyBasedEra era => SerialiseNodeToClient (ShelleyBlock era) (GenTx (ShelleyBlock era)) where - encodeNodeToClient _ _ = toCBOR - decodeNodeToClient _ _ = fromCBOR - -instance ShelleyBasedEra era => SerialiseNodeToClient (ShelleyBlock era) (GenTxId (ShelleyBlock era)) where - encodeNodeToClient _ _ = toCBOR - decodeNodeToClient _ _ = fromCBOR - --- | @'ApplyTxErr' '(ShelleyBlock era)'@ -instance ShelleyBasedEra era => SerialiseNodeToClient (ShelleyBlock era) (SL.ApplyTxError era) where - encodeNodeToClient _ _ = toCBOR - decodeNodeToClient _ _ = fromCBOR - -instance ShelleyBasedEra era - => SerialiseNodeToClient (ShelleyBlock era) (SomeSecond BlockQuery (ShelleyBlock era)) where - encodeNodeToClient _ version (SomeSecond q) - | querySupportedVersion q version - = encodeShelleyQuery q - | otherwise - = throw $ ShelleyEncoderUnsupportedQuery (SomeSecond q) version - decodeNodeToClient _ _ = decodeShelleyQuery - -instance ShelleyBasedEra era => SerialiseResult (ShelleyBlock era) (BlockQuery (ShelleyBlock era)) where - encodeResult _ _ = encodeShelleyResult - decodeResult _ _ = decodeShelleyResult - -instance ShelleyBasedEra era => SerialiseNodeToClient (ShelleyBlock era) SlotNo where - encodeNodeToClient _ _ = toCBOR - decodeNodeToClient _ _ = fromCBOR - -{------------------------------------------------------------------------------- - HFC support - - Since 'NestedCtxt' for Shelley is trivial, these instances can use defaults. --------------------------------------------------------------------------------} - -instance ShelleyBasedEra era => ReconstructNestedCtxt Header (ShelleyBlock era) -instance ShelleyBasedEra era => EncodeDiskDepIx (NestedCtxt Header) (ShelleyBlock era) -instance ShelleyBasedEra era => EncodeDiskDep (NestedCtxt Header) (ShelleyBlock era) -instance ShelleyBasedEra era => DecodeDiskDepIx (NestedCtxt Header) (ShelleyBlock era) -instance ShelleyBasedEra era => DecodeDiskDep (NestedCtxt Header) (ShelleyBlock era)