{-# 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.ResourceRegistry
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.Ledger.Tables.Utils (forgetLedgerTables)
import Ouroboros.Consensus.Protocol.Abstract
  ( ChainDepState
  , tickChainDepState
  )
import Ouroboros.Consensus.Storage.ChainDB.API as ChainDB
  ( AddBlockResult (..)
  , ChainDB
  , addBlockAsync
  , blockProcessed
  , getCurrentChain
  , getPastLedger
  , getReadOnlyForkerAtPoint
  )
import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as InvalidBlockPunishment
  ( noPunishment
  )
import Ouroboros.Consensus.Storage.LedgerDB
import Ouroboros.Consensus.Util.IOLike (atomically)
import Ouroboros.Network.AnchoredFragment as AF
  ( Anchor (..)
  , AnchoredFragment
  , AnchoredSeq (..)
  , headPoint
  )
import Ouroboros.Network.Protocol.LocalStateQuery.Type

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 mk =
  SlotNo ->
  IO (ReadOnlyForker IO (ExtLedgerState blk) blk) ->
  TickedLedgerState blk DiffMK ->
  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 mk.
  LedgerSupportsProtocol blk =>
  EpochSize ->
  SlotNo ->
  ForgeLimit ->
  ChainDB IO blk ->
  [BlockForging IO blk] ->
  TopLevelConfig blk ->
  GenTxs blk mk ->
  IO ForgeResult
runForge :: forall blk mk.
LedgerSupportsProtocol blk =>
EpochSize
-> SlotNo
-> ForgeLimit
-> ChainDB IO blk
-> [BlockForging IO blk]
-> TopLevelConfig blk
-> GenTxs blk mk
-> IO ForgeResult
runForge EpochSize
epochSize_ SlotNo
nextSlot ForgeLimit
opts ChainDB IO blk
chainDB [BlockForging IO blk]
blockForging TopLevelConfig blk
cfg GenTxs blk mk
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
  endState <- ForgeState -> IO ForgeState
go ForgeState
initialForgeState{currentSlot = nextSlot}
  putStrLn $
    "--> forged and adopted "
      ++ show (forged endState)
      ++ " blocks; reached "
      ++ show (currentSlot endState)
  pure $ ForgeResult $ fromIntegral $ forged 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{bcBlockNo, bcPrevPoint} <- do
      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 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'
    unticked <- do
      mExtLedger <- lift $ atomically $ ChainDB.getPastLedger chainDB bcPrevPoint
      case mExtLedger of
        Just ExtLedgerState blk EmptyMK
l -> ExtLedgerState blk EmptyMK
-> ExceptT String IO (ExtLedgerState blk EmptyMK)
forall a. a -> ExceptT String IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ExtLedgerState blk EmptyMK
l
        Maybe (ExtLedgerState blk EmptyMK)
Nothing -> String -> ExceptT String IO (ExtLedgerState blk EmptyMK)
forall {e} {a}. e -> ExceptT e IO a
exitEarly' String
"no ledger state"

    ledgerView <-
      case runExcept $
        forecastFor
          ( ledgerViewForecastAt
              (configLedger cfg)
              (ledgerState unticked)
          )
          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 =
          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 EmptyMK -> HeaderState blk
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> HeaderState blk
headerState ExtLedgerState blk EmptyMK
unticked))

    -- Check if any forger is slot leader
    let
      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

    checks <- zip blockForging <$> liftIO (mapM checkShouldForge' blockForging)

    (blockForging', proof) <- case [(f, p) | (f, ShouldForge p) <- 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) DiffMK
        tickedLedgerState =
          ComputeLedgerEvents
-> LedgerConfig blk
-> SlotNo
-> LedgerState blk EmptyMK
-> Ticked (LedgerState blk) DiffMK
forall (l :: MapKind -> *).
IsLedger l =>
ComputeLedgerEvents
-> LedgerCfg l -> SlotNo -> l EmptyMK -> Ticked l DiffMK
applyChainTick
            ComputeLedgerEvents
OmitLedgerEvents
            (TopLevelConfig blk -> LedgerConfig blk
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig blk
cfg)
            SlotNo
currentSlot
            (ExtLedgerState blk EmptyMK -> LedgerState blk EmptyMK
forall blk (mk :: MapKind).
ExtLedgerState blk mk -> LedgerState blk mk
ledgerState ExtLedgerState blk EmptyMK
unticked)

    -- Let the caller generate transactions
    txs <- lift $ withRegistry $ \ResourceRegistry IO
reg ->
      GenTxs blk mk
genTxs
        SlotNo
currentSlot
        ( (GetForkerError -> ReadOnlyForker IO (ExtLedgerState blk) blk)
-> (ReadOnlyForker IO (ExtLedgerState blk) blk
    -> ReadOnlyForker IO (ExtLedgerState blk) blk)
-> Either
     GetForkerError (ReadOnlyForker IO (ExtLedgerState blk) blk)
-> ReadOnlyForker IO (ExtLedgerState blk) blk
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
            (String
-> GetForkerError -> ReadOnlyForker IO (ExtLedgerState blk) blk
forall a. HasCallStack => String -> a
error String
"Impossible: we are forging on top of a block that the ChainDB cannot create forkers on!")
            ReadOnlyForker IO (ExtLedgerState blk) blk
-> ReadOnlyForker IO (ExtLedgerState blk) blk
forall a. a -> a
id
            (Either GetForkerError (ReadOnlyForker IO (ExtLedgerState blk) blk)
 -> ReadOnlyForker IO (ExtLedgerState blk) blk)
-> IO
     (Either
        GetForkerError (ReadOnlyForker IO (ExtLedgerState blk) blk))
-> IO (ReadOnlyForker IO (ExtLedgerState blk) blk)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ChainDB IO blk
-> ResourceRegistry IO
-> Target (Point blk)
-> IO
     (Either
        GetForkerError (ReadOnlyForker IO (ExtLedgerState blk) blk))
forall (m :: * -> *) blk.
ChainDB m blk
-> ResourceRegistry m
-> Target (Point blk)
-> m (Either GetForkerError (ReadOnlyForker' m blk))
getReadOnlyForkerAtPoint ChainDB IO blk
chainDB ResourceRegistry IO
reg (Point blk -> Target (Point blk)
forall point. point -> Target point
SpecificPoint Point blk
bcPrevPoint)
        )
        Ticked (LedgerState blk) DiffMK
tickedLedgerState

    -- Actually produce the block
    newBlock <-
      lift $
        Block.forgeBlock
          blockForging'
          cfg
          bcBlockNo
          currentSlot
          (forgetLedgerTables tickedLedgerState)
          txs
          proof

    -- Add the block to the chain DB (synchronously) and verify adoption
    let noPunish = InvalidBlockPunishment IO
forall (m :: * -> *). Applicative m => InvalidBlockPunishment m
InvalidBlockPunishment.noPunishment
    result <- lift $ ChainDB.addBlockAsync chainDB noPunish newBlock
    mbCurTip <- lift $ atomically $ ChainDB.blockProcessed result

    when (mbCurTip /= SuccesfullyAddedBlock (blockPoint newBlock)) $
      exitEarly' "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'