{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.Shelley.Node.TPraos
  ( MaxMajorProtVer (..)
  , ProtocolParamsShelleyBased (..)
  , SL.Nonce (..)
  , SL.ProtVer (..)
  , SL.ShelleyGenesis (..)
  , SL.ShelleyGenesisStaking (..)
  , SL.emptyGenesisStaking
  , ShelleyLeaderCredentials (..)
  , protocolInfoShelley
  , protocolInfoTPraosShelleyBased
  , shelleyBlockForging
  , shelleySharedBlockForging
  , validateGenesis
  ) where

import Cardano.Crypto.Hash (Hash)
import qualified Cardano.Crypto.VRF as VRF
import qualified Cardano.Ledger.Api.Era as L
import qualified Cardano.Ledger.Api.Transition as L
import Cardano.Ledger.Hashes (HASH)
import qualified Cardano.Ledger.Shelley.API as SL
import Cardano.Protocol.Crypto (VRF)
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 Cardano.Slotting.EpochInfo
import Cardano.Slotting.Time (mkSlotLength)
import Control.Monad.Except (Except)
import Data.Bifunctor (first)
import qualified Data.Text as T
import qualified Data.Text as Text
import Lens.Micro ((^.))
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
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.Ledger.SupportsMempool (TxLimits)
import Ouroboros.Consensus.Ledger.Tables.Utils
import Ouroboros.Consensus.Node.ProtocolInfo
import Ouroboros.Consensus.Protocol.Abstract
import Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey)
import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey
import Ouroboros.Consensus.Protocol.Praos.Common
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.Common
  ( ProtocolParamsShelleyBased (..)
  , ShelleyEraWithCrypto
  , ShelleyLeaderCredentials (..)
  , shelleyBlockIssuerVKey
  )
import Ouroboros.Consensus.Shelley.Node.Serialisation ()
import Ouroboros.Consensus.Shelley.Protocol.TPraos ()
import Ouroboros.Consensus.Util.Assert
import Ouroboros.Consensus.Util.IOLike

{-------------------------------------------------------------------------------
  BlockForging
-------------------------------------------------------------------------------}

-- | 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 c.
  ( ShelleyCompatible (TPraos c) era
  , TxLimits (ShelleyBlock (TPraos c) era)
  , IOLike m
  ) =>
  TPraosParams ->
  ShelleyLeaderCredentials c ->
  m (BlockForging m (ShelleyBlock (TPraos c) era))
shelleyBlockForging :: forall (m :: * -> *) era c.
(ShelleyCompatible (TPraos c) era,
 TxLimits (ShelleyBlock (TPraos c) era), IOLike m) =>
TPraosParams
-> ShelleyLeaderCredentials c
-> m (BlockForging m (ShelleyBlock (TPraos c) era))
shelleyBlockForging TPraosParams
tpraosParams ShelleyLeaderCredentials c
credentials = do
  hotKey <- forall (m :: * -> *) c.
(Crypto c, IOLike m) =>
UnsoundPureSignKeyKES (KES c)
-> KESPeriod -> Word64 -> m (HotKey c m)
HotKey.mkHotKey @m @c UnsoundPureSignKeyKES (KES c)
initSignKey KESPeriod
startPeriod Word64
tpraosMaxKESEvo
  pure $ shelleySharedBlockForging hotKey slotToPeriod credentials
 where
  TPraosParams{Word64
tpraosMaxKESEvo :: Word64
tpraosMaxKESEvo :: TPraosParams -> Word64
tpraosMaxKESEvo, Word64
tpraosSlotsPerKESPeriod :: Word64
tpraosSlotsPerKESPeriod :: TPraosParams -> Word64
tpraosSlotsPerKESPeriod} = TPraosParams
tpraosParams

  ShelleyLeaderCredentials
    { shelleyLeaderCredentialsInitSignKey :: forall c.
ShelleyLeaderCredentials c -> UnsoundPureSignKeyKES (KES c)
shelleyLeaderCredentialsInitSignKey = UnsoundPureSignKeyKES (KES c)
initSignKey
    , shelleyLeaderCredentialsCanBeLeader :: forall c. ShelleyLeaderCredentials c -> PraosCanBeLeader c
shelleyLeaderCredentialsCanBeLeader = PraosCanBeLeader c
canBeLeader
    } = ShelleyLeaderCredentials c
