{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.Shelley.Node.Praos
  ( -- * BlockForging
    praosBlockForging
  , praosSharedBlockForging
  , praos2SharedBlockForging
  ) 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 Ouroboros.Consensus.Protocol.Abstract (CanBeLeader, ConsensusConfig)
import qualified Ouroboros.Consensus.Protocol.Ledger.HotKey as HotKey
import Ouroboros.Consensus.Protocol.Praos
  ( Praos
  , PraosCannotForge
  , PraosParams (..)
  , praosCheckCanForge
  )
import Ouroboros.Consensus.Protocol.Praos.Common (PraosCanBeLeader, WhenLeios)
import Ouroboros.Consensus.Protocol.Praos2 (ConsensusConfig (..), Praos2)
import Ouroboros.Consensus.Shelley.Ledger
  ( ShelleyBlock
  , ShelleyCompatible
  , forgeShelleyBlock
  )
import Ouroboros.Consensus.Shelley.Node.Common
  ( ShelleyLeaderCredentials (..)
  )
import Ouroboros.Consensus.Shelley.Protocol.Abstract (CannotForgeError, ProtoCrypto)
import Ouroboros.Consensus.Shelley.Protocol.Praos ()
import Ouroboros.Consensus.Util.IOLike (IOLike)

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

-- | Create a 'BlockForging' record for a single era.
praosBlockForging ::
  forall m era c.
  ( ShelleyCompatible (Praos c) era
  , IOLike m
  ) =>
  PraosParams ->
  HotKey.HotKey c m ->
  ShelleyLeaderCredentials c ->
  BlockForging m (ShelleyBlock (Praos c) era)
praosBlockForging :: forall (m :: * -> *) era c.
(ShelleyCompatible (Praos c) era, IOLike m) =>
PraosParams
-> HotKey c m
-> ShelleyLeaderCredentials c
-> BlockForging m (ShelleyBlock (Praos c) era)
praosBlockForging PraosParams
praosParams HotKey c m
hotKey ShelleyLeaderCredentials c
credentials =
  HotKey c m
-> (SlotNo -> KESPeriod)
-> ShelleyLeaderCredentials c
-> BlockForging m (ShelleyBlock (Praos c) era)
forall (m :: * -> *) c era.
(ShelleyCompatible (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 c
credentials
 where
  PraosParams{Word64
praosSlotsPerKESPeriod :: Word64
praosSlotsPerKESPeriod :: PraosParams -> Word64
praosSlotsPerKESPeriod} = PraosParams
praosParams

  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

-- | Create a 'BlockForging' record safely using the given 'Hotkey'.
--
-- The name of the era (separated by a @_@) will be appended to each
-- 'forgeLabel'.
praosSharedBlockForging ::
  forall m c era.
  ( ShelleyCompatible (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.
(ShelleyCompatible (Praos c) era, IOLike m) =>
HotKey c m
-> (SlotNo -> KESPeriod)
-> ShelleyLeaderCredentials c
-> BlockForging m (ShelleyBlock (Praos c) era)
praosSharedBlockForging = (ConsensusConfig (Praos c) -> PraosParams)
-> HotKey c m
-> (SlotNo -> KESPeriod)
-> ShelleyLeaderCredentials c
-> BlockForging m (ShelleyBlock (Praos c) era)
forall (m :: * -> *) proto c era.
(ShelleyCompatible proto era, ProtoCrypto proto ~ c,
 CanBeLeader proto ~ PraosCanBeLeader c,
 CannotForgeError proto ~ PraosCannotForge c,
 Applicative (WhenLeios proto), IOLike m) =>
(ConsensusConfig proto -> PraosParams)
-> HotKey c m
-> (SlotNo -> KESPeriod)
-> ShelleyLeaderCredentials c
-> BlockForging m (ShelleyBlock proto era)
basePraosSharedBlockForging ConsensusConfig (Praos c) -> PraosParams
forall c. ConsensusConfig (Praos c) -> PraosParams
praosParams

-- | 'praosSharedBlockForging' for every Praos.
basePraosSharedBlockForging ::
  forall m proto c era.
  ( ShelleyCompatible proto era
  , ProtoCrypto proto ~ c
  , CanBeLeader proto ~ PraosCanBeLeader c
  , CannotForgeError proto ~ PraosCannotForge c
  , Applicative (WhenLeios proto)
  , IOLike m
  ) =>
  -- | The Praos parameters within this protocol's configuration
  (ConsensusConfig proto -> PraosParams) ->
  HotKey.HotKey c m ->
  (SlotNo -> Absolute.KESPeriod) ->
  ShelleyLeaderCredentials c ->
  BlockForging m (ShelleyBlock proto era)
basePraosSharedBlockForging :: forall (m :: * -> *) proto c era.
(ShelleyCompatible proto era, ProtoCrypto proto ~ c,
 CanBeLeader proto ~ PraosCanBeLeader c,
 CannotForgeError proto ~ PraosCannotForge c,
 Applicative (WhenLeios proto), IOLike m) =>
(ConsensusConfig proto -> PraosParams)
-> HotKey c m
-> (SlotNo -> KESPeriod)
-> ShelleyLeaderCredentials c
-> BlockForging m (ShelleyBlock proto era)
basePraosSharedBlockForging
  ConsensusConfig proto -> PraosParams
getPraosParams
  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
    } =
    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 proto era))
canBeLeader = CanBeLeader (BlockProtocol (ShelleyBlock proto era))
PraosCanBeLeader c
canBeLeader
      , updateForgeState :: TopLevelConfig (ShelleyBlock proto era)
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol (ShelleyBlock proto era)))
-> m (ForgeStateUpdateInfo (ShelleyBlock proto era))
updateForgeState = \TopLevelConfig (ShelleyBlock proto era)
_ SlotNo
curSlot Ticked (ChainDepState (BlockProtocol (ShelleyBlock proto era)))
_ ->
          UpdateInfo
  (ForgeStateInfo (ShelleyBlock proto era))
  (ForgeStateUpdateError (ShelleyBlock proto era))
