{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Cardano.Tools.DBSynthesizer.Forging (
    GenTxs
  , runForge
  ) where

import           Cardano.Tools.DBSynthesizer.Types (ForgeLimit (..),
                     ForgeResult (..))
import           Control.Monad (when)
import           Control.Monad.Except (runExcept)
import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
import           Control.Tracer as Trace (nullTracer)
import           Data.Either (isRight)
import           Data.Maybe (isJust)
import           Data.Proxy
import           Data.Word (Word64)
import           Ouroboros.Consensus.Block.Abstract as Block
import           Ouroboros.Consensus.Block.Forging as Block (BlockForging (..),
                     ShouldForge (..), checkShouldForge)
import           Ouroboros.Consensus.Config (TopLevelConfig, configConsensus,
                     configLedger)
import           Ouroboros.Consensus.Forecast (forecastFor)
import           Ouroboros.Consensus.HeaderValidation
                     (BasicEnvelopeValidation (..), HeaderState (..))
import           Ouroboros.Consensus.Ledger.Abstract (Validated)
import           Ouroboros.Consensus.Ledger.Basics
import           Ouroboros.Consensus.Ledger.Extended
import           Ouroboros.Consensus.Ledger.SupportsMempool (GenTx)
import           Ouroboros.Consensus.Ledger.SupportsProtocol
import           Ouroboros.Consensus.Protocol.Abstract (ChainDepState,
                     tickChainDepState)
import           Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
                     (AddBlockResult (..), ChainDB, addBlockAsync,
                     blockProcessed, getCurrentChain, getPastLedger)
import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as InvalidBlockPunishment
                     (noPunishment)
import           Ouroboros.Consensus.Util.IOLike (atomically)
import           Ouroboros.Network.AnchoredFragment as AF (Anchor (..),
                     AnchoredFragment, AnchoredSeq (..), headPoint)


data ForgeState =
  ForgeState {
    ForgeState -> SlotNo
currentSlot  :: !SlotNo
  , ForgeState -> Word64
forged       :: !Word64
  , ForgeState -> Word64
currentEpoch :: !Word64
  , ForgeState -> SlotNo
processed    :: !SlotNo
  }

initialForgeState :: ForgeState
initialForgeState :: ForgeState
initialForgeState = SlotNo -> Word64 -> Word64 -> SlotNo -> ForgeState
ForgeState SlotNo
0 Word64
0 Word64
0 SlotNo
0

-- | An action to generate transactions for a given block
type GenTxs blk = SlotNo -> TickedLedgerState blk -> IO [Validated (GenTx blk)]

-- DUPLICATE: runForge mirrors forging loop from ouroboros-consensus/src/Ouroboros/Consensus/NodeKernel.hs
-- For an extensive commentary of the forging loop, see there.

runForge ::
     forall blk.
    ( LedgerSupportsProtocol blk )
    => EpochSize
    -> SlotNo
    -> ForgeLimit
    -> ChainDB IO blk
    -> [BlockForging IO blk]
    -> TopLevelConfig blk
    -> GenTxs blk
    -> IO ForgeResult
runForge :: forall blk.
LedgerSupportsProtocol blk =>
EpochSize
-> SlotNo
-> ForgeLimit
-> ChainDB IO blk
-> [BlockForging IO blk]
-> TopLevelConfig blk
-> GenTxs blk
-> IO ForgeResult
runForge EpochSize
epochSize_ SlotNo
nextSlot ForgeLimit
opts ChainDB IO blk
chainDB [BlockForging IO blk]
blockForging TopLevelConfig blk
cfg GenTxs blk
genTxs = do
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"--> epoch size: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ EpochSize -> String
forall a. Show a => a -> String
show EpochSize
epochSize_
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"--> will process until: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ForgeLimit -> String
forall a. Show a => a -> String
show ForgeLimit
opts
    ForgeState
endState <- ForgeState -> IO ForgeState
go ForgeState
initialForgeState {currentSlot = nextSlot}
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"--> forged and adopted " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show (ForgeState -> Word64
forged ForgeState
endState) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" blocks; reached " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SlotNo -> String
forall a. Show a => a -> String
show (ForgeState -> SlotNo
currentSlot ForgeState
endState)
    ForgeResult -> IO ForgeResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ForgeResult -> IO ForgeResult) -> ForgeResult -> IO ForgeResult