credentials

  startPeriod :: Absolute.KESPeriod
  startPeriod :: KESPeriod
startPeriod = OCert c -> KESPeriod
forall c. OCert c -> KESPeriod
SL.ocertKESPeriod (OCert c -> KESPeriod) -> OCert c -> KESPeriod
forall a b. (a -> b) -> a -> b
$ PraosCanBeLeader c -> OCert c
forall c. PraosCanBeLeader c -> OCert c
praosCanBeLeaderOpCert PraosCanBeLeader c
canBeLeader

  slotToPeriod :: SlotNo -> Absolute.KESPeriod
  slotToPeriod :: SlotNo -> KESPeriod
slotToPeriod (SlotNo Word64
slot) =
    Word -> KESPeriod
SL.KESPeriod (Word -> KESPeriod) -> Word -> KESPeriod
forall a b. (a -> b) -> a -> b
$ Word64 -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word) -> Word64 -> Word
forall a b. (a -> b) -> a -> b
$ Word64
slot Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
tpraosSlotsPerKESPeriod

-- | Create a 'BlockForging' record safely using a given 'Hotkey'.
--
-- The name of the era (separated by a @_@) will be appended to each
-- 'forgeLabel'.
shelleySharedBlockForging ::
  forall m c era.
  ( ShelleyEraWithCrypto c (TPraos c) era
  , IOLike m
  ) =>
  HotKey c m ->
  (SlotNo -> Absolute.KESPeriod) ->
  ShelleyLeaderCredentials c ->
  BlockForging m (ShelleyBlock (TPraos c) era)
shelleySharedBlockForging :: forall (m :: * -> *) c era.
(ShelleyEraWithCrypto c (TPraos c) era, IOLike m) =>
HotKey c m
-> (SlotNo -> KESPeriod)
-> ShelleyLeaderCredentials c
-> BlockForging m (ShelleyBlock (TPraos c) era)
shelleySharedBlockForging HotKey c m
hotKey SlotNo -> KESPeriod
slotToPeriod ShelleyLeaderCredentials c
credentials =
  BlockForging
    { forgeLabel :: Text
forgeLabel = Text
label Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall era. Era era => String
L.eraName @era)
    , canBeLeader :: CanBeLeader (BlockProtocol (ShelleyBlock (TPraos c) era))
canBeLeader = CanBeLeader (BlockProtocol (ShelleyBlock (TPraos c) era))
PraosCanBeLeader c
canBeLeader
    , updateForgeState :: TopLevelConfig (ShelleyBlock (TPraos c) era)
-> SlotNo
-> Ticked
     (ChainDepState (BlockProtocol (ShelleyBlock (TPraos c) era)))
-> m (ForgeStateUpdateInfo (ShelleyBlock (TPraos c) era))
updateForgeState = \TopLevelConfig (ShelleyBlock (TPraos c) era)
_ SlotNo
curSlot Ticked
  (ChainDepState (BlockProtocol (ShelleyBlock (TPraos c) era)))
_ ->
        UpdateInfo
  (ForgeStateInfo (ShelleyBlock (TPraos c) era))
  (ForgeStateUpdateError (ShelleyBlock (TPraos c) era))
-> ForgeStateUpdateInfo (ShelleyBlock (TPraos c) era)
UpdateInfo KESInfo KESEvolutionError
-> ForgeStateUpdateInfo (ShelleyBlock (TPraos c) era)
forall blk.
UpdateInfo (ForgeStateInfo blk) (ForgeStateUpdateError blk)
-> ForgeStateUpdateInfo blk
forgeStateUpdateInfoFromUpdateInfo
          (UpdateInfo KESInfo KESEvolutionError
 -> ForgeStateUpdateInfo (ShelleyBlock (TPraos c) era))
