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

module Ouroboros.Consensus.Block.Forging (
    CannotForge
  , ForgeStateInfo
  , ForgeStateUpdateError
  , ForgeStateUpdateInfo(..)
  , castForgeStateUpdateInfo
  , BlockForging(..)
  , ShouldForge(..)
  , checkShouldForge
    -- * 'UpdateInfo'
  , UpdateInfo (..)
  , castUpdateInfo
  ) 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.
newtype ForgeStateUpdateInfo blk = ForgeStateUpdateInfo {
      ForgeStateUpdateInfo blk
-> UpdateInfo
     (ForgeStateInfo blk)
     (ForgeStateInfo blk)
     (ForgeStateUpdateError blk)
getForgeStateUpdateInfo :: UpdateInfo
                                   (ForgeStateInfo        blk)
                                   (ForgeStateInfo        blk)
                                   (ForgeStateUpdateError blk)
    }

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 =
      UpdateInfo
  (ForgeStateInfo blk')
  (ForgeStateInfo blk')
  (ForgeStateUpdateError blk')
-> ForgeStateUpdateInfo blk'
forall blk.
UpdateInfo
  (ForgeStateInfo blk)
  (ForgeStateInfo blk)
  (ForgeStateUpdateError blk)
-> ForgeStateUpdateInfo blk
ForgeStateUpdateInfo
    (UpdateInfo
   (ForgeStateInfo blk')
   (ForgeStateInfo blk')
   (ForgeStateUpdateError blk')
 -> ForgeStateUpdateInfo blk')
-> (ForgeStateUpdateInfo blk
    -> UpdateInfo
         (ForgeStateInfo blk')
         (ForgeStateInfo blk')
         (ForgeStateUpdateError blk'))
-> ForgeStateUpdateInfo blk
-> ForgeStateUpdateInfo blk'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpdateInfo
  (ForgeStateInfo blk')
  (ForgeStateInfo blk')
  (ForgeStateUpdateError blk')
-> UpdateInfo
     (ForgeStateInfo blk')
     (ForgeStateInfo blk')
     (ForgeStateUpdateError blk')
forall updated updated' unchanged unchanged' failed failed'.
(updated ~ updated', unchanged ~ unchanged', failed ~ failed') =>
UpdateInfo updated unchanged failed
-> UpdateInfo updated' unchanged' failed'
castUpdateInfo
    (UpdateInfo
   (ForgeStateInfo blk')
   (ForgeStateInfo blk')
   (ForgeStateUpdateError blk')
 -> UpdateInfo
      (ForgeStateInfo blk')
      (ForgeStateInfo blk')
      (ForgeStateUpdateError blk'))
-> (ForgeStateUpdateInfo blk
    -> UpdateInfo
         (ForgeStateInfo blk')
         (ForgeStateInfo blk')
         (ForgeStateUpdateError blk'))
-> ForgeStateUpdateInfo blk
-> UpdateInfo
     (ForgeStateInfo blk')
     (ForgeStateInfo blk')
     (ForgeStateUpdateError blk')
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForgeStateUpdateInfo blk
-> UpdateInfo
     (ForgeStateInfo blk')
     (ForgeStateInfo blk')
     (ForgeStateUpdateError blk')
forall blk.
ForgeStateUpdateInfo blk
-> UpdateInfo
     (ForgeStateInfo blk)
     (ForgeStateInfo blk)
     (ForgeStateUpdateError blk)
getForgeStateUpdateInfo

-- | 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' or 'Unchanged' is returned, we trace the
      -- 'ForgeStateInfo'.
      --
      -- When 'UpdateFailed' is returned, we trace the 'ForgeStateUpdateError'
      -- and don't call 'checkCanForge'.
    , BlockForging m blk -> SlotNo -> m (ForgeStateUpdateInfo blk)
updateForgeState :: SlotNo -> 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
-> forall p.
   (BlockProtocol blk ~ p) =>
   TopLevelConfig blk
   -> SlotNo
   -> Ticked (ChainDepState p)
   -> IsLeader p
   -> ForgeStateInfo blk
   -> Either (CannotForge blk) ()
checkCanForge ::
           forall p. BlockProtocol blk ~ p
        => TopLevelConfig blk
        -> SlotNo
        -> Ticked (ChainDepState p)
        -> IsLeader p
        -> 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
-> [GenTx blk]
-> IsLeader (BlockProtocol blk)
-> m blk
forgeBlock ::
           TopLevelConfig blk
        -> BlockNo                      -- Current block number
        -> SlotNo                       -- Current slot number
        -> TickedLedgerState blk        -- Current ledger state
        -> [GenTx blk]                  -- Contents of the mempool
        -> 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 :: BlockForging m blk
-> Tracer m (ForgeStateInfo blk)
-> TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> m (ShouldForge blk)
checkShouldForge BlockForging{Text
CanBeLeader (BlockProtocol blk)
SlotNo -> m (ForgeStateUpdateInfo blk)
TopLevelConfig blk
-> BlockNo
-> SlotNo
-> TickedLedgerState blk
-> [GenTx blk]
-> IsLeader (BlockProtocol blk)
-> m blk
forall p.
(BlockProtocol blk ~ p) =>
TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState p)
-> IsLeader p
-> ForgeStateInfo blk
-> Either (CannotForge blk) ()
forgeBlock :: TopLevelConfig blk
-> BlockNo
-> SlotNo
-> TickedLedgerState blk
-> [GenTx blk]
-> IsLeader (BlockProtocol blk)
-> m blk
checkCanForge :: forall p.
(BlockProtocol blk ~ p) =>
TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState p)
-> IsLeader p
-> ForgeStateInfo blk
-> Either (CannotForge blk) ()
updateForgeState :: SlotNo -> m (ForgeStateUpdateInfo blk)
canBeLeader :: CanBeLeader (BlockProtocol blk)
forgeLabel :: Text
forgeBlock :: forall (m :: * -> *) blk.
BlockForging m blk
-> TopLevelConfig blk
-> BlockNo
-> SlotNo
-> TickedLedgerState blk
-> [GenTx blk]
-> IsLeader (BlockProtocol blk)
-> m blk
checkCanForge :: forall (m :: * -> *) blk.
BlockForging m blk
-> forall p.
   (BlockProtocol blk ~ p) =>
   TopLevelConfig blk
   -> SlotNo
   -> Ticked (ChainDepState p)
   -> IsLeader p
   -> ForgeStateInfo blk
   -> Either (CannotForge blk) ()
updateForgeState :: forall (m :: * -> *) blk.
BlockForging m blk -> SlotNo -> 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 = do
    Either (ForgeStateUpdateError blk) (ForgeStateInfo blk)
eForgeStateInfo <-
      SlotNo -> m (ForgeStateUpdateInfo blk)
updateForgeState SlotNo
slot m (ForgeStateUpdateInfo blk)
-> (ForgeStateUpdateInfo blk
    -> m (Either (ForgeStateUpdateError blk) (ForgeStateInfo blk)))
-> m (Either (ForgeStateUpdateError blk) (ForgeStateInfo blk))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ForgeStateUpdateInfo blk
updateInfo ->
        case ForgeStateUpdateInfo blk
-> UpdateInfo
     (ForgeStateInfo blk)
     (ForgeStateInfo blk)
     (ForgeStateUpdateError blk)
forall blk.
ForgeStateUpdateInfo blk
-> UpdateInfo
     (ForgeStateInfo blk)
     (ForgeStateInfo blk)
     (ForgeStateUpdateError blk)
getForgeStateUpdateInfo ForgeStateUpdateInfo blk
updateInfo of
          Updated 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
            Either (ForgeStateUpdateError blk) (ForgeStateInfo blk)
-> m (Either (ForgeStateUpdateError blk) (ForgeStateInfo blk))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (ForgeStateUpdateError blk) (ForgeStateInfo blk)
 -> m (Either (ForgeStateUpdateError blk) (ForgeStateInfo blk)))
-> Either (ForgeStateUpdateError blk) (ForgeStateInfo blk)
-> m (Either (ForgeStateUpdateError blk) (ForgeStateInfo blk))
forall a b. (a -> b) -> a -> b
$ ForgeStateInfo blk
-> Either (ForgeStateUpdateError blk) (ForgeStateInfo blk)
forall a b. b -> Either a b
Right ForgeStateInfo blk
info
          Unchanged 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
            Either (ForgeStateUpdateError blk) (ForgeStateInfo blk)
-> m (Either (ForgeStateUpdateError blk) (ForgeStateInfo blk))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (ForgeStateUpdateError blk) (ForgeStateInfo blk)
 -> m (Either (ForgeStateUpdateError blk) (ForgeStateInfo blk)))
-> Either (ForgeStateUpdateError blk) (ForgeStateInfo blk)
-> m (Either (ForgeStateUpdateError blk) (ForgeStateInfo blk))
forall a b. (a -> b) -> a -> b
$ ForgeStateInfo blk
-> Either (ForgeStateUpdateError blk) (ForgeStateInfo blk)
forall a b. b -> Either a b
Right ForgeStateInfo blk
info
          UpdateFailed ForgeStateUpdateError blk
err ->
            Either (ForgeStateUpdateError blk) (ForgeStateInfo blk)
-> m (Either (ForgeStateUpdateError blk) (ForgeStateInfo blk))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (ForgeStateUpdateError blk) (ForgeStateInfo blk)
 -> m (Either (ForgeStateUpdateError blk) (ForgeStateInfo blk)))
-> Either (ForgeStateUpdateError blk) (ForgeStateInfo blk)
-> m (Either (ForgeStateUpdateError blk) (ForgeStateInfo blk))
forall a b. (a -> b) -> a -> b
$ ForgeStateUpdateError blk
-> Either (ForgeStateUpdateError blk) (ForgeStateInfo blk)
forall a b. a -> Either a b
Left 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
$
      case Either (ForgeStateUpdateError blk) (ForgeStateInfo blk)
eForgeStateInfo of
        Left  ForgeStateUpdateError blk
err            -> ForgeStateUpdateError blk -> ShouldForge blk
forall blk. ForgeStateUpdateError blk -> ShouldForge blk
ForgeStateUpdateError ForgeStateUpdateError blk
err
        Right ForgeStateInfo blk
forgeStateInfo ->
          case 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 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) ()
forall p.
(BlockProtocol blk ~ p) =>
TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState p)
-> IsLeader p
-> ForgeStateInfo blk
-> Either (CannotForge blk) ()
checkCanForge TopLevelConfig blk
cfg SlotNo
slot Ticked (ChainDepState (BlockProtocol blk))
tickedChainDepState IsLeader (BlockProtocol blk)
isLeader ForgeStateInfo blk
forgeStateInfo 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 unchanged failed =
    Updated      updated
  | Unchanged    unchanged
  | UpdateFailed failed
  deriving (Int -> UpdateInfo updated unchanged failed -> ShowS
[UpdateInfo updated unchanged failed] -> ShowS
UpdateInfo updated unchanged failed -> String
(Int -> UpdateInfo updated unchanged failed -> ShowS)
-> (UpdateInfo updated unchanged failed -> String)
-> ([UpdateInfo updated unchanged failed] -> ShowS)
-> Show (UpdateInfo updated unchanged failed)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall updated unchanged failed.
(Show updated, Show unchanged, Show failed) =>
Int -> UpdateInfo updated unchanged failed -> ShowS
forall updated unchanged failed.
(Show updated, Show unchanged, Show failed) =>
[UpdateInfo updated unchanged failed] -> ShowS
forall updated unchanged failed.
(Show updated, Show unchanged, Show failed) =>
UpdateInfo updated unchanged failed -> String
showList :: [UpdateInfo updated unchanged failed] -> ShowS
$cshowList :: forall updated unchanged failed.
(Show updated, Show unchanged, Show failed) =>
[UpdateInfo updated unchanged failed] -> ShowS
show :: UpdateInfo updated unchanged failed -> String
$cshow :: forall updated unchanged failed.
(Show updated, Show unchanged, Show failed) =>
UpdateInfo updated unchanged failed -> String
showsPrec :: Int -> UpdateInfo updated unchanged failed -> ShowS
$cshowsPrec :: forall updated unchanged failed.
(Show updated, Show unchanged, Show failed) =>
Int -> UpdateInfo updated unchanged failed -> ShowS
Show)

castUpdateInfo ::
     ( updated   ~ updated'
     , unchanged ~ unchanged'
     , failed    ~ failed'
     )
  => UpdateInfo updated  unchanged  failed
  -> UpdateInfo updated' unchanged' failed'
castUpdateInfo :: UpdateInfo updated unchanged failed
-> UpdateInfo updated' unchanged' failed'
castUpdateInfo = \case
    Updated      updated
updated   -> updated -> UpdateInfo updated unchanged' failed'
forall updated unchanged failed.
updated -> UpdateInfo updated unchanged failed
Updated      updated
updated
    Unchanged    unchanged
unchanged -> unchanged -> UpdateInfo updated' unchanged failed'
forall updated unchanged failed.
unchanged -> UpdateInfo updated unchanged failed
Unchanged    unchanged
unchanged
    UpdateFailed failed
failed    -> failed -> UpdateInfo updated' unchanged' failed
forall updated unchanged failed.
failed -> UpdateInfo updated unchanged failed
UpdateFailed failed
failed