{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE RankNTypes           #-}
{-# LANGUAGE RecordWildCards      #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE StandaloneDeriving   #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.Block.Forging (
    BlockForging (..)
  , CannotForge
  , ForgeStateInfo
  , ForgeStateUpdateError
  , ForgeStateUpdateInfo (..)
  , ShouldForge (..)
  , castForgeStateUpdateInfo
  , checkShouldForge
  , forgeStateUpdateInfoFromUpdateInfo
    -- * 'UpdateInfo'
  , UpdateInfo (..)
    -- * Selecting transaction sequence prefixes
  , takeLargestPrefixThatFits
  ) where

import           Control.Tracer (Tracer, traceWith)
import           Data.Kind (Type)
import           Data.Text (Text)
import           GHC.Stack

import qualified Data.Measure as Measure

import           Ouroboros.Consensus.Block.Abstract
import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.SupportsMempool
import           Ouroboros.Consensus.Mempool.TxLimits (TxLimits)
import qualified Ouroboros.Consensus.Mempool.TxLimits as TxLimits
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 =
    ForgeStateUpdated          (ForgeStateInfo        blk)
    -- ^ NB The update might have not changed the forge state.
  | ForgeStateUpdateFailed     (ForgeStateUpdateError blk)
  | ForgeStateUpdateSuppressed
    -- ^ 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.

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 :: 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 {
      -- | Identifier used in the trace messages produced for this
      -- 'BlockForging' record.
      --
      -- Useful when the node is running with multiple sets of credentials.
      BlockForging m blk -> Text
forgeLabel :: Text

      -- | 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.
    , BlockForging m blk -> CanBeLeader (BlockProtocol blk)
canBeLeader :: CanBeLeader (BlockProtocol 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'.
    , BlockForging m blk
-> TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> m (ForgeStateUpdateInfo blk)
updateForgeState ::
           TopLevelConfig blk
        -> SlotNo
        -> Ticked (ChainDepState (BlockProtocol blk))
        -> m (ForgeStateUpdateInfo 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'.
    , 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) ()

      -- | Forge a block
      --
      -- The function is passed the contents of the mempool; this is a set of
      -- transactions that is guaranteed to be consistent with the ledger state
      -- (also provided as an argument) and with each other (when applied in
      -- order). In principle /all/ of them could be included in the block (up
      -- to maximum block size).
      --
      -- 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 'TopLevelConfig' instead, as it is guaranteed to be correct
      -- even when used as part of the hard fork combinator.
      --
      -- PRECONDITION: 'checkCanForge' returned @Right ()@.
    , BlockForging m blk
-> TopLevelConfig blk
-> BlockNo
-> SlotNo
-> TickedLedgerState blk
-> [Validated (GenTx blk)]
-> IsLeader (BlockProtocol blk)
-> m blk
forgeBlock ::
           TopLevelConfig blk
        -> BlockNo                      -- Current block number
        -> SlotNo                       -- Current slot number
        -> TickedLedgerState blk        -- Current ledger state
        -> [Validated (GenTx blk)]      -- Contents of the mempool
        -> IsLeader (BlockProtocol blk) -- Proof we are leader
        -> m blk
    }

-- | The prefix of transactions to include in the block
--
-- Filters out all transactions that do not fit the maximum size of total
-- transactions in a single block, which is determined by querying the ledger
-- state for the current limit and the given override. The result is the
-- pointwise minimum of the ledger-specific capacity and the result of the
-- override. In other words, the override can only reduce (parts of) the
-- 'TxLimits.TxMeasure'.
takeLargestPrefixThatFits ::
     TxLimits blk
  => TxLimits.Overrides blk
  -> TickedLedgerState blk
  -> [Validated (GenTx blk)]
  -> [Validated (GenTx blk)]
takeLargestPrefixThatFits :: Overrides blk
-> TickedLedgerState blk
-> [Validated (GenTx blk)]
-> [Validated (GenTx blk)]
takeLargestPrefixThatFits Overrides blk
overrides TickedLedgerState blk
ledger [Validated (GenTx blk)]
txs =
    (Validated (GenTx blk) -> TxMeasure blk)
-> TxMeasure blk
-> [Validated (GenTx blk)]
-> [Validated (GenTx blk)]
forall a e. Measure a => (e -> a) -> a -> [e] -> [e]
Measure.take Validated (GenTx blk) -> TxMeasure blk
forall blk. TxLimits blk => Validated (GenTx blk) -> TxMeasure blk
TxLimits.txMeasure TxMeasure blk
capacity [Validated (GenTx blk)]
txs
  where
    capacity :: TxMeasure blk
capacity =
      Overrides blk -> TxMeasure blk -> TxMeasure blk
forall blk.
TxLimits blk =>
Overrides blk -> TxMeasure blk -> TxMeasure blk
TxLimits.applyOverrides
        Overrides blk
overrides
        (TickedLedgerState blk -> TxMeasure blk
forall blk.
TxLimits blk =>
Ticked (LedgerState blk) -> TxMeasure blk
TxLimits.txsBlockCapacity TickedLedgerState blk
ledger)

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 :: BlockForging m blk
-> Tracer m (ForgeStateInfo blk)
-> TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> m (ShouldForge blk)
checkShouldForge BlockForging{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) ()
TopLevelConfig blk
-> BlockNo
-> SlotNo
-> TickedLedgerState blk
-> [Validated (GenTx blk)]
-> IsLeader (BlockProtocol blk)
-> m blk
forgeBlock :: TopLevelConfig blk
-> BlockNo
-> SlotNo
-> TickedLedgerState blk
-> [Validated (GenTx blk)]
-> IsLeader (BlockProtocol blk)
-> m blk
checkCanForge :: TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> IsLeader (BlockProtocol blk)
-> ForgeStateInfo blk
-> Either (CannotForge blk) ()
updateForgeState :: TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> m (ForgeStateUpdateInfo blk)
canBeLeader :: CanBeLeader (BlockProtocol blk)
forgeLabel :: Text
forgeBlock :: forall (m :: * -> *) blk.
BlockForging m blk
-> TopLevelConfig blk
-> BlockNo
-> SlotNo
-> TickedLedgerState blk
-> [Validated (GenTx blk)]
-> IsLeader (BlockProtocol blk)
-> m blk
checkCanForge :: forall (m :: * -> *) blk.
BlockForging m blk
-> TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> IsLeader (BlockProtocol blk)
-> ForgeStateInfo blk
-> Either (CannotForge blk) ()
updateForgeState :: forall (m :: * -> *) blk.
BlockForging m blk
-> TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> m (ForgeStateUpdateInfo blk)
canBeLeader :: forall (m :: * -> *) blk.
BlockForging m blk -> CanBeLeader (BlockProtocol blk)
forgeLabel :: forall (m :: * -> *) blk. BlockForging m blk -> Text
..}
                 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 (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 (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 (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. Tracer m a -> a -> m ()
traceWith Tracer m (ForgeStateInfo blk)
forgeStateInfoTracer ForgeStateInfo blk
info
        ShouldForge blk -> m (ShouldForge blk)
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
showList :: [UpdateInfo updated failed] -> ShowS
$cshowList :: forall updated failed.
(Show updated, Show failed) =>
[UpdateInfo updated failed] -> ShowS
show :: UpdateInfo updated failed -> String
$cshow :: forall updated failed.
(Show updated, Show failed) =>
UpdateInfo updated failed -> String
showsPrec :: Int -> UpdateInfo updated failed -> ShowS
$cshowsPrec :: forall updated failed.
(Show updated, Show failed) =>
Int -> UpdateInfo updated failed -> ShowS
Show)

-- | Embed 'UpdateInfo' into 'ForgeStateUpdateInfo'
forgeStateUpdateInfoFromUpdateInfo ::
     UpdateInfo (ForgeStateInfo blk) (ForgeStateUpdateError blk)
  -> ForgeStateUpdateInfo blk
forgeStateUpdateInfoFromUpdateInfo :: 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