{-# 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 TypeOperators #-}
{-# 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 qualified Cardano.Crypto.VRF as VRF
import qualified Cardano.Ledger.Api.Era as L
import qualified Cardano.Ledger.Api.Transition as L
import qualified Cardano.Ledger.Shelley.API as SL
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.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
      , PraosCrypto c
      , c ~ EraCrypto era
      , TxLimits (ShelleyBlock (TPraos c) era)
      , IOLike m
      )
  => TPraosParams
  -> ShelleyLeaderCredentials (EraCrypto era)
  -> m (BlockForging m (ShelleyBlock (TPraos c) era))
shelleyBlockForging :: forall (m :: * -> *) era c.
(ShelleyCompatible (TPraos c) era, PraosCrypto c,
 c ~ EraCrypto era, TxLimits (ShelleyBlock (TPraos c) era),
 IOLike m) =>
TPraosParams
-> ShelleyLeaderCredentials (EraCrypto era)
-> m (BlockForging m (ShelleyBlock (TPraos c) era))
shelleyBlockForging TPraosParams
tpraosParams ShelleyLeaderCredentials (EraCrypto era)
credentials = do
    HotKey c m
hotKey <- forall (m :: * -> *) c.
(Crypto c, IOLike m) =>
SignKeyKES c -> KESPeriod -> Word64 -> m (HotKey c m)
HotKey.mkHotKey @m @c SignKeyKES c
SignKeyKES (EraCrypto era)
initSignKey KESPeriod
startPeriod Word64
tpraosMaxKESEvo
    BlockForging m (ShelleyBlock (TPraos c) era)
-> m (BlockForging m (ShelleyBlock (TPraos c) era))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlockForging m (ShelleyBlock (TPraos c) era)
 -> m (BlockForging m (ShelleyBlock (TPraos c) era)))