forall a b. (a -> b) -> a -> b
$ Int -> ForgeResult
ForgeResult (Int -> ForgeResult) -> Int -> ForgeResult
forall a b. (a -> b) -> a -> b
$ Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Word64 -> Int
forall a b. (a -> b) -> a -> b
$ ForgeState -> Word64
forged ForgeState
endState
  where
    epochSize :: Word64
epochSize = EpochSize -> Word64
unEpochSize EpochSize
epochSize_

    forgingDone :: ForgeState -> Bool
    forgingDone :: ForgeState -> Bool
forgingDone = case ForgeLimit
opts of
        ForgeLimitSlot SlotNo
s  -> (SlotNo
s SlotNo -> SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
== ) (SlotNo -> Bool) -> (ForgeState -> SlotNo) -> ForgeState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForgeState -> SlotNo
processed
        ForgeLimitBlock Word64
b -> (Word64
b Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== ) (Word64 -> Bool) -> (ForgeState -> Word64) -> ForgeState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForgeState -> Word64
forged
        ForgeLimitEpoch Word64
e -> (Word64
e Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== ) (Word64 -> Bool) -> (ForgeState -> Word64) -> ForgeState -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForgeState -> Word64
currentEpoch

    go :: ForgeState -> IO ForgeState
    go :: ForgeState -> IO ForgeState
go ForgeState
forgeState
      | ForgeState -> Bool
forgingDone ForgeState
forgeState = ForgeState -> IO ForgeState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ForgeState
forgeState
      | Bool
otherwise = ForgeState -> IO ForgeState
go (ForgeState -> IO ForgeState)
-> (Either String () -> ForgeState)
-> Either String ()
-> IO ForgeState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForgeState -> Bool -> ForgeState
nextForgeState ForgeState
forgeState (Bool -> ForgeState)
-> (Either String () -> Bool) -> Either String () -> ForgeState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either String () -> Bool
forall a b. Either a b -> Bool
isRight
          (Either String () -> IO ForgeState)
-> IO (Either String ()) -> IO ForgeState
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT String IO () -> IO (Either String ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (SlotNo -> ExceptT String IO ()
goSlot (SlotNo -> ExceptT String IO ()) -> SlotNo -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$ ForgeState -> SlotNo
currentSlot ForgeState
forgeState)

    nextForgeState :: ForgeState -> Bool -> ForgeState
    nextForgeState :: ForgeState -> Bool -> ForgeState
nextForgeState ForgeState{SlotNo
currentSlot :: ForgeState -> SlotNo
currentSlot :: SlotNo
currentSlot, Word64
forged :: ForgeState -> Word64
forged :: Word64
forged, Word64
currentEpoch :: ForgeState -> Word64
currentEpoch :: Word64
currentEpoch, SlotNo
processed :: ForgeState -> SlotNo
processed :: SlotNo
processed} Bool
didForge = ForgeState {
          currentSlot :: SlotNo
currentSlot = SlotNo
currentSlot SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1
        , forged :: Word64
forged = Word64
forged Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ if Bool
didForge then Word64
1 else Word64
0
        , currentEpoch :: Word64
currentEpoch = Word64
epoch'
        , processed :: SlotNo
processed = SlotNo
processed'
        }
      where
        processed' :: SlotNo
processed' = SlotNo
processed SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
1
        epoch' :: Word64
epoch' = Word64
currentEpoch Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ if SlotNo -> Word64
unSlotNo SlotNo
processed' Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`rem` Word64
epochSize Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0 then Word64
1 else Word64
0


    -- just some shims; in this ported code, we use ExceptT instead of WithEarlyExit
    exitEarly' :: e -> ExceptT e IO a
exitEarly'  = e -> ExceptT e IO a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE
    lift :: IO a -> ExceptT String IO a
lift        = IO a -> ExceptT String IO a
forall a. IO a -> ExceptT String IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

    goSlot :: SlotNo -> ExceptT String IO ()
    goSlot :: SlotNo -> ExceptT String IO ()
goSlot SlotNo
currentSlot = do
        -- Figure out which block to connect to
        BlockContext{BlockNo
bcBlockNo :: BlockNo
bcBlockNo :: forall blk. BlockContext blk -> BlockNo
bcBlockNo, Point blk
bcPrevPoint :: Point blk
bcPrevPoint :: forall blk. BlockContext blk -> Point blk
bcPrevPoint} <- do
          Either () (BlockContext blk)
eBlkCtx <- IO (Either () (BlockContext blk))
-> ExceptT String IO (Either () (BlockContext blk))
forall a. IO a -> ExceptT String IO a
lift (IO (Either () (BlockContext blk))
 -> ExceptT String IO (Either () (BlockContext blk)))
-> IO (Either () (BlockContext blk))
-> ExceptT String IO (Either () (BlockContext blk))
forall a b. (a -> b) -> a -> b
$ STM IO (Either () (BlockContext blk))
-> IO (Either () (BlockContext blk))
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO (Either () (BlockContext blk))
 -> IO (Either () (BlockContext blk)))
