{-# 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
  ( -- * BlockForging
    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.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)

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

-- | Create a 'BlockForging' record for a single era.
praosBlockForging ::
  forall m era c.
  ( ShelleyCompatible (Praos c) era
  , Mempool.TxLimits (ShelleyBlock (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,
 TxLimits (ShelleyBlock (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.
(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 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.
  ( 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
    } =
    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
      , finalize :: m ()
finalize = HotKey c m -> m ()
forall c (m :: * -> *). HotKey c m -> m ()
HotKey.finalize HotKey c m
hotKey
      }