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

{-------------------------------------------------------------------------------
  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
  -> 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

-- | 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) 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
      }