-> STM IO (Either () (BlockContext blk))
-> IO (Either () (BlockContext blk))
forall a b. (a -> b) -> a -> b
$
            SlotNo
-> AnchoredFragment (Header blk) -> Either () (BlockContext blk)
forall blk.
(GetHeader blk, BasicEnvelopeValidation blk) =>
SlotNo
-> AnchoredFragment (Header blk) -> Either () (BlockContext blk)
mkCurrentBlockContext SlotNo
currentSlot
                (AnchoredFragment (Header blk) -> Either () (BlockContext blk))
-> STM (AnchoredFragment (Header blk))
-> STM (Either () (BlockContext blk))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB IO blk -> STM IO (AnchoredFragment (Header blk))
forall (m :: * -> *) blk.
ChainDB m blk -> STM m (AnchoredFragment (Header blk))
ChainDB.getCurrentChain ChainDB IO blk
chainDB
          case Either () (BlockContext blk)
eBlkCtx of
            Right BlockContext blk
blkCtx -> BlockContext blk -> ExceptT String IO (BlockContext blk)
forall a. a -> ExceptT String IO a
forall (m :: * -> *) a. Monad m => a -> m a
return BlockContext blk
blkCtx
            Left{}       -> String -> ExceptT String IO (BlockContext blk)
forall {e} {a}. e -> ExceptT e IO a
exitEarly' String
"no block context"

        -- Get corresponding ledger state, ledgder view and ticked 'ChainDepState'
        ExtLedgerState blk
unticked <- do
          Maybe (ExtLedgerState blk)
mExtLedger <- IO (Maybe (ExtLedgerState blk))
-> ExceptT String IO (Maybe (ExtLedgerState blk))
forall a. IO a -> ExceptT String IO a
lift (IO (Maybe (ExtLedgerState blk))
 -> ExceptT String IO (Maybe (ExtLedgerState blk)))
-> IO (Maybe (ExtLedgerState blk))
-> ExceptT String IO (Maybe (ExtLedgerState blk))
forall a b. (a -> b) -> a -> b
$ STM IO (Maybe (ExtLedgerState blk))
-> IO (Maybe (ExtLedgerState blk))
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO (Maybe (ExtLedgerState blk))
 -> IO (Maybe (ExtLedgerState blk)))
-> STM IO (Maybe (ExtLedgerState blk))
-> IO (Maybe (ExtLedgerState blk))
forall a b. (a -> b) -> a -> b
$ ChainDB IO blk -> Point blk -> STM IO (Maybe (ExtLedgerState blk))
forall (m :: * -> *) blk.
(Monad (STM m), LedgerSupportsProtocol blk) =>
ChainDB m blk -> Point blk -> STM m (Maybe (ExtLedgerState blk))
ChainDB.getPastLedger ChainDB IO blk
chainDB Point blk
bcPrevPoint
          case Maybe (ExtLedgerState blk)
mExtLedger of
            Just ExtLedgerState blk
l  -> ExtLedgerState blk -> ExceptT String IO (ExtLedgerState blk)
forall a. a -> ExceptT String IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ExtLedgerState blk
l
            Maybe (ExtLedgerState blk)
Nothing -> String -> ExceptT String IO (ExtLedgerState blk)
forall {e} {a}. e -> ExceptT e IO a
exitEarly' String
"no ledger state"

        LedgerView (BlockProtocol blk)
