{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Ouroboros.Consensus.Shelley.Node.Praos
(
praosBlockForging
, praosSharedBlockForging
) where
import qualified Cardano.Ledger.Api.Era as L
import qualified Cardano.Protocol.TPraos.OCert as Absolute
import qualified Cardano.Protocol.TPraos.OCert as SL
import qualified Data.Text as T
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config (configConsensus)
import qualified Ouroboros.Consensus.Ledger.SupportsMempool as Mempool
import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey
import Ouroboros.Consensus.Protocol.Praos
( Praos
, PraosParams (..)
, praosCheckCanForge
)
import Ouroboros.Consensus.Protocol.Praos.Common
( PraosCanBeLeader (praosCanBeLeaderOpCert)
)
import Ouroboros.Consensus.Shelley.Ledger
( ShelleyBlock
, ShelleyCompatible
, forgeShelleyBlock
)
import Ouroboros.Consensus.Shelley.Node.Common
( ShelleyEraWithCrypto
, ShelleyLeaderCredentials (..)
)
import Ouroboros.Consensus.Shelley.Protocol.Praos ()
import Ouroboros.Consensus.Util.IOLike (IOLike)
praosBlockForging ::
forall m era c.
( ShelleyCompatible (Praos c) era
, Mempool.TxLimits (ShelleyBlock (Praos c) era)
, IOLike m
) =>
PraosParams ->
ShelleyLeaderCredentials c ->
m (BlockForging m (ShelleyBlock (Praos c) era))
praosBlockForging :: forall (m :: * -> *) era c.
(ShelleyCompatible (Praos c) era,
TxLimits (ShelleyBlock (Praos c) era), IOLike m) =>
PraosParams
-> ShelleyLeaderCredentials c
-> m (BlockForging m (ShelleyBlock (Praos c) era))
praosBlockForging PraosParams
praosParams 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
praosMaxKESEvo
pure $ praosSharedBlockForging hotKey slotToPeriod credentials
where
PraosParams{Word64
praosMaxKESEvo :: Word64
praosMaxKESEvo :: PraosParams -> Word64
praosMaxKESEvo, Word64
praosSlotsPerKESPeriod :: Word64
praosSlotsPerKESPeriod :: PraosParams -> Word64
praosSlotsPerKESPeriod} = PraosParams
praosParams
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
praosSlotsPerKESPeriod
praosSharedBlockForging ::
forall m c era.
( ShelleyEraWithCrypto c (Praos c) era
, IOLike m
) =>
HotKey.HotKey c m ->
(SlotNo -> Absolute.KESPeriod) ->
ShelleyLeaderCredentials c ->
BlockForging m (ShelleyBlock (Praos c) era)
praosSharedBlockForging :: forall (m :: * -> *) c era.
(ShelleyEraWithCrypto c (Praos c) era, IOLike m) =>
HotKey c m
-> (SlotNo -> KESPeriod)
-> ShelleyLeaderCredentials c
-> BlockForging m (ShelleyBlock (Praos c) era)
praosSharedBlockForging
HotKey c m
hotKey
SlotNo -> KESPeriod
slotToPeriod
ShelleyLeaderCredentials
{ shelleyLeaderCredentialsCanBeLeader :: forall c. ShelleyLeaderCredentials c -> PraosCanBeLeader c
shelleyLeaderCredentialsCanBeLeader = PraosCanBeLeader c
canBeLeader
, shelleyLeaderCredentialsLabel :: forall c. ShelleyLeaderCredentials c -> Text
shelleyLeaderCredentialsLabel = Text
label
} = do
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 (Praos c) era))
canBeLeader = CanBeLeader (BlockProtocol (ShelleyBlock (Praos c) era))
PraosCanBeLeader c
canBeLeader
, updateForgeState :: TopLevelConfig (ShelleyBlock (Praos c) era)
-> SlotNo
-> Ticked
(ChainDepState (BlockProtocol (ShelleyBlock (Praos c) era)))
-> m (ForgeStateUpdateInfo (ShelleyBlock (Praos c) era))
updateForgeState = \TopLevelConfig (ShelleyBlock (Praos c) era)
_ SlotNo
curSlot Ticked (ChainDepState (BlockProtocol (ShelleyBlock (Praos c) era)))
_ ->
UpdateInfo
(ForgeStateInfo (ShelleyBlock (Praos c) era))
(ForgeStateUpdateError (ShelleyBlock (Praos c) era))
-> ForgeStateUpdateInfo (ShelleyBlock (Praos c) era)
UpdateInfo KESInfo KESEvolutionError
-> ForgeStateUpdateInfo (ShelleyBlock (Praos c) era)
forall blk.
UpdateInfo (ForgeStateInfo blk) (ForgeStateUpdateError blk)
-> ForgeStateUpdateInfo blk
forgeStateUpdateInfoFromUpdateInfo
(UpdateInfo KESInfo KESEvolutionError
-> ForgeStateUpdateInfo (ShelleyBlock (Praos c) era))
-> m (UpdateInfo KESInfo KESEvolutionError)
-> m (ForgeStateUpdateInfo (ShelleyBlock (Praos 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 (Praos c) era)
-> SlotNo
-> Ticked
(ChainDepState (BlockProtocol (ShelleyBlock (Praos c) era)))
-> IsLeader (BlockProtocol (ShelleyBlock (Praos c) era))
-> ForgeStateInfo (ShelleyBlock (Praos c) era)
-> Either (CannotForge (ShelleyBlock (Praos c) era)) ()
checkCanForge = \TopLevelConfig (ShelleyBlock (Praos c) era)
cfg SlotNo
curSlot Ticked (ChainDepState (BlockProtocol (ShelleyBlock (Praos c) era)))
_tickedChainDepState IsLeader (BlockProtocol (ShelleyBlock (Praos c) era))
_isLeader ->
ConsensusConfig (Praos c)
-> SlotNo -> KESInfo -> Either (PraosCannotForge c) ()
forall c.
ConsensusConfig (Praos c)
-> SlotNo -> KESInfo -> Either (PraosCannotForge c) ()
praosCheckCanForge
(TopLevelConfig (ShelleyBlock (Praos c) era)
-> ConsensusConfig (BlockProtocol (ShelleyBlock (Praos c) era))
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
configConsensus TopLevelConfig (ShelleyBlock (Praos c) era)
cfg)
SlotNo
curSlot
, forgeBlock :: TopLevelConfig (ShelleyBlock (Praos c) era)
-> BlockNo
-> SlotNo
-> TickedLedgerState (ShelleyBlock (Praos c) era) EmptyMK
-> [Validated (GenTx (ShelleyBlock (Praos c) era))]
-> IsLeader (BlockProtocol (ShelleyBlock (Praos c) era))
-> m (ShelleyBlock (Praos c) era)
forgeBlock = \TopLevelConfig (ShelleyBlock (Praos c) era)
cfg ->
HotKey (ProtoCrypto (Praos c)) m
-> CanBeLeader (Praos c)
-> TopLevelConfig (ShelleyBlock (Praos c) era)
-> BlockNo
-> SlotNo
-> TickedLedgerState (ShelleyBlock (Praos c) era) EmptyMK
-> [Validated (GenTx (ShelleyBlock (Praos c) era))]
-> IsLeader (Praos c)
-> m (ShelleyBlock (Praos 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 (Praos c)) m
hotKey
CanBeLeader (Praos c)
PraosCanBeLeader c
canBeLeader
TopLevelConfig (ShelleyBlock (Praos c) era)
cfg
}