{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# 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 qualified Control.Tracer as Tracer
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.Peras (initPerasState)
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.AgentClient
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 (..)
  , ShelleyLeaderCredentials (..)
  , shelleyBlockIssuerVKey
  )
import Ouroboros.Consensus.Shelley.Node.Serialisation ()
import Ouroboros.Consensus.Shelley.Protocol.TPraos ()
import Ouroboros.Consensus.Util.Assert
import Ouroboros.Consensus.Util.IOLike
import System.FS.API (SomeHasFS (..))

{-------------------------------------------------------------------------------
  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
  , IOLike m
  ) =>
  TPraosParams ->
  HotKey c m ->
  ShelleyLeaderCredentials c ->
  BlockForging m (ShelleyBlock (TPraos c) era)
shelleyBlockForging :: forall (m :: * -> *) era c.
(ShelleyCompatible (TPraos c) era, IOLike m) =>
TPraosParams
-> HotKey c m
-> ShelleyLeaderCredentials c
-> BlockForging m (ShelleyBlock (TPraos c) era)
shelleyBlockForging TPraosParams
tpraosParams HotKey c m
hotKey ShelleyLeaderCredentials c
credentials = do
  HotKey c m
-> (SlotNo -> KESPeriod)
-> ShelleyLeaderCredentials c
-> BlockForging m (ShelleyBlock (TPraos c) era)
forall (m :: * -> *) c era.
(ShelleyCompatible (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
 where
  TPraosParams{Word64
tpraosSlotsPerKESPeriod :: Word64
tpraosSlotsPerKESPeriod :: TPraosParams -> Word64
tpraosSlotsPerKESPeriod} = TPraosParams
tpraosParams

  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.
  ( ShelleyCompatible (TPraos c) era
  , IOLike m
  ) =>
  HotKey c m ->
  (SlotNo -> Absolute.KESPeriod) ->
  ShelleyLeaderCredentials c ->
  BlockForging m (ShelleyBlock (TPraos c) era)
shelleySharedBlockForging :: forall (m :: * -> *) c era.
(ShelleyCompatible (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 :: ForgeBlockArgs (ShelleyBlock (TPraos c) era)
-> m (ShelleyBlock (TPraos c) era)
forgeBlock = HotKey (ProtoCrypto (TPraos c)) m
-> CanBeLeader (TPraos c)
-> ForgeBlockArgs (ShelleyBlock (TPraos c) era)
-> m (ShelleyBlock (TPraos c) era)
forall (m :: * -> *) era proto.
(ShelleyCompatible proto era, Monad m) =>
HotKey (ProtoCrypto proto) m
-> CanBeLeader proto
-> ForgeBlockArgs (ShelleyBlock proto era)
-> m (ShelleyBlock proto era)
forgeShelleyBlock HotKey c m
HotKey (ProtoCrypto (TPraos c)) m
hotKey CanBeLeader (TPraos c)
PraosCanBeLeader c
canBeLeader
    , finalize :: m ()
finalize = HotKey c m -> m ()
forall c (m :: * -> *). HotKey c m -> m ()
HotKey.finalize HotKey c m
hotKey
    }
 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 :: * -> * -> *) 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
  , AgentCrypto c
  , ShelleyCompatible (TPraos c) ShelleyEra
  , MonadKESAgent m
  ) =>
  SomeHasFS m ->
  SL.ShelleyGenesis ->
  ProtocolParamsShelleyBased c ->
  SL.ProtVer ->
  m
    ( ProtocolInfo (ShelleyBlock (TPraos c) ShelleyEra)
    , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (ShelleyBlock (TPraos c) ShelleyEra)]
    )
protocolInfoShelley :: forall (m :: * -> *) c.
(IOLike m, AgentCrypto c, ShelleyCompatible (TPraos c) ShelleyEra,
 MonadKESAgent m) =>
SomeHasFS m
-> ShelleyGenesis
-> ProtocolParamsShelleyBased c
-> ProtVer
-> m (ProtocolInfo (ShelleyBlock (TPraos c) ShelleyEra),
      Tracer m KESAgentClientTrace
      -> m [MkBlockForging m (ShelleyBlock (TPraos c) ShelleyEra)])
protocolInfoShelley
  SomeHasFS m
fs
  ShelleyGenesis
shelleyGenesis
  ProtocolParamsShelleyBased c
protocolParamsShelleyBased
  ProtVer
protVer =
    SomeHasFS m
-> ProtocolParamsShelleyBased c
-> TransitionConfig ShelleyEra
-> ProtVer
-> m (ProtocolInfo (ShelleyBlock (TPraos c) ShelleyEra),
      Tracer m KESAgentClientTrace
      -> m [MkBlockForging m (ShelleyBlock (TPraos c) ShelleyEra)])
forall (m :: * -> *) era c.
(ShelleyCompatible (TPraos c) era, KESAgentContext c m) =>
SomeHasFS m
-> ProtocolParamsShelleyBased c
-> TransitionConfig era
-> ProtVer
-> m (ProtocolInfo (ShelleyBlock (TPraos c) era),
      Tracer m KESAgentClientTrace
      -> m [MkBlockForging m (ShelleyBlock (TPraos c) era)])