ledgerView <-
          case Except OutsideForecastRange (LedgerView (BlockProtocol blk))
-> Either OutsideForecastRange (LedgerView (BlockProtocol blk))
forall e a. Except e a -> Either e a
runExcept (Except OutsideForecastRange (LedgerView (BlockProtocol blk))
 -> Either OutsideForecastRange (LedgerView (BlockProtocol blk)))
-> Except OutsideForecastRange (LedgerView (BlockProtocol blk))
-> Either OutsideForecastRange (LedgerView (BlockProtocol blk))
forall a b. (a -> b) -> a -> b
$ Forecast (LedgerView (BlockProtocol blk))
-> SlotNo
-> Except OutsideForecastRange (LedgerView (BlockProtocol blk))
forall a. Forecast a -> SlotNo -> Except OutsideForecastRange a
forecastFor
                           (LedgerConfig blk
-> LedgerState blk -> Forecast (LedgerView (BlockProtocol blk))
forall blk.
(LedgerSupportsProtocol blk, HasCallStack) =>
LedgerConfig blk
-> LedgerState blk -> Forecast (LedgerView (BlockProtocol blk))
ledgerViewForecastAt
                              (TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg)
                              (ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState ExtLedgerState blk
unticked))
                           SlotNo
currentSlot of
            Left OutsideForecastRange
err -> String -> ExceptT String IO (LedgerView (BlockProtocol blk))
forall {e} {a}. e -> ExceptT e IO a
exitEarly' (String -> ExceptT String IO (LedgerView (BlockProtocol blk)))
-> String -> ExceptT String IO (LedgerView (BlockProtocol blk))
forall a b. (a -> b) -> a -> b
$ String
"no ledger view: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ OutsideForecastRange -> String
forall a. Show a => a -> String
show OutsideForecastRange
err
            Right LedgerView (BlockProtocol blk)
lv -> LedgerView (BlockProtocol blk)
-> ExceptT String IO (LedgerView (BlockProtocol blk))
forall a. a -> ExceptT String IO a
forall (m :: * -> *) a. Monad m => a -> m a
return LedgerView (BlockProtocol blk)
lv

        let tickedChainDepState :: Ticked (ChainDepState (BlockProtocol blk))
            tickedChainDepState :: Ticked (ChainDepState (BlockProtocol blk))
tickedChainDepState =
                ConsensusConfig (BlockProtocol blk)
-> LedgerView (BlockProtocol blk)
-> SlotNo
-> ChainDepState (BlockProtocol blk)
-> Ticked (ChainDepState (BlockProtocol blk))
forall p.
ConsensusProtocol p =>
ConsensusConfig p
-> LedgerView p
-> SlotNo
-> ChainDepState p
-> Ticked (ChainDepState p)
tickChainDepState
                  (TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
configConsensus TopLevelConfig blk
cfg)
                  LedgerView (BlockProtocol blk)
ledgerView
                  SlotNo
currentSlot
                  (HeaderState blk -> ChainDepState (BlockProtocol blk)
forall blk. HeaderState blk -> ChainDepState (BlockProtocol blk)
headerStateChainDep (ExtLedgerState blk -> HeaderState blk
forall blk. ExtLedgerState blk -> HeaderState blk
headerState ExtLedgerState blk
unticked))

        -- Check if any forger is slot leader
        let
            checkShouldForge' :: BlockForging m blk -> m (ShouldForge blk)
checkShouldForge' BlockForging m blk
f =
              BlockForging m blk
-> Tracer m (ForgeStateInfo blk)
-> TopLevelConfig blk
-> SlotNo
-> Ticked (ChainDepState (BlockProtocol blk))
-> m (ShouldForge blk)
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
f Tracer m (ForgeStateInfo blk)
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer TopLevelConfig blk
cfg SlotNo
currentSlot Ticked (ChainDepState (BlockProtocol blk))
tickedChainDepState

        [(BlockForging IO blk, ShouldForge blk)]
