{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

{-# 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.Protocol.Praos.Common
                     (PraosCanBeLeader (praosCanBeLeaderOpCert))
import           Ouroboros.Consensus.Shelley.Eras (EraCrypto)
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
     , c ~ EraCrypto era
     , Mempool.TxLimits (ShelleyBlock (Praos c) era)
     , IOLike m
     )
  => PraosParams
  -> ShelleyLeaderCredentials (EraCrypto era)
  -> m (BlockForging m (ShelleyBlock (Praos c) era))
praosBlockForging :: forall (m :: * -> *) era c.
(ShelleyCompatible (Praos c) era, c ~ EraCrypto era,
 TxLimits (ShelleyBlock (Praos c) era), IOLike m) =>
PraosParams
-> ShelleyLeaderCredentials (EraCrypto era)
-> m (BlockForging m (ShelleyBlock (Praos c) era))
praosBlockForging PraosParams
praosParams 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
praosMaxKESEvo
    BlockForging m (ShelleyBlock (Praos c) era)
-> m (BlockForging m (ShelleyBlock (Praos c) era))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlockForging m (ShelleyBlock (Praos c) era)
 -> m (BlockForging m (ShelleyBlock (Praos c) era)))
-> BlockForging m (ShelleyBlock (Praos c) era)
-> m (BlockForging m (ShelleyBlock (Praos c) era))
forall a b. (a -> b) -> a -> b
$ 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
ShelleyLeaderCredentials (EraCrypto era)
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 -> 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
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
    } = 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)
-> [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 (EraCrypto era) m
-> CanBeLeader (Praos c)
-> TopLevelConfig (ShelleyBlock (Praos c) era)
-> BlockNo
-> SlotNo
-> TickedLedgerState (ShelleyBlock (Praos c) era)
-> [Validated (GenTx (ShelleyBlock (Praos c) era))]
-> IsLeader (Praos c)
-> m (ShelleyBlock (Praos 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 (Praos c)
PraosCanBeLeader c
canBeLeader
            TopLevelConfig (ShelleyBlock (Praos c) era)
cfg
      }