{-# 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'