checks <- [BlockForging IO blk]
-> [ShouldForge blk] -> [(BlockForging IO blk, ShouldForge blk)]
forall a b. [a] -> [b] -> [(a, b)]
zip [BlockForging IO blk]
blockForging ([ShouldForge blk] -> [(BlockForging IO blk, ShouldForge blk)])
-> ExceptT String IO [ShouldForge blk]
-> ExceptT String IO [(BlockForging IO blk, ShouldForge blk)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [ShouldForge blk] -> ExceptT String IO [ShouldForge blk]
forall a. IO a -> ExceptT String IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ((BlockForging IO blk -> IO (ShouldForge blk))
-> [BlockForging IO blk] -> IO [ShouldForge blk]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM BlockForging IO blk -> IO (ShouldForge blk)
forall {m :: * -> *}.
Monad m =>
BlockForging m blk -> m (ShouldForge blk)
checkShouldForge' [BlockForging IO blk]
blockForging)

        (BlockForging IO blk
blockForging', IsLeader (BlockProtocol blk)
proof) <- case [(BlockForging IO blk
f, IsLeader (BlockProtocol blk)
p) | (BlockForging IO blk
f, ShouldForge IsLeader (BlockProtocol blk)
p) <- [(BlockForging IO blk, ShouldForge blk)]
checks] of
          (BlockForging IO blk, IsLeader (BlockProtocol blk))
x:[(BlockForging IO blk, IsLeader (BlockProtocol blk))]
_ -> (BlockForging IO blk, IsLeader (BlockProtocol blk))
-> ExceptT
     String IO (BlockForging IO blk, IsLeader (BlockProtocol blk))
forall a. a -> ExceptT String IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlockForging IO blk, IsLeader (BlockProtocol blk))
x
          [(BlockForging IO blk, IsLeader (BlockProtocol blk))]
_   -> String
-> ExceptT
     String IO (BlockForging IO blk, IsLeader (BlockProtocol blk))
forall {e} {a}. e -> ExceptT e IO a
exitEarly' String
"NoLeader"

        -- Tick the ledger state for the 'SlotNo' we're producing a block for
        let tickedLedgerState :: Ticked (LedgerState blk)
            tickedLedgerState :: Ticked (LedgerState blk)
tickedLedgerState =
              LedgerConfig blk
-> SlotNo -> LedgerState blk -> Ticked (LedgerState blk)
forall l. IsLedger l => LedgerCfg l -> SlotNo -> l -> Ticked l
applyChainTick
                (TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg)
                SlotNo
currentSlot
                (ExtLedgerState blk -> LedgerState blk
forall blk. ExtLedgerState blk -> LedgerState blk
ledgerState ExtLedgerState blk
unticked)

        -- Let the caller generate transactions
        [Validated (GenTx blk)]
txs <- IO [Validated (GenTx blk)]
-> ExceptT String IO [Validated (GenTx blk)]
forall a. IO a -> ExceptT String IO a
lift (IO [Validated (GenTx blk)]
 -> ExceptT String IO [Validated (GenTx blk)])
-> IO [Validated (GenTx blk)]
-> ExceptT String IO [Validated (GenTx blk)]
forall a b. (a -> b) -> a -> b
$ GenTxs blk
genTxs SlotNo
currentSlot Ticked (LedgerState blk)
tickedLedgerState

        -- Actually produce the block
        blk
newBlock <- IO blk -> ExceptT String IO blk
forall a. IO a -> ExceptT String IO a
lift (IO blk -> ExceptT String IO blk)
-> IO blk -> ExceptT String IO blk
forall a b. (a -> b) -> a -> b
$
          BlockForging IO blk
-> TopLevelConfig blk
-> BlockNo
-> SlotNo
-> Ticked (LedgerState blk)
-> [Validated (GenTx blk)]
-> IsLeader (BlockProtocol blk)
-> IO blk
forall (m :: * -> *) blk.
BlockForging m blk
-> TopLevelConfig blk
-> BlockNo
-> SlotNo
-> TickedLedgerState blk
-> [Validated (GenTx blk)]
-> IsLeader (BlockProtocol blk)
-> m blk
Block.forgeBlock BlockForging IO blk
blockForging'
            TopLevelConfig blk
cfg
            BlockNo
bcBlockNo
            SlotNo
currentSlot
            Ticked (LedgerState blk)
tickedLedgerState
            [Validated (GenTx blk)]
txs
            IsLeader (BlockProtocol blk)
proof

        -- Add the block to the chain DB (synchronously) and verify adoption
        let noPunish :: InvalidBlockPunishment IO