protocolInfoTPraosShelleyBased
      SomeHasFS m
fs
      ProtocolParamsShelleyBased c
protocolParamsShelleyBased
      (ShelleyGenesis -> TransitionConfig ShelleyEra
L.mkShelleyTransitionConfig ShelleyGenesis
shelleyGenesis)
      ProtVer
protVer

protocolInfoTPraosShelleyBased ::
  forall m era c.
  ( ShelleyCompatible (TPraos c) era
  , KESAgentContext c m
  ) =>
  SomeHasFS m ->
  ProtocolParamsShelleyBased c ->
  L.TransitionConfig era ->
  -- | see 'shelleyProtVer', mutatis mutandi
  SL.ProtVer ->
  m
    ( ProtocolInfo (ShelleyBlock (TPraos c) era)
    , Tracer.Tracer m KESAgentClientTrace -> m [MkBlockForging m (ShelleyBlock (TPraos c) era)]
    )
protocolInfoTPraosShelleyBased :: forall (m :: * -> *) era c.
(ShelleyCompatible (TPraos c) era, KESAgentContext c m) =>
SomeHasFS m
-> ProtocolParamsShelleyBased c
-> TransitionConfig era
-> ProtVer
-> m (ProtocolInfo (ShelleyBlock (TPraos c) era),
      Tracer m KESAgentClientTrace
      -> m [MkBlockForging m (ShelleyBlock (TPraos c) era)])
protocolInfoTPraosShelleyBased
  (SomeHasFS HasFS m h
hasFS)
  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 ()
-> m (ProtocolInfo (ShelleyBlock (TPraos c) era),
      Tracer m KESAgentClientTrace
      -> m [MkBlockForging m (ShelleyBlock (TPraos c) era)])
-> m (ProtocolInfo (ShelleyBlock (TPraos c) era),
      Tracer m KESAgentClientTrace
      -> m [MkBlockForging m (ShelleyBlock (TPraos c) era)])
forall a. HasCallStack => Either String () -> a -> a
assertWithMsg (ShelleyGenesis -> Either String ()
validateGenesis ShelleyGenesis
genesis) (m (ProtocolInfo (ShelleyBlock (TPraos c) era),
    Tracer m KESAgentClientTrace
    -> m [MkBlockForging m (ShelleyBlock (TPraos c) era)])
 -> m (ProtocolInfo (ShelleyBlock (TPraos c) era),
       Tracer m KESAgentClientTrace
       -> m [MkBlockForging m (ShelleyBlock (TPraos c) era)]))
-> m (ProtocolInfo (ShelleyBlock (TPraos c) era),
      Tracer m KESAgentClientTrace
      -> m [MkBlockForging m (ShelleyBlock (TPraos c) era)])
-> m (ProtocolInfo (ShelleyBlock (TPraos c) era),
      Tracer m KESAgentClientTrace
      -> m [MkBlockForging m (ShelleyBlock (TPraos c) era)])
forall a b. (a -> b) -> a -> b
$ do
      ledgerState <- m (LedgerState (ShelleyBlock (TPraos c) era) ValuesMK)
mkInitLedgerState
      let 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
      let perasState = LedgerCfg LedgerState (ShelleyBlock (TPraos c) era)
-> LedgerState (ShelleyBlock (TPraos c) era) ValuesMK
-> HeaderState (ShelleyBlock (TPraos c) era)
-> PerasState (ShelleyBlock (TPraos c) era)
forall blk (mk :: * -> * -> *).
(All Top (HardForkIndices blk), StateSupportsPerasEpochContext blk,
 HasLedgerTables LedgerState blk) =>
