Skip to content

Commit

Permalink
Wrap Byron and Shelley in the HFC
Browse files Browse the repository at this point in the history
Closes #2407.
  • Loading branch information
mrBliss committed Jul 15, 2020
1 parent e414678 commit 9bf21ab
Show file tree
Hide file tree
Showing 8 changed files with 177 additions and 19 deletions.
Original file line number Diff line number Diff line change
Expand Up @@ -286,19 +286,25 @@ instance LedgerSupportsProtocol ByronBlock where
Origin -> SlotNo $ 2 * k
NotOrigin s -> SlotNo $ unSlotNo s + 1 + (2 * k)

byronEraParams :: HardFork.SafeBeforeEpoch -> Gen.Config -> HardFork.EraParams
byronEraParams safeBeforeEpoch genesis = HardFork.EraParams {
byronEraParams ::
Maybe HardFork.SafeBeforeEpoch
-> Gen.Config
-> HardFork.EraParams
byronEraParams mSafeBeforeEpoch genesis = HardFork.EraParams {
eraEpochSize = fromByronEpochSlots $ Gen.configEpochSlots genesis
, eraSlotLength = fromByronSlotLength $ genesisSlotLength genesis
, eraSafeZone = HardFork.StandardSafeZone (2 * k) safeBeforeEpoch
, eraSafeZone =
case mSafeBeforeEpoch of
Nothing -> HardFork.UnsafeIndefiniteSafeZone
Just safeBeforeEpoch -> HardFork.StandardSafeZone (2 * k) safeBeforeEpoch
}
where
SecurityParam k = genesisSecurityParam genesis

instance HasHardForkHistory ByronBlock where
type HardForkIndices ByronBlock = '[ByronBlock]
hardForkSummary =
neverForksHardForkSummary (byronEraParams HardFork.NoLowerBound)
neverForksHardForkSummary (byronEraParams Nothing)

{-------------------------------------------------------------------------------
Auxiliary
Expand Down
2 changes: 2 additions & 0 deletions ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -27,6 +27,8 @@ library
exposed-modules:
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
Expand Down
27 changes: 14 additions & 13 deletions ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano.hs
Original file line number Diff line number Diff line change
Expand Up @@ -52,6 +52,7 @@ import Ouroboros.Consensus.Util
import Ouroboros.Consensus.Util.IOLike

import Ouroboros.Consensus.HardFork.Combinator
import Ouroboros.Consensus.HardFork.Combinator.Unary

import Ouroboros.Consensus.Mock.Ledger
import Ouroboros.Consensus.Mock.Node ()
Expand All @@ -63,16 +64,16 @@ import Ouroboros.Consensus.Mock.Protocol.Praos as X

import Ouroboros.Consensus.Byron.Ledger
import Ouroboros.Consensus.Byron.Node as X
import Ouroboros.Consensus.Byron.Protocol (PBftByronCrypto)

import Ouroboros.Consensus.Shelley.Ledger
import Ouroboros.Consensus.Shelley.Node as X
import Ouroboros.Consensus.Shelley.Protocol (TPraos,
TPraosStandardCrypto)
import Ouroboros.Consensus.Shelley.Protocol (TPraosStandardCrypto)

import Ouroboros.Consensus.Cardano.Block
import Ouroboros.Consensus.Cardano.ByronHFC
import Ouroboros.Consensus.Cardano.CanHardFork
import Ouroboros.Consensus.Cardano.Node
import Ouroboros.Consensus.Cardano.ShelleyHFC

{-------------------------------------------------------------------------------
Supported protocols
Expand All @@ -87,8 +88,8 @@ type ProtocolMockBFT = Bft BftMockCrypto
type ProtocolMockPraos = Praos PraosMockCrypto
type ProtocolLeaderSchedule = WithLeaderSchedule (Praos PraosCryptoUnused)
type ProtocolMockPBFT = PBft PBftMockCrypto
type ProtocolRealPBFT = PBft PBftByronCrypto
type ProtocolRealTPraos = TPraos TPraosStandardCrypto
type ProtocolRealPBFT = HardForkProtocol '[ByronBlock]
type ProtocolRealTPraos = HardForkProtocol '[ShelleyBlock TPraosStandardCrypto]
type ProtocolCardano = HardForkProtocol '[ByronBlock, ShelleyBlock TPraosStandardCrypto]

{-------------------------------------------------------------------------------
Expand Down Expand Up @@ -136,7 +137,7 @@ data Protocol (m :: * -> *) blk p where
-> Update.ProtocolVersion
-> Update.SoftwareVersion
-> Maybe PBftLeaderCredentials
-> Protocol m ByronBlock ProtocolRealPBFT
-> Protocol m ByronBlockHFC ProtocolRealPBFT

-- | Run TPraos against the real Shelley ledger
ProtocolRealTPraos
Expand All @@ -150,7 +151,7 @@ data Protocol (m :: * -> *) blk p where
-> ProtVer
-> Natural -- ^ Max major protocol version
-> Maybe (TPraosLeaderCredentials TPraosStandardCrypto)
-> Protocol m (ShelleyBlock TPraosStandardCrypto) ProtocolRealTPraos
-> Protocol m (ShelleyBlockHFC TPraosStandardCrypto) ProtocolRealTPraos

-- | Run the protocols of /the/ Cardano block
ProtocolCardano
Expand Down Expand Up @@ -215,10 +216,10 @@ protocolInfo (ProtocolMockPBFT paramsPBft paramsEra nid) =
protocolInfoMockPBFT paramsPBft paramsEra nid

protocolInfo (ProtocolRealPBFT gc mthr prv swv mplc) =
protocolInfoByron gc mthr prv swv mplc
inject $ protocolInfoByron gc mthr prv swv mplc

protocolInfo (ProtocolRealTPraos genesis initialNonce protVer maxMajorPV mbLeaderCredentials) =
protocolInfoShelley genesis initialNonce maxMajorPV protVer mbLeaderCredentials
inject $ protocolInfoShelley genesis initialNonce maxMajorPV protVer mbLeaderCredentials

protocolInfo (ProtocolCardano
genesisByron mthr prv swv mbLeaderCredentialsByron
Expand Down Expand Up @@ -258,12 +259,12 @@ data ProtocolClient blk p where
:: EpochSlots
-> SecurityParam
-> ProtocolClient
ByronBlock
ByronBlockHFC
ProtocolRealPBFT

ProtocolClientRealTPraos
:: ProtocolClient
(ShelleyBlock TPraosStandardCrypto)
(ShelleyBlockHFC TPraosStandardCrypto)
ProtocolRealTPraos

ProtocolClientCardano
Expand All @@ -288,10 +289,10 @@ runProtocolClient ProtocolClientCardano{} = Dict
-- | Data required by clients of a node running the specified protocol.
protocolClientInfo :: ProtocolClient blk p -> ProtocolClientInfo blk
protocolClientInfo (ProtocolClientRealPBFT epochSlots secParam) =
protocolClientInfoByron epochSlots secParam
inject $ protocolClientInfoByron epochSlots secParam

protocolClientInfo ProtocolClientRealTPraos =
protocolClientInfoShelley
inject $ protocolClientInfoShelley

protocolClientInfo (ProtocolClientCardano epochSlots secParam) =
protocolClientInfoCardano epochSlots secParam
Original file line number Diff line number Diff line change
@@ -0,0 +1,81 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Ouroboros.Consensus.Cardano.ByronHFC (
ByronBlockHFC
) where

import qualified Data.Map.Strict as Map
import Data.SOP.Strict

import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Node.NetworkProtocolVersion
import Ouroboros.Consensus.Storage.ChainDB.Serialisation

import Ouroboros.Consensus.HardFork.Combinator
import Ouroboros.Consensus.HardFork.Combinator.Degenerate
import Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common

import Ouroboros.Consensus.Byron.Ledger
import Ouroboros.Consensus.Byron.Node ()

import Ouroboros.Consensus.Cardano.CanHardFork
import Ouroboros.Consensus.Cardano.Node ()

{-------------------------------------------------------------------------------
Synonym for convenience
-------------------------------------------------------------------------------}

-- | Byron as the single era in the hard fork combinator
type ByronBlockHFC = HardForkBlock '[ByronBlock]

{-------------------------------------------------------------------------------
NoHardForks instance
-------------------------------------------------------------------------------}

instance NoHardForks ByronBlock where
getEraParams cfg =
byronEraParams
Nothing
(byronGenesisConfig (configBlock cfg))
toPartialConsensusConfig _ = id
toPartialLedgerConfig _ cfg = ByronPartialLedgerConfig {
byronLedgerConfig = cfg
, triggerHardFork = TriggerHardForkNever
}

{-------------------------------------------------------------------------------
SupportedNetworkProtocolVersion instance
-------------------------------------------------------------------------------}

-- | Forward to the ByronBlock instance. Only supported
-- 'HardForkNodeToNodeDisabled', which is compatible with nodes running with
-- 'ByronBlock'.
instance SupportedNetworkProtocolVersion ByronBlockHFC where
supportedNodeToNodeVersions _ =
Map.map HardForkNodeToNodeDisabled $
supportedNodeToNodeVersions (Proxy @ByronBlock)

supportedNodeToClientVersions _ =
Map.map HardForkNodeToClientDisabled $
supportedNodeToClientVersions (Proxy @ByronBlock)

{-------------------------------------------------------------------------------
SerialiseHFC instance
-------------------------------------------------------------------------------}

-- | Forward to the ByronBlock instance, this means we don't add an era
-- wrapper around blocks on disk. This makes sure we're compatible with the
-- existing Byron blocks.
instance SerialiseHFC '[ByronBlock] where
encodeDiskHfcBlock (DegenCodecConfig ccfg) (DegenBlock b) =
encodeDisk ccfg b
decodeDiskHfcBlock (DegenCodecConfig ccfg) =
fmap DegenBlock <$> decodeDisk ccfg
reconstructHfcPrefixLen _ =
reconstructPrefixLen (Proxy @(Header ByronBlock))
reconstructHfcNestedCtxt _ prefix blockSize =
mapSomeNestedCtxt NCZ $
reconstructNestedCtxt (Proxy @(Header ByronBlock)) prefix blockSize
Original file line number Diff line number Diff line change
Expand Up @@ -211,6 +211,7 @@ byronTransition ByronPartialLedgerConfig{..}
instance SingleEraBlock ByronBlock where
singleEraTransition pcfg eraParams eraStart ledgerState =
case triggerHardFork pcfg of
TriggerHardForkNever -> Nothing
TriggerHardForkAtEpoch epoch -> Just epoch
TriggerHardForkAtVersion shelleyMajorVersion ->
byronTransition
Expand All @@ -235,6 +236,8 @@ data TriggerHardFork =
-- | 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 (Generic, NoUnexpectedThunks)

-- | When Byron is part of the hard-fork combinator, we use the partial ledger
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -361,7 +361,7 @@ protocolInfoCardano genesisByron mSigThresh pVer sVer mbCredsByron
shape :: History.Shape (CardanoEras sc)
shape = History.Shape $
exactlyTwo
(Byron.byronEraParams safeBeforeByron genesisByron)
(Byron.byronEraParams (Just safeBeforeByron) genesisByron)
(Shelley.shelleyEraParams genesisShelley)
where
safeBeforeByron :: History.SafeBeforeEpoch
Expand Down
Original file line number Diff line number Diff line change
@@ -0,0 +1,65 @@
{-# 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 c = HardForkBlock '[ShelleyBlock c]

{-------------------------------------------------------------------------------
NoHardForks instance
-------------------------------------------------------------------------------}

instance TPraosCrypto c => NoHardForks (ShelleyBlock c) where
getEraParams cfg = shelleyLedgerEraParams (configLedger cfg)
toPartialConsensusConfig _ = tpraosParams
toPartialLedgerConfig _ = ShelleyPartialLedgerConfig

{-------------------------------------------------------------------------------
SupportedNetworkProtocolVersion instance
-------------------------------------------------------------------------------}

-- | Forward to the ShelleyBlock instance. Only supported
-- 'HardForkNodeToNodeDisabled', which is compatible with nodes running with
-- 'ShelleyBlock'.
instance TPraosCrypto c => SupportedNetworkProtocolVersion (ShelleyBlockHFC c) where
supportedNodeToNodeVersions _ =
Map.map HardForkNodeToNodeDisabled $
supportedNodeToNodeVersions (Proxy @(ShelleyBlock c))

supportedNodeToClientVersions _ =
Map.map HardForkNodeToClientDisabled $
supportedNodeToClientVersions (Proxy @(ShelleyBlock c))

{-------------------------------------------------------------------------------
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 TPraosCrypto c => SerialiseHFC '[ShelleyBlock c] where
Original file line number Diff line number Diff line change
Expand Up @@ -146,7 +146,7 @@ injExamplesShelley Golden.Examples {..} = Golden.Examples {
]

byronEraParams :: History.EraParams
byronEraParams = Byron.byronEraParams History.NoLowerBound Byron.dummyConfig
byronEraParams = Byron.byronEraParams (Just History.NoLowerBound) Byron.dummyConfig

shelleyEraParams :: History.EraParams
shelleyEraParams = Shelley.shelleyEraParams Shelley.testShelleyGenesis
Expand Down

0 comments on commit 9bf21ab

Please sign in to comment.