noPunish = InvalidBlockPunishment IO
forall (m :: * -> *). Applicative m => InvalidBlockPunishment m
InvalidBlockPunishment.noPunishment
        AddBlockPromise IO blk
result <- IO (AddBlockPromise IO blk)
-> ExceptT String IO (AddBlockPromise IO blk)
forall a. IO a -> ExceptT String IO a
lift (IO (AddBlockPromise IO blk)
 -> ExceptT String IO (AddBlockPromise IO blk))
-> IO (AddBlockPromise IO blk)
-> ExceptT String IO (AddBlockPromise IO blk)
forall a b. (a -> b) -> a -> b
$ ChainDB IO blk
-> InvalidBlockPunishment IO -> blk -> IO (AddBlockPromise IO blk)
forall (m :: * -> *) blk.
ChainDB m blk
-> InvalidBlockPunishment m -> blk -> m (AddBlockPromise m blk)
ChainDB.addBlockAsync ChainDB IO blk
chainDB InvalidBlockPunishment IO
noPunish blk
newBlock
        AddBlockResult blk
mbCurTip <- IO (AddBlockResult blk) -> ExceptT String IO (AddBlockResult blk)
forall a. IO a -> ExceptT String IO a
lift (IO (AddBlockResult blk) -> ExceptT String IO (AddBlockResult blk))
-> IO (AddBlockResult blk)
-> ExceptT String IO (AddBlockResult blk)
forall a b. (a -> b) -> a -> b
$ STM IO (AddBlockResult blk) -> IO (AddBlockResult blk)
forall a. HasCallStack => STM IO a -> IO a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM IO (AddBlockResult blk) -> IO (AddBlockResult blk))
-> STM IO (AddBlockResult blk) -> IO (AddBlockResult blk)
forall a b. (a -> b) -> a -> b
$ AddBlockPromise IO blk -> STM IO (AddBlockResult blk)
forall (m :: * -> *) blk.
AddBlockPromise m blk -> STM m (AddBlockResult blk)
ChainDB.blockProcessed AddBlockPromise IO blk
result

        Bool -> ExceptT String IO () -> ExceptT String IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AddBlockResult blk
mbCurTip AddBlockResult blk -> AddBlockResult blk -> Bool
forall a. Eq a => a -> a -> Bool
/= Point blk -> AddBlockResult blk
forall blk. Point blk -> AddBlockResult blk
SuccesfullyAddedBlock (blk -> Point blk
forall block. HasHeader block => block -> Point block
blockPoint blk
newBlock)) (ExceptT String IO () -> ExceptT String IO ())
-> ExceptT String IO () -> ExceptT String IO ()
forall a b. (a -> b) -> a -> b
$
            String -> ExceptT String IO ()
forall {e} {a}. e -> ExceptT e IO a
exitEarly' String
"block not adopted"

-- | Context required to forge a block
data BlockContext blk = BlockContext
  { forall blk. BlockContext blk -> BlockNo
bcBlockNo   :: !BlockNo
  , forall blk. BlockContext blk -> Point blk
bcPrevPoint :: !(Point blk)
  }

-- | Create the 'BlockContext' from the header of the previous block
blockContextFromPrevHeader ::
     HasHeader (Header blk)
  => Header blk
  -> BlockContext blk
blockContextFromPrevHeader :: forall blk.
HasHeader (Header blk) =>
Header blk -> BlockContext blk
blockContextFromPrevHeader Header blk
hdr =
    BlockNo -> Point blk -> BlockContext blk
forall blk. BlockNo -> Point blk -> BlockContext blk
BlockContext (BlockNo -> BlockNo
forall a. Enum a => a -> a
succ (Header blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo Header blk
hdr)) (Header blk -> Point blk
forall blk. HasHeader (Header blk) => Header blk -> Point blk
headerPoint Header blk
hdr)

-- | Determine the 'BlockContext' for a block about to be forged from the
-- current slot, ChainDB chain fragment, and ChainDB tip block number
mkCurrentBlockContext ::
     forall blk.
     ( GetHeader blk
     , BasicEnvelopeValidation blk )
  => SlotNo
  -> AnchoredFragment (Header blk)
  -> Either () (BlockContext blk)
