{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Cardano.Node.Protocol.Cardano
( mkConsensusProtocolCardano
, CardanoProtocolInstantiationError (..)
) where
import Cardano.Api.Any (Error (..))
import qualified Cardano.Chain.Update as Byron
import qualified Cardano.Ledger.Api.Era as L
import qualified Cardano.Ledger.Api.Transition as SL
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Dijkstra.PParams
import qualified Cardano.Node.Protocol.Alonzo as Alonzo
import qualified Cardano.Node.Protocol.Byron as Byron
import qualified Cardano.Node.Protocol.Conway as Conway
import Cardano.Node.Protocol.Shelley (readGenesisAny)
import qualified Cardano.Node.Protocol.Shelley as Shelley
import Cardano.Node.Types
import Control.Monad.Trans.Except (ExceptT)
import Control.Monad.Trans.Except.Extra (firstExceptT)
import Data.Maybe (fromMaybe)
import Ouroboros.Consensus.Cardano
import qualified Ouroboros.Consensus.Cardano as Consensus
import Ouroboros.Consensus.Cardano.Condense ()
import Ouroboros.Consensus.Cardano.Node (CardanoProtocolParams (..))
import Ouroboros.Consensus.Config (emptyCheckpointsMap)
import Ouroboros.Consensus.HardFork.Combinator.Condense ()
import Ouroboros.Consensus.Shelley.Crypto (StandardCrypto)
mkConsensusProtocolCardano ::
NodeByronProtocolConfiguration ->
NodeShelleyProtocolConfiguration ->
NodeAlonzoProtocolConfiguration ->
NodeConwayProtocolConfiguration ->
Maybe NodeDijkstraProtocolConfiguration ->
NodeHardForkProtocolConfiguration ->
Maybe ProtocolFilepaths ->
ExceptT CardanoProtocolInstantiationError IO (CardanoProtocolParams StandardCrypto)
mkConsensusProtocolCardano :: NodeByronProtocolConfiguration
-> NodeShelleyProtocolConfiguration
-> NodeAlonzoProtocolConfiguration
-> NodeConwayProtocolConfiguration
-> Maybe NodeDijkstraProtocolConfiguration
-> NodeHardForkProtocolConfiguration
-> Maybe ProtocolFilepaths
-> ExceptT
CardanoProtocolInstantiationError
IO
(CardanoProtocolParams StandardCrypto)
mkConsensusProtocolCardano
NodeByronProtocolConfiguration
{ GenesisFile
npcByronGenesisFile :: GenesisFile
npcByronGenesisFile :: NodeByronProtocolConfiguration -> GenesisFile
npcByronGenesisFile
, Maybe GenesisHash
npcByronGenesisFileHash :: Maybe GenesisHash
npcByronGenesisFileHash :: NodeByronProtocolConfiguration -> Maybe GenesisHash
npcByronGenesisFileHash
, RequiresNetworkMagic
npcByronReqNetworkMagic :: RequiresNetworkMagic
npcByronReqNetworkMagic :: NodeByronProtocolConfiguration -> RequiresNetworkMagic
npcByronReqNetworkMagic
, Maybe Double
npcByronPbftSignatureThresh :: Maybe Double
npcByronPbftSignatureThresh :: NodeByronProtocolConfiguration -> Maybe Double
npcByronPbftSignatureThresh
, ApplicationName
npcByronApplicationName :: ApplicationName
npcByronApplicationName :: NodeByronProtocolConfiguration -> ApplicationName
npcByronApplicationName
, NumSoftwareVersion
npcByronApplicationVersion :: NumSoftwareVersion
npcByronApplicationVersion :: NodeByronProtocolConfiguration -> NumSoftwareVersion
npcByronApplicationVersion
, Word16
npcByronSupportedProtocolVersionMajor :: Word16
npcByronSupportedProtocolVersionMajor :: NodeByronProtocolConfiguration -> Word16
npcByronSupportedProtocolVersionMajor
, Word16
npcByronSupportedProtocolVersionMinor :: Word16
npcByronSupportedProtocolVersionMinor :: NodeByronProtocolConfiguration -> Word16
npcByronSupportedProtocolVersionMinor
, Word8
npcByronSupportedProtocolVersionAlt :: Word8
npcByronSupportedProtocolVersionAlt :: NodeByronProtocolConfiguration -> Word8
npcByronSupportedProtocolVersionAlt
}
NodeShelleyProtocolConfiguration
{ GenesisFile
npcShelleyGenesisFile :: GenesisFile
npcShelleyGenesisFile :: NodeShelleyProtocolConfiguration -> GenesisFile
npcShelleyGenesisFile
, Maybe GenesisHash
npcShelleyGenesisFileHash :: Maybe GenesisHash
npcShelleyGenesisFileHash :: NodeShelleyProtocolConfiguration -> Maybe GenesisHash
npcShelleyGenesisFileHash
}
NodeAlonzoProtocolConfiguration
{ GenesisFile
npcAlonzoGenesisFile :: GenesisFile
npcAlonzoGenesisFile :: NodeAlonzoProtocolConfiguration -> GenesisFile
npcAlonzoGenesisFile
, Maybe GenesisHash
npcAlonzoGenesisFileHash :: Maybe GenesisHash
npcAlonzoGenesisFileHash :: NodeAlonzoProtocolConfiguration -> Maybe GenesisHash
npcAlonzoGenesisFileHash
}
NodeConwayProtocolConfiguration
{ GenesisFile
npcConwayGenesisFile :: GenesisFile
npcConwayGenesisFile :: NodeConwayProtocolConfiguration -> GenesisFile
npcConwayGenesisFile
, Maybe GenesisHash
npcConwayGenesisFileHash :: Maybe GenesisHash
npcConwayGenesisFileHash :: NodeConwayProtocolConfiguration -> Maybe GenesisHash
npcConwayGenesisFileHash
}
Maybe NodeDijkstraProtocolConfiguration
npcDijkstraProtocolConfig
NodeHardForkProtocolConfiguration
{ npcTestEnableDevelopmentHardForkEras :: NodeHardForkProtocolConfiguration -> Bool
npcTestEnableDevelopmentHardForkEras = Bool
_
,
Maybe EpochNo
npcTestShelleyHardForkAtEpoch :: Maybe EpochNo
npcTestShelleyHardForkAtEpoch :: NodeHardForkProtocolConfiguration -> Maybe EpochNo
npcTestShelleyHardForkAtEpoch
, Maybe EpochNo
npcTestAllegraHardForkAtEpoch :: Maybe EpochNo
npcTestAllegraHardForkAtEpoch :: NodeHardForkProtocolConfiguration -> Maybe EpochNo
npcTestAllegraHardForkAtEpoch
, Maybe EpochNo
npcTestMaryHardForkAtEpoch :: Maybe EpochNo
npcTestMaryHardForkAtEpoch :: NodeHardForkProtocolConfiguration -> Maybe EpochNo
npcTestMaryHardForkAtEpoch
, Maybe EpochNo
npcTestAlonzoHardForkAtEpoch :: Maybe EpochNo
npcTestAlonzoHardForkAtEpoch :: NodeHardForkProtocolConfiguration -> Maybe EpochNo
npcTestAlonzoHardForkAtEpoch
, Maybe EpochNo
npcTestBabbageHardForkAtEpoch :: Maybe EpochNo
npcTestBabbageHardForkAtEpoch :: NodeHardForkProtocolConfiguration -> Maybe EpochNo
npcTestBabbageHardForkAtEpoch
, Maybe EpochNo
npcTestConwayHardForkAtEpoch :: Maybe EpochNo
npcTestConwayHardForkAtEpoch :: NodeHardForkProtocolConfiguration -> Maybe EpochNo
npcTestConwayHardForkAtEpoch
, Maybe EpochNo
npcTestDijkstraHardForkAtEpoch :: Maybe EpochNo
npcTestDijkstraHardForkAtEpoch :: NodeHardForkProtocolConfiguration -> Maybe EpochNo
npcTestDijkstraHardForkAtEpoch
}
Maybe ProtocolFilepaths
files = do
byronGenesis <-
(ByronProtocolInstantiationError
-> CardanoProtocolInstantiationError)
-> ExceptT ByronProtocolInstantiationError IO Config
-> ExceptT CardanoProtocolInstantiationError IO Config
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT ByronProtocolInstantiationError
-> CardanoProtocolInstantiationError
CardanoProtocolInstantiationErrorByron (ExceptT ByronProtocolInstantiationError IO Config
-> ExceptT CardanoProtocolInstantiationError IO Config)
-> ExceptT ByronProtocolInstantiationError IO Config
-> ExceptT CardanoProtocolInstantiationError IO Config
forall a b. (a -> b) -> a -> b
$
GenesisFile
-> Maybe GenesisHash
-> RequiresNetworkMagic
-> ExceptT ByronProtocolInstantiationError IO Config
Byron.readGenesis
GenesisFile
npcByronGenesisFile
Maybe GenesisHash
npcByronGenesisFileHash
RequiresNetworkMagic
npcByronReqNetworkMagic
byronLeaderCredentials <-
firstExceptT CardanoProtocolInstantiationErrorByron $
Byron.readLeaderCredentials byronGenesis files
(shelleyGenesis, shelleyGenesisHash) <-
firstExceptT CardanoProtocolInstantiationShelleyGenesisReadError $
Shelley.readGenesis
npcShelleyGenesisFile
npcShelleyGenesisFileHash
(alonzoGenesis, _alonzoGenesisHash) <-
firstExceptT CardanoProtocolInstantiationAlonzoGenesisReadError $
Alonzo.readGenesis
npcAlonzoGenesisFile
npcAlonzoGenesisFileHash
(conwayGenesis, _conwayGenesisHash) <-
firstExceptT CardanoProtocolInstantiationConwayGenesisReadError $
Conway.readGenesis
npcConwayGenesisFile
npcConwayGenesisFileHash
dijkstraGenesis <- case npcDijkstraProtocolConfig of
Maybe NodeDijkstraProtocolConfiguration
Nothing -> DijkstraGenesis
-> ExceptT CardanoProtocolInstantiationError IO DijkstraGenesis
forall a. a -> ExceptT CardanoProtocolInstantiationError IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure DijkstraGenesis
emptyDijkstraGenesis
Just
( NodeDijkstraProtocolConfiguration
{ GenesisFile
npcDijkstraGenesisFile :: GenesisFile
npcDijkstraGenesisFile :: NodeDijkstraProtocolConfiguration -> GenesisFile
npcDijkstraGenesisFile
, Maybe GenesisHash
npcDijkstraGenesisFileHash :: Maybe GenesisHash
npcDijkstraGenesisFileHash :: NodeDijkstraProtocolConfiguration -> Maybe GenesisHash
npcDijkstraGenesisFileHash
}
) -> do
(dijkstraGenesis, _dijkstraGenesisHash) <-
(GenesisReadError -> CardanoProtocolInstantiationError)
-> ExceptT GenesisReadError IO (DijkstraGenesis, GenesisHash)
-> ExceptT
CardanoProtocolInstantiationError IO (DijkstraGenesis, GenesisHash)
forall (m :: * -> *) x y a.
Functor m =>
(x -> y) -> ExceptT x m a -> ExceptT y m a
firstExceptT GenesisReadError -> CardanoProtocolInstantiationError
CardanoProtocolInstantiationDijkstraGenesisReadError (ExceptT GenesisReadError IO (DijkstraGenesis, GenesisHash)
-> ExceptT
CardanoProtocolInstantiationError
IO
(DijkstraGenesis, GenesisHash))
-> ExceptT GenesisReadError IO (DijkstraGenesis, GenesisHash)
-> ExceptT
CardanoProtocolInstantiationError IO (DijkstraGenesis, GenesisHash)
forall a b. (a -> b) -> a -> b
$
GenesisFile
-> Maybe GenesisHash
-> ExceptT GenesisReadError IO (DijkstraGenesis, GenesisHash)
forall genesis.
FromJSON genesis =>
GenesisFile
-> Maybe GenesisHash
-> ExceptT GenesisReadError IO (genesis, GenesisHash)
readGenesisAny
GenesisFile
npcDijkstraGenesisFile
Maybe GenesisHash
npcDijkstraGenesisFileHash
pure dijkstraGenesis
shelleyLeaderCredentials <-
firstExceptT CardanoProtocolInstantiationPraosLeaderCredentialsError $
Shelley.readLeaderCredentials files
let transitionLedgerConfig =
ShelleyGenesis
-> AlonzoGenesis
-> ConwayGenesis
-> DijkstraGenesis
-> TransitionConfig LatestKnownEra
SL.mkLatestTransitionConfig ShelleyGenesis
shelleyGenesis AlonzoGenesis
alonzoGenesis ConwayGenesis
conwayGenesis DijkstraGenesis
dijkstraGenesis
return $!
CardanoProtocolParams
Consensus.ProtocolParamsByron
{ byronGenesis = byronGenesis
, byronPbftSignatureThreshold =
PBftSignatureThreshold <$> npcByronPbftSignatureThresh
,
byronProtocolVersion =
Byron.ProtocolVersion
npcByronSupportedProtocolVersionMajor
npcByronSupportedProtocolVersionMinor
npcByronSupportedProtocolVersionAlt
, byronSoftwareVersion =
Byron.SoftwareVersion
npcByronApplicationName
npcByronApplicationVersion
, byronLeaderCredentials = byronLeaderCredentials
}
Consensus.ProtocolParamsShelleyBased
{ shelleyBasedInitialNonce =
Shelley.genesisHashToPraosNonce
shelleyGenesisHash
, shelleyBasedLeaderCredentials = shelleyLeaderCredentials
}
Consensus.CardanoHardForkTriggers'
{ triggerHardForkShelley =
case npcTestShelleyHardForkAtEpoch of
Maybe EpochNo
Nothing -> CardanoHardForkTrigger
(ShelleyBlock (TPraos StandardCrypto) ShelleyEra)
forall blk. CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtDefaultVersion
Just EpochNo
epochNo -> EpochNo
-> CardanoHardForkTrigger
(ShelleyBlock (TPraos StandardCrypto) ShelleyEra)
forall blk. EpochNo -> CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtEpoch EpochNo
epochNo
,
triggerHardForkAllegra =
case npcTestAllegraHardForkAtEpoch of
Maybe EpochNo
Nothing -> CardanoHardForkTrigger
(ShelleyBlock (TPraos StandardCrypto) AllegraEra)
forall blk. CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtDefaultVersion
Just EpochNo
epochNo -> EpochNo
-> CardanoHardForkTrigger
(ShelleyBlock (TPraos StandardCrypto) AllegraEra)
forall blk. EpochNo -> CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtEpoch EpochNo
epochNo
,
triggerHardForkMary =
case npcTestMaryHardForkAtEpoch of
Maybe EpochNo
Nothing -> CardanoHardForkTrigger
(ShelleyBlock (TPraos StandardCrypto) MaryEra)
forall blk. CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtDefaultVersion
Just EpochNo
epochNo -> EpochNo
-> CardanoHardForkTrigger
(ShelleyBlock (TPraos StandardCrypto) MaryEra)
forall blk. EpochNo -> CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtEpoch EpochNo
epochNo
,
triggerHardForkAlonzo =
case npcTestAlonzoHardForkAtEpoch of
Maybe EpochNo
Nothing -> CardanoHardForkTrigger
(ShelleyBlock (TPraos StandardCrypto) AlonzoEra)
forall blk. CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtDefaultVersion
Just EpochNo
epochNo -> EpochNo
-> CardanoHardForkTrigger
(ShelleyBlock (TPraos StandardCrypto) AlonzoEra)
forall blk. EpochNo -> CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtEpoch EpochNo
epochNo
,
triggerHardForkBabbage =
case npcTestBabbageHardForkAtEpoch of
Maybe EpochNo
Nothing -> CardanoHardForkTrigger
(ShelleyBlock (Praos StandardCrypto) BabbageEra)
forall blk. CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtDefaultVersion
Just EpochNo
epochNo -> EpochNo
-> CardanoHardForkTrigger
(ShelleyBlock (Praos StandardCrypto) BabbageEra)
forall blk. EpochNo -> CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtEpoch EpochNo
epochNo
,
triggerHardForkConway =
case npcTestConwayHardForkAtEpoch of
Maybe EpochNo
Nothing -> CardanoHardForkTrigger
(ShelleyBlock (Praos StandardCrypto) ConwayEra)
forall blk. CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtDefaultVersion
Just EpochNo
epochNo -> EpochNo
-> CardanoHardForkTrigger
(ShelleyBlock (Praos StandardCrypto) ConwayEra)
forall blk. EpochNo -> CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtEpoch EpochNo
epochNo
,
triggerHardForkDijkstra =
case npcTestDijkstraHardForkAtEpoch of
Maybe EpochNo
Nothing -> CardanoHardForkTrigger
(ShelleyBlock (Praos StandardCrypto) LatestKnownEra)
forall blk. CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtDefaultVersion
Just EpochNo
epochNo -> EpochNo
-> CardanoHardForkTrigger
(ShelleyBlock (Praos StandardCrypto) LatestKnownEra)
forall blk. EpochNo -> CardanoHardForkTrigger blk
Consensus.CardanoTriggerHardForkAtEpoch EpochNo
epochNo
}
transitionLedgerConfig
emptyCheckpointsMap
(ProtVer (L.eraProtVerHigh @L.LatestKnownEra) 0)
emptyDijkstraGenesis :: SL.DijkstraGenesis
emptyDijkstraGenesis :: DijkstraGenesis
emptyDijkstraGenesis =
let upgradePParamsDef :: UpgradeDijkstraPParams Identity era
upgradePParamsDef =
UpgradeDijkstraPParams
{ udppMaxRefScriptSizePerBlock :: HKD Identity NumSoftwareVersion
udppMaxRefScriptSizePerBlock = HKD Identity NumSoftwareVersion
1048576
, udppMaxRefScriptSizePerTx :: HKD Identity NumSoftwareVersion
udppMaxRefScriptSizePerTx = HKD Identity NumSoftwareVersion
204800
, udppRefScriptCostStride :: HKD Identity (NonZero NumSoftwareVersion)
udppRefScriptCostStride = NumSoftwareVersion -> NonZero NumSoftwareVersion
forall a. a -> NonZero a
unsafeNonZero NumSoftwareVersion
25600
, udppRefScriptCostMultiplier :: HKD Identity PositiveInterval
udppRefScriptCostMultiplier = HKD Identity PositiveInterval
-> Maybe (HKD Identity PositiveInterval)
-> HKD Identity PositiveInterval
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> HKD Identity PositiveInterval
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible") (Maybe (HKD Identity PositiveInterval)
-> HKD Identity PositiveInterval)
-> Maybe (HKD Identity PositiveInterval)
-> HKD Identity PositiveInterval
forall a b. (a -> b) -> a -> b
$ Rational -> Maybe (HKD Identity PositiveInterval)
forall r. BoundedRational r => Rational -> Maybe r
boundRational Rational
1.2
}
in SL.DijkstraGenesis{dgUpgradePParams :: UpgradeDijkstraPParams Identity LatestKnownEra
SL.dgUpgradePParams = UpgradeDijkstraPParams Identity LatestKnownEra
forall {era}. UpgradeDijkstraPParams Identity era
upgradePParamsDef}
data CardanoProtocolInstantiationError
= CardanoProtocolInstantiationErrorByron
Byron.ByronProtocolInstantiationError
| CardanoProtocolInstantiationShelleyGenesisReadError
Shelley.GenesisReadError
| CardanoProtocolInstantiationAlonzoGenesisReadError
Shelley.GenesisReadError
| CardanoProtocolInstantiationConwayGenesisReadError
Shelley.GenesisReadError
| CardanoProtocolInstantiationDijkstraGenesisReadError
Shelley.GenesisReadError
| CardanoProtocolInstantiationPraosLeaderCredentialsError
Shelley.PraosLeaderCredentialsError
| CardanoProtocolInstantiationErrorAlonzo
Alonzo.AlonzoProtocolInstantiationError
deriving Int -> CardanoProtocolInstantiationError -> ShowS
[CardanoProtocolInstantiationError] -> ShowS
CardanoProtocolInstantiationError -> [Char]
(Int -> CardanoProtocolInstantiationError -> ShowS)
-> (CardanoProtocolInstantiationError -> [Char])
-> ([CardanoProtocolInstantiationError] -> ShowS)
-> Show CardanoProtocolInstantiationError
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CardanoProtocolInstantiationError -> ShowS
showsPrec :: Int -> CardanoProtocolInstantiationError -> ShowS
$cshow :: CardanoProtocolInstantiationError -> [Char]
show :: CardanoProtocolInstantiationError -> [Char]
$cshowList :: [CardanoProtocolInstantiationError] -> ShowS
showList :: [CardanoProtocolInstantiationError] -> ShowS
Show
instance Error CardanoProtocolInstantiationError where
displayError :: CardanoProtocolInstantiationError -> [Char]
displayError (CardanoProtocolInstantiationErrorByron ByronProtocolInstantiationError
err) =
ByronProtocolInstantiationError -> [Char]
forall e. Error e => e -> [Char]
displayError ByronProtocolInstantiationError
err
displayError (CardanoProtocolInstantiationShelleyGenesisReadError GenesisReadError
err) =
[Char]
"Shelley related: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> GenesisReadError -> [Char]
forall e. Error e => e -> [Char]
displayError GenesisReadError
err
displayError (CardanoProtocolInstantiationAlonzoGenesisReadError GenesisReadError
err) =
[Char]
"Alonzo related: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> GenesisReadError -> [Char]
forall e. Error e => e -> [Char]
displayError GenesisReadError
err
displayError (CardanoProtocolInstantiationConwayGenesisReadError GenesisReadError
err) =
[Char]
"Conway related: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> GenesisReadError -> [Char]
forall e. Error e => e -> [Char]
displayError GenesisReadError
err
displayError (CardanoProtocolInstantiationDijkstraGenesisReadError GenesisReadError
err) =
[Char]
"Dijkstra related: " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> GenesisReadError -> [Char]
forall e. Error e => e -> [Char]
displayError GenesisReadError
err
displayError (CardanoProtocolInstantiationPraosLeaderCredentialsError PraosLeaderCredentialsError
err) =
PraosLeaderCredentialsError -> [Char]
forall e. Error e => e -> [Char]
displayError PraosLeaderCredentialsError
err
displayError (CardanoProtocolInstantiationErrorAlonzo AlonzoProtocolInstantiationError
err) =
AlonzoProtocolInstantiationError -> [Char]
forall e. Error e => e -> [Char]
displayError AlonzoProtocolInstantiationError
err