-> BlockForging m (ShelleyBlock (TPraos c) era)
-> m (BlockForging m (ShelleyBlock (TPraos c) era))
forall a b. (a -> b) -> a -> b
$ HotKey c m
-> (SlotNo -> KESPeriod)
-> ShelleyLeaderCredentials c
-> BlockForging m (ShelleyBlock (TPraos c) era)
forall (m :: * -> *) c era.
(PraosCrypto c, 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
ShelleyLeaderCredentials (EraCrypto era)
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 -> SignKeyKES c
shelleyLeaderCredentialsInitSignKey = SignKeyKES (EraCrypto era)
initSignKey
      , shelleyLeaderCredentialsCanBeLeader :: forall c. ShelleyLeaderCredentials c -> PraosCanBeLeader c
shelleyLeaderCredentialsCanBeLeader = PraosCanBeLeader (EraCrypto era)
canBeLeader
      } = ShelleyLeaderCredentials (EraCrypto era)
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
PraosCanBeLeader (EraCrypto era)
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.
     ( PraosCrypto c
     , 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.
(PraosCrypto c, 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 c (VerKeyVRF c)
-> SlotNo
-> IsLeader (TPraos c)
-> KESInfo
-> Either (TPraosCannotForge c) ()
forall c.
ConsensusConfig (TPraos c)
-> Hash c (VerKeyVRF 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 c (VerKeyVRF c)
forgingVRFHash
                                 SlotNo
curSlot
      , forgeBlock :: TopLevelConfig (ShelleyBlock (TPraos c) era)
-> BlockNo
-> SlotNo
-> TickedLedgerState (ShelleyBlock (TPraos c) era)
-> [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 (EraCrypto era) m
-> CanBeLeader (TPraos c)
-> TopLevelConfig (ShelleyBlock (TPraos c) era)
-> BlockNo
-> SlotNo
-> TickedLedgerState (ShelleyBlock (TPraos c) era)
-> [Validated (GenTx (ShelleyBlock (TPraos c) era))]
-> IsLeader (TPraos c)
-> m (ShelleyBlock (TPraos c) era)
forall (m :: * -> *) era proto.
(ShelleyCompatible proto era, Monad m) =>
HotKey (EraCrypto era) m
-> CanBeLeader proto
-> TopLevelConfig (ShelleyBlock proto era)
-> BlockNo
-> SlotNo
-> TickedLedgerState (ShelleyBlock proto era)
-> [Validated (GenTx (ShelleyBlock proto era))]
-> IsLeader proto
-> m (ShelleyBlock proto era)
forgeShelleyBlock
            HotKey c m
HotKey (EraCrypto era) 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 :: SL.Hash c (SL.VerKeyVRF c)
    forgingVRFHash :: Hash c (VerKeyVRF c)
forgingVRFHash =
          VerKeyVRF c -> Hash c (VerKeyVRF c)
forall h. HashAlgorithm h => VerKeyVRF c -> Hash h (VerKeyVRF c)
forall v h.
(VRFAlgorithm v, HashAlgorithm h) =>
VerKeyVRF v -> Hash h (VerKeyVRF v)
SL.hashVerKeyVRF
        (VerKeyVRF c -> Hash c (VerKeyVRF c))
-> (PraosCanBeLeader c -> VerKeyVRF c)
-> PraosCanBeLeader c
-> Hash c (VerKeyVRF c)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignKeyVRF (VRF c) -> VerKeyVRF c
forall v. VRFAlgorithm v => SignKeyVRF v -> VerKeyVRF v
VRF.deriveVerKeyVRF
        (SignKeyVRF (VRF c) -> VerKeyVRF c)
-> (PraosCanBeLeader c -> SignKeyVRF (VRF c))
-> PraosCanBeLeader c
-> VerKeyVRF c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PraosCanBeLeader c -> SignKeyVRF (VRF c)
forall c. PraosCanBeLeader c -> SignKeyVRF c
praosCanBeLeaderSignKeyVRF
        (PraosCanBeLeader c -> Hash c (VerKeyVRF c))
-> PraosCanBeLeader c -> Hash c (VerKeyVRF 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 ::
     PraosCrypto c
  => SL.ShelleyGenesis c -> Either String ()
validateGenesis :: forall c. PraosCrypto c => ShelleyGenesis c -> Either String ()
validateGenesis = ([ValidationErr] -> String)
-> Either [ValidationErr] () -> Either String ()
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first [ValidationErr] -> String
errsToString (Either [ValidationErr] () -> Either String ())
-> (ShelleyGenesis c -> Either [ValidationErr] ())
-> ShelleyGenesis c
-> Either String ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyGenesis c -> Either [ValidationErr] ()
forall c. Crypto c => ShelleyGenesis c -> 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
      , PraosCrypto c
      , ShelleyCompatible (TPraos c) (ShelleyEra c)
      , TxLimits (ShelleyBlock (TPraos c) (ShelleyEra c))
      )
  => SL.ShelleyGenesis c
  -> ProtocolParamsShelleyBased c
  -> SL.ProtVer
  -> ( ProtocolInfo (ShelleyBlock (TPraos c) (ShelleyEra c) )
     , m [BlockForging m (ShelleyBlock (TPraos c) (ShelleyEra c))]
     )
protocolInfoShelley :: forall (m :: * -> *) c.
(IOLike m, PraosCrypto c,
 ShelleyCompatible (TPraos c) (ShelleyEra c),
 TxLimits (ShelleyBlock (TPraos c) (ShelleyEra c))) =>
ShelleyGenesis c
-> ProtocolParamsShelleyBased c
-> ProtVer
-> (ProtocolInfo (ShelleyBlock (TPraos c) (ShelleyEra c)),
    m [BlockForging m (ShelleyBlock (TPraos c) (ShelleyEra c))])
protocolInfoShelley ShelleyGenesis c
shelleyGenesis
                    ProtocolParamsShelleyBased c
protocolParamsShelleyBased
                    ProtVer
protVer =
    ProtocolParamsShelleyBased c
-> TransitionConfig (ShelleyEra c)
-> ProtVer
-> (ProtocolInfo (ShelleyBlock (TPraos c) (ShelleyEra c)),
    m [BlockForging m (ShelleyBlock (TPraos c) (ShelleyEra c))])
forall (m :: * -> *) era c.
(IOLike m, PraosCrypto c, ShelleyCompatible (TPraos c) era,
 TxLimits (ShelleyBlock (TPraos c) era), c ~ EraCrypto era) =>
ProtocolParamsShelleyBased c
-> TransitionConfig era
-> ProtVer
-> (ProtocolInfo (ShelleyBlock (TPraos c) era),
    m [BlockForging m (ShelleyBlock (TPraos c) era)])
protocolInfoTPraosShelleyBased
      ProtocolParamsShelleyBased c
protocolParamsShelleyBased
      (ShelleyGenesis c -> TransitionConfig (ShelleyEra c)
forall c. ShelleyGenesis c -> TransitionConfig (ShelleyEra c)
L.mkShelleyTransitionConfig ShelleyGenesis c
shelleyGenesis)
      ProtVer
protVer

protocolInfoTPraosShelleyBased ::
     forall m era c.
      ( IOLike m
      , PraosCrypto c
      , ShelleyCompatible (TPraos c) era
      , TxLimits (ShelleyBlock (TPraos c) era)
      , c ~ EraCrypto era
      )
  => ProtocolParamsShelleyBased c
  -> L.TransitionConfig era
  -> SL.ProtVer
     -- ^ see 'shelleyProtVer', mutatis mutandi
  -> ( ProtocolInfo (ShelleyBlock (TPraos c) era)
     , m [BlockForging m (ShelleyBlock (TPraos c) era)]
     )
protocolInfoTPraosShelleyBased :: forall (m :: * -> *) era c.
(IOLike m, PraosCrypto c, ShelleyCompatible (TPraos c) era,
 TxLimits (ShelleyBlock (TPraos c) era), c ~ EraCrypto 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 c -> Either String ()
forall c. PraosCrypto c => ShelleyGenesis c -> Either String ()
validateGenesis ShelleyGenesis c
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)
pInfoInitLedger   = ExtLedgerState (ShelleyBlock (TPraos c) era)
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 (EraCrypto era)
-> m (BlockForging m (ShelleyBlock (TPraos c) era))
forall (m :: * -> *) era c.
(ShelleyCompatible (TPraos c) era, PraosCrypto c,
 c ~ EraCrypto era, TxLimits (ShelleyBlock (TPraos c) era),
 IOLike m) =>
TPraosParams
-> ShelleyLeaderCredentials (EraCrypto era)
-> m (BlockForging m (ShelleyBlock (TPraos c) era))
shelleyBlockForging TPraosParams
tpraosParams)
        [ShelleyLeaderCredentials c]
credentialss
    )
  where
    genesis :: SL.ShelleyGenesis c
    genesis :: ShelleyGenesis c
genesis = TransitionConfig era
transitionCfg TransitionConfig era
-> Getting
     (ShelleyGenesis c) (TransitionConfig era) (ShelleyGenesis c)
-> ShelleyGenesis c
forall s a. s -> Getting a s a -> a
^. Getting
  (ShelleyGenesis c) (TransitionConfig era) (ShelleyGenesis c)
(ShelleyGenesis (EraCrypto era)
 -> Const (ShelleyGenesis c) (ShelleyGenesis (EraCrypto era)))
-> TransitionConfig era
-> Const (ShelleyGenesis c) (TransitionConfig era)
forall era.
EraTransition era =>
Lens' (TransitionConfig era) (ShelleyGenesis (EraCrypto era))
Lens' (TransitionConfig era) (ShelleyGenesis (EraCrypto era))
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 (EraCrypto era)
-> TranslationContext era
-> EpochInfo (Except PastHorizonException)
-> ShelleyLedgerConfig era
forall era.
ShelleyGenesis (EraCrypto era)
-> TranslationContext era
-> EpochInfo (Except PastHorizonException)
-> ShelleyLedgerConfig era
mkShelleyLedgerConfig
         ShelleyGenesis c
ShelleyGenesis (EraCrypto era)
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 c -> EpochSize
forall c. ShelleyGenesis c -> EpochSize
SL.sgEpochLength ShelleyGenesis c
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 c -> NominalDiffTimeMicro
forall c. ShelleyGenesis c -> NominalDiffTimeMicro
SL.sgSlotLength ShelleyGenesis c
genesis)

    tpraosParams :: TPraosParams
    tpraosParams :: TPraosParams
tpraosParams = MaxMajorProtVer -> Nonce -> ShelleyGenesis c -> TPraosParams
forall era.
MaxMajorProtVer -> Nonce -> ShelleyGenesis era -> TPraosParams
mkTPraosParams MaxMajorProtVer
maxMajorProtVer Nonce
initialNonce ShelleyGenesis c
genesis

    blockConfig :: BlockConfig (ShelleyBlock (TPraos c) era)
    blockConfig :: BlockConfig (ShelleyBlock (TPraos c) era)
blockConfig =
        ProtVer
-> ShelleyGenesis (EraCrypto era)
-> [VKey 'BlockIssuer (EraCrypto era)]
-> BlockConfig (ShelleyBlock (TPraos c) era)
forall proto era.
ShelleyBasedEra era =>
ProtVer
-> ShelleyGenesis (EraCrypto era)
-> [VKey 'BlockIssuer (EraCrypto era)]
-> BlockConfig (ShelleyBlock proto era)
mkShelleyBlockConfig
          ProtVer
protVer
          ShelleyGenesis c
ShelleyGenesis (EraCrypto era)
genesis
          (ShelleyLeaderCredentials c -> VKey 'BlockIssuer c
forall c. ShelleyLeaderCredentials c -> VKey 'BlockIssuer c
shelleyBlockIssuerVKey (ShelleyLeaderCredentials c -> VKey 'BlockIssuer c)
-> [ShelleyLeaderCredentials c] -> [VKey 'BlockIssuer c]
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)
    initLedgerState :: LedgerState (ShelleyBlock (TPraos c) era)
initLedgerState = 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}
      }

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

    initExtLedgerState :: ExtLedgerState (ShelleyBlock (TPraos c) era)
    initExtLedgerState :: ExtLedgerState (ShelleyBlock (TPraos c) era)
initExtLedgerState = ExtLedgerState {
        ledgerState :: LedgerState (ShelleyBlock (TPraos c) era)
ledgerState = LedgerState (ShelleyBlock (TPraos c) era)
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 c
initChainDepState
      }