Merge #3754

3754: Bugfix in HFC: do not consider the last known era to be eternal r=nfrisby a=nfrisby

This supersedes PR #3750. And it unblocks the Vasil HF.

This PR fixes a bug in the Consensus Hard Fork Combinator (HFC). The bug is that certain parts of the HFC before this PR assume that the final era the code is aware of (ie the rightmost era in the `xs` argument to `HardForkBlock xs`) will never end. At face value, this assumption seems very reasonable. If the final era could end, then that means we wrote the code that knows how to end the final era but didn't simultaneously add the code for the following era, which is pretty clearly a bad idea unless you indeed want your system-wide chain to stop growing. The patterns we have in `protocolInfoCardano` and in the related call in [input-output-hk/cardano-node](https://github.com/input-output-hk/cardano-node) ensure that mistake would be quite obvious in review of such a PR. Despite that assumption seeming reasonable, merely adding Babbage in the recent PR #3595 revealed this assumption as a bug: the new code considered some Alonzo transactions on the historical chains to now be invalid. Together, this PR and PR IntersectMBO/cardano-ledger#2785 fix the bug and also allows those Alonzo transactions to remain valid.

The recent PR #3595 added the Babbage era, changing `type CardanoBlock = HardForkBlock [ByronBlock, ShelleyBlock, AllegraBlock, MaryBlock, AlonzoBlock]` to `type CardanoBlock = HardForkBlock [ByronBlock, ShelleyBlock, AllegraBlock, MaryBlock, AlonzoBlock, BabbageBlock]`. From that change alone, due to the bug, the code stopped considering the Alonzo era as eternal, since it was no longer the final era. We now classify this assumption as a bug because it's clear that the (inevitable) addition of a new final era causes, via the bug, a non-mononotic change in behavior: for Alonzo (ie before we transition to Babbage), the Babbage-aware HFC now refuses to translate some slot<->times that it happily translated when Alonzo was the final era in the list.

