From dc0e11855b311b203b1d3f9ee11202e93a6079ff Mon Sep 17 00:00:00 2001 From: Jimmy Hartzell Date: Tue, 26 Jan 2021 13:18:35 -0500 Subject: [PATCH] Refactor to decouple consensus modes - Functionality that handles Shelley-based eras in a multi-era consensus is moved to ouroboros-consensus-shelley so that it can be shared between mainnet consensus (in ouroboros-consensus-cardano) and other consensus modes comprising multiple Shelley eras. - The `Protocol` GADT that enumerates consensus modes and provides a wealth of information for clients is converted into a type class so that ouroboros-consensus-cardano does not need to know about other consensus modes. --- .../Test/Consensus/Cardano/Serialisation.hs | 2 - .../ouroboros-consensus-cardano.cabal | 1 - .../src/Ouroboros/Consensus/Cardano.hs | 175 ++------- .../Consensus/Cardano/CanHardFork.hs | 218 +----------- .../src/Ouroboros/Consensus/Cardano/Node.hs | 4 +- .../Consensus/Cardano/ShelleyBased.hs | 53 +-- .../Ouroboros/Consensus/Cardano/ShelleyHFC.hs | 74 ---- .../ouroboros-consensus-shelley.cabal | 3 + .../Consensus/Shelley/Ledger/Block.hs | 2 + .../Consensus/Shelley/ShelleyBased.hs | 64 ++++ .../Ouroboros/Consensus/Shelley/ShelleyHFC.hs | 333 ++++++++++++++++++ ouroboros-consensus/ouroboros-consensus.cabal | 2 + .../src/Ouroboros/Consensus/HardFork.hs | 24 ++ .../src/Ouroboros/Consensus/Protocol.hs | 37 ++ 14 files changed, 511 insertions(+), 481 deletions(-) delete mode 100644 ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/ShelleyHFC.hs create mode 100644 ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/ShelleyBased.hs create mode 100644 ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/ShelleyHFC.hs create mode 100644 ouroboros-consensus/src/Ouroboros/Consensus/HardFork.hs create mode 100644 ouroboros-consensus/src/Ouroboros/Consensus/Protocol.hs diff --git a/ouroboros-consensus-cardano-test/test/Test/Consensus/Cardano/Serialisation.hs b/ouroboros-consensus-cardano-test/test/Test/Consensus/Cardano/Serialisation.hs index baeebef92c3..0eca329a3a6 100644 --- a/ouroboros-consensus-cardano-test/test/Test/Consensus/Cardano/Serialisation.hs +++ b/ouroboros-consensus-cardano-test/test/Test/Consensus/Cardano/Serialisation.hs @@ -15,8 +15,6 @@ import Ouroboros.Consensus.Block import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util (Dict (..)) -import Ouroboros.Consensus.HardFork.Combinator (NestedCtxt_ (..)) - import Ouroboros.Consensus.Byron.Ledger import Ouroboros.Consensus.Byron.Node () diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index 494208cf414..73045dfb230 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -28,7 +28,6 @@ library Ouroboros.Consensus.Cardano Ouroboros.Consensus.Cardano.Block Ouroboros.Consensus.Cardano.ByronHFC - Ouroboros.Consensus.Cardano.ShelleyHFC Ouroboros.Consensus.Cardano.Condense Ouroboros.Consensus.Cardano.CanHardFork Ouroboros.Consensus.Cardano.Node diff --git a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano.hs b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano.hs index 5ecd3e0884c..662cc1b1032 100644 --- a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano.hs +++ b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano.hs @@ -1,8 +1,13 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.Cardano ( -- * The block type of the Cardano block chain @@ -18,31 +23,16 @@ module Ouroboros.Consensus.Cardano ( , ProtocolParamsMary(..) , ProtocolParamsTransition(..) , Protocol(..) - , verifyProtocol - -- * Data required to run a protocol - , protocolInfo - -- * Evidence that we can run all the supported protocols - , runProtocol , module X - -- * Client support for nodes running a protocol , ProtocolClient(..) - , protocolClientInfo - , runProtocolClient - , verifyProtocolClient + , RunProtocol(..) + , RunProtocolClient(..) ) where -import Data.Kind (Type) -import Data.Type.Equality - import Cardano.Chain.Slotting (EpochSlots) -import Ouroboros.Consensus.Block -import Ouroboros.Consensus.Node.ProtocolInfo -import Ouroboros.Consensus.Node.Run -import Ouroboros.Consensus.Protocol.Abstract as X -import Ouroboros.Consensus.Protocol.PBFT as X -import Ouroboros.Consensus.Util +import Ouroboros.Consensus.Protocol as X import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.HardFork.Combinator @@ -57,7 +47,7 @@ import Ouroboros.Consensus.Shelley.Node as X import Ouroboros.Consensus.Cardano.Block import Ouroboros.Consensus.Cardano.ByronHFC import Ouroboros.Consensus.Cardano.Node -import Ouroboros.Consensus.Cardano.ShelleyHFC +import Ouroboros.Consensus.Shelley.ShelleyHFC {------------------------------------------------------------------------------- Supported protocols @@ -69,70 +59,28 @@ import Ouroboros.Consensus.Cardano.ShelleyHFC -------------------------------------------------------------------------------} type ProtocolByron = HardForkProtocol '[ ByronBlock ] -type ProtocolShelley = HardForkProtocol '[ ShelleyBlock StandardShelley ] type ProtocolCardano = HardForkProtocol '[ ByronBlock , ShelleyBlock StandardShelley , ShelleyBlock StandardAllegra , ShelleyBlock StandardMary ] -{------------------------------------------------------------------------------- - Abstract over the various protocols --------------------------------------------------------------------------------} - --- | Consensus protocol to use -data Protocol (m :: Type -> Type) blk p where - -- | Run PBFT against the Byron ledger - ProtocolByron - :: ProtocolParamsByron - -> Protocol m ByronBlockHFC ProtocolByron - - -- | Run TPraos against the Shelley ledger - ProtocolShelley - :: ProtocolParamsShelleyBased StandardShelley - -> ProtocolParamsShelley - -> Protocol m (ShelleyBlockHFC StandardShelley) ProtocolShelley - - -- | Run the protocols of /the/ Cardano block - -- - -- WARNING: only a single set of Shelley credentials is allowed when used for - -- mainnet. Testnets allow multiple Shelley credentials. - ProtocolCardano - :: ProtocolParamsByron - -> ProtocolParamsShelleyBased StandardShelley - -> ProtocolParamsShelley - -> ProtocolParamsAllegra - -> ProtocolParamsMary - -> ProtocolParamsTransition - ByronBlock - (ShelleyBlock StandardShelley) - -> ProtocolParamsTransition - (ShelleyBlock StandardShelley) - (ShelleyBlock StandardAllegra) - -> ProtocolParamsTransition - (ShelleyBlock StandardAllegra) - (ShelleyBlock StandardMary) - -> Protocol m (CardanoBlock StandardCrypto) ProtocolCardano - -verifyProtocol :: Protocol m blk p -> (p :~: BlockProtocol blk) -verifyProtocol ProtocolByron{} = Refl -verifyProtocol ProtocolShelley{} = Refl -verifyProtocol ProtocolCardano{} = Refl - -{------------------------------------------------------------------------------- - Data required to run a protocol --------------------------------------------------------------------------------} - --- | Data required to run the selected protocol -protocolInfo :: forall m blk p. IOLike m - => Protocol m blk p -> ProtocolInfo m blk -protocolInfo (ProtocolByron params) = - inject $ protocolInfoByron params - -protocolInfo (ProtocolShelley paramsShelleyBased paramsShelley) = - inject $ protocolInfoShelley paramsShelleyBased paramsShelley - -protocolInfo (ProtocolCardano +-- | Run PBFT against the Byron ledger +instance IOLike m => Protocol m ByronBlockHFC ProtocolByron where + data RunProtocol m ByronBlockHFC ProtocolByron = RunProtocolByron ProtocolParamsByron + protocolInfo (RunProtocolByron params) = inject $ protocolInfoByron params + +instance IOLike m => Protocol m (CardanoBlock StandardCrypto) ProtocolCardano where + data RunProtocol m (CardanoBlock StandardCrypto) ProtocolCardano = RunProtocolCardano + ProtocolParamsByron + (ProtocolParamsShelleyBased StandardShelley) + ProtocolParamsShelley + ProtocolParamsAllegra + ProtocolParamsMary + (ProtocolParamsTransition ByronBlock (ShelleyBlock StandardShelley)) + (ProtocolParamsTransition (ShelleyBlock StandardShelley) (ShelleyBlock StandardAllegra)) + (ProtocolParamsTransition (ShelleyBlock StandardAllegra) (ShelleyBlock StandardMary)) + protocolInfo (RunProtocolCardano paramsByron paramsShelleyBased paramsShelley @@ -151,61 +99,14 @@ protocolInfo (ProtocolCardano paramsShelleyAllegra paramsAllegraMary -{------------------------------------------------------------------------------- - Evidence that we can run all the supported protocols --------------------------------------------------------------------------------} - -runProtocol :: Protocol m blk p -> Dict (RunNode blk) -runProtocol ProtocolByron{} = Dict -runProtocol ProtocolShelley{} = Dict -runProtocol ProtocolCardano{} = Dict - -{------------------------------------------------------------------------------- - Client support for the protocols: what you need as a client of the node --------------------------------------------------------------------------------} - --- | Node client support for each consensus protocol. --- --- This is like 'Protocol' but for clients of the node, so with less onerous --- requirements than to run a node. --- -data ProtocolClient blk p where - ProtocolClientByron - :: EpochSlots - -> ProtocolClient - ByronBlockHFC - ProtocolByron - - ProtocolClientShelley - :: ProtocolClient - (ShelleyBlockHFC StandardShelley) - ProtocolShelley - - ProtocolClientCardano - :: EpochSlots - -> ProtocolClient - (CardanoBlock StandardCrypto) - ProtocolCardano - --- | Sanity check that we have the right type combinations -verifyProtocolClient :: ProtocolClient blk p -> (p :~: BlockProtocol blk) -verifyProtocolClient ProtocolClientByron{} = Refl -verifyProtocolClient ProtocolClientShelley{} = Refl -verifyProtocolClient ProtocolClientCardano{} = Refl - --- | Sanity check that we have the right class instances available -runProtocolClient :: ProtocolClient blk p -> Dict (RunNode blk) -runProtocolClient ProtocolClientByron{} = Dict -runProtocolClient ProtocolClientShelley{} = Dict -runProtocolClient ProtocolClientCardano{} = Dict - --- | Data required by clients of a node running the specified protocol. -protocolClientInfo :: ProtocolClient blk p -> ProtocolClientInfo blk -protocolClientInfo (ProtocolClientByron epochSlots) = +instance ProtocolClient ByronBlockHFC ProtocolByron where + data RunProtocolClient ByronBlockHFC ProtocolByron = + RunProtocolClientByron EpochSlots + protocolClientInfo (RunProtocolClientByron epochSlots) = inject $ protocolClientInfoByron epochSlots -protocolClientInfo ProtocolClientShelley = - inject $ protocolClientInfoShelley - -protocolClientInfo (ProtocolClientCardano epochSlots) = +instance ProtocolClient (CardanoBlock StandardCrypto) ProtocolCardano where + data RunProtocolClient (CardanoBlock StandardCrypto) ProtocolCardano = + RunProtocolClientCardano EpochSlots + protocolClientInfo (RunProtocolClientCardano epochSlots) = protocolClientInfoCardano epochSlots diff --git a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs index 518b5c58dd5..dc116004040 100644 --- a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs +++ b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs @@ -22,6 +22,7 @@ module Ouroboros.Consensus.Cardano.CanHardFork ( , ByronPartialLedgerConfig (..) , ShelleyPartialLedgerConfig (..) , CardanoHardForkConstraints + -- * Re-exports of Shelley code , forecastAcrossShelley , translateChainDepStateAcrossShelley ) where @@ -32,7 +33,6 @@ import qualified Data.Map.Strict as Map import Data.Maybe (listToMaybe, mapMaybe) import Data.Proxy import Data.SOP.Strict (NP (..), unComp, (:.:) (..)) -import Data.Void (Void) import Data.Word import GHC.Generics (Generic) import NoThunks.Class (NoThunks) @@ -46,6 +46,7 @@ import qualified Cardano.Chain.Update as CC.Update import Ouroboros.Consensus.Block import Ouroboros.Consensus.Forecast +import Ouroboros.Consensus.HardFork import Ouroboros.Consensus.HardFork.History (Bound (boundSlot), addSlots) import Ouroboros.Consensus.Ledger.Abstract @@ -67,9 +68,9 @@ import Ouroboros.Consensus.Protocol.PBFT.State (PBftState) import qualified Ouroboros.Consensus.Protocol.PBFT.State as PBftState import Ouroboros.Consensus.Shelley.Ledger -import qualified Ouroboros.Consensus.Shelley.Ledger.Inspect as Shelley.Inspect import Ouroboros.Consensus.Shelley.Node () import Ouroboros.Consensus.Shelley.Protocol +import Ouroboros.Consensus.Shelley.ShelleyHFC import Cardano.Ledger.Allegra.Translation () import Cardano.Ledger.Crypto (ADDRHASH, DSIGN, HASH) @@ -197,52 +198,6 @@ byronTransition ByronPartialLedgerConfig{..} shelleyMajorVersion state = takeAny :: [a] -> Maybe a takeAny = listToMaybe -{------------------------------------------------------------------------------- - Figure out the transition point for Shelley --------------------------------------------------------------------------------} - -shelleyTransition :: - forall era. ShelleyBasedEra era - => PartialLedgerConfig (ShelleyBlock era) - -> Word16 -- ^ Next era's major protocol version - -> LedgerState (ShelleyBlock era) - -> Maybe EpochNo -shelleyTransition ShelleyPartialLedgerConfig{..} - transitionMajorVersion - state = - takeAny - . mapMaybe isTransition - . Shelley.Inspect.protocolUpdates genesis - $ state - where - ShelleyTransitionInfo{..} = shelleyLedgerTransition state - - -- 'shelleyLedgerConfig' contains a dummy 'EpochInfo' but this does not - -- matter for extracting the genesis config - genesis :: SL.ShelleyGenesis era - genesis = shelleyLedgerGenesis shelleyLedgerConfig - - k :: Word64 - k = SL.sgSecurityParam genesis - - isTransition :: Shelley.Inspect.ProtocolUpdate era -> Maybe EpochNo - isTransition Shelley.Inspect.ProtocolUpdate{..} = do - SL.ProtVer major _minor <- proposalVersion - guard $ fromIntegral major == transitionMajorVersion - guard $ proposalReachedQuorum - guard $ shelleyAfterVoting >= fromIntegral k - return proposalEpoch - where - Shelley.Inspect.UpdateProposal{..} = protocolUpdateProposal - Shelley.Inspect.UpdateState{..} = protocolUpdateState - - -- In principle there could be multiple proposals that all change the - -- major protocol version. In practice this can't happen because each - -- delegate can only vote for one proposal, but the types don't guarantee - -- this. We don't need to worry about this, and just pick any of them. - takeAny :: [a] -> Maybe a - takeAny = listToMaybe - {------------------------------------------------------------------------------- SingleEraBlock Byron -------------------------------------------------------------------------------} @@ -265,18 +220,6 @@ instance SingleEraBlock ByronBlock where instance PBftCrypto bc => HasPartialConsensusConfig (PBft bc) -- Use defaults --- | The trigger condition that will cause the hard fork transition. -data TriggerHardFork = - -- | Trigger the transition when the on-chain protocol major version (from - -- the ledger state) reaches this number. - TriggerHardForkAtVersion !Word16 - -- | For testing only, trigger the transition at a specific hard-coded - -- epoch, irrespective of the ledger state. - | TriggerHardForkAtEpoch !EpochNo - -- | Never trigger a hard fork - | TriggerHardForkNever - deriving (Show, Generic, NoThunks) - -- | When Byron is part of the hard-fork combinator, we use the partial ledger -- config. Standalone Byron uses the regular ledger config. This means that -- the partial ledger config is the perfect place to store the trigger @@ -294,54 +237,6 @@ instance HasPartialLedgerConfig ByronBlock where completeLedgerConfig _ _ = byronLedgerConfig -{------------------------------------------------------------------------------- - SingleEraBlock Shelley --------------------------------------------------------------------------------} - -instance ShelleyBasedEra era => SingleEraBlock (ShelleyBlock era) where - singleEraTransition pcfg _eraParams _eraStart ledgerState = - case shelleyTriggerHardFork pcfg of - TriggerHardForkNever -> Nothing - TriggerHardForkAtEpoch epoch -> Just epoch - TriggerHardForkAtVersion shelleyMajorVersion -> - shelleyTransition - pcfg - shelleyMajorVersion - ledgerState - - singleEraInfo _ = SingleEraInfo { - singleEraName = shelleyBasedEraName (Proxy @era) - } - -instance PraosCrypto c => HasPartialConsensusConfig (TPraos c) where - type PartialConsensusConfig (TPraos c) = TPraosParams - - completeConsensusConfig _ tpraosEpochInfo tpraosParams = TPraosConfig {..} - -data ShelleyPartialLedgerConfig era = ShelleyPartialLedgerConfig { - -- | We cache the non-partial ledger config containing a dummy - -- 'EpochInfo' that needs to be replaced with the correct one. - -- - -- We do this to avoid recomputing the ledger config each time - -- 'completeLedgerConfig' is called, as 'mkShelleyLedgerConfig' does - -- some rather expensive computations that shouldn't be repeated too - -- often (e.g., 'sgActiveSlotCoeff'). - shelleyLedgerConfig :: !(ShelleyLedgerConfig era) - , shelleyTriggerHardFork :: !TriggerHardFork - } - deriving (Generic, NoThunks) - -instance ShelleyBasedEra era => HasPartialLedgerConfig (ShelleyBlock era) where - type PartialLedgerConfig (ShelleyBlock era) = ShelleyPartialLedgerConfig era - - -- Replace the dummy 'EpochInfo' with the real one - completeLedgerConfig _ epochInfo (ShelleyPartialLedgerConfig cfg _) = - cfg { - shelleyLedgerGlobals = (shelleyLedgerGlobals cfg) { - SL.epochInfo = epochInfo - } - } - {------------------------------------------------------------------------------- CanHardFork -------------------------------------------------------------------------------} @@ -555,113 +450,6 @@ translateLedgerViewByronToShelleyWrapper = maxFor :: SlotNo maxFor = addSlots swindow (boundSlot bound) -{------------------------------------------------------------------------------- - Translation from one Shelley-based era to another Shelley-based era --------------------------------------------------------------------------------} - -instance ( ShelleyBasedEra era - , ShelleyBasedEra (SL.PreviousEra era) - , EraCrypto (SL.PreviousEra era) ~ EraCrypto era - ) => SL.TranslateEra era ShelleyTip where - translateEra _ (ShelleyTip sno bno (ShelleyHash hash)) = - return $ ShelleyTip sno bno (ShelleyHash hash) - -instance ( ShelleyBasedEra era - , SL.TranslateEra era ShelleyTip - , SL.TranslateEra era SL.NewEpochState - , SL.TranslationError era SL.NewEpochState ~ Void - ) => SL.TranslateEra era (LedgerState :.: ShelleyBlock) where - translateEra ctxt (Comp (ShelleyLedgerState tip state _transition)) = do - tip' <- mapM (SL.translateEra ctxt) tip - state' <- SL.translateEra ctxt state - return $ Comp $ ShelleyLedgerState { - shelleyLedgerTip = tip' - , shelleyLedgerState = state' - , shelleyLedgerTransition = ShelleyTransitionInfo 0 - } - -instance ( ShelleyBasedEra era - , SL.TranslateEra era SL.Tx - ) => SL.TranslateEra era (GenTx :.: ShelleyBlock) where - type TranslationError era (GenTx :.: ShelleyBlock) = SL.TranslationError era SL.Tx - translateEra ctxt (Comp (ShelleyTx _txId tx)) = - -- TODO will the txId stay the same? If so, we could avoid recomputing it - Comp . mkShelleyTx <$> SL.translateEra ctxt tx - --- | Forecast from a Shelley-based era to the next Shelley-based era. -forecastAcrossShelley :: - forall eraFrom eraTo. - ( EraCrypto eraFrom ~ EraCrypto eraTo - , ShelleyBasedEra eraFrom - ) - => ShelleyLedgerConfig eraFrom - -> ShelleyLedgerConfig eraTo - -> Bound -- ^ Transition between the two eras - -> SlotNo -- ^ Forecast for this slot - -> LedgerState (ShelleyBlock eraFrom) - -> Except OutsideForecastRange (Ticked (WrapLedgerView (ShelleyBlock eraTo))) -forecastAcrossShelley cfgFrom cfgTo transition forecastFor ledgerStateFrom - | forecastFor < maxFor - = return $ futureLedgerView forecastFor - | otherwise - = throwError $ OutsideForecastRange { - outsideForecastAt = ledgerTipSlot ledgerStateFrom - , outsideForecastMaxFor = maxFor - , outsideForecastFor = forecastFor - } - where - -- | 'SL.futureLedgerView' imposes its own bounds. Those bounds could - -- /exceed/ the 'maxFor' we have computed, but should never be /less/. - futureLedgerView :: SlotNo -> Ticked (WrapLedgerView (ShelleyBlock eraTo)) - futureLedgerView = - WrapTickedLedgerView - . TickedPraosLedgerView - . either - (\e -> error ("futureLedgerView failed: " <> show e)) - id - . SL.futureLedgerView - (shelleyLedgerGlobals cfgFrom) - (shelleyLedgerState ledgerStateFrom) - - -- Exclusive upper bound - maxFor :: SlotNo - maxFor = crossEraForecastBound - (ledgerTipSlot ledgerStateFrom) - (boundSlot transition) - (SL.stabilityWindow (shelleyLedgerGlobals cfgFrom)) - (SL.stabilityWindow (shelleyLedgerGlobals cfgTo)) - -translateChainDepStateAcrossShelley :: - forall eraFrom eraTo. - EraCrypto eraFrom ~ EraCrypto eraTo - => RequiringBoth - WrapConsensusConfig - (Translate WrapChainDepState) - (ShelleyBlock eraFrom) - (ShelleyBlock eraTo) -translateChainDepStateAcrossShelley = - ignoringBoth $ - Translate $ \_epochNo (WrapChainDepState chainDepState) -> - -- Same protocol, same 'ChainDepState'. Note that we don't have to apply - -- any changes related to an epoch transition, this is already done when - -- ticking the state. - WrapChainDepState chainDepState - -translateLedgerViewAcrossShelley :: - forall eraFrom eraTo. - ( EraCrypto eraFrom ~ EraCrypto eraTo - , ShelleyBasedEra eraFrom - ) - => RequiringBoth - WrapLedgerConfig - (TranslateForecast LedgerState WrapLedgerView) - (ShelleyBlock eraFrom) - (ShelleyBlock eraTo) -translateLedgerViewAcrossShelley = - RequireBoth $ \(WrapLedgerConfig cfgFrom) - (WrapLedgerConfig cfgTo) -> - TranslateForecast $ forecastAcrossShelley cfgFrom cfgTo - {------------------------------------------------------------------------------- Translation from Shelley to Allegra -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Node.hs b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Node.hs index 3bd0b716969..f8ede5c7abc 100644 --- a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Node.hs +++ b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Node.hs @@ -73,24 +73,24 @@ import Ouroboros.Consensus.Byron.Ledger.NetworkProtocolVersion import Ouroboros.Consensus.Byron.Node import qualified Cardano.Ledger.Era as SL +import Ouroboros.Consensus.Cardano.ShelleyBased import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock) import qualified Ouroboros.Consensus.Shelley.Ledger as Shelley import Ouroboros.Consensus.Shelley.Ledger.NetworkProtocolVersion import Ouroboros.Consensus.Shelley.Node import Ouroboros.Consensus.Shelley.Protocol (TPraosParams (..)) import qualified Ouroboros.Consensus.Shelley.Protocol as Shelley +import Ouroboros.Consensus.Shelley.ShelleyBased import qualified Shelley.Spec.Ledger.API as SL import Ouroboros.Consensus.Cardano.Block import Ouroboros.Consensus.Cardano.CanHardFork -import Ouroboros.Consensus.Cardano.ShelleyBased {------------------------------------------------------------------------------- SerialiseHFC -------------------------------------------------------------------------------} instance SerialiseConstraintsHFC ByronBlock -instance ShelleyBasedEra era => SerialiseConstraintsHFC (ShelleyBlock era) -- | Important: we need to maintain binary compatibility with Byron blocks, as -- they are already stored on disk. diff --git a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/ShelleyBased.hs b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/ShelleyBased.hs index 5e5207dd1fe..10a73a050f7 100644 --- a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/ShelleyBased.hs +++ b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/ShelleyBased.hs @@ -7,64 +7,17 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module Ouroboros.Consensus.Cardano.ShelleyBased ( - -- * Injection from Shelley-based eras into the Cardano eras - InjectShelley - , injectShelleyNP - , injectShelleyOptNP - -- * Transform Shelley-based types - , HasCrypto - , overShelleyBasedLedgerState + overShelleyBasedLedgerState ) where import Data.SOP.Strict -import Ouroboros.Consensus.Util.OptNP (OptNP (..)) - import Ouroboros.Consensus.HardFork.Combinator +import Ouroboros.Consensus.Cardano.Block import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock) import Ouroboros.Consensus.Shelley.Protocol (PraosCrypto) - -import Ouroboros.Consensus.Cardano.Block - -{------------------------------------------------------------------------------- - Injection from Shelley-based eras into the Cardano eras --------------------------------------------------------------------------------} - --- | Witness the relation between the Cardano eras and the Shelley-based eras. -class cardanoEra ~ ShelleyBlock shelleyEra => InjectShelley shelleyEra cardanoEra -instance cardanoEra ~ ShelleyBlock shelleyEra => InjectShelley shelleyEra cardanoEra - -injectShelleyNP :: - AllZip InjectShelley shelleyEras cardanoEras - => ( forall shelleyEra cardanoEra. - InjectShelley shelleyEra cardanoEra - => f shelleyEra -> g cardanoEra - ) - -> NP f shelleyEras -> NP g cardanoEras -injectShelleyNP _ Nil = Nil -injectShelleyNP f (x :* xs) = f x :* injectShelleyNP f xs - -injectShelleyOptNP :: - AllZip InjectShelley shelleyEras cardanoEras - => ( forall shelleyEra cardanoEra. - InjectShelley shelleyEra cardanoEra - => f shelleyEra -> g cardanoEra - ) - -> OptNP empty f shelleyEras -> OptNP empty g cardanoEras -injectShelleyOptNP _ OptNil = OptNil -injectShelleyOptNP f (OptSkip xs) = OptSkip (injectShelleyOptNP f xs) -injectShelleyOptNP f (OptCons x xs) = OptCons (f x) (injectShelleyOptNP f xs) - -{------------------------------------------------------------------------------- - Transform Shelley-based types --------------------------------------------------------------------------------} - --- | Witness the relation between the crypto used by a Shelley-based era. --- --- Can be partially applied while an equality constraint cannot. -class EraCrypto era ~ c => HasCrypto c era -instance EraCrypto era ~ c => HasCrypto c era +import Ouroboros.Consensus.Shelley.ShelleyBased -- | When the given ledger state corresponds to a Shelley-based era, apply the -- given function to it. diff --git a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/ShelleyHFC.hs b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/ShelleyHFC.hs deleted file mode 100644 index 3ab7bd4be2b..00000000000 --- a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/ShelleyHFC.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wno-orphans #-} -module Ouroboros.Consensus.Cardano.ShelleyHFC ( - ShelleyBlockHFC - ) where - -import qualified Data.Map.Strict as Map -import Data.SOP.Strict - -import Ouroboros.Consensus.Config -import Ouroboros.Consensus.Node.NetworkProtocolVersion - -import Ouroboros.Consensus.HardFork.Combinator -import Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common - -import Ouroboros.Consensus.Shelley.Ledger -import Ouroboros.Consensus.Shelley.Node () -import Ouroboros.Consensus.Shelley.Protocol - -import Ouroboros.Consensus.Cardano.CanHardFork -import Ouroboros.Consensus.Cardano.Node () - -{------------------------------------------------------------------------------- - Synonym for convenience --------------------------------------------------------------------------------} - --- | Shelley as the single era in the hard fork combinator -type ShelleyBlockHFC era = HardForkBlock '[ShelleyBlock era] - -{------------------------------------------------------------------------------- - NoHardForks instance --------------------------------------------------------------------------------} - -instance ShelleyBasedEra era => NoHardForks (ShelleyBlock era) where - getEraParams = - shelleyEraParamsNeverHardForks - . shelleyLedgerGenesis - . configLedger - toPartialConsensusConfig _ = tpraosParams - toPartialLedgerConfig _ cfg = ShelleyPartialLedgerConfig { - shelleyLedgerConfig = cfg - , shelleyTriggerHardFork = TriggerHardForkNever - } - -{------------------------------------------------------------------------------- - SupportedNetworkProtocolVersion instance --------------------------------------------------------------------------------} - --- | Forward to the ShelleyBlock instance. Only supports --- 'HardForkNodeToNodeDisabled', which is compatible with nodes running with --- 'ShelleyBlock'. -instance ShelleyBasedEra era - => SupportedNetworkProtocolVersion (ShelleyBlockHFC era) where - supportedNodeToNodeVersions _ = - Map.map HardForkNodeToNodeDisabled $ - supportedNodeToNodeVersions (Proxy @(ShelleyBlock era)) - - supportedNodeToClientVersions _ = - Map.map HardForkNodeToClientDisabled $ - supportedNodeToClientVersions (Proxy @(ShelleyBlock era)) - - latestReleasedNodeVersion = latestReleasedNodeVersionDefault - -{------------------------------------------------------------------------------- - SerialiseHFC instance --------------------------------------------------------------------------------} - --- | Use the default implementations. This means the serialisation of blocks --- includes an era wrapper. Each block should do this from the start to be --- prepared for future hard forks without having to do any bit twiddling. -instance ShelleyBasedEra era => SerialiseHFC '[ShelleyBlock era] diff --git a/ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal b/ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal index f072a80db5e..48131da426f 100644 --- a/ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal +++ b/ouroboros-consensus-shelley/ouroboros-consensus-shelley.cabal @@ -45,6 +45,8 @@ library Ouroboros.Consensus.Shelley.Protocol.Crypto Ouroboros.Consensus.Shelley.Protocol.HotKey Ouroboros.Consensus.Shelley.Protocol.Util + Ouroboros.Consensus.Shelley.ShelleyBased + Ouroboros.Consensus.Shelley.ShelleyHFC build-depends: base >=4.9 && <4.15 , bytestring >=0.10 && <0.11 @@ -73,6 +75,7 @@ library default-language: Haskell2010 ghc-options: -Wall + -Werror -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Block.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Block.hs index 8ccb42505f4..eaf35a04c70 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Block.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Block.hs @@ -56,6 +56,8 @@ import qualified Shelley.Spec.Ledger.API as SL import Ouroboros.Consensus.Shelley.Eras +import Ouroboros.Consensus.HardFork.Combinator + {------------------------------------------------------------------------------- Header hash -------------------------------------------------------------------------------} diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/ShelleyBased.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/ShelleyBased.hs new file mode 100644 index 00000000000..df454dba3a4 --- /dev/null +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/ShelleyBased.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +module Ouroboros.Consensus.Shelley.ShelleyBased ( + -- * Injection from Shelley-based eras into the Cardano eras + InjectShelley + , injectShelleyNP + , injectShelleyOptNP + -- * Transform Shelley-based types + , HasCrypto + , EraCrypto + ) where + +import Data.SOP.Strict + +import Ouroboros.Consensus.Util.OptNP (OptNP (..)) + +import Ouroboros.Consensus.Shelley.Eras (EraCrypto) +import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock) + +{------------------------------------------------------------------------------- + Injection from Shelley-based eras into consensus mode eras +-------------------------------------------------------------------------------} + +-- | Witness the relation between consensus mode (e.g. Cardano) eras and the Shelley-based eras. +class consensusModeEra ~ ShelleyBlock shelleyEra => InjectShelley shelleyEra consensusModeEra +instance consensusModeEra ~ ShelleyBlock shelleyEra => InjectShelley shelleyEra consensusModeEra + +injectShelleyNP :: + AllZip InjectShelley shelleyEras consensusModeEras + => ( forall shelleyEra consensusModeEra. + InjectShelley shelleyEra consensusModeEra + => f shelleyEra -> g consensusModeEra + ) + -> NP f shelleyEras -> NP g consensusModeEras +injectShelleyNP _ Nil = Nil +injectShelleyNP f (x :* xs) = f x :* injectShelleyNP f xs + +injectShelleyOptNP :: + AllZip InjectShelley shelleyEras consensusModeEras + => ( forall shelleyEra consensusModeEra. + InjectShelley shelleyEra consensusModeEra + => f shelleyEra -> g consensusModeEra + ) + -> OptNP empty f shelleyEras -> OptNP empty g consensusModeEras +injectShelleyOptNP _ OptNil = OptNil +injectShelleyOptNP f (OptSkip xs) = OptSkip (injectShelleyOptNP f xs) +injectShelleyOptNP f (OptCons x xs) = OptCons (f x) (injectShelleyOptNP f xs) + +{------------------------------------------------------------------------------- + Transform Shelley-based types +-------------------------------------------------------------------------------} + +-- | Witness the relation between the crypto used by a Shelley-based era. +-- +-- Can be partially applied while an equality constraint cannot. +class EraCrypto era ~ c => HasCrypto c era +instance EraCrypto era ~ c => HasCrypto c era diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/ShelleyHFC.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/ShelleyHFC.hs new file mode 100644 index 00000000000..2a09cba80fb --- /dev/null +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/ShelleyHFC.hs @@ -0,0 +1,333 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} +module Ouroboros.Consensus.Shelley.ShelleyHFC ( + ShelleyBlockHFC + , ShelleyPartialLedgerConfig (..) + , ProtocolShelley + , RunProtocol(..) + , RunProtocolClient(..) + , forecastAcrossShelley + , translateChainDepStateAcrossShelley + , translateLedgerViewAcrossShelley + ) where + +import Control.Monad (guard) +import Control.Monad.Except (Except, throwError) +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.SOP.Strict +import Data.Void (Void) +import Data.Word +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) + +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Forecast +import Ouroboros.Consensus.HardFork +import Ouroboros.Consensus.HardFork.History (Bound (boundSlot)) +import Ouroboros.Consensus.Ledger.Abstract +import Ouroboros.Consensus.TypeFamilyWrappers + +import Ouroboros.Consensus.Config +import Ouroboros.Consensus.Node.NetworkProtocolVersion +import Ouroboros.Consensus.Protocol + +import Ouroboros.Consensus.HardFork.Combinator +import Ouroboros.Consensus.HardFork.Combinator.Embed.Unary +import Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common +import Ouroboros.Consensus.HardFork.Combinator.State.Types +import Ouroboros.Consensus.HardFork.Combinator.Util.InPairs + (RequiringBoth (..), ignoringBoth) + +import Ouroboros.Consensus.Shelley.Eras +import Ouroboros.Consensus.Shelley.Ledger +import Ouroboros.Consensus.Shelley.Ledger.Inspect as Shelley.Inspect +import Ouroboros.Consensus.Shelley.Node (ProtocolParamsShelley, + ProtocolParamsShelleyBased, protocolClientInfoShelley, + protocolInfoShelley) +import Ouroboros.Consensus.Shelley.Protocol + +import Ouroboros.Consensus.Util.IOLike (IOLike) + +import qualified Cardano.Ledger.Era as SL +import qualified Shelley.Spec.Ledger.API as SL + +{------------------------------------------------------------------------------- + Synonym for convenience +-------------------------------------------------------------------------------} + +-- | Shelley as the single era in the hard fork combinator +type ShelleyBlockHFC era = HardForkBlock '[ShelleyBlock era] + +{------------------------------------------------------------------------------- + NoHardForks instance +-------------------------------------------------------------------------------} + +instance ShelleyBasedEra era => NoHardForks (ShelleyBlock era) where + getEraParams = + shelleyEraParamsNeverHardForks + . shelleyLedgerGenesis + . configLedger + toPartialConsensusConfig _ = tpraosParams + toPartialLedgerConfig _ cfg = ShelleyPartialLedgerConfig { + shelleyLedgerConfig = cfg + , shelleyTriggerHardFork = TriggerHardForkNever + } + +{------------------------------------------------------------------------------- + SupportedNetworkProtocolVersion instance +-------------------------------------------------------------------------------} + +-- | Forward to the ShelleyBlock instance. Only supports +-- 'HardForkNodeToNodeDisabled', which is compatible with nodes running with +-- 'ShelleyBlock'. +instance ShelleyBasedEra era + => SupportedNetworkProtocolVersion (ShelleyBlockHFC era) where + supportedNodeToNodeVersions _ = + Map.map HardForkNodeToNodeDisabled $ + supportedNodeToNodeVersions (Proxy @(ShelleyBlock era)) + + supportedNodeToClientVersions _ = + Map.map HardForkNodeToClientDisabled $ + supportedNodeToClientVersions (Proxy @(ShelleyBlock era)) + + latestReleasedNodeVersion = latestReleasedNodeVersionDefault + +{------------------------------------------------------------------------------- + SerialiseHFC instance +-------------------------------------------------------------------------------} + +-- | Use the default implementations. This means the serialisation of blocks +-- includes an era wrapper. Each block should do this from the start to be +-- prepared for future hard forks without having to do any bit twiddling. +instance ShelleyBasedEra era => SerialiseHFC '[ShelleyBlock era] +instance ShelleyBasedEra era => SerialiseConstraintsHFC (ShelleyBlock era) + +{------------------------------------------------------------------------------- + Protocol Instances +-------------------------------------------------------------------------------} + +type ProtocolShelley = HardForkProtocol '[ ShelleyBlock StandardShelley ] + +-- | Run TPraos against the Shelley ledger +instance IOLike m => Protocol m (ShelleyBlockHFC StandardShelley) ProtocolShelley where + data RunProtocol m (ShelleyBlockHFC StandardShelley) ProtocolShelley = RunProtocolShelley + (ProtocolParamsShelleyBased StandardShelley) + (ProtocolParamsShelley) + protocolInfo (RunProtocolShelley paramsShelleyBased paramsShelley) = + inject $ protocolInfoShelley paramsShelleyBased paramsShelley + +instance ProtocolClient (ShelleyBlockHFC StandardShelley) ProtocolShelley where + data RunProtocolClient (ShelleyBlockHFC StandardShelley) ProtocolShelley = + RunProtocolClientShelley + protocolClientInfo RunProtocolClientShelley = + inject $ protocolClientInfoShelley + +{------------------------------------------------------------------------------- + SingleEraBlock Shelley +-------------------------------------------------------------------------------} + +shelleyTransition :: + forall era. ShelleyBasedEra era + => PartialLedgerConfig (ShelleyBlock era) + -> Word16 -- ^ Next era's major protocol version + -> LedgerState (ShelleyBlock era) + -> Maybe EpochNo +shelleyTransition ShelleyPartialLedgerConfig{..} + transitionMajorVersion + state = + takeAny + . mapMaybe isTransition + . Shelley.Inspect.protocolUpdates genesis + $ state + where + ShelleyTransitionInfo{..} = shelleyLedgerTransition state + + -- 'shelleyLedgerConfig' contains a dummy 'EpochInfo' but this does not + -- matter for extracting the genesis config + genesis :: SL.ShelleyGenesis era + genesis = shelleyLedgerGenesis shelleyLedgerConfig + + k :: Word64 + k = SL.sgSecurityParam genesis + + isTransition :: Shelley.Inspect.ProtocolUpdate era -> Maybe EpochNo + isTransition Shelley.Inspect.ProtocolUpdate{..} = do + SL.ProtVer major _minor <- proposalVersion + guard $ fromIntegral major == transitionMajorVersion + guard $ proposalReachedQuorum + guard $ shelleyAfterVoting >= fromIntegral k + return proposalEpoch + where + Shelley.Inspect.UpdateProposal{..} = protocolUpdateProposal + Shelley.Inspect.UpdateState{..} = protocolUpdateState + + -- In principle there could be multiple proposals that all change the + -- major protocol version. In practice this can't happen because each + -- delegate can only vote for one proposal, but the types don't guarantee + -- this. We don't need to worry about this, and just pick any of them. + takeAny :: [a] -> Maybe a + takeAny = listToMaybe + +instance ShelleyBasedEra era => SingleEraBlock (ShelleyBlock era) where + singleEraTransition pcfg _eraParams _eraStart ledgerState = + case shelleyTriggerHardFork pcfg of + TriggerHardForkNever -> Nothing + TriggerHardForkAtEpoch epoch -> Just epoch + TriggerHardForkAtVersion shelleyMajorVersion -> + shelleyTransition + pcfg + shelleyMajorVersion + ledgerState + + singleEraInfo _ = SingleEraInfo { + singleEraName = shelleyBasedEraName (Proxy @era) + } + +instance PraosCrypto c => HasPartialConsensusConfig (TPraos c) where + type PartialConsensusConfig (TPraos c) = TPraosParams + + completeConsensusConfig _ tpraosEpochInfo tpraosParams = TPraosConfig {..} + +data ShelleyPartialLedgerConfig era = ShelleyPartialLedgerConfig { + -- | We cache the non-partial ledger config containing a dummy + -- 'EpochInfo' that needs to be replaced with the correct one. + -- + -- We do this to avoid recomputing the ledger config each time + -- 'completeLedgerConfig' is called, as 'mkShelleyLedgerConfig' does + -- some rather expensive computations that shouldn't be repeated too + -- often (e.g., 'sgActiveSlotCoeff'). + shelleyLedgerConfig :: !(ShelleyLedgerConfig era) + , shelleyTriggerHardFork :: !TriggerHardFork + } + deriving (Generic, NoThunks) + +instance ShelleyBasedEra era => HasPartialLedgerConfig (ShelleyBlock era) where + type PartialLedgerConfig (ShelleyBlock era) = ShelleyPartialLedgerConfig era + + -- Replace the dummy 'EpochInfo' with the real one + completeLedgerConfig _ epochInfo (ShelleyPartialLedgerConfig cfg _) = + cfg { + shelleyLedgerGlobals = (shelleyLedgerGlobals cfg) { + SL.epochInfo = epochInfo + } + } + +-- | Forecast from a Shelley-based era to the next Shelley-based era. +forecastAcrossShelley :: + forall eraFrom eraTo. + ( EraCrypto eraFrom ~ EraCrypto eraTo + , ShelleyBasedEra eraFrom + ) + => ShelleyLedgerConfig eraFrom + -> ShelleyLedgerConfig eraTo + -> Bound -- ^ Transition between the two eras + -> SlotNo -- ^ Forecast for this slot + -> LedgerState (ShelleyBlock eraFrom) + -> Except OutsideForecastRange (Ticked (WrapLedgerView (ShelleyBlock eraTo))) +forecastAcrossShelley cfgFrom cfgTo transition forecastFor ledgerStateFrom + | forecastFor < maxFor + = return $ futureLedgerView forecastFor + | otherwise + = throwError $ OutsideForecastRange { + outsideForecastAt = ledgerTipSlot ledgerStateFrom + , outsideForecastMaxFor = maxFor + , outsideForecastFor = forecastFor + } + where + -- | 'SL.futureLedgerView' imposes its own bounds. Those bounds could + -- /exceed/ the 'maxFor' we have computed, but should never be /less/. + futureLedgerView :: SlotNo -> Ticked (WrapLedgerView (ShelleyBlock eraTo)) + futureLedgerView = + WrapTickedLedgerView + . TickedPraosLedgerView + . either + (\e -> error ("futureLedgerView failed: " <> show e)) + id + . SL.futureLedgerView + (shelleyLedgerGlobals cfgFrom) + (shelleyLedgerState ledgerStateFrom) + + -- Exclusive upper bound + maxFor :: SlotNo + maxFor = crossEraForecastBound + (ledgerTipSlot ledgerStateFrom) + (boundSlot transition) + (SL.stabilityWindow (shelleyLedgerGlobals cfgFrom)) + (SL.stabilityWindow (shelleyLedgerGlobals cfgTo)) + +translateChainDepStateAcrossShelley :: + forall eraFrom eraTo. + EraCrypto eraFrom ~ EraCrypto eraTo + => RequiringBoth + WrapConsensusConfig + (Translate WrapChainDepState) + (ShelleyBlock eraFrom) + (ShelleyBlock eraTo) +translateChainDepStateAcrossShelley = + ignoringBoth $ + Translate $ \_epochNo (WrapChainDepState chainDepState) -> + -- Same protocol, same 'ChainDepState'. Note that we don't have to apply + -- any changes related to an epoch transition, this is already done when + -- ticking the state. + WrapChainDepState chainDepState + +translateLedgerViewAcrossShelley :: + forall eraFrom eraTo. + ( EraCrypto eraFrom ~ EraCrypto eraTo + , ShelleyBasedEra eraFrom + ) + => RequiringBoth + WrapLedgerConfig + (TranslateForecast LedgerState WrapLedgerView) + (ShelleyBlock eraFrom) + (ShelleyBlock eraTo) +translateLedgerViewAcrossShelley = + RequireBoth $ \(WrapLedgerConfig cfgFrom) + (WrapLedgerConfig cfgTo) -> + TranslateForecast $ forecastAcrossShelley cfgFrom cfgTo + + +{------------------------------------------------------------------------------- + Translation from one Shelley-based era to another Shelley-based era +-------------------------------------------------------------------------------} + +instance ( ShelleyBasedEra era + , ShelleyBasedEra (SL.PreviousEra era) + , EraCrypto (SL.PreviousEra era) ~ EraCrypto era + ) => SL.TranslateEra era ShelleyTip where + translateEra _ (ShelleyTip sno bno (ShelleyHash hash)) = + return $ ShelleyTip sno bno (ShelleyHash hash) + +instance ( ShelleyBasedEra era + , SL.TranslateEra era ShelleyTip + , SL.TranslateEra era SL.NewEpochState + , SL.TranslationError era SL.NewEpochState ~ Void + ) => SL.TranslateEra era (LedgerState :.: ShelleyBlock) where + translateEra ctxt (Comp (ShelleyLedgerState tip state _transition)) = do + tip' <- mapM (SL.translateEra ctxt) tip + state' <- SL.translateEra ctxt state + return $ Comp $ ShelleyLedgerState { + shelleyLedgerTip = tip' + , shelleyLedgerState = state' + , shelleyLedgerTransition = ShelleyTransitionInfo 0 + } + +instance ( ShelleyBasedEra era + , SL.TranslateEra era SL.Tx + ) => SL.TranslateEra era (GenTx :.: ShelleyBlock) where + type TranslationError era (GenTx :.: ShelleyBlock) = SL.TranslationError era SL.Tx + translateEra ctxt (Comp (ShelleyTx _txId tx)) = + -- TODO will the txId stay the same? If so, we could avoid recomputing it + Comp . mkShelleyTx <$> SL.translateEra ctxt tx diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 5c5a7e008bf..18dc6dded3b 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -54,6 +54,7 @@ library Ouroboros.Consensus.Fragment.InFuture Ouroboros.Consensus.Fragment.Validated Ouroboros.Consensus.Fragment.ValidatedDiff + Ouroboros.Consensus.HardFork Ouroboros.Consensus.HardFork.Abstract Ouroboros.Consensus.HardFork.Combinator Ouroboros.Consensus.HardFork.Combinator.Abstract @@ -144,6 +145,7 @@ library Ouroboros.Consensus.Node.Run Ouroboros.Consensus.Node.Serialisation Ouroboros.Consensus.Node.Tracers + Ouroboros.Consensus.Protocol Ouroboros.Consensus.Protocol.Abstract Ouroboros.Consensus.Protocol.BFT Ouroboros.Consensus.Protocol.LeaderSchedule diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork.hs new file mode 100644 index 00000000000..42b18bffaf7 --- /dev/null +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + +module Ouroboros.Consensus.HardFork ( + TriggerHardFork (..) + ) where + +import Data.Word +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) + +import Cardano.Slotting.Slot (EpochNo) + +-- | The trigger condition that will cause the hard fork transition. +data TriggerHardFork = + -- | Trigger the transition when the on-chain protocol major version (from + -- the ledger state) reaches this number. + TriggerHardForkAtVersion !Word16 + -- | For testing only, trigger the transition at a specific hard-coded + -- epoch, irrespective of the ledger state. + | TriggerHardForkAtEpoch !EpochNo + -- | Never trigger a hard fork + | TriggerHardForkNever + deriving (Show, Generic, NoThunks) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Protocol.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol.hs new file mode 100644 index 00000000000..4bfd3159dc2 --- /dev/null +++ b/ouroboros-consensus/src/Ouroboros/Consensus/Protocol.hs @@ -0,0 +1,37 @@ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeSynonymInstances #-} + +module Ouroboros.Consensus.Protocol ( + Protocol(..) + , module X + -- * Client support for nodes running a protocol + , ProtocolClient(..) + ) where + +import Ouroboros.Consensus.Block +import Ouroboros.Consensus.Node.ProtocolInfo +import Ouroboros.Consensus.Node.Run +import Ouroboros.Consensus.Protocol.Abstract as X +import Ouroboros.Consensus.Protocol.PBFT as X +import Ouroboros.Consensus.Util.IOLike + +class (p ~ BlockProtocol blk, RunNode blk, IOLike m) => Protocol m blk p where + data RunProtocol m blk p + protocolInfo :: RunProtocol m blk p -> ProtocolInfo m blk + +-- | Node client support for each consensus protocol. +-- +-- This is like 'Protocol' but for clients of the node, so with less onerous +-- requirements than to run a node. +-- +class (p ~ BlockProtocol blk, RunNode blk) => ProtocolClient blk p where + data RunProtocolClient blk p + protocolClientInfo :: RunProtocolClient blk p -> ProtocolClientInfo blk