{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.HardFork.Combinator.Forging ( HardForkCannotForge , HardForkForgeStateInfo (..) , HardForkForgeStateUpdateError , hardForkBlockForging ) where import Data.Functor.Product import Data.Maybe (fromMaybe) import Data.SOP.BasicFunctors import Data.SOP.Functors (Product2 (..)) import Data.SOP.Index import Data.SOP.InPairs (InPairs) import qualified Data.SOP.InPairs as InPairs import qualified Data.SOP.Match as Match import Data.SOP.OptNP (NonEmptyOptNP, OptNP, ViewOptNP (..)) import qualified Data.SOP.OptNP as OptNP import Data.SOP.Strict import Data.Text (Text) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.HardFork.Combinator.Abstract import Ouroboros.Consensus.HardFork.Combinator.AcrossEras import Ouroboros.Consensus.HardFork.Combinator.Basics import Ouroboros.Consensus.HardFork.Combinator.InjectTxs import Ouroboros.Consensus.HardFork.Combinator.Ledger (Ticked (..)) import Ouroboros.Consensus.HardFork.Combinator.Mempool import Ouroboros.Consensus.HardFork.Combinator.Protocol import qualified Ouroboros.Consensus.HardFork.Combinator.State as State import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util ((.:)) -- | If we cannot forge, it's because the current era could not forge type HardForkCannotForge xs = OneEraCannotForge xs type instance CannotForge (HardForkBlock xs) = HardForkCannotForge xs -- | For each era in which we want to forge blocks, we have a 'BlockForging', -- and thus 'ForgeStateInfo'. -- -- When we update the hard fork forge state, we only update the forge state of -- the current era. However, the current era /might not/ have a forge state as -- it lacks a 'BlockForging'. -- -- TODO #2766: expire past 'ForgeState' data HardForkForgeStateInfo xs where -- | There is no 'BlockForging' record for the current era. CurrentEraLacksBlockForging :: EraIndex (x ': y ': xs) -> HardForkForgeStateInfo (x ': y ': xs) -- | The 'ForgeState' of the current era was updated. CurrentEraForgeStateUpdated :: OneEraForgeStateInfo xs -> HardForkForgeStateInfo xs deriving instance CanHardFork xs => Show (HardForkForgeStateInfo xs) type instance ForgeStateInfo (HardForkBlock xs) = HardForkForgeStateInfo xs -- | For each era in which we want to forge blocks, we have a 'BlockForging', -- and thus 'ForgeStateUpdateError'. type HardForkForgeStateUpdateError xs = OneEraForgeStateUpdateError xs type instance ForgeStateUpdateError (HardForkBlock xs) = HardForkForgeStateUpdateError xs hardForkBlockForging :: forall m xs. (CanHardFork xs, Monad m) => Text -- ^ Used as the 'forgeLabel', the labels of the given 'BlockForging's will -- be ignored. -> NonEmptyOptNP (BlockForging m) xs -> BlockForging m (HardForkBlock xs) hardForkBlockForging :: forall (m :: * -> *) (xs :: [*]). (CanHardFork xs, Monad m) => Text -> NonEmptyOptNP (BlockForging m) xs -> BlockForging m (HardForkBlock xs) hardForkBlockForging Text label NonEmptyOptNP (BlockForging m) xs blockForging = BlockForging { forgeLabel :: Text forgeLabel = Text label , canBeLeader :: CanBeLeader (BlockProtocol (HardForkBlock xs)) canBeLeader = NonEmptyOptNP (BlockForging m) xs -> HardForkCanBeLeader xs forall (xs :: [*]) (m :: * -> *). CanHardFork xs => NonEmptyOptNP (BlockForging m) xs -> HardForkCanBeLeader xs hardForkCanBeLeader NonEmptyOptNP (BlockForging m) xs blockForging , updateForgeState :: TopLevelConfig (HardForkBlock xs) -> SlotNo -> Ticked (ChainDepState (BlockProtocol (HardForkBlock xs))) -> m (ForgeStateUpdateInfo (HardForkBlock xs)) updateForgeState = NonEmptyOptNP (BlockForging m) xs -> TopLevelConfig (HardForkBlock xs) -> SlotNo -> Ticked (HardForkChainDepState xs) -> m (ForgeStateUpdateInfo (HardForkBlock xs)) forall (m :: * -> *) (xs :: [*]). (CanHardFork xs, Monad m) => NonEmptyOptNP (BlockForging m) xs -> TopLevelConfig (HardForkBlock xs) -> SlotNo -> Ticked (HardForkChainDepState xs) -> m (ForgeStateUpdateInfo (HardForkBlock xs)) hardForkUpdateForgeState NonEmptyOptNP (BlockForging m) xs blockForging , checkCanForge :: TopLevelConfig (HardForkBlock xs) -> SlotNo -> Ticked (ChainDepState (BlockProtocol (HardForkBlock xs))) -> IsLeader (BlockProtocol (HardForkBlock xs)) -> ForgeStateInfo (HardForkBlock xs) -> Either (CannotForge (HardForkBlock xs)) () checkCanForge = NonEmptyOptNP (BlockForging m) xs -> TopLevelConfig (HardForkBlock xs) -> SlotNo -> Ticked (HardForkChainDepState xs) -> HardForkIsLeader xs -> HardForkForgeStateInfo xs -> Either (HardForkCannotForge xs) () forall (m :: * -> *) (xs :: [*]) (empty :: Bool). CanHardFork xs => OptNP empty (BlockForging m) xs -> TopLevelConfig (HardForkBlock xs) -> SlotNo -> Ticked (HardForkChainDepState xs) -> HardForkIsLeader xs -> HardForkForgeStateInfo xs -> Either (HardForkCannotForge xs) () hardForkCheckCanForge NonEmptyOptNP (BlockForging m) xs blockForging , forgeBlock :: TopLevelConfig (HardForkBlock xs) -> BlockNo -> SlotNo -> TickedLedgerState (HardForkBlock xs) -> [Validated (GenTx (HardForkBlock xs))] -> IsLeader (BlockProtocol (HardForkBlock xs)) -> m (HardForkBlock xs) forgeBlock = NonEmptyOptNP (BlockForging m) xs -> TopLevelConfig (HardForkBlock xs) -> BlockNo -> SlotNo -> TickedLedgerState (HardForkBlock xs) -> [Validated (GenTx (HardForkBlock xs))] -> HardForkIsLeader xs -> m (HardForkBlock xs) forall (m :: * -> *) (xs :: [*]) (empty :: Bool). (CanHardFork xs, Monad m) => OptNP empty (BlockForging m) xs -> TopLevelConfig (HardForkBlock xs) -> BlockNo -> SlotNo -> TickedLedgerState (HardForkBlock xs) -> [Validated (GenTx (HardForkBlock xs))] -> HardForkIsLeader xs -> m (HardForkBlock xs) hardForkForgeBlock NonEmptyOptNP (BlockForging m) xs blockForging } hardForkCanBeLeader :: CanHardFork xs => NonEmptyOptNP (BlockForging m) xs -> HardForkCanBeLeader xs hardForkCanBeLeader :: forall (xs :: [*]) (m :: * -> *). CanHardFork xs => NonEmptyOptNP (BlockForging m) xs -> HardForkCanBeLeader xs hardForkCanBeLeader = NonEmptyOptNP WrapCanBeLeader xs -> SomeErasCanBeLeader xs forall (xs :: [*]). NonEmptyOptNP WrapCanBeLeader xs -> SomeErasCanBeLeader xs SomeErasCanBeLeader (NonEmptyOptNP WrapCanBeLeader xs -> SomeErasCanBeLeader xs) -> (NonEmptyOptNP (BlockForging m) xs -> NonEmptyOptNP WrapCanBeLeader xs) -> NonEmptyOptNP (BlockForging m) xs -> SomeErasCanBeLeader xs forall b c a. (b -> c) -> (a -> b) -> a -> c . (forall a. BlockForging m a -> WrapCanBeLeader a) -> NonEmptyOptNP (BlockForging m) xs -> NonEmptyOptNP WrapCanBeLeader xs forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *) (f' :: k -> *). (SListIN (Prod h) xs, HAp h) => (forall (a :: k). f a -> f' a) -> h f xs -> h f' xs hmap (CanBeLeader (BlockProtocol a) -> WrapCanBeLeader a forall blk. CanBeLeader (BlockProtocol blk) -> WrapCanBeLeader blk WrapCanBeLeader (CanBeLeader (BlockProtocol a) -> WrapCanBeLeader a) -> (BlockForging m a -> CanBeLeader (BlockProtocol a)) -> BlockForging m a -> WrapCanBeLeader a forall b c a. (b -> c) -> (a -> b) -> a -> c . BlockForging m a -> CanBeLeader (BlockProtocol a) forall (m :: * -> *) blk. BlockForging m blk -> CanBeLeader (BlockProtocol blk) canBeLeader) -- | POSTCONDITION: the returned 'ForgeStateUpdateInfo' is from the same era as -- the ticked 'ChainDepState'. hardForkUpdateForgeState :: forall m xs. (CanHardFork xs, Monad m) => NonEmptyOptNP (BlockForging m) xs -> TopLevelConfig (HardForkBlock xs) -> SlotNo -> Ticked (HardForkChainDepState xs) -> m (ForgeStateUpdateInfo (HardForkBlock xs)) hardForkUpdateForgeState :: forall (m :: * -> *) (xs :: [*]). (CanHardFork xs, Monad m) => NonEmptyOptNP (BlockForging m) xs -> TopLevelConfig (HardForkBlock xs) -> SlotNo -> Ticked (HardForkChainDepState xs) -> m (ForgeStateUpdateInfo (HardForkBlock xs)) hardForkUpdateForgeState NonEmptyOptNP (BlockForging m) xs blockForging TopLevelConfig (HardForkBlock xs) cfg SlotNo curSlot (TickedHardForkChainDepState HardForkState (Ticked :.: WrapChainDepState) xs chainDepState EpochInfo (Except PastHorizonException) ei) = case NonEmptyOptNP (BlockForging m) xs -> ViewOptNP (BlockForging m) xs forall {k} (f :: k -> *) (xs :: [k]). NonEmptyOptNP f xs -> ViewOptNP f xs OptNP.view NonEmptyOptNP (BlockForging m) xs blockForging of OptNP_ExactlyOne BlockForging m x blockForging' -> ForgeStateUpdateInfo x -> ForgeStateUpdateInfo (HardForkBlock xs) ForgeStateUpdateInfo x -> ForgeStateUpdateInfo (HardForkBlock '[x]) forall blk. (xs ~ '[blk]) => ForgeStateUpdateInfo blk -> ForgeStateUpdateInfo (HardForkBlock '[blk]) injectSingle (ForgeStateUpdateInfo x -> ForgeStateUpdateInfo (HardForkBlock xs)) -> m (ForgeStateUpdateInfo x) -> m (ForgeStateUpdateInfo (HardForkBlock xs)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> BlockForging m x -> TopLevelConfig x -> SlotNo -> Ticked (ChainDepState (BlockProtocol x)) -> m (ForgeStateUpdateInfo x) forall (m :: * -> *) blk. BlockForging m blk -> TopLevelConfig blk -> SlotNo -> Ticked (ChainDepState (BlockProtocol blk)) -> m (ForgeStateUpdateInfo blk) updateForgeState BlockForging m x blockForging' (NP TopLevelConfig '[x] -> TopLevelConfig x forall {k} (f :: k -> *) (x :: k) (xs :: [k]). NP f (x : xs) -> f x hd (EpochInfo (Except PastHorizonException) -> TopLevelConfig (HardForkBlock '[x]) -> NP TopLevelConfig '[x] forall (xs :: [*]). All SingleEraBlock xs => EpochInfo (Except PastHorizonException) -> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs distribTopLevelConfig EpochInfo (Except PastHorizonException) ei TopLevelConfig (HardForkBlock xs) TopLevelConfig (HardForkBlock '[x]) cfg)) SlotNo curSlot (Ticked (WrapChainDepState x) -> Ticked (ChainDepState (BlockProtocol x)) forall blk. Ticked (WrapChainDepState blk) -> Ticked (ChainDepState (BlockProtocol blk)) unwrapTickedChainDepState (Ticked (WrapChainDepState x) -> Ticked (ChainDepState (BlockProtocol x))) -> (HardForkState (Ticked :.: WrapChainDepState) xs -> Ticked (WrapChainDepState x)) -> HardForkState (Ticked :.: WrapChainDepState) xs -> Ticked (ChainDepState (BlockProtocol x)) forall b c a. (b -> c) -> (a -> b) -> a -> c . (:.:) Ticked WrapChainDepState x -> Ticked (WrapChainDepState x) forall {l} {k} (f :: l -> *) (g :: k -> l) (p :: k). (:.:) f g p -> f (g p) unComp ((:.:) Ticked WrapChainDepState x -> Ticked (WrapChainDepState x)) -> (HardForkState (Ticked :.: WrapChainDepState) xs -> (:.:) Ticked WrapChainDepState x) -> HardForkState (Ticked :.: WrapChainDepState) xs -> Ticked (WrapChainDepState x) forall b c a. (b -> c) -> (a -> b) -> a -> c . HardForkState (Ticked :.: WrapChainDepState) xs -> (:.:) Ticked WrapChainDepState x HardForkState (Ticked :.: WrapChainDepState) '[x] -> (:.:) Ticked WrapChainDepState x forall (f :: * -> *) blk. HardForkState f '[blk] -> f blk State.fromTZ (HardForkState (Ticked :.: WrapChainDepState) xs -> Ticked (ChainDepState (BlockProtocol x))) -> HardForkState (Ticked :.: WrapChainDepState) xs -> Ticked (ChainDepState (BlockProtocol x)) forall a b. (a -> b) -> a -> b $ HardForkState (Ticked :.: WrapChainDepState) xs chainDepState) ViewOptNP (BlockForging m) xs OptNP_AtLeastTwo -> (NS (Maybe :.: ForgeStateUpdateInfo) xs -> ForgeStateUpdateInfo (HardForkBlock xs)) -> m (NS (Maybe :.: ForgeStateUpdateInfo) xs) -> m (ForgeStateUpdateInfo (HardForkBlock xs)) forall a b. (a -> b) -> m a -> m b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap NS (Maybe :.: ForgeStateUpdateInfo) xs -> ForgeStateUpdateInfo (HardForkBlock xs) forall x y (zs :: [*]). (xs ~ (x : y : zs)) => NS (Maybe :.: ForgeStateUpdateInfo) xs -> ForgeStateUpdateInfo (HardForkBlock xs) undistrib (m (NS (Maybe :.: ForgeStateUpdateInfo) xs) -> m (ForgeStateUpdateInfo (HardForkBlock xs))) -> m (NS (Maybe :.: ForgeStateUpdateInfo) xs) -> m (ForgeStateUpdateInfo (HardForkBlock xs)) forall a b. (a -> b) -> a -> b $ NS (m :.: (Maybe :.: ForgeStateUpdateInfo)) xs -> m (NS (Maybe :.: ForgeStateUpdateInfo) xs) forall (xs :: [*]) (f :: * -> *) (g :: * -> *). (SListIN NS xs, Applicative f) => NS (f :.: g) xs -> f (NS g xs) forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: * -> *) (g :: k -> *). (HSequence h, SListIN h xs, Applicative f) => h (f :.: g) xs -> f (h g xs) hsequence' (NS (m :.: (Maybe :.: ForgeStateUpdateInfo)) xs -> m (NS (Maybe :.: ForgeStateUpdateInfo) xs)) -> NS (m :.: (Maybe :.: ForgeStateUpdateInfo)) xs -> m (NS (Maybe :.: ForgeStateUpdateInfo) xs) forall a b. (a -> b) -> a -> b $ (forall a. (:.:) Maybe (BlockForging m) a -> TopLevelConfig a -> (:.:) Ticked WrapChainDepState a -> (:.:) m (Maybe :.: ForgeStateUpdateInfo) a) -> Prod NS (Maybe :.: BlockForging m) xs -> Prod NS TopLevelConfig xs -> NS (Ticked :.: WrapChainDepState) xs -> NS (m :.: (Maybe :.: ForgeStateUpdateInfo)) xs forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *) (f' :: k -> *) (f'' :: k -> *) (f''' :: k -> *). (SListIN (Prod h) xs, HAp h, HAp (Prod h)) => (forall (a :: k). f a -> f' a -> f'' a -> f''' a) -> Prod h f xs -> Prod h f' xs -> h f'' xs -> h f''' xs hzipWith3 (:.:) Maybe (BlockForging m) a -> TopLevelConfig a -> (:.:) Ticked WrapChainDepState a -> (:.:) m (Maybe :.: ForgeStateUpdateInfo) a forall a. (:.:) Maybe (BlockForging m) a -> TopLevelConfig a -> (:.:) Ticked WrapChainDepState a -> (:.:) m (Maybe :.: ForgeStateUpdateInfo) a aux (NonEmptyOptNP (BlockForging m) xs -> NP (Maybe :.: BlockForging m) xs forall {k} (empty :: Bool) (f :: k -> *) (xs :: [k]). OptNP empty f xs -> NP (Maybe :.: f) xs OptNP.toNP NonEmptyOptNP (BlockForging m) xs blockForging) (EpochInfo (Except PastHorizonException) -> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs forall (xs :: [*]). All SingleEraBlock xs => EpochInfo (Except PastHorizonException) -> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs distribTopLevelConfig EpochInfo (Except PastHorizonException) ei TopLevelConfig (HardForkBlock xs) cfg) (NS (Ticked :.: WrapChainDepState) xs -> NS (m :.: (Maybe :.: ForgeStateUpdateInfo)) xs) -> NS (Ticked :.: WrapChainDepState) xs -> NS (m :.: (Maybe :.: ForgeStateUpdateInfo)) xs forall a b. (a -> b) -> a -> b $ HardForkState (Ticked :.: WrapChainDepState) xs -> NS (Ticked :.: WrapChainDepState) xs forall (xs :: [*]) (f :: * -> *). SListI xs => HardForkState f xs -> NS f xs State.tip HardForkState (Ticked :.: WrapChainDepState) xs chainDepState where injectSingle :: xs ~ '[blk] => ForgeStateUpdateInfo blk -> ForgeStateUpdateInfo (HardForkBlock '[blk]) injectSingle :: forall blk. (xs ~ '[blk]) => ForgeStateUpdateInfo blk -> ForgeStateUpdateInfo (HardForkBlock '[blk]) injectSingle ForgeStateUpdateInfo blk forgeStateUpdateInfo = case ForgeStateUpdateInfo blk forgeStateUpdateInfo of ForgeStateUpdated ForgeStateInfo blk info -> ForgeStateInfo (HardForkBlock '[blk]) -> ForgeStateUpdateInfo (HardForkBlock '[blk]) forall blk. ForgeStateInfo blk -> ForgeStateUpdateInfo blk ForgeStateUpdated (ForgeStateInfo (HardForkBlock '[blk]) -> ForgeStateUpdateInfo (HardForkBlock '[blk])) -> ForgeStateInfo (HardForkBlock '[blk]) -> ForgeStateUpdateInfo (HardForkBlock '[blk]) forall a b. (a -> b) -> a -> b $ Index xs blk -> ForgeStateInfo blk -> ForgeStateInfo (HardForkBlock xs) forall blk. Index xs blk -> ForgeStateInfo blk -> ForgeStateInfo (HardForkBlock xs) injInfo Index xs blk Index '[blk] blk forall blk. Index '[blk] blk index ForgeStateInfo blk info ForgeStateUpdateFailed ForgeStateUpdateError blk err -> ForgeStateUpdateError (HardForkBlock '[blk]) -> ForgeStateUpdateInfo (HardForkBlock '[blk]) forall blk. ForgeStateUpdateError blk -> ForgeStateUpdateInfo blk ForgeStateUpdateFailed (ForgeStateUpdateError (HardForkBlock '[blk]) -> ForgeStateUpdateInfo (HardForkBlock '[blk])) -> ForgeStateUpdateError (HardForkBlock '[blk]) -> ForgeStateUpdateInfo (HardForkBlock '[blk]) forall a b. (a -> b) -> a -> b $ Index xs blk -> ForgeStateUpdateError blk -> ForgeStateUpdateError (HardForkBlock xs) forall blk. Index xs blk -> ForgeStateUpdateError blk -> ForgeStateUpdateError (HardForkBlock xs) injUpdateError Index xs blk Index '[blk] blk forall blk. Index '[blk] blk index ForgeStateUpdateError blk err ForgeStateUpdateInfo blk ForgeStateUpdateSuppressed -> ForgeStateUpdateInfo (HardForkBlock '[blk]) forall blk. ForgeStateUpdateInfo blk ForgeStateUpdateSuppressed where index :: Index '[blk] blk index :: forall blk. Index '[blk] blk index = Index '[blk] blk forall {k} (x :: k) (xs1 :: [k]). Index (x : xs1) x IZ aux :: (Maybe :.: BlockForging m) blk -> TopLevelConfig blk -> (Ticked :.: WrapChainDepState) blk -> (m :.: (Maybe :.: ForgeStateUpdateInfo)) blk aux :: forall a. (:.:) Maybe (BlockForging m) a -> TopLevelConfig a -> (:.:) Ticked WrapChainDepState a -> (:.:) m (Maybe :.: ForgeStateUpdateInfo) a aux (Comp Maybe (BlockForging m blk) mBlockForging) TopLevelConfig blk cfg' (Comp Ticked (WrapChainDepState blk) chainDepState') = m ((:.:) Maybe ForgeStateUpdateInfo blk) -> (:.:) m (Maybe :.: ForgeStateUpdateInfo) blk forall l k (f :: l -> *) (g :: k -> l) (p :: k). f (g p) -> (:.:) f g p Comp (m ((:.:) Maybe ForgeStateUpdateInfo blk) -> (:.:) m (Maybe :.: ForgeStateUpdateInfo) blk) -> m ((:.:) Maybe ForgeStateUpdateInfo blk) -> (:.:) m (Maybe :.: ForgeStateUpdateInfo) blk forall a b. (a -> b) -> a -> b $ (Maybe (ForgeStateUpdateInfo blk) -> (:.:) Maybe ForgeStateUpdateInfo blk) -> m (Maybe (ForgeStateUpdateInfo blk)) -> m ((:.:) Maybe ForgeStateUpdateInfo blk) forall a b. (a -> b) -> m a -> m b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap Maybe (ForgeStateUpdateInfo blk) -> (:.:) Maybe ForgeStateUpdateInfo blk forall l k (f :: l -> *) (g :: k -> l) (p :: k). f (g p) -> (:.:) f g p Comp (m (Maybe (ForgeStateUpdateInfo blk)) -> m ((:.:) Maybe ForgeStateUpdateInfo blk)) -> m (Maybe (ForgeStateUpdateInfo blk)) -> m ((:.:) Maybe ForgeStateUpdateInfo blk) forall a b. (a -> b) -> a -> b $ case Maybe (BlockForging m blk) mBlockForging of Maybe (BlockForging m blk) Nothing -> Maybe (ForgeStateUpdateInfo blk) -> m (Maybe (ForgeStateUpdateInfo blk)) forall a. a -> m a forall (m :: * -> *) a. Monad m => a -> m a return Maybe (ForgeStateUpdateInfo blk) forall a. Maybe a Nothing Just BlockForging m blk blockForging' -> ForgeStateUpdateInfo blk -> Maybe (ForgeStateUpdateInfo blk) forall a. a -> Maybe a Just (ForgeStateUpdateInfo blk -> Maybe (ForgeStateUpdateInfo blk)) -> m (ForgeStateUpdateInfo blk) -> m (Maybe (ForgeStateUpdateInfo blk)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> BlockForging m blk -> TopLevelConfig blk -> SlotNo -> Ticked (ChainDepState (BlockProtocol blk)) -> m (ForgeStateUpdateInfo blk) forall (m :: * -> *) blk. BlockForging m blk -> TopLevelConfig blk -> SlotNo -> Ticked (ChainDepState (BlockProtocol blk)) -> m (ForgeStateUpdateInfo blk) updateForgeState BlockForging m blk blockForging' TopLevelConfig blk cfg' SlotNo curSlot (Ticked (WrapChainDepState blk) -> Ticked (ChainDepState (BlockProtocol blk)) forall blk. Ticked (WrapChainDepState blk) -> Ticked (ChainDepState (BlockProtocol blk)) unwrapTickedChainDepState Ticked (WrapChainDepState blk) chainDepState') injInfo :: Index xs blk -> ForgeStateInfo blk -> ForgeStateInfo (HardForkBlock xs) injInfo :: forall blk. Index xs blk -> ForgeStateInfo blk -> ForgeStateInfo (HardForkBlock xs) injInfo Index xs blk index = OneEraForgeStateInfo xs -> HardForkForgeStateInfo xs forall (xs :: [*]). OneEraForgeStateInfo xs -> HardForkForgeStateInfo xs CurrentEraForgeStateUpdated (OneEraForgeStateInfo xs -> HardForkForgeStateInfo xs) -> (ForgeStateInfo blk -> OneEraForgeStateInfo xs) -> ForgeStateInfo blk -> HardForkForgeStateInfo xs forall b c a. (b -> c) -> (a -> b) -> a -> c . NS WrapForgeStateInfo xs -> OneEraForgeStateInfo xs forall (xs :: [*]). NS WrapForgeStateInfo xs -> OneEraForgeStateInfo xs OneEraForgeStateInfo (NS WrapForgeStateInfo xs -> OneEraForgeStateInfo xs) -> (ForgeStateInfo blk -> NS WrapForgeStateInfo xs) -> ForgeStateInfo blk -> OneEraForgeStateInfo xs forall b c a. (b -> c) -> (a -> b) -> a -> c . Index xs blk -> WrapForgeStateInfo blk -> NS WrapForgeStateInfo xs forall {k} (f :: k -> *) (x :: k) (xs :: [k]). Index xs x -> f x -> NS f xs injectNS Index xs blk index (WrapForgeStateInfo blk -> NS WrapForgeStateInfo xs) -> (ForgeStateInfo blk -> WrapForgeStateInfo blk) -> ForgeStateInfo blk -> NS WrapForgeStateInfo xs forall b c a. (b -> c) -> (a -> b) -> a -> c . ForgeStateInfo blk -> WrapForgeStateInfo blk forall blk. ForgeStateInfo blk -> WrapForgeStateInfo blk WrapForgeStateInfo injUpdateError :: Index xs blk -> ForgeStateUpdateError blk -> ForgeStateUpdateError (HardForkBlock xs) injUpdateError :: forall blk. Index xs blk -> ForgeStateUpdateError blk -> ForgeStateUpdateError (HardForkBlock xs) injUpdateError Index xs blk index = NS WrapForgeStateUpdateError xs -> OneEraForgeStateUpdateError xs forall (xs :: [*]). NS WrapForgeStateUpdateError xs -> OneEraForgeStateUpdateError xs OneEraForgeStateUpdateError (NS WrapForgeStateUpdateError xs -> OneEraForgeStateUpdateError xs) -> (ForgeStateUpdateError blk -> NS WrapForgeStateUpdateError xs) -> ForgeStateUpdateError blk -> OneEraForgeStateUpdateError xs forall b c a. (b -> c) -> (a -> b) -> a -> c . Index xs blk -> WrapForgeStateUpdateError blk -> NS WrapForgeStateUpdateError xs forall {k} (f :: k -> *) (x :: k) (xs :: [k]). Index xs x -> f x -> NS f xs injectNS Index xs blk index (WrapForgeStateUpdateError blk -> NS WrapForgeStateUpdateError xs) -> (ForgeStateUpdateError blk -> WrapForgeStateUpdateError blk) -> ForgeStateUpdateError blk -> NS WrapForgeStateUpdateError xs forall b c a. (b -> c) -> (a -> b) -> a -> c . ForgeStateUpdateError blk -> WrapForgeStateUpdateError blk forall blk. ForgeStateUpdateError blk -> WrapForgeStateUpdateError blk WrapForgeStateUpdateError undistrib :: xs ~ (x ': y ': zs) => NS (Maybe :.: ForgeStateUpdateInfo) xs -> ForgeStateUpdateInfo (HardForkBlock xs) undistrib :: forall x y (zs :: [*]). (xs ~ (x : y : zs)) => NS (Maybe :.: ForgeStateUpdateInfo) xs -> ForgeStateUpdateInfo (HardForkBlock xs) undistrib = NS (K (ForgeStateUpdateInfo (HardForkBlock (x : y : zs)))) xs -> CollapseTo NS (ForgeStateUpdateInfo (HardForkBlock (x : y : zs))) NS (K (ForgeStateUpdateInfo (HardForkBlock (x : y : zs)))) xs -> ForgeStateUpdateInfo (HardForkBlock xs) forall (xs :: [*]) a. SListIN NS xs => NS (K a) xs -> CollapseTo NS a forall k l (h :: (k -> *) -> l -> *) (xs :: l) a. (HCollapse h, SListIN h xs) => h (K a) xs -> CollapseTo h a hcollapse (NS (K (ForgeStateUpdateInfo (HardForkBlock (x : y : zs)))) xs -> ForgeStateUpdateInfo (HardForkBlock xs)) -> (NS (Maybe :.: ForgeStateUpdateInfo) xs -> NS (K (ForgeStateUpdateInfo (HardForkBlock (x : y : zs)))) xs) -> NS (Maybe :.: ForgeStateUpdateInfo) xs -> ForgeStateUpdateInfo (HardForkBlock xs) forall b c a. (b -> c) -> (a -> b) -> a -> c . (forall a. Index xs a -> (:.:) Maybe ForgeStateUpdateInfo a -> K (ForgeStateUpdateInfo (HardForkBlock (x : y : zs))) a) -> NS (Maybe :.: ForgeStateUpdateInfo) xs -> NS (K (ForgeStateUpdateInfo (HardForkBlock (x : y : zs)))) xs forall {k} (h :: (k -> *) -> [k] -> *) (xs :: [k]) (f1 :: k -> *) (f2 :: k -> *). (HAp h, SListI xs, Prod h ~ NP) => (forall (a :: k). Index xs a -> f1 a -> f2 a) -> h f1 xs -> h f2 xs himap Index xs a -> (:.:) Maybe ForgeStateUpdateInfo a -> K (ForgeStateUpdateInfo (HardForkBlock xs)) a Index xs a -> (:.:) Maybe ForgeStateUpdateInfo a -> K (ForgeStateUpdateInfo (HardForkBlock (x : y : zs))) a forall blk. Index xs blk -> (:.:) Maybe ForgeStateUpdateInfo blk -> K (ForgeStateUpdateInfo (HardForkBlock xs)) blk forall a. Index xs a -> (:.:) Maybe ForgeStateUpdateInfo a -> K (ForgeStateUpdateInfo (HardForkBlock (x : y : zs))) a inj where inj :: forall blk. Index xs blk -> (Maybe :.: ForgeStateUpdateInfo) blk -> K (ForgeStateUpdateInfo (HardForkBlock xs)) blk inj :: forall blk. Index xs blk -> (:.:) Maybe ForgeStateUpdateInfo blk -> K (ForgeStateUpdateInfo (HardForkBlock xs)) blk inj Index xs blk index (Comp Maybe (ForgeStateUpdateInfo blk) mForgeStateUpdateInfo) = ForgeStateUpdateInfo (HardForkBlock xs) -> K (ForgeStateUpdateInfo (HardForkBlock xs)) blk forall k a (b :: k). a -> K a b K (ForgeStateUpdateInfo (HardForkBlock xs) -> K (ForgeStateUpdateInfo (HardForkBlock xs)) blk) -> ForgeStateUpdateInfo (HardForkBlock xs) -> K (ForgeStateUpdateInfo (HardForkBlock xs)) blk forall a b. (a -> b) -> a -> b $ case Maybe (ForgeStateUpdateInfo blk) mForgeStateUpdateInfo of Maybe (ForgeStateUpdateInfo blk) Nothing -> ForgeStateInfo (HardForkBlock xs) -> ForgeStateUpdateInfo (HardForkBlock xs) forall blk. ForgeStateInfo blk -> ForgeStateUpdateInfo blk ForgeStateUpdated (ForgeStateInfo (HardForkBlock xs) -> ForgeStateUpdateInfo (HardForkBlock xs)) -> ForgeStateInfo (HardForkBlock xs) -> ForgeStateUpdateInfo (HardForkBlock xs) forall a b. (a -> b) -> a -> b $ EraIndex (x : y : zs) -> HardForkForgeStateInfo (x : y : zs) forall x y (xs :: [*]). EraIndex (x : y : xs) -> HardForkForgeStateInfo (x : y : xs) CurrentEraLacksBlockForging (EraIndex (x : y : zs) -> HardForkForgeStateInfo (x : y : zs)) -> EraIndex (x : y : zs) -> HardForkForgeStateInfo (x : y : zs) forall a b. (a -> b) -> a -> b $ Index (x : y : zs) blk -> EraIndex (x : y : zs) forall (xs :: [*]) blk. Index xs blk -> EraIndex xs eraIndexFromIndex Index xs blk Index (x : y : zs) blk index Just ForgeStateUpdateInfo blk forgeStateUpdateInfo -> case ForgeStateUpdateInfo blk forgeStateUpdateInfo of ForgeStateUpdated ForgeStateInfo blk info -> ForgeStateInfo (HardForkBlock xs) -> ForgeStateUpdateInfo (HardForkBlock xs) forall blk. ForgeStateInfo blk -> ForgeStateUpdateInfo blk ForgeStateUpdated (ForgeStateInfo (HardForkBlock xs) -> ForgeStateUpdateInfo (HardForkBlock xs)) -> ForgeStateInfo (HardForkBlock xs) -> ForgeStateUpdateInfo (HardForkBlock xs) forall a b. (a -> b) -> a -> b $ Index xs blk -> ForgeStateInfo blk -> ForgeStateInfo (HardForkBlock xs) forall blk. Index xs blk -> ForgeStateInfo blk -> ForgeStateInfo (HardForkBlock xs) injInfo Index xs blk index ForgeStateInfo blk info ForgeStateUpdateFailed ForgeStateUpdateError blk err -> ForgeStateUpdateError (HardForkBlock xs) -> ForgeStateUpdateInfo (HardForkBlock xs) forall blk. ForgeStateUpdateError blk -> ForgeStateUpdateInfo blk ForgeStateUpdateFailed (ForgeStateUpdateError (HardForkBlock xs) -> ForgeStateUpdateInfo (HardForkBlock xs)) -> ForgeStateUpdateError (HardForkBlock xs) -> ForgeStateUpdateInfo (HardForkBlock xs) forall a b. (a -> b) -> a -> b $ Index xs blk -> ForgeStateUpdateError blk -> ForgeStateUpdateError (HardForkBlock xs) forall blk. Index xs blk -> ForgeStateUpdateError blk -> ForgeStateUpdateError (HardForkBlock xs) injUpdateError Index xs blk index ForgeStateUpdateError blk err ForgeStateUpdateInfo blk ForgeStateUpdateSuppressed -> ForgeStateUpdateInfo (HardForkBlock xs) forall blk. ForgeStateUpdateInfo blk ForgeStateUpdateSuppressed -- | PRECONDITION: the ticked 'ChainDepState', the 'HardForkIsLeader', and the -- 'HardForkStateInfo' are all from the same era, and we must have a -- 'BlockForging' for that era. -- -- This follows from the postconditions of 'check' and -- 'hardForkUpdateForgeState'. hardForkCheckCanForge :: forall m xs empty. CanHardFork xs => OptNP empty (BlockForging m) xs -> TopLevelConfig (HardForkBlock xs) -> SlotNo -> Ticked (HardForkChainDepState xs) -> HardForkIsLeader xs -> HardForkForgeStateInfo xs -> Either (HardForkCannotForge xs) () hardForkCheckCanForge :: forall (m :: * -> *) (xs :: [*]) (empty :: Bool). CanHardFork xs => OptNP empty (BlockForging m) xs -> TopLevelConfig (HardForkBlock xs) -> SlotNo -> Ticked (HardForkChainDepState xs) -> HardForkIsLeader xs -> HardForkForgeStateInfo xs -> Either (HardForkCannotForge xs) () hardForkCheckCanForge OptNP empty (BlockForging m) xs blockForging TopLevelConfig (HardForkBlock xs) cfg SlotNo curSlot (TickedHardForkChainDepState HardForkState (Ticked :.: WrapChainDepState) xs chainDepState EpochInfo (Except PastHorizonException) ei) HardForkIsLeader xs isLeader HardForkForgeStateInfo xs forgeStateInfo = NS (Maybe :.: WrapCannotForge) xs -> Either (HardForkCannotForge xs) () distrib (NS (Maybe :.: WrapCannotForge) xs -> Either (HardForkCannotForge xs) ()) -> NS (Maybe :.: WrapCannotForge) xs -> Either (HardForkCannotForge xs) () forall a b. (a -> b) -> a -> b $ (forall a. Index xs a -> TopLevelConfig a -> (:.:) Maybe (BlockForging m) a -> Product WrapForgeStateInfo (Product WrapIsLeader (Ticked :.: WrapChainDepState)) a -> (:.:) Maybe WrapCannotForge a) -> NP TopLevelConfig xs -> NP (Maybe :.: BlockForging m) xs -> NS (Product WrapForgeStateInfo (Product WrapIsLeader (Ticked :.: WrapChainDepState))) xs -> NS (Maybe :.: WrapCannotForge) xs forall {k} (h :: (k -> *) -> [k] -> *) (xs :: [k]) (f1 :: k -> *) (f2 :: k -> *) (f3 :: k -> *) (f4 :: k -> *). (HAp h, SListI xs, Prod h ~ NP) => (forall (a :: k). Index xs a -> f1 a -> f2 a -> f3 a -> f4 a) -> NP f1 xs -> NP f2 xs -> h f3 xs -> h f4 xs hizipWith3 Index xs a -> TopLevelConfig a -> (:.:) Maybe (BlockForging m) a -> Product WrapForgeStateInfo (Product WrapIsLeader (Ticked :.: WrapChainDepState)) a -> (:.:) Maybe WrapCannotForge a forall a. Index xs a -> TopLevelConfig a -> (:.:) Maybe (BlockForging m) a -> Product WrapForgeStateInfo (Product WrapIsLeader (Ticked :.: WrapChainDepState)) a -> (:.:) Maybe WrapCannotForge a checkOne (EpochInfo (Except PastHorizonException) -> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs forall (xs :: [*]). All SingleEraBlock xs => EpochInfo (Except PastHorizonException) -> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs distribTopLevelConfig EpochInfo (Except PastHorizonException) ei TopLevelConfig (HardForkBlock xs) cfg) (OptNP empty (BlockForging m) xs -> NP (Maybe :.: BlockForging m) xs forall {k} (empty :: Bool) (f :: k -> *) (xs :: [k]). OptNP empty f xs -> NP (Maybe :.: f) xs OptNP.toNP OptNP empty (BlockForging m) xs blockForging) -- We know all three NSs must be from the same era, because they were -- all produced from the same 'BlockForging'. Unfortunately, we can't -- enforce it statically. ( String -> NS WrapForgeStateInfo xs -> NS (Product WrapIsLeader (Ticked :.: WrapChainDepState)) xs -> NS (Product WrapForgeStateInfo (Product WrapIsLeader (Ticked :.: WrapChainDepState))) xs forall {k} (f :: k -> *) (g :: k -> *) (xs :: [k]). HasCallStack => String -> NS f xs -> NS g xs -> NS (Product f g) xs Match.mustMatchNS String "ForgeStateInfo" NS WrapForgeStateInfo xs forgeStateInfo' (NS (Product WrapIsLeader (Ticked :.: WrapChainDepState)) xs -> NS (Product WrapForgeStateInfo (Product WrapIsLeader (Ticked :.: WrapChainDepState))) xs) -> NS (Product WrapIsLeader (Ticked :.: WrapChainDepState)) xs -> NS (Product WrapForgeStateInfo (Product WrapIsLeader (Ticked :.: WrapChainDepState))) xs forall a b. (a -> b) -> a -> b $ String -> NS WrapIsLeader xs -> NS (Ticked :.: WrapChainDepState) xs -> NS (Product WrapIsLeader (Ticked :.: WrapChainDepState)) xs forall {k} (f :: k -> *) (g :: k -> *) (xs :: [k]). HasCallStack => String -> NS f xs -> NS g xs -> NS (Product f g) xs Match.mustMatchNS String "IsLeader" (HardForkIsLeader xs -> NS WrapIsLeader xs forall (xs :: [*]). OneEraIsLeader xs -> NS WrapIsLeader xs getOneEraIsLeader HardForkIsLeader xs isLeader) (NS (Ticked :.: WrapChainDepState) xs -> NS (Product WrapIsLeader (Ticked :.: WrapChainDepState)) xs) -> NS (Ticked :.: WrapChainDepState) xs -> NS (Product WrapIsLeader (Ticked :.: WrapChainDepState)) xs forall a b. (a -> b) -> a -> b $ HardForkState (Ticked :.: WrapChainDepState) xs -> NS (Ticked :.: WrapChainDepState) xs forall (xs :: [*]) (f :: * -> *). SListI xs => HardForkState f xs -> NS f xs State.tip HardForkState (Ticked :.: WrapChainDepState) xs chainDepState ) where distrib :: NS (Maybe :.: WrapCannotForge) xs -> Either (HardForkCannotForge xs) () distrib :: NS (Maybe :.: WrapCannotForge) xs -> Either (HardForkCannotForge xs) () distrib = Either (HardForkCannotForge xs) () -> (NS WrapCannotForge xs -> Either (HardForkCannotForge xs) ()) -> Maybe (NS WrapCannotForge xs) -> Either (HardForkCannotForge xs) () forall b a. b -> (a -> b) -> Maybe a -> b maybe (() -> Either (HardForkCannotForge xs) () forall a b. b -> Either a b Right ()) (HardForkCannotForge xs -> Either (HardForkCannotForge xs) () forall a b. a -> Either a b Left (HardForkCannotForge xs -> Either (HardForkCannotForge xs) ()) -> (NS WrapCannotForge xs -> HardForkCannotForge xs) -> NS WrapCannotForge xs -> Either (HardForkCannotForge xs) () forall b c a. (b -> c) -> (a -> b) -> a -> c . NS WrapCannotForge xs -> HardForkCannotForge xs forall (xs :: [*]). NS WrapCannotForge xs -> OneEraCannotForge xs OneEraCannotForge) (Maybe (NS WrapCannotForge xs) -> Either (HardForkCannotForge xs) ()) -> (NS (Maybe :.: WrapCannotForge) xs -> Maybe (NS WrapCannotForge xs)) -> NS (Maybe :.: WrapCannotForge) xs -> Either (HardForkCannotForge xs) () forall b c a. (b -> c) -> (a -> b) -> a -> c . NS (Maybe :.: WrapCannotForge) xs -> Maybe (NS WrapCannotForge xs) forall (xs :: [*]) (f :: * -> *) (g :: * -> *). (SListIN NS xs, Applicative f) => NS (f :.: g) xs -> f (NS g xs) forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: * -> *) (g :: k -> *). (HSequence h, SListIN h xs, Applicative f) => h (f :.: g) xs -> f (h g xs) hsequence' missingBlockForgingImpossible :: EraIndex xs -> String missingBlockForgingImpossible :: EraIndex xs -> String missingBlockForgingImpossible EraIndex xs eraIndex = String "impossible: current era lacks block forging but we have an IsLeader proof " String -> ShowS forall a. Semigroup a => a -> a -> a <> EraIndex xs -> String forall a. Show a => a -> String show EraIndex xs eraIndex forgeStateInfo' :: NS WrapForgeStateInfo xs forgeStateInfo' :: NS WrapForgeStateInfo xs forgeStateInfo' = case HardForkForgeStateInfo xs forgeStateInfo of CurrentEraForgeStateUpdated OneEraForgeStateInfo xs info -> OneEraForgeStateInfo xs -> NS WrapForgeStateInfo xs forall (xs :: [*]). OneEraForgeStateInfo xs -> NS WrapForgeStateInfo xs getOneEraForgeStateInfo OneEraForgeStateInfo xs info CurrentEraLacksBlockForging EraIndex (x : y : xs) eraIndex -> String -> NS WrapForgeStateInfo xs forall a. HasCallStack => String -> a error (String -> NS WrapForgeStateInfo xs) -> String -> NS WrapForgeStateInfo xs forall a b. (a -> b) -> a -> b $ EraIndex xs -> String missingBlockForgingImpossible EraIndex xs EraIndex (x : y : xs) eraIndex checkOne :: Index xs blk -> TopLevelConfig blk -> (Maybe :.: BlockForging m) blk -> Product WrapForgeStateInfo (Product WrapIsLeader (Ticked :.: WrapChainDepState)) blk -> (Maybe :.: WrapCannotForge) blk -- ^ We use @Maybe x@ instead of @Either x ()@ because the former can -- be partially applied. checkOne :: forall a. Index xs a -> TopLevelConfig a -> (:.:) Maybe (BlockForging m) a -> Product WrapForgeStateInfo (Product WrapIsLeader (Ticked :.: WrapChainDepState)) a -> (:.:) Maybe WrapCannotForge a checkOne Index xs blk index TopLevelConfig blk cfg' (Comp Maybe (BlockForging m blk) mBlockForging') (Pair (WrapForgeStateInfo ForgeStateInfo blk forgeStateInfo'') (Pair (WrapIsLeader IsLeader (BlockProtocol blk) isLeader') (Comp Ticked (WrapChainDepState blk) tickedChainDepState))) = Maybe (WrapCannotForge blk) -> (:.:) Maybe WrapCannotForge blk forall l k (f :: l -> *) (g :: k -> l) (p :: k). f (g p) -> (:.:) f g p Comp (Maybe (WrapCannotForge blk) -> (:.:) Maybe WrapCannotForge blk) -> Maybe (WrapCannotForge blk) -> (:.:) Maybe WrapCannotForge blk forall a b. (a -> b) -> a -> b $ (CannotForge blk -> Maybe (WrapCannotForge blk)) -> (() -> Maybe (WrapCannotForge blk)) -> Either (CannotForge blk) () -> Maybe (WrapCannotForge blk) forall a c b. (a -> c) -> (b -> c) -> Either a b -> c either (WrapCannotForge blk -> Maybe (WrapCannotForge blk) forall a. a -> Maybe a Just (WrapCannotForge blk -> Maybe (WrapCannotForge blk)) -> (CannotForge blk -> WrapCannotForge blk) -> CannotForge blk -> Maybe (WrapCannotForge blk) forall b c a. (b -> c) -> (a -> b) -> a -> c . CannotForge blk -> WrapCannotForge blk forall blk. CannotForge blk -> WrapCannotForge blk WrapCannotForge) (Maybe (WrapCannotForge blk) -> () -> Maybe (WrapCannotForge blk) forall a b. a -> b -> a const Maybe (WrapCannotForge blk) forall a. Maybe a Nothing) (Either (CannotForge blk) () -> Maybe (WrapCannotForge blk)) -> Either (CannotForge blk) () -> Maybe (WrapCannotForge blk) forall a b. (a -> b) -> a -> b $ BlockForging m blk -> TopLevelConfig blk -> SlotNo -> Ticked (ChainDepState (BlockProtocol blk)) -> IsLeader (BlockProtocol blk) -> ForgeStateInfo blk -> Either (CannotForge blk) () forall (m :: * -> *) blk. BlockForging m blk -> TopLevelConfig blk -> SlotNo -> Ticked (ChainDepState (BlockProtocol blk)) -> IsLeader (BlockProtocol blk) -> ForgeStateInfo blk -> Either (CannotForge blk) () checkCanForge (BlockForging m blk -> Maybe (BlockForging m blk) -> BlockForging m blk forall a. a -> Maybe a -> a fromMaybe (String -> BlockForging m blk forall a. HasCallStack => String -> a error (EraIndex xs -> String missingBlockForgingImpossible (Index xs blk -> EraIndex xs forall (xs :: [*]) blk. Index xs blk -> EraIndex xs eraIndexFromIndex Index xs blk index))) Maybe (BlockForging m blk) mBlockForging') TopLevelConfig blk cfg' SlotNo curSlot (Ticked (WrapChainDepState blk) -> Ticked (ChainDepState (BlockProtocol blk)) forall blk. Ticked (WrapChainDepState blk) -> Ticked (ChainDepState (BlockProtocol blk)) unwrapTickedChainDepState Ticked (WrapChainDepState blk) tickedChainDepState) IsLeader (BlockProtocol blk) isLeader' ForgeStateInfo blk forgeStateInfo'' -- | PRECONDITION: the ticked 'LedgerState' and 'HardForkIsLeader' are from the -- same era, and we must have a 'BlockForging' for that era. -- -- This follows from the postcondition of 'check' and the fact that the ticked -- 'ChainDepState' and ticked 'LedgerState' are from the same era. hardForkForgeBlock :: forall m xs empty. (CanHardFork xs, Monad m) => OptNP empty (BlockForging m) xs -> TopLevelConfig (HardForkBlock xs) -> BlockNo -> SlotNo -> TickedLedgerState (HardForkBlock xs) -> [Validated (GenTx (HardForkBlock xs))] -> HardForkIsLeader xs -> m (HardForkBlock xs) hardForkForgeBlock :: forall (m :: * -> *) (xs :: [*]) (empty :: Bool). (CanHardFork xs, Monad m) => OptNP empty (BlockForging m) xs -> TopLevelConfig (HardForkBlock xs) -> BlockNo -> SlotNo -> TickedLedgerState (HardForkBlock xs) -> [Validated (GenTx (HardForkBlock xs))] -> HardForkIsLeader xs -> m (HardForkBlock xs) hardForkForgeBlock OptNP empty (BlockForging m) xs blockForging TopLevelConfig (HardForkBlock xs) cfg BlockNo bno SlotNo sno (TickedHardForkLedgerState TransitionInfo transition HardForkState (Ticked :.: LedgerState) xs ledgerState) [Validated (GenTx (HardForkBlock xs))] txs HardForkIsLeader xs isLeader = (NS I xs -> HardForkBlock xs) -> m (NS I xs) -> m (HardForkBlock xs) forall a b. (a -> b) -> m a -> m b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (OneEraBlock xs -> HardForkBlock xs forall (xs :: [*]). OneEraBlock xs -> HardForkBlock xs HardForkBlock (OneEraBlock xs -> HardForkBlock xs) -> (NS I xs -> OneEraBlock xs) -> NS I xs -> HardForkBlock xs forall b c a. (b -> c) -> (a -> b) -> a -> c . NS I xs -> OneEraBlock xs forall (xs :: [*]). NS I xs -> OneEraBlock xs OneEraBlock) (m (NS I xs) -> m (HardForkBlock xs)) -> m (NS I xs) -> m (HardForkBlock xs) forall a b. (a -> b) -> a -> b $ NS m xs -> m (NS I xs) forall {l} (h :: (* -> *) -> l -> *) (xs :: l) (f :: * -> *). (SListIN h xs, SListIN (Prod h) xs, HSequence h, Applicative f) => h f xs -> f (h I xs) hsequence (NS m xs -> m (NS I xs)) -> NS m xs -> m (NS I xs) forall a b. (a -> b) -> a -> b $ (forall a. Index xs a -> TopLevelConfig a -> (:.:) Maybe (BlockForging m) a -> Product (Product WrapIsLeader (Ticked :.: LedgerState)) ([] :.: WrapValidatedGenTx) a -> m a) -> NP TopLevelConfig xs -> NP (Maybe :.: BlockForging m) xs -> NS (Product (Product WrapIsLeader (Ticked :.: LedgerState)) ([] :.: WrapValidatedGenTx)) xs -> NS m xs forall {k} (h :: (k -> *) -> [k] -> *) (xs :: [k]) (f1 :: k -> *) (f2 :: k -> *) (f3 :: k -> *) (f4 :: k -> *). (HAp h, SListI xs, Prod h ~ NP) => (forall (a :: k). Index xs a -> f1 a -> f2 a -> f3 a -> f4 a) -> NP f1 xs -> NP f2 xs -> h f3 xs -> h f4 xs hizipWith3 Index xs a -> TopLevelConfig a -> (:.:) Maybe (BlockForging m) a -> Product (Product WrapIsLeader (Ticked :.: LedgerState)) ([] :.: WrapValidatedGenTx) a -> m a forall a. Index xs a -> TopLevelConfig a -> (:.:) Maybe (BlockForging m) a -> Product (Product WrapIsLeader (Ticked :.: LedgerState)) ([] :.: WrapValidatedGenTx) a -> m a forgeBlockOne NP TopLevelConfig xs cfgs (OptNP empty (BlockForging m) xs -> NP (Maybe :.: BlockForging m) xs forall {k} (empty :: Bool) (f :: k -> *) (xs :: [k]). OptNP empty f xs -> NP (Maybe :.: f) xs OptNP.toNP OptNP empty (BlockForging m) xs blockForging) (NS (Product (Product WrapIsLeader (Ticked :.: LedgerState)) ([] :.: WrapValidatedGenTx)) xs -> NS m xs) -> NS (Product (Product WrapIsLeader (Ticked :.: LedgerState)) ([] :.: WrapValidatedGenTx)) xs -> NS m xs forall a b. (a -> b) -> a -> b $ [NS WrapValidatedGenTx xs] -> NS (Product WrapIsLeader (Ticked :.: LedgerState)) xs -> NS (Product (Product WrapIsLeader (Ticked :.: LedgerState)) ([] :.: WrapValidatedGenTx)) xs forall (f :: * -> *). [NS WrapValidatedGenTx xs] -> NS f xs -> NS (Product f ([] :.: WrapValidatedGenTx)) xs injectValidatedTxs ((Validated (GenTx (HardForkBlock xs)) -> NS WrapValidatedGenTx xs) -> [Validated (GenTx (HardForkBlock xs))] -> [NS WrapValidatedGenTx xs] forall a b. (a -> b) -> [a] -> [b] map (OneEraValidatedGenTx xs -> NS WrapValidatedGenTx xs forall (xs :: [*]). OneEraValidatedGenTx xs -> NS WrapValidatedGenTx xs getOneEraValidatedGenTx (OneEraValidatedGenTx xs -> NS WrapValidatedGenTx xs) -> (Validated (GenTx (HardForkBlock xs)) -> OneEraValidatedGenTx xs) -> Validated (GenTx (HardForkBlock xs)) -> NS WrapValidatedGenTx xs forall b c a. (b -> c) -> (a -> b) -> a -> c . Validated (GenTx (HardForkBlock xs)) -> OneEraValidatedGenTx xs forall (xs :: [*]). Validated (GenTx (HardForkBlock xs)) -> OneEraValidatedGenTx xs getHardForkValidatedGenTx) [Validated (GenTx (HardForkBlock xs))] txs) -- We know both NSs must be from the same era, because they were all -- produced from the same 'BlockForging'. Unfortunately, we can't enforce -- it statically. (NS (Product WrapIsLeader (Ticked :.: LedgerState)) xs -> NS (Product (Product WrapIsLeader (Ticked :.: LedgerState)) ([] :.: WrapValidatedGenTx)) xs) -> NS (Product WrapIsLeader (Ticked :.: LedgerState)) xs -> NS (Product (Product WrapIsLeader (Ticked :.: LedgerState)) ([] :.: WrapValidatedGenTx)) xs forall a b. (a -> b) -> a -> b $ String -> NS WrapIsLeader xs -> NS (Ticked :.: LedgerState) xs -> NS (Product WrapIsLeader (Ticked :.: LedgerState)) xs forall {k} (f :: k -> *) (g :: k -> *) (xs :: [k]). HasCallStack => String -> NS f xs -> NS g xs -> NS (Product f g) xs Match.mustMatchNS String "IsLeader" (HardForkIsLeader xs -> NS WrapIsLeader xs forall (xs :: [*]). OneEraIsLeader xs -> NS WrapIsLeader xs getOneEraIsLeader HardForkIsLeader xs isLeader) (HardForkState (Ticked :.: LedgerState) xs -> NS (Ticked :.: LedgerState) xs forall (xs :: [*]) (f :: * -> *). SListI xs => HardForkState f xs -> NS f xs State.tip HardForkState (Ticked :.: LedgerState) xs ledgerState) where cfgs :: NP TopLevelConfig xs cfgs = EpochInfo (Except PastHorizonException) -> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs forall (xs :: [*]). All SingleEraBlock xs => EpochInfo (Except PastHorizonException) -> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs distribTopLevelConfig EpochInfo (Except PastHorizonException) ei TopLevelConfig (HardForkBlock xs) cfg ei :: EpochInfo (Except PastHorizonException) ei = Shape xs -> TransitionInfo -> HardForkState (Ticked :.: LedgerState) xs -> EpochInfo (Except PastHorizonException) forall (xs :: [*]) (f :: * -> *). Shape xs -> TransitionInfo -> HardForkState f xs -> EpochInfo (Except PastHorizonException) State.epochInfoPrecomputedTransitionInfo (HardForkLedgerConfig xs -> Shape xs forall (xs :: [*]). HardForkLedgerConfig xs -> Shape xs hardForkLedgerConfigShape (TopLevelConfig (HardForkBlock xs) -> LedgerConfig (HardForkBlock xs) forall blk. TopLevelConfig blk -> LedgerConfig blk configLedger TopLevelConfig (HardForkBlock xs) cfg)) TransitionInfo transition HardForkState (Ticked :.: LedgerState) xs ledgerState missingBlockForgingImpossible :: EraIndex xs -> String missingBlockForgingImpossible :: EraIndex xs -> String missingBlockForgingImpossible EraIndex xs eraIndex = String "impossible: current era lacks block forging but we have an IsLeader proof " String -> ShowS forall a. Semigroup a => a -> a -> a <> EraIndex xs -> String forall a. Show a => a -> String show EraIndex xs eraIndex injectValidatedTxs :: [NS WrapValidatedGenTx xs] -> NS f xs -> NS (Product f ([] :.: WrapValidatedGenTx)) xs injectValidatedTxs :: forall (f :: * -> *). [NS WrapValidatedGenTx xs] -> NS f xs -> NS (Product f ([] :.: WrapValidatedGenTx)) xs injectValidatedTxs = ([Mismatch WrapValidatedGenTx f xs], NS (Product f ([] :.: WrapValidatedGenTx)) xs) -> NS (Product f ([] :.: WrapValidatedGenTx)) xs forall (f :: * -> *). ([Mismatch WrapValidatedGenTx f xs], NS (Product f ([] :.: WrapValidatedGenTx)) xs) -> NS (Product f ([] :.: WrapValidatedGenTx)) xs noMismatches (([Mismatch WrapValidatedGenTx f xs], NS (Product f ([] :.: WrapValidatedGenTx)) xs) -> NS (Product f ([] :.: WrapValidatedGenTx)) xs) -> ([NS WrapValidatedGenTx xs] -> NS f xs -> ([Mismatch WrapValidatedGenTx f xs], NS (Product f ([] :.: WrapValidatedGenTx)) xs)) -> [NS WrapValidatedGenTx xs] -> NS f xs -> NS (Product f ([] :.: WrapValidatedGenTx)) xs forall y z x0 x1. (y -> z) -> (x0 -> x1 -> y) -> x0 -> x1 -> z .: (NS f xs -> [NS WrapValidatedGenTx xs] -> ([Mismatch WrapValidatedGenTx f xs], NS (Product f ([] :.: WrapValidatedGenTx)) xs)) -> [NS WrapValidatedGenTx xs] -> NS f xs -> ([Mismatch WrapValidatedGenTx f xs], NS (Product f ([] :.: WrapValidatedGenTx)) xs) forall a b c. (a -> b -> c) -> b -> a -> c flip (InPairs InjectValidatedTx xs -> NS f xs -> [NS WrapValidatedGenTx xs] -> ([Mismatch WrapValidatedGenTx f xs], NS (Product f ([] :.: WrapValidatedGenTx)) xs) forall (f :: * -> *) (xs :: [*]). SListI xs => InPairs InjectValidatedTx xs -> NS f xs -> [NS WrapValidatedGenTx xs] -> ([Mismatch WrapValidatedGenTx f xs], NS (Product f ([] :.: WrapValidatedGenTx)) xs) matchValidatedTxsNS InPairs InjectValidatedTx xs injTxs) where injTxs :: InPairs InjectValidatedTx xs injTxs :: InPairs InjectValidatedTx xs injTxs = (forall x y. Product2 InjectTx InjectValidatedTx x y -> InjectValidatedTx x y) -> InPairs (Product2 InjectTx InjectValidatedTx) xs -> InPairs InjectValidatedTx xs forall {k} (xs :: [k]) (f :: k -> k -> *) (g :: k -> k -> *). SListI xs => (forall (x :: k) (y :: k). f x y -> g x y) -> InPairs f xs -> InPairs g xs InPairs.hmap (\(Pair2 InjectTx x y _ InjectValidatedTx x y x) -> InjectValidatedTx x y x) (InPairs (Product2 InjectTx InjectValidatedTx) xs -> InPairs InjectValidatedTx xs) -> InPairs (Product2 InjectTx InjectValidatedTx) xs -> InPairs InjectValidatedTx xs forall a b. (a -> b) -> a -> b $ NP WrapLedgerConfig xs -> InPairs (RequiringBoth WrapLedgerConfig (Product2 InjectTx InjectValidatedTx)) xs -> InPairs (Product2 InjectTx InjectValidatedTx) xs forall {k} (h :: k -> *) (xs :: [k]) (f :: k -> k -> *). NP h xs -> InPairs (RequiringBoth h f) xs -> InPairs f xs InPairs.requiringBoth ((forall a. TopLevelConfig a -> WrapLedgerConfig a) -> NP TopLevelConfig xs -> NP WrapLedgerConfig xs forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *) (f' :: k -> *). (SListIN (Prod h) xs, HAp h) => (forall (a :: k). f a -> f' a) -> h f xs -> h f' xs hmap (LedgerConfig a -> WrapLedgerConfig a forall blk. LedgerConfig blk -> WrapLedgerConfig blk WrapLedgerConfig (LedgerConfig a -> WrapLedgerConfig a) -> (TopLevelConfig a -> LedgerConfig a) -> TopLevelConfig a -> WrapLedgerConfig a forall b c a. (b -> c) -> (a -> b) -> a -> c . TopLevelConfig a -> LedgerConfig a forall blk. TopLevelConfig blk -> LedgerConfig blk configLedger) NP TopLevelConfig xs cfgs) InPairs (RequiringBoth WrapLedgerConfig (Product2 InjectTx InjectValidatedTx)) xs forall (xs :: [*]). CanHardFork xs => InPairs (RequiringBoth WrapLedgerConfig (Product2 InjectTx InjectValidatedTx)) xs hardForkInjectTxs -- | We know the transactions must be valid w.r.t. the given ledger -- state, the Mempool maintains that invariant. That means they are -- either from the same era, or can be injected into that era. noMismatches :: ([Match.Mismatch WrapValidatedGenTx f xs], NS (Product f ([] :.: WrapValidatedGenTx)) xs) -> NS (Product f ([] :.: WrapValidatedGenTx)) xs noMismatches :: forall (f :: * -> *). ([Mismatch WrapValidatedGenTx f xs], NS (Product f ([] :.: WrapValidatedGenTx)) xs) -> NS (Product f ([] :.: WrapValidatedGenTx)) xs noMismatches ([], NS (Product f ([] :.: WrapValidatedGenTx)) xs xs) = NS (Product f ([] :.: WrapValidatedGenTx)) xs xs noMismatches ([Mismatch WrapValidatedGenTx f xs] _errs, NS (Product f ([] :.: WrapValidatedGenTx)) xs _) = String -> NS (Product f ([] :.: WrapValidatedGenTx)) xs forall a. HasCallStack => String -> a error String "unexpected unmatchable transactions" -- | Unwraps all the layers needed for SOP and call 'forgeBlock'. forgeBlockOne :: Index xs blk -> TopLevelConfig blk -> (Maybe :.: BlockForging m) blk -> Product (Product WrapIsLeader (Ticked :.: LedgerState)) ([] :.: WrapValidatedGenTx) blk -> m blk forgeBlockOne :: forall a. Index xs a -> TopLevelConfig a -> (:.:) Maybe (BlockForging m) a -> Product (Product WrapIsLeader (Ticked :.: LedgerState)) ([] :.: WrapValidatedGenTx) a -> m a forgeBlockOne Index xs blk index TopLevelConfig blk cfg' (Comp Maybe (BlockForging m blk) mBlockForging') (Pair (Pair (WrapIsLeader IsLeader (BlockProtocol blk) isLeader') (Comp Ticked (LedgerState blk) ledgerState')) (Comp [WrapValidatedGenTx blk] txs')) = BlockForging m blk -> TopLevelConfig blk -> BlockNo -> SlotNo -> Ticked (LedgerState blk) -> [Validated (GenTx blk)] -> IsLeader (BlockProtocol blk) -> m blk forall (m :: * -> *) blk. BlockForging m blk -> TopLevelConfig blk -> BlockNo -> SlotNo -> TickedLedgerState blk -> [Validated (GenTx blk)] -> IsLeader (BlockProtocol blk) -> m blk forgeBlock (BlockForging m blk -> Maybe (BlockForging m blk) -> BlockForging m blk forall a. a -> Maybe a -> a fromMaybe (String -> BlockForging m blk forall a. HasCallStack => String -> a error (EraIndex xs -> String missingBlockForgingImpossible (Index xs blk -> EraIndex xs forall (xs :: [*]) blk. Index xs blk -> EraIndex xs eraIndexFromIndex Index xs blk index))) Maybe (BlockForging m blk) mBlockForging') TopLevelConfig blk cfg' BlockNo bno SlotNo sno Ticked (LedgerState blk) ledgerState' ((WrapValidatedGenTx blk -> Validated (GenTx blk)) -> [WrapValidatedGenTx blk] -> [Validated (GenTx blk)] forall a b. (a -> b) -> [a] -> [b] map WrapValidatedGenTx blk -> Validated (GenTx blk) forall blk. WrapValidatedGenTx blk -> Validated (GenTx blk) unwrapValidatedGenTx [WrapValidatedGenTx blk] txs') IsLeader (BlockProtocol blk) isLeader'