LedgerCfg LedgerState blk
-> LedgerState blk mk -> HeaderState blk -> PerasState blk
initPerasState LedgerCfg LedgerState (ShelleyBlock (TPraos c) era)
ledgerConfig LedgerState (ShelleyBlock (TPraos c) era) ValuesMK
ledgerState HeaderState (ShelleyBlock (TPraos c) era)
headerState
      let initExtLedgerState =
            ExtLedgerState
              { LedgerState (ShelleyBlock (TPraos c) era) ValuesMK
ledgerState :: LedgerState (ShelleyBlock (TPraos c) era) ValuesMK
ledgerState :: LedgerState (ShelleyBlock (TPraos c) era) ValuesMK
ledgerState
              , HeaderState (ShelleyBlock (TPraos c) era)
headerState :: HeaderState (ShelleyBlock (TPraos c) era)
headerState :: HeaderState (ShelleyBlock (TPraos c) era)
headerState
              , PerasState (ShelleyBlock (TPraos c) era)
perasState :: PerasState (ShelleyBlock (TPraos c) era)
perasState :: PerasState (ShelleyBlock (TPraos c) era)
perasState
              }
      pure
        ( ProtocolInfo
            { pInfoConfig = topLevelConfig
            , pInfoInitLedger = initExtLedgerState
            }
        , \Tracer m KESAgentClientTrace
tr -> [MkBlockForging m (ShelleyBlock (TPraos c) era)]
-> m [MkBlockForging m (ShelleyBlock (TPraos c) era)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([MkBlockForging m (ShelleyBlock (TPraos c) era)]
 -> m [MkBlockForging m (ShelleyBlock (TPraos c) era)])
-> [MkBlockForging m (ShelleyBlock (TPraos c) era)]
-> m [MkBlockForging m (ShelleyBlock (TPraos c) era)]
forall a b. (a -> b) -> a -> b
$ Tracer m KESAgentClientTrace
-> ShelleyLeaderCredentials c
-> MkBlockForging m (ShelleyBlock (TPraos c) era)
mkBlockForging Tracer m KESAgentClientTrace
tr (ShelleyLeaderCredentials c
 -> MkBlockForging m (ShelleyBlock (TPraos c) era))
-> [ShelleyLeaderCredentials c]
-> [MkBlockForging m (ShelleyBlock (TPraos c) era)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ShelleyLeaderCredentials c]
credentialss
        )
   where
    mkBlockForging ::
      Tracer.Tracer m KESAgentClientTrace ->
      ShelleyLeaderCredentials c ->
      MkBlockForging m (ShelleyBlock (TPraos c) era)
    mkBlockForging :: Tracer m KESAgentClientTrace
-> ShelleyLeaderCredentials c
-> MkBlockForging m (ShelleyBlock (TPraos c) era)
mkBlockForging Tracer m KESAgentClientTrace
tr ShelleyLeaderCredentials c
credentials = m (BlockForging m (ShelleyBlock (TPraos c) era))
-> MkBlockForging m (ShelleyBlock (TPraos c) era)
forall (m :: * -> *) blk.
m (BlockForging m blk) -> MkBlockForging m blk
MkBlockForging (m (BlockForging m (ShelleyBlock (TPraos c) era))
 -> MkBlockForging m (ShelleyBlock (TPraos c) era))
-> m (BlockForging m (ShelleyBlock (TPraos c) era))
-> MkBlockForging m (ShelleyBlock (TPraos c) era)
forall a b. (a -> b) -> a -> b
$ do
      let canBeLeader :: PraosCanBeLeader c
canBeLeader = ShelleyLeaderCredentials c -> PraosCanBeLeader c
forall c. ShelleyLeaderCredentials c -> PraosCanBeLeader c
shelleyLeaderCredentialsCanBeLeader ShelleyLeaderCredentials c
credentials

      hotKey :: HotKey c m <-
        Word64
-> Tracer m KESAgentClientTrace
-> PraosCredentialsSource c
-> m (HotKey c m)
forall (m :: * -> *) c.
KESAgentContext c m =>
Word64
-> Tracer m KESAgentClientTrace
-> PraosCredentialsSource c
-> m (HotKey c m)
instantiatePraosCredentials
          (TPraosParams -> Word64
tpraosMaxKESEvo TPraosParams
tpraosParams)
          Tracer m KESAgentClientTrace
tr
          (PraosCanBeLeader c -> PraosCredentialsSource c
forall c. PraosCanBeLeader c -> PraosCredentialsSource c
praosCanBeLeaderCredentialsSource PraosCanBeLeader c
canBeLeader)

      return $ shelleyBlockForging tpraosParams hotKey credentials

    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 :: LedgerCfg LedgerState (ShelleyBlock (TPraos c) era)
topLevelConfigLedger = LedgerCfg LedgerState (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 :: LedgerCfg LedgerState (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
        }

    mkInitLedgerState :: m (LedgerState (ShelleyBlock (TPraos c) era) ValuesMK)
    mkInitLedgerState :: m (LedgerState (ShelleyBlock (TPraos c) era) ValuesMK)
mkInitLedgerState = do
      injected <-
        HasFS m h
-> TransitionConfig era
-> NewEpochState era
-> m (NewEpochState era)
forall era (m :: * -> *) h.
(EraTransition era, HasCallStack, MonadST m, MonadThrow m) =>
HasFS m h
-> TransitionConfig era
-> NewEpochState era
-> m (NewEpochState era)
forall (m :: * -> *) h.
(HasCallStack, MonadST m, MonadThrow m) =>
HasFS m h
-> TransitionConfig era
-> NewEpochState era
-> m (NewEpochState era)
L.injectIntoTestState
          HasFS m h
hasFS
          TransitionConfig era
transitionCfg
          (TransitionConfig era -> NewEpochState era
forall era.
(EraTransition era, HasCallStack) =>
TransitionConfig era -> NewEpochState era
L.createInitialState TransitionConfig era
transitionCfg)
      pure $
        unstowLedgerTables
          ShelleyLedgerState
            { shelleyLedgerTip = Origin
            , shelleyLedgerState = injected
            , shelleyLedgerTransition = ShelleyTransitionInfo{shelleyAfterVoting = 0}
            , shelleyLedgerTables = 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 GenesisRole) GenDelegPair -> ChainDepState
SL.initialChainDepState Nonce
initialNonce (ShelleyGenesis -> Map (KeyHash GenesisRole) GenDelegPair
SL.sgGenDelegs ShelleyGenesis
genesis)