-> m (UpdateInfo KESInfo KESEvolutionError)
-> m (ForgeStateUpdateInfo (ShelleyBlock (TPraos c) era))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HotKey c m -> KESPeriod -> m (UpdateInfo KESInfo KESEvolutionError)
forall c (m :: * -> *).
HotKey c m -> KESPeriod -> m (UpdateInfo KESInfo KESEvolutionError)
HotKey.evolve HotKey c m
hotKey (SlotNo -> KESPeriod
slotToPeriod SlotNo
curSlot)
    , checkCanForge :: TopLevelConfig (ShelleyBlock (TPraos c) era)
-> SlotNo
-> Ticked
     (ChainDepState (BlockProtocol (ShelleyBlock (TPraos c) era)))
-> IsLeader (BlockProtocol (ShelleyBlock (TPraos c) era))
-> ForgeStateInfo (ShelleyBlock (TPraos c) era)
-> Either (CannotForge (ShelleyBlock (TPraos c) era)) ()
checkCanForge = \TopLevelConfig (ShelleyBlock (TPraos c) era)
cfg SlotNo
curSlot Ticked
  (ChainDepState (BlockProtocol (ShelleyBlock (TPraos c) era)))
_tickedChainDepState ->
        ConsensusConfig (TPraos c)
-> Hash HASH (VerKeyVRF (VRF c))
-> SlotNo
-> IsLeader (TPraos c)
-> KESInfo
-> Either (TPraosCannotForge c) ()
forall c.
ConsensusConfig (TPraos c)
-> Hash HASH (VerKeyVRF (VRF c))
-> SlotNo
-> IsLeader (TPraos c)
-> KESInfo
-> Either (TPraosCannotForge c) ()
tpraosCheckCanForge
          (TopLevelConfig (ShelleyBlock (TPraos c) era)
-> ConsensusConfig (BlockProtocol (ShelleyBlock (TPraos c) era))
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
configConsensus TopLevelConfig (ShelleyBlock (TPraos c) era)
cfg)
          Hash HASH (VerKeyVRF (VRF c))
forgingVRFHash
          SlotNo
curSlot
    , forgeBlock :: TopLevelConfig (ShelleyBlock (TPraos c) era)
-> BlockNo
-> SlotNo
-> TickedLedgerState (ShelleyBlock (TPraos c) era) EmptyMK
-> [Validated (GenTx (ShelleyBlock (TPraos c) era))]
-> IsLeader (BlockProtocol (ShelleyBlock (TPraos c) era))
-> m (ShelleyBlock (TPraos c) era)
forgeBlock = \TopLevelConfig (ShelleyBlock (TPraos c) era)
cfg ->
        HotKey (ProtoCrypto (TPraos c)) m
-> CanBeLeader (TPraos c)
-> TopLevelConfig (ShelleyBlock (TPraos c) era)
-> BlockNo
-> SlotNo
-> TickedLedgerState (ShelleyBlock (TPraos c) era) EmptyMK
-> [Validated (GenTx (ShelleyBlock (TPraos c) era))]
-> IsLeader (TPraos c)
-> m (ShelleyBlock (TPraos c) era)
forall (m :: * -> *) era proto (mk :: MapKind).
(ShelleyCompatible proto era, Monad m) =>
HotKey (ProtoCrypto proto) m
-> CanBeLeader proto
-> TopLevelConfig (ShelleyBlock proto era)
-> BlockNo
-> SlotNo
-> TickedLedgerState (ShelleyBlock proto era) mk
-> [Validated (GenTx (ShelleyBlock proto era))]
-> IsLeader proto
-> m (ShelleyBlock proto era)
forgeShelleyBlock
          HotKey c m
HotKey (ProtoCrypto (TPraos c)) m
hotKey
          CanBeLeader (TPraos c)
PraosCanBeLeader c
canBeLeader
          TopLevelConfig (ShelleyBlock (TPraos c) era)
cfg
    }
 where
  ShelleyLeaderCredentials
    { shelleyLeaderCredentialsCanBeLeader :: forall c. ShelleyLeaderCredentials c -> PraosCanBeLeader c
shelleyLeaderCredentialsCanBeLeader = PraosCanBeLeader c
canBeLeader
    , shelleyLeaderCredentialsLabel :: forall c. ShelleyLeaderCredentials c -> Text
shelleyLeaderCredentialsLabel = Text
label
    } = ShelleyLeaderCredentials c