The eras prior to Alonzo are unaffected because Alonzo introduced Plutus scripts and with them the requirement that the validity interval (specified as an interval between two slots) on an Alonzo transaction that contains Plutus scripts must be translatable to POSIX times, because the Plutus interpreter exposes the interval to the script as POSIX times, not as slots. The translation between slots and times is the responsibility of the HFC, because it depends on the slot duration, which is allowed to change during era transitions (eg it changed from 20s to 1s when the chain transitioned from Byron to Shelley; it has not yet changed a second time). The HFC is very careful with that translation, as you can see in the Time chapter in the Hard Fork Combinator section of the [The Cardano Consensus and Storage Layer](https://hydra.iohk.io/job/Cardano/ouroboros-network/native.consensus-docs.x86_64-linux/latest/download/1) report. In particular, that chapter explains that the HFC refuses to translate slots<->times unless the answer would always remain correct regardless of any possible rollbacks (ie would be the same for any extension of our immutable tip, which is `k` blocks back from the tip of our currently selected chain).

The assumption that the final era does not end is in direct violation of that rule: if we assume the final era won't end, then we might translate a slot/time that is (currently!) 1000 years into the future -- and it's obvious that future activity on this chain is likely to change the correspondence between slots and times at some point during the next 1000 years! It wasn't until Alonzo's transaction validity interval check that this mattered, because that's the first (and so far only) slot<->time translation in the ledger rules that involves a user-defined slot (ie what they set as the transaction's validity interval bounds) -- all other translations are fixed by the ledger rules and are by design always within the range the HFC will translate (even after this PR's bugfix).

Thus, as a result of this PR, Babbage and subsequent eras will never be considered eternal, thereby satisfying the rule about all successful slot<->time translations being deterministic with respect to the selection's immutable tip. And PR IntersectMBO/cardano-ledger#2785 will intentionally violate that rule only during Alonzo, so that the historical transactions already on-chain remain valid. Because the consequences are currently limited to transaction validity intervals, there's no harm in that.

So-called "clients", such as `db-sync`, the wallet, the Cardano cli tools, etc may also exhibit a change in behavior due to this PR, but those at worst will be less convenient than they seemed before: any features of those tools that allowed the user to translate slot<->time well into the future will now refuse to do so. This PR changes no types, so that downstream code already has code paths that handle the HFC's refusal to translate a slot/time; they merely weren't being exercised for as many arguments as they should have been.

Co-authored-by: Nicolas Frisby <nick.frisby@iohk.io>

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Ledger.hs

@@ -404,51 +404,37 @@ mkHardForkForecast translations st = Forecast {
        -> InPairs (TranslateForecast state view) xs'
        -> Telescope (K Past) (Current (AnnForecast state view)) xs'
        -> Except OutsideForecastRange (Ticked (HardForkLedgerView_ view xs'))
-    go sno PNil         (TZ cur)       = forecastFinalEra sno   cur
-    go sno (PCons t _)  (TZ cur)       = forecastNotFinal sno t cur
+    go sno pairs        (TZ cur)       = oneForecast sno pairs cur
     go sno (PCons _ ts) (TS past rest) = shiftView past <$> go sno ts rest
 
--- | Construct forecast when we're in the final era.
---
--- Since we're in the final era, no translation is required.
-forecastFinalEra ::
+oneForecast ::
      forall state view blk blks.
      SlotNo
+  -> InPairs (TranslateForecast state view) (blk : blks)
+     -- ^ this function uses at most the first translation
   -> Current (AnnForecast state view) blk
   -> Except OutsideForecastRange (Ticked (HardForkLedgerView_ view (blk : blks)))
-forecastFinalEra sno (Current start AnnForecast{..}) =
-    aux <$> forecastFor annForecast sno
-  where
-    aux :: Ticked (view blk)
-        -> Ticked (HardForkLedgerView_ view (blk : blks))
-    aux view = TickedHardForkLedgerView {
-          tickedHardForkLedgerViewTransition =
-            TransitionImpossible
-        , tickedHardForkLedgerViewPerEra = HardForkState $
-            TZ (Current start (Comp view))
-        }
-
--- | Make forecast with potential need to translate to next era
-forecastNotFinal ::
-     forall state view blk blk' blks.
-     SlotNo
-  -> TranslateForecast state view blk blk'
-  -> Current (AnnForecast state view) blk
-  -> Except OutsideForecastRange (Ticked (HardForkLedgerView_ view (blk : blk' : blks)))
-forecastNotFinal sno translate (Current start AnnForecast{..})
-  | Nothing <- annForecastEnd =
-      endUnknown <$>
-        forecastFor annForecast sno
-  | Just end <- annForecastEnd, sno < boundSlot end =
-      beforeKnownEnd end <$>
-        forecastFor annForecast sno
-  | Just end <- annForecastEnd, otherwise =
-      afterKnownEnd end <$>
-        translateForecastWith translate end sno annForecastState
+oneForecast sno pairs (Current start AnnForecast{..}) =
+    case annForecastEnd of
+      Nothing  -> endUnknown <$> forecastFor annForecast sno
+      Just end ->
+        if sno < boundSlot end
+        then beforeKnownEnd end <$> forecastFor annForecast sno
+        else case pairs of
+          PCons translate _ ->
+                afterKnownEnd end
+            <$> translateForecastWith translate end sno annForecastState
+          PNil              ->
+            -- The requested slot is after the last era the code knows about.
+            throwError OutsideForecastRange {
+                outsideForecastAt     = forecastAt annForecast
+              , outsideForecastMaxFor = boundSlot end
+              , outsideForecastFor    = sno
+              }
   where
     endUnknown ::
          Ticked (f blk)
-      -> Ticked (HardForkLedgerView_ f (blk : blk' : blks))
+      -> Ticked (HardForkLedgerView_ f (blk : blks))
     endUnknown view = TickedHardForkLedgerView {
           tickedHardForkLedgerViewTransition =
             TransitionUnknown annForecastTip
@@ -459,7 +445,7 @@ forecastNotFinal sno translate (Current start AnnForecast{..})
     beforeKnownEnd ::
          Bound
       -> Ticked (f blk)
-      -> Ticked (HardForkLedgerView_ f (blk : blk' : blks))
+      -> Ticked (HardForkLedgerView_ f (blk : blks))
     beforeKnownEnd end view = TickedHardForkLedgerView {
           tickedHardForkLedgerViewTransition =
             TransitionKnown (boundEpoch end)
@@ -470,7 +456,7 @@ forecastNotFinal sno translate (Current start AnnForecast{..})
     afterKnownEnd ::
          Bound
       -> Ticked (f blk')
-      -> Ticked (HardForkLedgerView_ f (blk : blk' : blks))
+      -> Ticked (HardForkLedgerView_ f (blk : blk' : blks'))
     afterKnownEnd end view = TickedHardForkLedgerView {
           tickedHardForkLedgerViewTransition =
             -- We assume that we only ever have to translate to the /next/ era

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/State.hs

@@ -157,6 +157,9 @@ epochInfoLedger cfg st =
       reconstructSummaryLedger cfg st
 
 -- | Construct 'EpochInfo' given precomputed 'TransitionInfo'
+--
+-- The transition and state arguments are acquired either from a ticked ledger
+-- state or a ticked ledger view.
 epochInfoPrecomputedTransitionInfo ::
      History.Shape xs
   -> TransitionInfo

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/State/Infra.hs

@@ -170,32 +170,53 @@ reconstructSummary (History.Shape shape) transition (HardForkState st) =
     go :: Exactly xs' EraParams
        -> Telescope (K Past) (Current f) xs'
        -> NonEmpty xs' EraSummary
+    go ExactlyNil              t                   = case t of {}
     go (ExactlyCons params ss) (TS (K Past{..}) t) =
         NonEmptyCons (EraSummary pastStart (EraEnd pastEnd) params) $ go ss t
-    go (ExactlyCons params ExactlyNil) (TZ Current{..}) =
-        -- The current era is the last. We assume it lasts until all eternity.
-        NonEmptyOne (EraSummary currentStart EraUnbounded params)
-    go (ExactlyCons params (ExactlyCons nextParams _)) (TZ Current{..}) =
+    go (ExactlyCons params ss) (TZ Current{..}) =
         case transition of
           TransitionKnown epoch ->
             -- We haven't reached the next era yet, but the transition is
             -- already known. The safe zone applies from the start of the
             -- next era.
             let currentEnd = History.mkUpperBound params currentStart epoch
                 nextStart  = currentEnd
-            in NonEmptyCons EraSummary {
-                   eraStart  = currentStart
-                 , eraParams = params
-                 , eraEnd    = EraEnd currentEnd
-                 }
-             $ NonEmptyOne EraSummary {
-                   eraStart  = nextStart
-                 , eraParams = nextParams
-                 , eraEnd    = applySafeZone
-                                 nextParams
-                                 nextStart
-                                 (boundSlot nextStart)
-                 }
+            in case ss of
+              ExactlyCons nextParams _ ->
+                  NonEmptyCons EraSummary {
+                      eraStart  = currentStart
+                    , eraParams = params
+                    , eraEnd    = EraEnd currentEnd
+                    }
+                $ NonEmptyOne EraSummary {
+                      eraStart  = nextStart
+                    , eraParams = nextParams
+                    , eraEnd    = applySafeZone
+                                    nextParams
+                                    nextStart
+                                    (boundSlot nextStart)
+                    }
+              ExactlyNil               ->
+                -- HOWEVER, this code doesn't know what that next era is! This
+                -- can arise when a node has not updated its code despite an
+                -- imminent hard fork.
+                --
+                -- In the specific case of 'ShelleyBlock' and 'CardanoBlock', a
+                -- lot would have to go wrong in the PR review process for
+                -- 'TransitionKnown' to arise during the last known era in the
+                -- code. The 'ShelleyBlock' 'singleEraTransition' method leads
+                -- to 'TransitionKnown' here only based on the
+                -- 'shelleyTriggerHardFork' field of its ledger config, which is
+                -- statically set by a quite obvious pattern in
+                -- 'protocolInfoCardano', which is passed concrete arguments by
+                -- a similarly obvious pattern in
+                -- 'mkSomeConsensusProtocolCardano' defined in the
+                -- @cardano-node@ repo.
+                NonEmptyOne EraSummary {
+                    eraStart  = currentStart
+                  , eraParams = params
+                  , eraEnd    = EraEnd currentEnd
+                  }
           TransitionUnknown ledgerTip -> NonEmptyOne $ EraSummary {
                 eraStart  = currentStart
               , eraParams = params
@@ -207,9 +228,10 @@ reconstructSummary (History.Shape shape) transition (HardForkState st) =
                               (next ledgerTip)
               }
           -- 'TransitionImpossible' is used in one of two cases: we are in the
-          -- final era (clearly not the case here) or this era is a future era
-          -- that hasn't begun yet, in which case the safe zone must start at
-          -- the beginning of this era.
+          -- final era this chain will ever have (handled by the corresponding
+          -- 'UnsafeIndefiniteSafeZone' case within 'applySafeZone' below) or
+          -- this era is a future era that hasn't begun yet, in which case the
+          -- safe zone must start at the beginning of this era.
           TransitionImpossible -> NonEmptyOne $ EraSummary {
                 eraStart  = currentStart
               , eraParams = params
@@ -219,8 +241,6 @@ reconstructSummary (History.Shape shape) transition (HardForkState st) =
                               (boundSlot currentStart)
               }
 
-    go ExactlyNil t = case t of {}
-
     -- Apply safe zone from the specified 'SlotNo'
     --
     -- All arguments must be referring to or in the same era.

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/History/Summary.hs

@@ -503,16 +503,7 @@ instance SListI xs => Serialise (Summary xs) where
   --
   -- - @|xs| > |ys|@: we know about more eras than the server does. The server
   --   will send us era summaries for @1 <= n <= |ys|@ eras. For sure @n <
-  --   |xs|@, so decoding will be unproblematic. The only slightly strange case
-  --   is when @n == |ys|@: in this case, the server thinks we are in the final
-  --   era, whereas in fact that era isn't actually final; consequently, the
-  --   server will give us an unbounded summary for that "final" era. However,
-  --   if we are following that particular server, treating that era as
-  --   unbounded is okay, since we anyway won't be transitioning to the next
-  --   era.
-  --
-  --   [TODO: Won't we be making any decisions that we might regret if we do
-  --   eventually switch server..?]
+  --   |xs|@, so decoding will be unproblematic.
   --
   -- - @|xs| < |ys|@: we know about fewer eras than the server does. This will
   --   happen when the server has been upgraded for the next hard fork, but the
@@ -525,50 +516,27 @@ instance SListI xs => Serialise (Summary xs) where
   --     not yet known; the summary sent to us by the server is fine as is.
   --
   --   o @n == |xs|@: The server does not yet know about the transition out of
-  --     what (we believe to be) the final era. In principle we could decide to
-  --     leave the era summaries as-is; however, since _we_ consider that era to
-  --     be the final one, we should regard it as unbounded (it does not make
-  --     sense to have a bounded final era). We must therefore modify the final
-  --     era summary. Of course this will mean that we will make some incorrect
-  --     decisions; but as long as we aren't updated, we will anyway be unable
-  --     to deal with the next era.
+  --     what (we believe to be) the final era.
   --
   --   o @n > |xs|@: the server already knows about the transition to the next
   --     era after our final era. In this case we must drop all eras that we
-  --     don't know about, and then modify again the final era to be unbounded,
-  --     just like in the case above.
+  --     don't know about.
   --
   -- Since we do not know @|ys|@, we cannot actually implement the outermost
   -- case statement. However:
   --
   -- - If @|xs| > |ys|@, by definition @n < |xs|@, and hence we will not modify
   --   the era summary: this is what we wanted.
   --
-  -- - If @|xs| == |ys|@, then at most @n == |xs|@, in which case we might
-  --   "modify" the final era to be unbounded. But in this case, the server will
-  --   consider that era to be final as well, and so it will _already_ be
-  --   unbounded: effectively this means that this means we will leave the
-  --   summary unchanged.
+  -- - If @|xs| == |ys|@, then at most @n == |xs|@.
   decode = do
       -- Drop all eras we don't know about
       eraSummaries <- take nbXs <$> decode
 
-      let n = length eraSummaries
-          go
-            -- @n == |xs|@
-            | n == nbXs = fixEndBound
-            -- @n <  |xs|@
-            | otherwise = id
-
-      case Summary . go <$> nonEmptyFromList eraSummaries of
+      case Summary <$> nonEmptyFromList eraSummaries of
         Just summary -> return summary
         Nothing      -> fail "Summary: expected at least one era summary"
     where
       -- @|xs|@
       nbXs :: Int
       nbXs = lengthSList (Proxy @xs)
-
-      -- | Make the last era's end bound unbounded.
-      fixEndBound :: NonEmpty xs' EraSummary -> NonEmpty xs' EraSummary
-      fixEndBound (NonEmptyCons e es) = NonEmptyCons e (fixEndBound es)
-      fixEndBound (NonEmptyOne  e)    = NonEmptyOne  e { eraEnd = EraUnbounded }