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

module Ouroboros.Consensus.Block.Forging (
    BlockForging (..)
  , CannotForge
  , ForgeStateInfo
  , ForgeStateUpdateError
  , ForgeStateUpdateInfo (..)
  , ShouldForge (..)
  , castForgeStateUpdateInfo
  , checkShouldForge
  , forgeStateUpdateInfoFromUpdateInfo
    -- * 'UpdateInfo'
  , UpdateInfo (..)
  ) 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.Config
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.SupportsMempool
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 :: 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 {
      -- | 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 -> 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.
    , forall (m :: * -> *) blk.
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'.
    , 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)

      -- | 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
-> 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 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 (also provided as an argument) 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 'TopLevelConfig' instead, as it is guaranteed to be correct
      -- even when used as part of the hard fork combinator.
      --
      -- PRECONDITION: 'checkCanForge' returned @Right ()@.
    , forall (m :: * -> *) blk.
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)]      -- Transactions to include
        -> IsLeader (BlockProtocol blk) -- Proof we are leader
        -> 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{Text
CanBeLeader (BlockProtocol blk)
TopLevelConfig blk
-> BlockNo
-> SlotNo
-> TickedLedgerState blk
-> [Validated (GenTx blk)]
-> IsLeader (BlockProtocol blk)
-> m 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) ()
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
-> TopLevelConfig blk
-> BlockNo
-> SlotNo
-> TickedLedgerState blk
-> [Validated (GenTx blk)]
-> IsLeader (BlockProtocol blk)
-> m blk
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 :: TopLevelConfig blk
-> BlockNo
-> SlotNo
-> TickedLedgerState blk
-> [Validated (GenTx blk)]
-> IsLeader (BlockProtocol blk)
-> m blk
..}
                 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. 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