Gracefully handle decoding more summaries than statically known eras

ouroboros-consensus-cardano-test/src/Test/Consensus/Cardano/Generators.hs

@@ -29,7 +29,7 @@ import Ouroboros.Consensus.Node.NetworkProtocolVersion
 import Ouroboros.Consensus.Node.Serialisation (Some (..))
 import Ouroboros.Consensus.TypeFamilyWrappers
 import Ouroboros.Consensus.Util.Counting (NonEmpty (..),
- nonEmptyFromList)
+ nonEmptyFromList, nonEmptyToList)
 import Ouroboros.Consensus.Util.SOP (nsFromIndex)
 
 import Ouroboros.Consensus.HardFork.Combinator
@@ -432,7 +432,23 @@ instance (Arbitrary a, SListI xs) => Arbitrary (NonEmpty xs a) where
  return $ fromMaybe (error "nonEmptyFromList failed") $ nonEmptyFromList xs
 
 instance Arbitrary (History.Interpreter (CardanoEras c)) where
- arbitrary = History.mkInterpreter . History.Summary <$> arbitrary
+ arbitrary =
+ History.mkInterpreter . History.Summary . enforceInvariant <$> arbitrary
+ where
+ -- Enforce the invariant that when the last era in the summary is the
+ -- final era, it is unbounded. The decoder relies on this.
+ enforceInvariant xs
+ | length (nonEmptyToList xs) == lengthSList (Proxy @(CardanoEras c))
+ = fixEndBound xs
+ | otherwise
+ = xs
+
+ fixEndBound ::
+ NonEmpty xs History.EraSummary
+ -> NonEmpty xs History.EraSummary
+ fixEndBound (NonEmptyCons e es) = NonEmptyCons e (fixEndBound es)
+ fixEndBound (NonEmptyOne e) =
+ NonEmptyOne e { History.eraEnd = History.EraUnbounded }
 
 instance Arbitrary (EraIndex (CardanoEras c)) where
  arbitrary = do

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

@@ -193,7 +193,7 @@ data EraEnd =
 --
 -- The summary zips 'Shape' with 'Forks', and provides detailed information
 -- about the start and end of each era.
-
+--
 -- We have at most one summary for each era, and at least one
 newtype Summary xs = Summary { getSummary :: NonEmpty xs EraSummary }
  deriving (Eq, Show)
@@ -492,10 +492,83 @@ instance Serialise EraSummary where
 
 instance SListI xs => Serialise (Summary xs) where
  encode (Summary eraSummaries) = encode (toList eraSummaries)
+
+ -- @xs@ is the list of eras that is statically known to us; the server has a
+ -- similar list @ys@ of eras that /it/ statically knows about. We do not know
+ -- what @ys@ is here, but we can nonetheless reason about how @|xs|@ and
+ -- @|ys|@ might relate:
+ --
+ -- - @|xs| == |ys|@: this is the normal case; we and the server know about the
+ -- same (number of) eras. No special care needs to be taken.
+ --
+ -- - @|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| < |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
+ -- client hasn't yet. Pattern match on the number @n@ of eras that the
+ -- server sends us summaries for:
+ --
+ -- o @n < |xs|@: Although the server knows about more eras than us, they
+ -- actually only send us era summaries for fewer eras than we know about.
+ -- This means that the transition to what _we_ believe is the final era is
+ -- 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.
+ --
+ -- 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.
+ --
+ -- 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.
  decode = do
- eraSummaries <- decode
- case Summary <$> nonEmptyFromList eraSummaries of
+ -- 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
  Just summary -> return summary
- Nothing -> fail $
- "Summary: expected between 1 and " <> show (lengthSList (Proxy @xs)) <>
- " eras but got " <> show (length eraSummaries)
+ 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 }

ouroboros-consensus/src/Ouroboros/Consensus/Util/Counting.hs

@@ -45,6 +45,7 @@ module Ouroboros.Consensus.Util.Counting (
  , nonEmptyLast
  , nonEmptyInit
  , nonEmptyFromList
+ , nonEmptyToList
  , nonEmptyWeaken
  , nonEmptyStrictPrefixes
  , nonEmptyMapOne
@@ -310,6 +311,14 @@ nonEmptyFromList = go (sList @xs)
  (SCons, []) -> Nothing
  (SNil, _) -> Nothing
 
+-- | Convert a 'NonEmpty' to a list.
+nonEmptyToList :: forall xs a. NonEmpty xs a -> [a]
+nonEmptyToList = go
+ where
+ go :: forall xs'. NonEmpty xs' a -> [a]
+ go (NonEmptyOne x) = x : []
+ go (NonEmptyCons x xs) = x : go xs
+
 nonEmptyWeaken :: NonEmpty xs a -> AtMost xs a
 nonEmptyWeaken = go
  where