credentials

  forgingVRFHash :: Hash HASH (VRF.VerKeyVRF (VRF c))
  forgingVRFHash :: Hash HASH (VerKeyVRF (VRF c))
forgingVRFHash =
    VerKeyVRF (VRF c) -> Hash HASH (VerKeyVRF (VRF c))
forall h.
HashAlgorithm h =>
VerKeyVRF (VRF c) -> Hash h (VerKeyVRF (VRF c))
forall v h.
(VRFAlgorithm v, HashAlgorithm h) =>
VerKeyVRF v -> Hash h (VerKeyVRF v)
VRF.hashVerKeyVRF
      (VerKeyVRF (VRF c) -> Hash HASH (VerKeyVRF (VRF c)))
-> (PraosCanBeLeader c -> VerKeyVRF (VRF c))
-> PraosCanBeLeader c
-> Hash HASH (VerKeyVRF (VRF c))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignKeyVRF (VRF c) -> VerKeyVRF (VRF c)
forall v. VRFAlgorithm v => SignKeyVRF v -> VerKeyVRF v
VRF.deriveVerKeyVRF
      (SignKeyVRF (VRF c) -> VerKeyVRF (VRF c))
-> (PraosCanBeLeader c -> SignKeyVRF (VRF c))
-> PraosCanBeLeader c
-> VerKeyVRF (VRF c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PraosCanBeLeader c -> SignKeyVRF (VRF c)
forall c. PraosCanBeLeader c -> SignKeyVRF (VRF c)
praosCanBeLeaderSignKeyVRF
      (PraosCanBeLeader c -> Hash HASH (VerKeyVRF (VRF c)))
-> PraosCanBeLeader c -> Hash HASH (VerKeyVRF (VRF c))
forall a b. (a -> b) -> a -> b
$ PraosCanBeLeader c
canBeLeader

{-------------------------------------------------------------------------------
  ProtocolInfo
-------------------------------------------------------------------------------}

-- | Check the validity of the genesis config. To be used in conjunction with
-- 'assertWithMsg'.
validateGenesis :: SL.ShelleyGenesis -> Either String ()
validateGenesis :: ShelleyGenesis -> Either String ()
validateGenesis = ([ValidationErr] -> String)
-> Either [ValidationErr] () -> Either String ()
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: MapKind) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [ValidationErr] -> String
errsToString (Either [ValidationErr] () -> Either String ())
-> (ShelleyGenesis -> Either [ValidationErr] ())
-> ShelleyGenesis
-> Either String ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyGenesis -> Either [ValidationErr] ()
SL.validateGenesis
 where
  errsToString :: [SL.ValidationErr] -> String
  errsToString :: [ValidationErr] -> String
errsToString [ValidationErr]
errs =
    Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$
      [Text] -> Text
Text.unlines
        (Text
"Invalid genesis config:" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (ValidationErr -> Text) -> [ValidationErr] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ValidationErr -> Text
SL.describeValidationErr [ValidationErr]
errs)

protocolInfoShelley ::
  forall m c.
  ( IOLike m
  , ShelleyCompatible (TPraos c) ShelleyEra
  , TxLimits (ShelleyBlock (TPraos c) ShelleyEra)
  ) =>
  SL.ShelleyGenesis ->
  ProtocolParamsShelleyBased c ->
  SL.ProtVer ->
  ( ProtocolInfo (ShelleyBlock (TPraos c) ShelleyEra)
  , m [BlockForging m (ShelleyBlock (TPraos c) ShelleyEra)]
  )
protocolInfoShelley :: forall (m :: * -> *) c.
(IOLike m, ShelleyCompatible (TPraos c) ShelleyEra,
 TxLimits (ShelleyBlock (TPraos c) ShelleyEra)) =>
ShelleyGenesis
-> ProtocolParamsShelleyBased c
-> ProtVer
-> (ProtocolInfo (ShelleyBlock (TPraos c) ShelleyEra),
    m [BlockForging m (ShelleyBlock (TPraos c) ShelleyEra)])
