From 2985dbf54959dca34515dac9cdd1dbbc93bdcf00 Mon Sep 17 00:00:00 2001 From: Nicolas Frisby Date: Mon, 26 Apr 2021 20:10:06 -0700 Subject: [PATCH] consensus: HFC now provides EpochInfo in Except monad The ledger is about to expect an EpochInfo that can fail. Previously, the ledger did not expect EpochInfo to ever fail, since the ledger only used it under controlled circumstances (ie on slots that Consensus provided). But as of Alonzo, the ledger must apply EpochInfo to slots provided by the user: script transactions have a validity interval specified as a pair of slots. The Plutus interpreter expects the validity interval as a pair of UTC times. Since the user provides the slots, the ledger is now applying EpochInfo in a way that might fail. They want to notice that an invalidate the transaction if so. Hence this commit prepares for that. The HFC has always created EpochInfos that might fail. However, until now it converted those failures to pure exceptions ASAP. As of this commit, the conversion happens at the latest possible moment. And soon a cardano-ledger-specs will allow us to remove the conversion that this commit does just before passing the EpochInfo to the ledger. There are some places in Consensus itself where we continue to use the pure EpochInfo. As before, those places indicate bugs if the error is thrown, so using a pure exception was and still is appropriate. --- .../Consensus/Cardano/CanHardFork.hs | 2 +- .../Consensus/Shelley/Ledger/Ledger.hs | 8 +++-- .../src/Ouroboros/Consensus/Shelley/Node.hs | 5 ++-- .../Ouroboros/Consensus/Shelley/Protocol.hs | 19 ++++++++---- .../Ouroboros/Consensus/Shelley/ShelleyHFC.hs | 7 +++-- .../Test/Consensus/HardFork/Combinator/A.hs | 3 +- .../Test/Consensus/HardFork/History.hs | 2 +- .../Combinator/Abstract/NoHardForks.hs | 14 +++++---- .../Consensus/HardFork/Combinator/Basics.hs | 15 +++++----- .../HardFork/Combinator/Embed/Unary.hs | 4 +-- .../Consensus/HardFork/Combinator/Ledger.hs | 4 +-- .../HardFork/Combinator/PartialConfig.hs | 16 +++++----- .../Consensus/HardFork/Combinator/Protocol.hs | 9 +++--- .../Consensus/HardFork/Combinator/State.hs | 5 ++-- .../Consensus/HardFork/History/EpochInfo.hs | 30 +++++++++++++------ .../Consensus/HardFork/History/Qry.hs | 2 +- 16 files changed, 87 insertions(+), 58 deletions(-) diff --git a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs index 6f4a313e356..ad53429a438 100644 --- a/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs +++ b/ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs @@ -28,7 +28,7 @@ module Ouroboros.Consensus.Cardano.CanHardFork ( ) where import Control.Monad -import Control.Monad.Except (Except, runExcept, throwError) +import Control.Monad.Except (runExcept, throwError) import qualified Data.Map.Strict as Map import Data.Maybe (listToMaybe, mapMaybe) import Data.Proxy diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs index 5c30258e5cf..9152b6b3b98 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs @@ -136,13 +136,17 @@ shelleyEraParamsNeverHardForks genesis = HardFork.EraParams { mkShelleyLedgerConfig :: SL.ShelleyGenesis era - -> EpochInfo Identity + -> EpochInfo (Except HardFork.PastHorizonException) -> MaxMajorProtVer -> ShelleyLedgerConfig era mkShelleyLedgerConfig genesis epochInfo (MaxMajorProtVer maxMajorPV) = ShelleyLedgerConfig { shelleyLedgerCompactGenesis = compactGenesis genesis - , shelleyLedgerGlobals = SL.mkShelleyGlobals genesis epochInfo maxMajorPV + , shelleyLedgerGlobals = + SL.mkShelleyGlobals + genesis + (HardFork.toPureEpochInfo epochInfo) + maxMajorPV } type instance LedgerCfg (LedgerState (ShelleyBlock era)) = ShelleyLedgerConfig era diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node.hs index 054fbf5366c..7c6d9c701f5 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node.hs @@ -40,8 +40,8 @@ module Ouroboros.Consensus.Shelley.Node ( , validateGenesis ) where +import Control.Monad.Except (Except) import Data.Bifunctor (first) -import Data.Functor.Identity (Identity) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.SOP.Strict @@ -56,6 +56,7 @@ import Cardano.Slotting.Time (mkSlotLength) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.Config.SupportsNode +import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Extended @@ -294,7 +295,7 @@ protocolInfoShelleyBased ProtocolParamsShelleyBased { ledgerConfig :: LedgerConfig (ShelleyBlock era) ledgerConfig = mkShelleyLedgerConfig genesis epochInfo maxMajorProtVer - epochInfo :: EpochInfo Identity + epochInfo :: EpochInfo (Except History.PastHorizonException) epochInfo = fixedEpochInfo (SL.sgEpochLength genesis) diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol.hs index 547d341d5c2..587c13f01fd 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol.hs @@ -42,10 +42,9 @@ module Ouroboros.Consensus.Shelley.Protocol ( import qualified Codec.CBOR.Encoding as CBOR import Codec.Serialise (Serialise (..)) -import Control.Monad.Except (throwError) +import Control.Monad.Except (Except, throwError) import Data.Coerce (coerce) import Data.Function (on) -import Data.Functor.Identity (Identity) import qualified Data.Map.Strict as Map import Data.Ord (Down (..)) import Data.Word (Word64) @@ -59,6 +58,7 @@ import Cardano.Slotting.EpochInfo import Cardano.Slotting.Time (SystemStart (..)) import Ouroboros.Consensus.Block +import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Ticked import Ouroboros.Consensus.Util.Condense @@ -252,7 +252,7 @@ instance PraosCrypto c => NoThunks (TPraosIsLeader c) -- | Static configuration data instance ConsensusConfig (TPraos c) = TPraosConfig { tpraosParams :: !TPraosParams - , tpraosEpochInfo :: !(EpochInfo Identity) + , tpraosEpochInfo :: !(EpochInfo (Except History.PastHorizonException)) -- it's useful for this record to be EpochInfo and one other thing, -- because the one other thing can then be used as the @@ -412,7 +412,10 @@ instance PraosCrypto c => ConsensusProtocol (TPraos c) where lv = getTickedPraosLedgerView $ tickedTPraosStateLedgerView cs d = SL.lvD lv asc = tpraosLeaderF $ tpraosParams cfg - firstSlot = firstSlotOfEpochOfSlot (tpraosEpochInfo cfg) slot + firstSlot = + firstSlotOfEpochOfSlot + (History.toPureEpochInfo $ tpraosEpochInfo cfg) + slot gkeys = Map.keysSet dlgMap eta0 = SL.ticknStateEpochNonce $ SL.csTickn chainState vkhCold = SL.hashKey tpraosCanBeLeaderColdVerKey @@ -436,7 +439,11 @@ instance PraosCrypto c => ConsensusProtocol (TPraos c) where st' = SL.tickChainDepState shelleyGlobals lv - (isNewEpoch tpraosEpochInfo lastSlot slot) + ( isNewEpoch + (History.toPureEpochInfo tpraosEpochInfo) + lastSlot + slot + ) st shelleyGlobals = mkShelleyGlobals cfg @@ -464,7 +471,7 @@ instance PraosCrypto c => ConsensusProtocol (TPraos c) where mkShelleyGlobals :: ConsensusConfig (TPraos c) -> SL.Globals mkShelleyGlobals TPraosConfig{..} = SL.Globals { - epochInfo = tpraosEpochInfo + epochInfo = History.toPureEpochInfo tpraosEpochInfo , slotsPerKESPeriod = tpraosSlotsPerKESPeriod , stabilityWindow = SL.computeStabilityWindow k tpraosLeaderF , randomnessStabilisationWindow = SL.computeRandomnessStabilisationWindow k tpraosLeaderF diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/ShelleyHFC.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/ShelleyHFC.hs index 902c75a1561..41e81666521 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/ShelleyHFC.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/ShelleyHFC.hs @@ -23,7 +23,7 @@ module Ouroboros.Consensus.Shelley.ShelleyHFC ( ) where import Control.Monad (guard) -import Control.Monad.Except (Except, throwError) +import Control.Monad.Except (throwError) import qualified Data.Map.Strict as Map import Data.Maybe import Data.SOP.Strict @@ -40,7 +40,8 @@ import Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common import Ouroboros.Consensus.HardFork.Combinator.State.Types import Ouroboros.Consensus.HardFork.Combinator.Util.InPairs (RequiringBoth (..), ignoringBoth) -import Ouroboros.Consensus.HardFork.History (Bound (boundSlot)) +import Ouroboros.Consensus.HardFork.History (Bound (boundSlot), + toPureEpochInfo) import Ouroboros.Consensus.HardFork.Simple import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Node.NetworkProtocolVersion @@ -198,7 +199,7 @@ instance ShelleyBasedEra era => HasPartialLedgerConfig (ShelleyBlock era) where completeLedgerConfig _ epochInfo (ShelleyPartialLedgerConfig cfg _) = cfg { shelleyLedgerGlobals = (shelleyLedgerGlobals cfg) { - SL.epochInfo = epochInfo + SL.epochInfo = toPureEpochInfo epochInfo } } diff --git a/ouroboros-consensus-test/test-consensus/Test/Consensus/HardFork/Combinator/A.hs b/ouroboros-consensus-test/test-consensus/Test/Consensus/HardFork/Combinator/A.hs index 85656f504c2..99b1a00b367 100644 --- a/ouroboros-consensus-test/test-consensus/Test/Consensus/HardFork/Combinator/A.hs +++ b/ouroboros-consensus-test/test-consensus/Test/Consensus/HardFork/Combinator/A.hs @@ -43,6 +43,7 @@ import Control.Monad.Except import qualified Data.Binary as B import Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy +import Data.Functor.Identity (Identity) import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) @@ -244,7 +245,7 @@ instance HasPartialConsensusConfig ProtocolA instance HasPartialLedgerConfig BlockA where type PartialLedgerConfig BlockA = PartialLedgerConfigA - completeLedgerConfig _ = (,) + completeLedgerConfig _ ei pcfg = (History.toPureEpochInfo ei, pcfg) data TxPayloadA = InitiateAtoB deriving (Show, Eq, Generic, NoThunks, Serialise) diff --git a/ouroboros-consensus-test/test-consensus/Test/Consensus/HardFork/History.hs b/ouroboros-consensus-test/test-consensus/Test/Consensus/HardFork/History.hs index b0ce84c7cc4..e39db0415cc 100644 --- a/ouroboros-consensus-test/test-consensus/Test/Consensus/HardFork/History.hs +++ b/ouroboros-consensus-test/test-consensus/Test/Consensus/HardFork/History.hs @@ -814,7 +814,7 @@ hardForkEpochInfo ArbitraryChain{..} for = tickedHardForkLedgerViewTransition tickedHardForkLedgerViewPerEra in ( - HF.snapshotEpochInfo reconstructed + HF.toPureEpochInfo (HF.snapshotEpochInfo reconstructed) , show view , show reconstructed ) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Abstract/NoHardForks.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Abstract/NoHardForks.hs index d74931cc59c..43ef09d358f 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Abstract/NoHardForks.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Abstract/NoHardForks.hs @@ -3,6 +3,8 @@ module Ouroboros.Consensus.HardFork.Combinator.Abstract.NoHardForks ( , noHardForksEpochInfo ) where +import Data.Functor.Identity (runIdentity) + import Cardano.Slotting.EpochInfo import Ouroboros.Consensus.Block @@ -39,12 +41,14 @@ class SingleEraBlock blk => NoHardForks blk where toPartialLedgerConfig :: proxy blk -> LedgerConfig blk -> PartialLedgerConfig blk -noHardForksEpochInfo :: NoHardForks blk - => TopLevelConfig blk -> EpochInfo Identity +noHardForksEpochInfo :: (Monad m, NoHardForks blk) + => TopLevelConfig blk + -> EpochInfo m noHardForksEpochInfo cfg = - fixedEpochInfo - (History.eraEpochSize params) - (History.eraSlotLength params) + hoistEpochInfo (pure . runIdentity) + $ fixedEpochInfo + (History.eraEpochSize params) + (History.eraSlotLength params) where params :: EraParams params = getEraParams cfg diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Basics.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Basics.hs index b616b276a4d..84bd4c9b9ed 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Basics.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Basics.hs @@ -33,10 +33,9 @@ module Ouroboros.Consensus.HardFork.Combinator.Basics ( , distribTopLevelConfig -- ** Convenience re-exports , EpochInfo - , Identity + , Except ) where -import Data.Functor.Identity import Data.Kind (Type) import Data.SOP.Strict import Data.Typeable @@ -152,7 +151,7 @@ type instance LedgerCfg (LedgerState (HardForkBlock xs)) = HardForkLedgerConfig completeLedgerConfig' :: forall blk. HasPartialLedgerConfig blk - => EpochInfo Identity + => EpochInfo (Except PastHorizonException) -> WrapPartialLedgerConfig blk -> LedgerConfig blk completeLedgerConfig' ei = @@ -161,7 +160,7 @@ completeLedgerConfig' ei = completeLedgerConfig'' :: forall blk. HasPartialLedgerConfig blk - => EpochInfo Identity + => EpochInfo (Except PastHorizonException) -> WrapPartialLedgerConfig blk -> WrapLedgerConfig blk completeLedgerConfig'' ei = @@ -171,7 +170,7 @@ completeLedgerConfig'' ei = completeConsensusConfig' :: forall blk. HasPartialConsensusConfig (BlockProtocol blk) - => EpochInfo Identity + => EpochInfo (Except PastHorizonException) -> WrapPartialConsensusConfig blk -> ConsensusConfig (BlockProtocol blk) completeConsensusConfig' ei = @@ -180,7 +179,7 @@ completeConsensusConfig' ei = completeConsensusConfig'' :: forall blk. HasPartialConsensusConfig (BlockProtocol blk) - => EpochInfo Identity + => EpochInfo (Except PastHorizonException) -> WrapPartialConsensusConfig blk -> WrapConsensusConfig blk completeConsensusConfig'' ei = @@ -190,7 +189,7 @@ completeConsensusConfig'' ei = distribLedgerConfig :: CanHardFork xs - => EpochInfo Identity + => EpochInfo (Except PastHorizonException) -> LedgerConfig (HardForkBlock xs) -> NP WrapLedgerConfig xs distribLedgerConfig ei cfg = @@ -200,7 +199,7 @@ distribLedgerConfig ei cfg = (getPerEraLedgerConfig $ hardForkLedgerConfigPerEra cfg) distribTopLevelConfig :: All SingleEraBlock xs - => EpochInfo Identity + => EpochInfo (Except PastHorizonException) -> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs distribTopLevelConfig ei tlc = diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs index 981e99389f0..9fcd03ea867 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs @@ -267,7 +267,7 @@ instance Isomorphic TopLevelConfig where (project $ configCodec tlc) (project $ configStorage tlc) where - ei :: EpochInfo Identity + ei :: EpochInfo (Except PastHorizonException) ei = noHardForksEpochInfo $ project tlc auxLedger :: LedgerConfig (HardForkBlock '[blk]) -> LedgerConfig blk @@ -448,7 +448,7 @@ instance Functor m => Isomorphic (BlockForging m) where } where injTickedChainDepSt :: - EpochInfo Identity + EpochInfo (Except PastHorizonException) -> Ticked (ChainDepState (BlockProtocol blk)) -> Ticked (ChainDepState (HardForkProtocol '[blk])) injTickedChainDepSt ei = diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs index f0d6b3fcf73..694e2fc0fb8 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs @@ -151,7 +151,7 @@ instance CanHardFork xs => IsLedger (LedgerState (HardForkBlock xs)) where extended = State.extendToSlot cfg slot st tickOne :: forall blk. SingleEraBlock blk - => EpochInfo Identity + => EpochInfo (Except PastHorizonException) -> SlotNo -> WrapPartialLedgerConfig blk -> LedgerState blk @@ -261,7 +261,7 @@ instance CanHardFork xs => ValidateEnvelope (HardForkBlock xs) where Right matched -> hcollapse $ hcizipWith proxySingle aux cfgs matched where - ei :: EpochInfo Identity + ei :: EpochInfo (Except PastHorizonException) ei = State.epochInfoPrecomputedTransitionInfo (hardForkLedgerConfigShape $ configLedger tlc) transition diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/PartialConfig.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/PartialConfig.hs index 5a67b537f98..f0f202d0012 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/PartialConfig.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/PartialConfig.hs @@ -13,16 +13,18 @@ module Ouroboros.Consensus.HardFork.Combinator.PartialConfig ( , WrapPartialLedgerConfig (..) -- * Convenience re-exports , EpochInfo (..) - , Identity (..) + , Except + , PastHorizonException ) where -import Data.Functor.Identity +import Control.Monad.Except (Except) import Data.Kind (Type) import NoThunks.Class (NoThunks) import Cardano.Slotting.EpochInfo import Ouroboros.Consensus.Block +import Ouroboros.Consensus.HardFork.History.Qry (PastHorizonException) import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Protocol.Abstract @@ -38,12 +40,12 @@ class ( ConsensusProtocol p -- See comments for 'completeLedgerConfig' for some details about the -- 'EpochInfo'. completeConsensusConfig :: proxy p - -> EpochInfo Identity + -> EpochInfo (Except PastHorizonException) -> PartialConsensusConfig p -> ConsensusConfig p default completeConsensusConfig :: (PartialConsensusConfig p ~ ConsensusConfig p) => proxy p - -> EpochInfo Identity + -> EpochInfo (Except PastHorizonException) -> PartialConsensusConfig p -> ConsensusConfig p completeConsensusConfig _ _ = id @@ -61,14 +63,12 @@ class ( UpdateLedger blk -- The horizon is determined by the tip of the ledger /state/ (not view) -- from which the 'EpochInfo' is derived. -- - -- TODO: This should not be Identity; - -- see completeLedgerConfig :: proxy blk - -> EpochInfo Identity + -> EpochInfo (Except PastHorizonException) -> PartialLedgerConfig blk -> LedgerConfig blk default completeLedgerConfig :: (PartialLedgerConfig blk ~ LedgerConfig blk) => proxy blk - -> EpochInfo Identity + -> EpochInfo (Except PastHorizonException) -> PartialLedgerConfig blk -> LedgerConfig blk completeLedgerConfig _ _ = id diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs index f898a94a661..1e27ed02424 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs @@ -141,7 +141,8 @@ data instance Ticked (HardForkChainDepState xs) = HardForkState (Ticked :.: WrapChainDepState) xs -- | 'EpochInfo' constructed from the ticked 'LedgerView' - , tickedHardForkChainDepStateEpochInfo :: EpochInfo Identity + , tickedHardForkChainDepStateEpochInfo :: + EpochInfo (Except PastHorizonException) } tick :: CanHardFork xs @@ -281,7 +282,7 @@ update HardForkConsensusConfig{..} cfgs = getPerEraConsensusConfig hardForkConsensusConfigPerEra updateEra :: forall xs blk. SingleEraBlock blk - => EpochInfo Identity + => EpochInfo (Except PastHorizonException) -> SlotNo -> Index xs blk -> WrapPartialConsensusConfig blk @@ -322,7 +323,7 @@ reupdate HardForkConsensusConfig{..} cfgs = getPerEraConsensusConfig hardForkConsensusConfigPerEra reupdateEra :: SingleEraBlock blk - => EpochInfo Identity + => EpochInfo (Except PastHorizonException) -> SlotNo -> WrapPartialConsensusConfig blk -> Product WrapValidateView (Ticked :.: WrapChainDepState) blk @@ -344,7 +345,7 @@ chainDepStateInfo :: forall blk. SingleEraBlock blk chainDepStateInfo _ = singleEraInfo (Proxy @blk) translateConsensus :: forall xs. CanHardFork xs - => EpochInfo Identity + => EpochInfo (Except PastHorizonException) -> ConsensusConfig (HardForkProtocol xs) -> InPairs (Translate WrapChainDepState) xs translateConsensus ei HardForkConsensusConfig{..} = diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/State.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/State.hs index 0d595a2b82e..a2e8a434f2a 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/State.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/State.hs @@ -32,7 +32,6 @@ module Ouroboros.Consensus.HardFork.Combinator.State ( import Prelude hiding (sequence) import Control.Monad (guard) -import Data.Functor.Identity import Data.Functor.Product import Data.Proxy import Data.SOP.Strict hiding (shape) @@ -152,7 +151,7 @@ reconstructSummaryLedger cfg@HardForkLedgerConfig{..} st = epochInfoLedger :: All SingleEraBlock xs => HardForkLedgerConfig xs -> HardForkState LedgerState xs - -> EpochInfo Identity + -> EpochInfo (Except PastHorizonException) epochInfoLedger cfg st = History.snapshotEpochInfo $ reconstructSummaryLedger cfg st @@ -162,7 +161,7 @@ epochInfoPrecomputedTransitionInfo :: History.Shape xs -> TransitionInfo -> HardForkState f xs - -> EpochInfo Identity + -> EpochInfo (Except PastHorizonException) epochInfoPrecomputedTransitionInfo shape transition st = History.snapshotEpochInfo $ reconstructSummary shape transition st diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/History/EpochInfo.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/History/EpochInfo.hs index e49990bd69a..ab3df4249ad 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/History/EpochInfo.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/History/EpochInfo.hs @@ -7,9 +7,11 @@ module Ouroboros.Consensus.HardFork.History.EpochInfo ( dummyEpochInfo , snapshotEpochInfo , summaryToEpochInfo + , toPureEpochInfo ) where -import Data.Functor.Identity +import Control.Exception (throw) +import Control.Monad.Except (Except, runExcept, throwError) import GHC.Stack import Cardano.Slotting.EpochInfo.API @@ -48,26 +50,36 @@ summaryToEpochInfo = -- -- When a particular request fails with a 'PastHorizon' error, we throw the -- error as a /pure/ exception. Such an exception would indicate a bug. -snapshotEpochInfo :: forall xs. Summary xs -> EpochInfo Identity +snapshotEpochInfo :: forall xs. Summary xs -> EpochInfo (Except PastHorizonException) snapshotEpochInfo summary = EpochInfo { - epochInfoSize_ = \e -> runQueryPure' (epochToSize e) - , epochInfoFirst_ = \e -> runQueryPure' (epochToSlot' e) - , epochInfoEpoch_ = \s -> runQueryPure' (fst <$> slotToEpoch' s) + epochInfoSize_ = \e -> runQuery' (epochToSize e) + , epochInfoFirst_ = \e -> runQuery' (epochToSlot' e) + , epochInfoEpoch_ = \s -> runQuery' (fst <$> slotToEpoch' s) , epochInfoSlotToRelativeTime_ = \s -> - runQueryPure' (fst <$> slotToWallclock s) + runQuery' (fst <$> slotToWallclock s) } where - runQueryPure' :: HasCallStack => Qry a -> Identity a - runQueryPure' = Identity . flip runQueryPure summary + runQuery' :: HasCallStack => Qry a -> Except PastHorizonException a + runQuery' q = either throwError pure $ runQuery q summary -- | A dummy 'EpochInfo' that always throws an 'error'. -- -- To be used as a placeholder before a summary is available. -dummyEpochInfo :: EpochInfo Identity +dummyEpochInfo :: EpochInfo (Except PastHorizonException) dummyEpochInfo = EpochInfo { epochInfoSize_ = \_ -> error "dummyEpochInfo used" , epochInfoFirst_ = \_ -> error "dummyEpochInfo used" , epochInfoEpoch_ = \_ -> error "dummyEpochInfo used" , epochInfoSlotToRelativeTime_ = \_ -> error "dummyEpochInfo used" } + +-- | Interpret the 'PastHorizonException' as a _pure exception_ via 'throw' +-- +-- As per usual, this should only be used when the pure exception would +-- indicate a bug. +toPureEpochInfo :: + Applicative f + => EpochInfo (Except PastHorizonException) + -> EpochInfo f +toPureEpochInfo = hoistEpochInfo (either throw pure . runExcept) diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/History/Qry.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/History/Qry.hs index e004c601f35..f8c25951c56 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/History/Qry.hs +++ b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/History/Qry.hs @@ -396,7 +396,7 @@ runQuery qry (Summary summary) = go summary Nothing -> Left $ PastHorizon callStack (Some e) (toList summary) -runQueryThrow :: (HasCallStack, MonadThrow m )=> Qry a -> Summary xs -> m a +runQueryThrow :: (HasCallStack, MonadThrow m) => Qry a -> Summary xs -> m a runQueryThrow q = either throwIO return . runQuery q runQueryPure :: HasCallStack => Qry a -> Summary xs -> a