{-# 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
type GenTxs blk mk =
SlotNo
-> IO (ReadOnlyForker IO (ExtLedgerState blk) blk)
-> TickedLedgerState blk DiffMK
-> IO [Validated (GenTx blk)]
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
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
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"
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))
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"
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)
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
newBlock <- lift $
Block.forgeBlock blockForging'
cfg
bcBlockNo
currentSlot
(forgetLedgerTables tickedLedgerState)
txs
proof
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"
data BlockContext blk = BlockContext
{ forall blk. BlockContext blk -> BlockNo
bcBlockNo :: !BlockNo
, forall blk. BlockContext blk -> Point blk
bcPrevPoint :: !(Point blk)
}
blockContextFromPrevHeader ::
HasHeader (Header blk)
=> Header blk
-> BlockContext blk
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)
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'