protocolInfoShelley
  ShelleyGenesis
shelleyGenesis
  ProtocolParamsShelleyBased c
protocolParamsShelleyBased
  ProtVer
protVer =
    ProtocolParamsShelleyBased c
-> TransitionConfig ShelleyEra
-> ProtVer
-> (ProtocolInfo (ShelleyBlock (TPraos c) ShelleyEra),
    m [BlockForging m (ShelleyBlock (TPraos c) ShelleyEra)])
forall (m :: * -> *) era c.
(IOLike m, ShelleyCompatible (TPraos c) era,
 TxLimits (ShelleyBlock (TPraos c) era)) =>
ProtocolParamsShelleyBased c
-> TransitionConfig era
-> ProtVer
-> (ProtocolInfo (ShelleyBlock (TPraos c) era),
    m [BlockForging m (ShelleyBlock (TPraos c) era)])
protocolInfoTPraosShelleyBased
      ProtocolParamsShelleyBased c
protocolParamsShelleyBased
      (ShelleyGenesis -> TransitionConfig ShelleyEra
L.mkShelleyTransitionConfig ShelleyGenesis
shelleyGenesis)
      ProtVer
protVer

protocolInfoTPraosShelleyBased ::
  forall m era c.
  ( IOLike m
  , ShelleyCompatible (TPraos c) era
  , TxLimits (ShelleyBlock (TPraos c) era)
  ) =>
  ProtocolParamsShelleyBased c ->
  L.TransitionConfig era ->
  -- | see 'shelleyProtVer', mutatis mutandi
  SL.ProtVer ->
  ( ProtocolInfo (ShelleyBlock (TPraos c) era)
  , m [BlockForging m (ShelleyBlock (TPraos c) era)]
  )
protocolInfoTPraosShelleyBased :: forall (m :: * -> *) era c.
(IOLike m, ShelleyCompatible (TPraos c) era,
 TxLimits (ShelleyBlock (TPraos c) era)) =>
ProtocolParamsShelleyBased c
-> TransitionConfig era
-> ProtVer
-> (ProtocolInfo (ShelleyBlock (TPraos c) era),
    m [BlockForging m (ShelleyBlock (TPraos c) era)])
protocolInfoTPraosShelleyBased
  ProtocolParamsShelleyBased
    { shelleyBasedInitialNonce :: forall c. ProtocolParamsShelleyBased c -> Nonce
shelleyBasedInitialNonce = Nonce
initialNonce
    , shelleyBasedLeaderCredentials :: forall c.
ProtocolParamsShelleyBased c -> [ShelleyLeaderCredentials c]
shelleyBasedLeaderCredentials = [ShelleyLeaderCredentials c]
credentialss
    }
  TransitionConfig era
transitionCfg
  ProtVer
protVer =
    Either String ()
-> (ProtocolInfo (ShelleyBlock (TPraos c) era),
    m [BlockForging m (ShelleyBlock (TPraos c) era)])
-> (ProtocolInfo (ShelleyBlock (TPraos c) era),
    m [BlockForging m (ShelleyBlock (TPraos c) era)])
forall a. HasCallStack => Either String () -> a -> a
assertWithMsg (ShelleyGenesis -> Either String ()
validateGenesis ShelleyGenesis
genesis) ((ProtocolInfo (ShelleyBlock (TPraos c) era),
  m [BlockForging m (ShelleyBlock (TPraos c) era)])
 -> (ProtocolInfo (ShelleyBlock (TPraos c) era),
     m [BlockForging m (ShelleyBlock (TPraos c) era)]))
-> (ProtocolInfo (ShelleyBlock (TPraos c) era),
    m [BlockForging m (ShelleyBlock (TPraos c) era)])
-> (ProtocolInfo (ShelleyBlock (TPraos c) era),
    m [BlockForging m (ShelleyBlock (TPraos c) era)])