mkCurrentBlockContext :: forall blk.
(GetHeader blk, BasicEnvelopeValidation blk) =>
SlotNo
-> AnchoredFragment (Header blk) -> Either () (BlockContext blk)
mkCurrentBlockContext SlotNo
currentSlot AnchoredFragment (Header blk)
c = case AnchoredFragment (Header blk)
c of
    Empty Anchor (Header blk)
AF.AnchorGenesis ->
      BlockContext blk -> Either () (BlockContext blk)
forall a b. b -> Either a b
Right (BlockContext blk -> Either () (BlockContext blk))
-> BlockContext blk -> Either () (BlockContext blk)
forall a b. (a -> b) -> a -> b
$ BlockNo -> Point blk -> BlockContext blk
forall blk. BlockNo -> Point blk -> BlockContext blk
BlockContext (Proxy blk -> BlockNo
forall blk (proxy :: * -> *).
BasicEnvelopeValidation blk =>
proxy blk -> BlockNo
forall (proxy :: * -> *). proxy blk -> BlockNo
expectedFirstBlockNo (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk)) Point blk
forall {k} (block :: k). Point block
GenesisPoint

    Empty (AF.Anchor SlotNo
anchorSlot HeaderHash (Header blk)
anchorHash BlockNo
anchorBlockNo) ->
      let Point blk
p :: Point blk = SlotNo -> HeaderHash blk -> Point blk
forall {k} (block :: k). SlotNo -> HeaderHash block -> Point block
BlockPoint SlotNo
anchorSlot HeaderHash blk
HeaderHash (Header blk)
anchorHash
      in if SlotNo
anchorSlot SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
currentSlot
           then BlockContext blk -> Either () (BlockContext blk)
forall a b. b -> Either a b
Right (BlockContext blk -> Either () (BlockContext blk))
-> BlockContext blk -> Either () (BlockContext blk)
forall a b. (a -> b) -> a -> b
$ BlockNo -> Point blk -> BlockContext blk
forall blk. BlockNo -> Point blk -> BlockContext blk
BlockContext (BlockNo -> BlockNo
forall a. Enum a => a -> a
succ BlockNo
anchorBlockNo) Point blk
p
           else () -> Either () (BlockContext blk)
forall a b. a -> Either a b
Left ()

    AnchoredFragment (Header blk)
c' :> Header blk
hdr -> case Header blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header blk
hdr SlotNo -> SlotNo -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` SlotNo
currentSlot of
      Ordering
LT -> BlockContext blk -> Either () (BlockContext blk)
forall a b. b -> Either a b
Right (BlockContext blk -> Either () (BlockContext blk))
-> BlockContext blk -> Either () (BlockContext blk)
forall a b. (a -> b) -> a -> b
$ Header blk -> BlockContext blk
forall blk.
HasHeader (Header blk) =>
Header blk -> BlockContext blk
blockContextFromPrevHeader Header blk
hdr
      Ordering
GT -> () -> Either () (BlockContext blk)
forall a b. a -> Either a b
Left ()
      Ordering
EQ -> BlockContext blk -> Either () (BlockContext blk)
forall a b. b -> Either a b
Right (BlockContext blk -> Either () (BlockContext blk))
-> BlockContext blk -> Either () (BlockContext blk)
forall a b. (a -> b) -> a -> b
$ if Maybe EpochNo -> Bool
forall a. Maybe a -> Bool
isJust (Header blk -> Maybe EpochNo
forall blk. GetHeader blk => Header blk -> Maybe EpochNo
headerIsEBB Header blk
hdr)
        then Header blk -> BlockContext blk
forall blk.
HasHeader (Header blk) =>
Header blk -> BlockContext blk
blockContextFromPrevHeader Header blk
hdr
        else BlockNo -> Point blk -> BlockContext blk
forall blk. BlockNo -> Point blk -> BlockContext blk
BlockContext (Header blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo Header blk
hdr) (Point blk -> BlockContext blk) -> Point blk -> BlockContext blk
forall a b. (a -> b) -> a -> b
$ Point (Header blk) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Header blk) -> Point blk)
-> Point (Header blk) -> Point blk
forall a b. (a -> b) -> a -> b
$ AnchoredFragment (Header blk) -> Point (Header blk)
forall block.
HasHeader block =>
AnchoredFragment block -> Point block
AF.headPoint AnchoredFragment (Header blk)
c'