{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.Block.Forging
  ( BlockForging (..)
  , MkBlockForging (..)
  , CannotForge
  , ForgeStateInfo
  , ForgeStateUpdateError
  , ForgeStateUpdateInfo (..)
  , ShouldForge (..)
  , castForgeStateUpdateInfo
  , checkShouldForge
  , forgeStateUpdateInfoFromUpdateInfo

    -- * 'UpdateInfo'
  , UpdateInfo (..)

    -- * 'ForgeBlockArgs'
  , ForgeBlockArgs (..)

    -- * 'ForgeBlockResult'
  , ForgeBlockResult (..)
  ) where

import Control.Tracer (Tracer, traceWith)
import Data.Kind (Type)
import Data.Text (Text)
import GHC.Stack
import Ouroboros.Consensus.Block.Abstract
import Ouroboros.Consensus.Block.SupportsPeras (PerasCert)
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.SupportsMempool
import Ouroboros.Consensus.Leios.Types (EndorserBlock)
import Ouroboros.Consensus.Protocol.Abstract
import Ouroboros.Consensus.Ticked

-- | Information about why we /cannot/ forge a block, although we are a leader
--
-- This should happen only rarely. An example might be that our hot key
-- does not (yet/anymore) match the delegation state.
type family CannotForge blk :: Type

-- | Returned when a call to 'updateForgeState' succeeded and caused the forge
-- state to change. This info is traced.
type family ForgeStateInfo blk :: Type

-- | Returned when a call 'updateForgeState' failed, e.g., because the KES key
-- is no longer valid. This info is traced.
type family ForgeStateUpdateError blk :: Type

-- | The result of 'updateForgeState'.
--
-- Note: the forge state itself is implicit and not reflected in the types.
data ForgeStateUpdateInfo blk
  = -- | NB The update might have not changed the forge state.
    ForgeStateUpdated (ForgeStateInfo blk)
  | ForgeStateUpdateFailed (ForgeStateUpdateError blk)
  | -- | A node was prevented from forging for an artificial reason, such as
    -- testing, benchmarking, etc. It's /artificial/ in that this constructor
    -- should never occur in a production deployment.
    ForgeStateUpdateSuppressed

deriving instance
  (Show (ForgeStateInfo blk), Show (ForgeStateUpdateError blk)) =>
  Show (ForgeStateUpdateInfo blk)

castForgeStateUpdateInfo ::
  ( ForgeStateInfo blk ~ ForgeStateInfo blk'
  , ForgeStateUpdateError blk ~ ForgeStateUpdateError blk'
  ) =>
  ForgeStateUpdateInfo blk -> ForgeStateUpdateInfo blk'
castForgeStateUpdateInfo :: forall blk blk'.
(ForgeStateInfo blk ~ ForgeStateInfo blk',
 ForgeStateUpdateError blk ~ ForgeStateUpdateError blk') =>
ForgeStateUpdateInfo blk -> ForgeStateUpdateInfo blk'
castForgeStateUpdateInfo = \case
  ForgeStateUpdated ForgeStateInfo blk
x -> ForgeStateInfo blk' -> ForgeStateUpdateInfo blk'
forall blk. ForgeStateInfo blk -> ForgeStateUpdateInfo blk
ForgeStateUpdated ForgeStateInfo blk
ForgeStateInfo blk'
x
  ForgeStateUpdateFailed ForgeStateUpdateError blk
x -> ForgeStateUpdateError blk' -> ForgeStateUpdateInfo blk'
forall blk. ForgeStateUpdateError blk -> ForgeStateUpdateInfo blk
ForgeStateUpdateFailed ForgeStateUpdateError blk
ForgeStateUpdateError blk'
x
  ForgeStateUpdateInfo blk
ForgeStateUpdateSuppressed -> ForgeStateUpdateInfo blk'
forall blk. ForgeStateUpdateInfo blk
ForgeStateUpdateSuppressed

-- | Stateful wrapper around block production
--
-- NOTE: do not refer to the consensus or ledger config in the closure of this
-- record because they might contain an @EpochInfo Identity@, which will be
-- incorrect when used as part of the hard fork combinator.
data BlockForging m blk = BlockForging
  { forall (m :: * -> *) blk. BlockForging m blk -> Text
forgeLabel :: Text
  -- ^ Identifier used in the trace messages produced for this
  -- 'BlockForging' record.
  --
  -- Useful when the node is running with multiple sets of credentials.
  , forall (m :: * -> *) blk.
BlockForging m blk -> CanBeLeader (BlockProtocol blk)
canBeLeader :: CanBeLeader (BlockProtocol blk)
  -- ^ Proof that the node can be a leader
  --
  -- NOTE: the other fields of this record may refer to this value (or a
  -- value derived from it) in their closure, which means one should not
  -- override this field independently from the others.
  , forall (m :: * -> *) blk.
BlockForging m blk
-> TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> m (ForgeStateUpdateInfo blk)
updateForgeState ::
      TopLevelConfig blk ->
      SlotNo ->
      Ticked (ChainDepState (BlockProtocol blk)) ->
      m (ForgeStateUpdateInfo blk)
  -- ^ Update the forge state.
  --
  -- When the node can be a leader, this will be called at the start of
  -- each slot, right before calling 'checkCanForge'.
  --
  -- When 'Updated' is returned, we trace the 'ForgeStateInfo'.
  --
  -- When 'UpdateFailed' is returned, we trace the 'ForgeStateUpdateError'
  -- and don't call 'checkCanForge'.
  , forall (m :: * -> *) blk.
BlockForging m blk
-> TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> IsLeader (BlockProtocol blk)
-> ForgeStateInfo blk
-> Either (CannotForge blk) ()
checkCanForge ::
      TopLevelConfig blk ->
      SlotNo ->
      Ticked (ChainDepState (BlockProtocol blk)) ->
      IsLeader (BlockProtocol blk) ->
      ForgeStateInfo blk -> -- Proof that 'updateForgeState' did not fail
      Either (CannotForge blk) ()
  -- ^ After checking that the node indeed is a leader ('checkIsLeader'
  -- returned 'Just') and successfully updating the forge state
  -- ('updateForgeState' did not return 'UpdateFailed'), do another check
  -- to see whether we can actually forge a block.
  --
  -- When 'CannotForge' is returned, we don't call 'forgeBlock'.
  , forall (m :: * -> *) blk.
BlockForging m blk
-> ForgeBlockArgs blk -> m (ForgeBlockResult blk)
forgeBlock :: ForgeBlockArgs blk -> m (ForgeBlockResult blk)
  -- ^ Forge a block. If the block announces an endorser block, also return
  -- this endorser block.
  , forall (m :: * -> *) blk. BlockForging m blk -> m ()
finalize :: m ()
  -- ^ Clean up any unmanaged resources.
  --
  -- Such resources may include KES keys that require explicit erasing
  -- ("secure forgetting"), and threads that connect to a KES agent.
  -- This method will be run once when the block forging thread
  -- terminates, whether cleanly or due to an exception.
  }

-- | 'MkBlockForging' is a wrapper around a monadic action that allocates a
-- 'BlockForging', potentially allocating other linked resources like KES
-- HotKeys, that *MUST* be finalized when the 'BlockForging' is no longer in
-- use. Users of this code must call the 'finalize' function on the returned 'BlockForging' at least once after terminating otherwise allocated resources
-- may leak.
newtype MkBlockForging m blk
  = MkBlockForging {forall (m :: * -> *) blk.
MkBlockForging m blk -> m (BlockForging m blk)
mkBlockForging :: m (BlockForging m blk)}

data ShouldForge blk
  = -- | Before check whether we are a leader in this slot, we tried to update
    --  our forge state ('updateForgeState'), but it failed. We will not check
    --  whether we are leader and will thus not forge a block either.
    --
    -- E.g., we could not evolve our KES key.
    ForgeStateUpdateError (ForgeStateUpdateError blk)
  | -- | We are a leader in this slot, but we cannot forge for a certain
    -- reason.
    --
    -- E.g., our KES key is not yet valid in this slot or we are not the
    -- current delegate of the genesis key we have a delegation certificate
    -- from.
    CannotForge (CannotForge blk)
  | -- | We are not a leader in this slot
    NotLeader
  | -- | We are a leader in this slot and we should forge a block.
    ShouldForge (IsLeader (BlockProtocol blk))

checkShouldForge ::
  forall m blk.
  ( Monad m
  , ConsensusProtocol (BlockProtocol blk)
  , HasCallStack
  ) =>
  BlockForging m blk ->
  Tracer m (ForgeStateInfo blk) ->
  TopLevelConfig blk ->
  SlotNo ->
  Ticked (ChainDepState (BlockProtocol blk)) ->
  m (ShouldForge blk)
checkShouldForge :: forall (m :: * -> *) blk.
(Monad m, ConsensusProtocol (BlockProtocol blk), HasCallStack) =>
BlockForging m blk
-> Tracer m (ForgeStateInfo blk)
-> TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> m (ShouldForge blk)
checkShouldForge
  BlockForging{m ()
Text
CanBeLeader (BlockProtocol blk)
TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> m (ForgeStateUpdateInfo blk)
TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> IsLeader (BlockProtocol blk)
-> ForgeStateInfo blk
-> Either (CannotForge blk) ()
ForgeBlockArgs blk -> m (ForgeBlockResult blk)
updateForgeState :: forall (m :: * -> *) blk.
BlockForging m blk
-> TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> m (ForgeStateUpdateInfo blk)
forgeLabel :: forall (m :: * -> *) blk. BlockForging m blk -> Text
canBeLeader :: forall (m :: * -> *) blk.
BlockForging m blk -> CanBeLeader (BlockProtocol blk)
checkCanForge :: forall (m :: * -> *) blk.
BlockForging m blk
-> TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> IsLeader (BlockProtocol blk)
-> ForgeStateInfo blk
-> Either (CannotForge blk) ()
forgeBlock :: forall (m :: * -> *) blk.
BlockForging m blk
-> ForgeBlockArgs blk -> m (ForgeBlockResult blk)
finalize :: forall (m :: * -> *) blk. BlockForging m blk -> m ()
forgeLabel :: Text
canBeLeader :: CanBeLeader (BlockProtocol blk)
updateForgeState :: TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> m (ForgeStateUpdateInfo blk)
checkCanForge :: TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> IsLeader (BlockProtocol blk)
-> ForgeStateInfo blk
-> Either (CannotForge blk) ()
forgeBlock :: ForgeBlockArgs blk -> m (ForgeBlockResult blk)
finalize :: m ()
..}
  Tracer m (ForgeStateInfo blk)
forgeStateInfoTracer
  TopLevelConfig blk
cfg
  SlotNo
slot
  Ticked (ChainDepState (BlockProtocol blk))
tickedChainDepState =
    TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> m (ForgeStateUpdateInfo blk)
updateForgeState TopLevelConfig blk
cfg SlotNo
slot Ticked (ChainDepState (BlockProtocol blk))
tickedChainDepState m (ForgeStateUpdateInfo blk)
-> (ForgeStateUpdateInfo blk -> m (ShouldForge blk))
-> m (ShouldForge blk)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ForgeStateUpdateInfo blk
updateInfo ->
      case ForgeStateUpdateInfo blk
updateInfo of
        ForgeStateUpdated ForgeStateInfo blk
info -> ForgeStateInfo blk -> m (ShouldForge blk)
handleUpdated ForgeStateInfo blk
info
        ForgeStateUpdateFailed ForgeStateUpdateError blk
err -> ShouldForge blk -> m (ShouldForge blk)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ShouldForge blk -> m (ShouldForge blk))
-> ShouldForge blk -> m (ShouldForge blk)
forall a b. (a -> b) -> a -> b
$ ForgeStateUpdateError blk -> ShouldForge blk
forall blk. ForgeStateUpdateError blk -> ShouldForge blk
ForgeStateUpdateError ForgeStateUpdateError blk
err
        ForgeStateUpdateInfo blk
ForgeStateUpdateSuppressed -> ShouldForge blk -> m (ShouldForge blk)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ShouldForge blk
forall blk. ShouldForge blk
NotLeader
   where
    mbIsLeader :: Maybe (IsLeader (BlockProtocol blk))
    mbIsLeader :: Maybe (IsLeader (BlockProtocol blk))
mbIsLeader =
      -- WARNING: It is critical that we do not depend on the 'BlockForging'
      -- record for the implementation of 'checkIsLeader'. Doing so would
      -- make composing multiple 'BlockForging' values responsible for also
      -- composing the 'checkIsLeader' checks, but that should be the
      -- responsibility of the 'ConsensusProtocol' instance for the
      -- composition of those blocks.
      ConsensusConfig (BlockProtocol blk)
-> CanBeLeader (BlockProtocol blk)
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> Maybe (IsLeader (BlockProtocol blk))
forall p.
(ConsensusProtocol p, HasCallStack) =>
ConsensusConfig p
-> CanBeLeader p
-> SlotNo
-> Ticked (ChainDepState p)
-> Maybe (IsLeader p)
checkIsLeader
        (TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
configConsensus TopLevelConfig blk
cfg)
        CanBeLeader (BlockProtocol blk)
canBeLeader
        SlotNo
slot
        Ticked (ChainDepState (BlockProtocol blk))
tickedChainDepState

    handleUpdated :: ForgeStateInfo blk -> m (ShouldForge blk)
    handleUpdated :: ForgeStateInfo blk -> m (ShouldForge blk)
handleUpdated ForgeStateInfo blk
info = do
      Tracer m (ForgeStateInfo blk) -> ForgeStateInfo blk -> m ()
forall (m :: * -> *) a. Monad m => Tracer m a -> a -> m ()
traceWith Tracer m (ForgeStateInfo blk)
forgeStateInfoTracer ForgeStateInfo blk
info
      ShouldForge blk -> m (ShouldForge blk)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (ShouldForge blk -> m (ShouldForge blk))
-> ShouldForge blk -> m (ShouldForge blk)
forall a b. (a -> b) -> a -> b
$ case Maybe (IsLeader (BlockProtocol blk))
mbIsLeader of
        Maybe (IsLeader (BlockProtocol blk))
Nothing -> ShouldForge blk
forall blk. ShouldForge blk
NotLeader
        Just IsLeader (BlockProtocol blk)
isLeader ->
          case TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> IsLeader (BlockProtocol blk)
-> ForgeStateInfo blk
-> Either (CannotForge blk) ()
checkCanForge TopLevelConfig blk
cfg SlotNo
slot Ticked (ChainDepState (BlockProtocol blk))
tickedChainDepState IsLeader (BlockProtocol blk)
isLeader ForgeStateInfo blk
info of
            Left CannotForge blk
cannotForge -> CannotForge blk -> ShouldForge blk
forall blk. CannotForge blk -> ShouldForge blk
CannotForge CannotForge blk
cannotForge
            Right () -> IsLeader (BlockProtocol blk) -> ShouldForge blk
forall blk. IsLeader (BlockProtocol blk) -> ShouldForge blk
ShouldForge IsLeader (BlockProtocol blk)
isLeader

{-------------------------------------------------------------------------------
  UpdateInfo
-------------------------------------------------------------------------------}

-- | The result of updating something, e.g., the forge state.
data UpdateInfo updated failed
  = -- | NOTE: The update may have induced no change.
    Updated updated
  | UpdateFailed failed
  deriving Int -> UpdateInfo updated failed -> ShowS
[UpdateInfo updated failed] -> ShowS
UpdateInfo updated failed -> String
(Int -> UpdateInfo updated failed -> ShowS)
-> (UpdateInfo updated failed -> String)
-> ([UpdateInfo updated failed] -> ShowS)
-> Show (UpdateInfo updated failed)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall updated failed.
(Show updated, Show failed) =>
Int -> UpdateInfo updated failed -> ShowS
forall updated failed.
(Show updated, Show failed) =>
[UpdateInfo updated failed] -> ShowS
forall updated failed.
(Show updated, Show failed) =>
UpdateInfo updated failed -> String
$cshowsPrec :: forall updated failed.
(Show updated, Show failed) =>
Int -> UpdateInfo updated failed -> ShowS
showsPrec :: Int -> UpdateInfo updated failed -> ShowS
$cshow :: forall updated failed.
(Show updated, Show failed) =>
UpdateInfo updated failed -> String
show :: UpdateInfo updated failed -> String
$cshowList :: forall updated failed.
(Show updated, Show failed) =>
[UpdateInfo updated failed] -> ShowS
showList :: [UpdateInfo updated failed] -> ShowS
Show

-- | Embed 'UpdateInfo' into 'ForgeStateUpdateInfo'
forgeStateUpdateInfoFromUpdateInfo ::
  UpdateInfo (ForgeStateInfo blk) (ForgeStateUpdateError blk) ->
  ForgeStateUpdateInfo blk
forgeStateUpdateInfoFromUpdateInfo :: forall blk.
UpdateInfo (ForgeStateInfo blk) (ForgeStateUpdateError blk)
-> ForgeStateUpdateInfo blk
forgeStateUpdateInfoFromUpdateInfo = \case
  Updated ForgeStateInfo blk
info -> ForgeStateInfo blk -> ForgeStateUpdateInfo blk
forall blk. ForgeStateInfo blk -> ForgeStateUpdateInfo blk
ForgeStateUpdated ForgeStateInfo blk
info
  UpdateFailed ForgeStateUpdateError blk
err -> ForgeStateUpdateError blk -> ForgeStateUpdateInfo blk
forall blk. ForgeStateUpdateError blk -> ForgeStateUpdateInfo blk
ForgeStateUpdateFailed ForgeStateUpdateError blk
err

{-------------------------------------------------------------------------------
  ForgeBlockArgs
-------------------------------------------------------------------------------}

-- | Arguments to 'forgeBlock' aggregated into a single record.
data ForgeBlockArgs blk = ForgeBlockArgs
  { forall blk. ForgeBlockArgs blk -> TopLevelConfig blk
fbConfig :: !(TopLevelConfig blk)
  -- ^ The node's top-level config.
  , forall blk. ForgeBlockArgs blk -> BlockNo
fbCurrentBlockNo :: !BlockNo
  -- ^ The block number of the block to be forged.
  , forall blk. ForgeBlockArgs blk -> SlotNo
fbCurrentSlotNo :: !SlotNo
  -- ^ The slot number of the block to be forged.
  , forall blk. ForgeBlockArgs blk -> Maybe (PerasCert blk)
fbPerasCert :: !(Maybe (PerasCert blk))
  -- ^ Optional Peras certificate to include in the forged block
  --
  -- For 'blk' that supports Peras 'Nothing' means no certificate.
  -- For 'blk' that doesn't support Peras it's always 'Nothing'.
  , forall blk. ForgeBlockArgs blk -> TickedLedgerState blk EmptyMK
fbCurrentTickedLedgerState :: !(TickedLedgerState blk EmptyMK)
  -- ^ The current ledger state ticked to 'fbCurrentSlotNo'.
  , forall blk. ForgeBlockArgs blk -> [Validated (GenTx blk)]
fbTxs :: ![Validated (GenTx blk)]
  -- ^ The transactions for the ranking block.
  --
  -- The function is passed the prefix of the mempool that will fit within
  -- a valid block; this is a set of transactions that is guaranteed to be
  -- consistent with the ledger state 'fbCurrentTickedLedgerState' and
  -- with each other (when applied in order). All of them should be
  -- included in the forged block, since the mempool ensures they can fit.
  --
  -- NOTE: do not refer to the consensus or ledger config in the closure,
  -- because they might contain an @EpochInfo Identity@, which will be
  -- incorrect when used as part of the hard fork combinator. Use the
  -- given 'fbConfig' instead, as it is guaranteed to be correct
  -- even when used as part of the hard fork combinator.
  --
  -- PRECONDITION: 'checkCanForge' returned @Right ()@.
  , forall blk. ForgeBlockArgs blk -> [Validated (GenTx blk)]
fbEbTxs :: ![Validated (GenTx blk)]
  -- ^ The transactions for the endorser block.
  -- 'Ouroboros.Consensus.Mempool.API.snapshotPartitionWithInitialPayload'
  -- selects them after 'fbTxs', up to the endorser-block capacity. They are in
  -- mempool order.
  --
  -- If you apply 'fbTxs' to 'fbCurrentTickedLedgerState', these transactions
  -- then apply in order without errors.
  , forall blk. ForgeBlockArgs blk -> IsLeader (BlockProtocol blk)
fbIsLeader :: !(IsLeader (BlockProtocol blk))
  -- ^ Proof that the node is the slot leader.
  }

{-------------------------------------------------------------------------------
  ForgeBlockResult
-------------------------------------------------------------------------------}

-- | The result of 'forgeBlock'.
data ForgeBlockResult blk = ForgeBlockResult
  { forall blk. ForgeBlockResult blk -> blk
rankingBlock :: !blk
  -- ^ The forged block.
  , forall blk. ForgeBlockResult blk -> Maybe EndorserBlock
endorserBlock :: !(Maybe EndorserBlock)
  -- ^ The endorser block that 'rankingBlock' announces. 'forgeBlock' builds
  -- it from 'fbEbTxs'. A @blk@ that does not support Leios returns 'Nothing'.
  }
  deriving stock (forall a b. (a -> b) -> ForgeBlockResult a -> ForgeBlockResult b)
-> (forall a b. a -> ForgeBlockResult b -> ForgeBlockResult a)
-> Functor ForgeBlockResult
forall a b. a -> ForgeBlockResult b -> ForgeBlockResult a
forall a b. (a -> b) -> ForgeBlockResult a -> ForgeBlockResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> ForgeBlockResult a -> ForgeBlockResult b
fmap :: forall a b. (a -> b) -> ForgeBlockResult a -> ForgeBlockResult b
$c<$ :: forall a b. a -> ForgeBlockResult b -> ForgeBlockResult a
<$ :: forall a b. a -> ForgeBlockResult b -> ForgeBlockResult a
Functor