forall a b. (a -> b) -> a -> b
$
      ( ProtocolInfo
          { pInfoConfig :: TopLevelConfig (ShelleyBlock (TPraos c) era)
pInfoConfig = TopLevelConfig (ShelleyBlock (TPraos c) era)
topLevelConfig
          , pInfoInitLedger :: ExtLedgerState (ShelleyBlock (TPraos c) era) ValuesMK
pInfoInitLedger = ExtLedgerState (ShelleyBlock (TPraos c) era) ValuesMK
initExtLedgerState
          }
      , (ShelleyLeaderCredentials c
 -> m (BlockForging m (ShelleyBlock (TPraos c) era)))
-> [ShelleyLeaderCredentials c]
-> m [BlockForging m (ShelleyBlock (TPraos c) era)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
          (TPraosParams
-> ShelleyLeaderCredentials c
-> m (BlockForging m (ShelleyBlock (TPraos c) era))
forall (m :: * -> *) era c.
(ShelleyCompatible (TPraos c) era,
 TxLimits (ShelleyBlock (TPraos c) era), IOLike m) =>
TPraosParams
-> ShelleyLeaderCredentials c
-> m (BlockForging m (ShelleyBlock (TPraos c) era))
shelleyBlockForging TPraosParams
tpraosParams)
          [ShelleyLeaderCredentials c]
credentialss
      )
   where
    genesis :: SL.ShelleyGenesis
    genesis :: ShelleyGenesis
genesis = TransitionConfig era
transitionCfg TransitionConfig era
-> Getting ShelleyGenesis (TransitionConfig era) ShelleyGenesis
-> ShelleyGenesis
forall s a. s -> Getting a s a -> a
^. Getting ShelleyGenesis (TransitionConfig era) ShelleyGenesis
forall era.
EraTransition era =>
Lens' (TransitionConfig era) ShelleyGenesis
Lens' (TransitionConfig era) ShelleyGenesis
L.tcShelleyGenesisL

    maxMajorProtVer :: MaxMajorProtVer
    maxMajorProtVer :: MaxMajorProtVer
maxMajorProtVer = Version -> MaxMajorProtVer
MaxMajorProtVer (Version -> MaxMajorProtVer) -> Version -> MaxMajorProtVer
forall a b. (a -> b) -> a -> b
$ ProtVer -> Version
SL.pvMajor ProtVer
protVer

    topLevelConfig :: TopLevelConfig (ShelleyBlock (TPraos c) era)
    topLevelConfig :: TopLevelConfig (ShelleyBlock (TPraos c) era)
topLevelConfig =
      TopLevelConfig
        { topLevelConfigProtocol :: ConsensusConfig (BlockProtocol (ShelleyBlock (TPraos c) era))
topLevelConfigProtocol = ConsensusConfig (BlockProtocol (ShelleyBlock (TPraos c) era))
consensusConfig
        , topLevelConfigLedger :: LedgerConfig (ShelleyBlock (TPraos c) era)
topLevelConfigLedger = LedgerConfig (ShelleyBlock (TPraos c) era)
ledgerConfig
        , topLevelConfigBlock :: BlockConfig (ShelleyBlock (TPraos c) era)
topLevelConfigBlock = BlockConfig (ShelleyBlock (TPraos c) era)
blockConfig
        , topLevelConfigCodec :: CodecConfig (ShelleyBlock (TPraos c) era)
topLevelConfigCodec = CodecConfig (ShelleyBlock (TPraos c) era)
forall proto era. CodecConfig (ShelleyBlock proto era)
ShelleyCodecConfig
        , topLevelConfigStorage :: StorageConfig (ShelleyBlock (TPraos c) era)
topLevelConfigStorage = StorageConfig (ShelleyBlock (TPraos c) era)
storageConfig
        , topLevelConfigCheckpoints :: CheckpointsMap (ShelleyBlock (TPraos c) era)
topLevelConfigCheckpoints = CheckpointsMap (ShelleyBlock (TPraos c) era)
forall blk. CheckpointsMap blk
emptyCheckpointsMap
        }

    consensusConfig :: ConsensusConfig (BlockProtocol (ShelleyBlock (TPraos c) era))
    consensusConfig :: ConsensusConfig (BlockProtocol (ShelleyBlock (TPraos c) era))
consensusConfig =
      TPraosConfig
        { TPraosParams
tpraosParams :: TPraosParams
tpraosParams :: TPraosParams
tpraosParams
        , tpraosEpochInfo :: EpochInfo (Except PastHorizonException)
tpraosEpochInfo = EpochInfo (Except PastHorizonException)
epochInfo
        }

    ledgerConfig :: LedgerConfig (ShelleyBlock (TPraos c) era)
    ledgerConfig :: LedgerConfig (ShelleyBlock (TPraos c) era)
ledgerConfig =
      ShelleyGenesis
-> TranslationContext era
-> EpochInfo (Except PastHorizonException)
-> ShelleyLedgerConfig era
forall era.
ShelleyGenesis
-> TranslationContext era
-> EpochInfo (Except PastHorizonException)
-> ShelleyLedgerConfig era
mkShelleyLedgerConfig
        ShelleyGenesis
genesis
        (TransitionConfig era
transitionCfg TransitionConfig era
-> Getting
     (TranslationContext era)
     (TransitionConfig era)
     (TranslationContext era)
-> TranslationContext era
forall s a. s -> Getting a s a -> a
^. Getting
  (TranslationContext era)
  (TransitionConfig era)
  (TranslationContext era)
forall era.
EraTransition era =>
Lens' (TransitionConfig era) (TranslationContext era)
Lens' (TransitionConfig era) (TranslationContext era)
L.tcTranslationContextL)
        EpochInfo (Except PastHorizonException)
epochInfo

    epochInfo :: EpochInfo (Except History.PastHorizonException)
    epochInfo :: EpochInfo (Except PastHorizonException)
epochInfo =
      EpochSize -> SlotLength -> EpochInfo (Except PastHorizonException)
forall (m :: * -> *).
Monad m =>
EpochSize -> SlotLength -> EpochInfo m
fixedEpochInfo
        (ShelleyGenesis -> EpochSize
SL.sgEpochLength ShelleyGenesis
genesis)
        (NominalDiffTime -> SlotLength
mkSlotLength (NominalDiffTime -> SlotLength) -> NominalDiffTime -> SlotLength
forall a b. (a -> b) -> a -> b
$ NominalDiffTimeMicro -> NominalDiffTime
SL.fromNominalDiffTimeMicro (NominalDiffTimeMicro -> NominalDiffTime)
-> NominalDiffTimeMicro -> NominalDiffTime
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis -> NominalDiffTimeMicro
SL.sgSlotLength ShelleyGenesis
genesis)

    tpraosParams :: TPraosParams
    tpraosParams :: TPraosParams
tpraosParams = MaxMajorProtVer -> Nonce -> ShelleyGenesis -> TPraosParams
mkTPraosParams MaxMajorProtVer
maxMajorProtVer Nonce
initialNonce ShelleyGenesis
genesis

    blockConfig :: BlockConfig (ShelleyBlock (TPraos c) era)
    blockConfig :: BlockConfig (ShelleyBlock (TPraos c) era)
blockConfig =
      ProtVer
-> ShelleyGenesis
-> [VKey 'BlockIssuer]
-> BlockConfig (ShelleyBlock (TPraos c) era)
forall proto era.
ShelleyBasedEra era =>
ProtVer
-> ShelleyGenesis
-> [VKey 'BlockIssuer]
-> BlockConfig (ShelleyBlock proto era)
mkShelleyBlockConfig
        ProtVer
protVer
        ShelleyGenesis
genesis
        (ShelleyLeaderCredentials c -> VKey 'BlockIssuer
forall c. ShelleyLeaderCredentials c -> VKey 'BlockIssuer
shelleyBlockIssuerVKey (ShelleyLeaderCredentials c -> VKey 'BlockIssuer)
-> [ShelleyLeaderCredentials c] -> [VKey 'BlockIssuer]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ShelleyLeaderCredentials c]
credentialss)

    storageConfig :: StorageConfig (ShelleyBlock (TPraos c) era)
    storageConfig :: StorageConfig (ShelleyBlock (TPraos c) era)
storageConfig =
      ShelleyStorageConfig
        { shelleyStorageConfigSlotsPerKESPeriod :: Word64
shelleyStorageConfigSlotsPerKESPeriod = TPraosParams -> Word64
tpraosSlotsPerKESPeriod TPraosParams
tpraosParams
        , shelleyStorageConfigSecurityParam :: SecurityParam
shelleyStorageConfigSecurityParam = TPraosParams -> SecurityParam
tpraosSecurityParam TPraosParams
tpraosParams
        }

    initLedgerState :: LedgerState (ShelleyBlock (TPraos c) era) ValuesMK
    initLedgerState :: LedgerState (ShelleyBlock (TPraos c) era) ValuesMK
initLedgerState =
      LedgerState (ShelleyBlock (TPraos c) era) EmptyMK
-> LedgerState (ShelleyBlock (TPraos c) era) ValuesMK
forall (l :: LedgerStateKind).
CanStowLedgerTables l =>
l EmptyMK -> l ValuesMK
unstowLedgerTables
        ShelleyLedgerState
          { shelleyLedgerTip :: WithOrigin (ShelleyTip (TPraos c) era)
shelleyLedgerTip = WithOrigin (ShelleyTip (TPraos c) era)
forall t. WithOrigin t
Origin
          , shelleyLedgerState :: NewEpochState era
shelleyLedgerState =
              TransitionConfig era -> NewEpochState era -> NewEpochState era
forall era.
EraTransition era =>
TransitionConfig era -> NewEpochState era -> NewEpochState era
L.injectIntoTestState TransitionConfig era
transitionCfg (NewEpochState era -> NewEpochState era)
-> NewEpochState era -> NewEpochState era
forall a b. (a -> b) -> a -> b
$
                TransitionConfig era -> NewEpochState era
forall era.
(EraTransition era, HasCallStack) =>
TransitionConfig era -> NewEpochState era
L.createInitialState TransitionConfig era
transitionCfg
          , shelleyLedgerTransition :: ShelleyTransition
shelleyLedgerTransition = ShelleyTransitionInfo{shelleyAfterVoting :: Word32
shelleyAfterVoting = Word32
0}
          , shelleyLedgerTables :: LedgerTables (LedgerState (ShelleyBlock (TPraos c) era)) EmptyMK
shelleyLedgerTables = LedgerTables (LedgerState (ShelleyBlock (TPraos c) era)) EmptyMK
forall (mk :: MapKind) (l :: LedgerStateKind).
(ZeroableMK mk, LedgerTableConstraints l) =>
LedgerTables l mk
emptyLedgerTables
          }

    initChainDepState :: TPraosState
    initChainDepState :: TPraosState
initChainDepState =
      WithOrigin SlotNo -> ChainDepState -> TPraosState
TPraosState WithOrigin SlotNo
forall t. WithOrigin t
Origin (ChainDepState -> TPraosState) -> ChainDepState -> TPraosState
forall a b. (a -> b) -> a -> b
$
        Nonce -> Map (KeyHash 'Genesis) GenDelegPair -> ChainDepState
SL.initialChainDepState Nonce
initialNonce (ShelleyGenesis -> Map (KeyHash 'Genesis) GenDelegPair
SL.sgGenDelegs ShelleyGenesis
genesis)

    initExtLedgerState :: ExtLedgerState (ShelleyBlock (TPraos c) era) ValuesMK
    initExtLedgerState :: ExtLedgerState (ShelleyBlock (TPraos c) era) ValuesMK
initExtLedgerState =
      ExtLedgerState
        { ledgerState :: LedgerState (ShelleyBlock (TPraos c) era) ValuesMK
ledgerState = LedgerState (ShelleyBlock (TPraos c) era) ValuesMK
initLedgerState
        , headerState :: HeaderState (ShelleyBlock (TPraos c) era)
headerState = ChainDepState (BlockProtocol (ShelleyBlock (TPraos c) era))
-> HeaderState (ShelleyBlock (TPraos c) era)
forall blk. ChainDepState (BlockProtocol blk) -> HeaderState blk
genesisHeaderState ChainDepState (BlockProtocol (ShelleyBlock (TPraos c) era))
TPraosState
initChainDepState
        }