diff --git a/ouroboros-consensus-cardano-test/src/Test/Consensus/Cardano/Generators.hs b/ouroboros-consensus-cardano-test/src/Test/Consensus/Cardano/Generators.hs index 6f557e6a654..ccf58cbf2e6 100644 --- a/ouroboros-consensus-cardano-test/src/Test/Consensus/Cardano/Generators.hs +++ b/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 diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/History/Summary.hs b/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/History/Summary.hs index 4de7f246432..454486ae7a6 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/HardFork/History/Summary.hs +++ b/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 } diff --git a/ouroboros-consensus/src/Ouroboros/Consensus/Util/Counting.hs b/ouroboros-consensus/src/Ouroboros/Consensus/Util/Counting.hs index c0b32cb1684..9dff69d0b47 100644 --- a/ouroboros-consensus/src/Ouroboros/Consensus/Util/Counting.hs +++ b/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