-> ForgeStateUpdateInfo (ShelleyBlock proto era)
UpdateInfo KESInfo KESEvolutionError
-> ForgeStateUpdateInfo (ShelleyBlock proto era)
forall blk.
UpdateInfo (ForgeStateInfo blk) (ForgeStateUpdateError blk)
-> ForgeStateUpdateInfo blk
forgeStateUpdateInfoFromUpdateInfo
            (UpdateInfo KESInfo KESEvolutionError
 -> ForgeStateUpdateInfo (ShelleyBlock proto era))
-> m (UpdateInfo KESInfo KESEvolutionError)
-> m (ForgeStateUpdateInfo (ShelleyBlock proto 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 proto era)
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol (ShelleyBlock proto era)))
-> IsLeader (BlockProtocol (ShelleyBlock proto era))
-> ForgeStateInfo (ShelleyBlock proto era)
-> Either (CannotForge (ShelleyBlock proto era)) ()
checkCanForge = \TopLevelConfig (ShelleyBlock proto era)
cfg SlotNo
curSlot Ticked (ChainDepState (BlockProtocol (ShelleyBlock proto era)))
_tickedChainDepState IsLeader (BlockProtocol (ShelleyBlock proto era))
_isLeader ->
          PraosParams -> SlotNo -> KESInfo -> Either (PraosCannotForge c) ()
forall c.
PraosParams -> SlotNo -> KESInfo -> Either (PraosCannotForge c) ()
praosCheckCanForge
            (ConsensusConfig proto -> PraosParams
getPraosParams (TopLevelConfig (ShelleyBlock proto era)
-> ConsensusConfig (BlockProtocol (ShelleyBlock proto era))
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
configConsensus TopLevelConfig (ShelleyBlock proto era)
cfg))
            SlotNo
curSlot
      , forgeBlock :: ForgeBlockArgs (ShelleyBlock proto era)
-> m (ShelleyBlock proto era)
forgeBlock = HotKey (ProtoCrypto proto) m
-> CanBeLeader proto
-> ForgeBlockArgs (ShelleyBlock proto era)
-> m (ShelleyBlock proto era)
forall (m :: * -> *) era proto.
(ShelleyCompatible proto era, Applicative (WhenLeios proto),
 Monad m) =>
HotKey (ProtoCrypto proto) m
-> CanBeLeader proto
-> ForgeBlockArgs (ShelleyBlock proto era)
-> m (ShelleyBlock proto era)
forgeShelleyBlock HotKey c m
HotKey (ProtoCrypto proto) m
hotKey CanBeLeader proto
PraosCanBeLeader c
canBeLeader
      , finalize :: m ()
finalize = HotKey c m -> m ()
forall c (m :: * -> *). HotKey c m -> m ()
HotKey.finalize HotKey c m
hotKey
      }

-- | As 'praosSharedBlockForging', for 'Praos2'.
praos2SharedBlockForging ::
  forall m c era.
  ( ShelleyCompatible (Praos2 c) era
  , IOLike m
  ) =>
  HotKey.HotKey c m ->
  (SlotNo -> Absolute.KESPeriod) ->
  ShelleyLeaderCredentials c ->
  BlockForging m (ShelleyBlock (Praos2 c) era)
praos2SharedBlockForging :: forall (m :: * -> *) c era.
(ShelleyCompatible (Praos2 c) era, IOLike m) =>
HotKey c m
-> (SlotNo -> KESPeriod)
-> ShelleyLeaderCredentials c
-> BlockForging m (ShelleyBlock (Praos2 c) era)
praos2SharedBlockForging = (ConsensusConfig (Praos2 c) -> PraosParams)
-> HotKey c m
-> (SlotNo -> KESPeriod)
-> ShelleyLeaderCredentials c
-> BlockForging m (ShelleyBlock (Praos2 c) era)
forall (m :: * -> *) proto c era.
(ShelleyCompatible proto era, ProtoCrypto proto ~ c,
 CanBeLeader proto ~ PraosCanBeLeader c,
 CannotForgeError proto ~ PraosCannotForge c,
 Applicative (WhenLeios proto), IOLike m) =>
(ConsensusConfig proto -> PraosParams)
-> HotKey c m
-> (SlotNo -> KESPeriod)
-> ShelleyLeaderCredentials c
-> BlockForging m (ShelleyBlock proto era)
basePraosSharedBlockForging (ConsensusConfig (Praos c) -> PraosParams
forall c. ConsensusConfig (Praos c) -> PraosParams
praosParams (ConsensusConfig (Praos c) -> PraosParams)
-> (ConsensusConfig (Praos2 c) -> ConsensusConfig (Praos c))
-> ConsensusConfig (Praos2 c)
-> PraosParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConsensusConfig (Praos2 c) -> ConsensusConfig (Praos c)
forall c. ConsensusConfig (Praos2 c) -> ConsensusConfig (Praos c)
leiosPraosConfig)