Fix a problem where HFC is out of sync with ledger

There is a bug where PPUP rule would not update the PParams,
while consensus Hard Fork Combinator (HFC) would still think that the
update was successful.

This degenerate case could have only happened whenever there was a
ProposedPPUpdates that contained an update to major protocol version
that is expected to be for the new era as well as contained an invalid
update to at least one of the `ppMaxTxSizeL`, `ppMaxBHSizeL` or `ppMaxBBSizeL`
parameters.

eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Newpp.hs

@@ -46,6 +46,7 @@ import Control.State.Transition (
   (?!),
  )
 import Data.Default.Class (Default, def)
+import Data.Maybe (fromMaybe)
 import Data.Word (Word64)
 import GHC.Generics (Generic)
 import Lens.Micro ((^.))
@@ -112,13 +113,7 @@ newPpTransition = do
         ?! UnexpectedDepositPot obligationCurr (utxosDeposited utxoState)
 
   coreNodeQuorum <- liftSTS $ asks quorum
-  case mppNew of
-    Just ppNew
-      | toInteger (ppNew ^. ppMaxTxSizeL)
-          + toInteger (ppNew ^. ppMaxBHSizeL)
-          < toInteger (ppNew ^. ppMaxBBSizeL) ->
-          pure $ NewppState ppNew $ updatePpup coreNodeQuorum ppupState ppNew
-    _ -> pure $ NewppState pp $ updatePpup coreNodeQuorum ppupState pp
+  pure $ updatePpup coreNodeQuorum ppupState $ fromMaybe pp mppNew
 
 -- | Update the protocol parameter updates by clearing out the proposals
 -- and making the future proposals become the new proposals,
@@ -131,13 +126,14 @@ updatePpup ::
   Word64 ->
   GovState era ->
   PParams era ->
-  ShelleyGovState era
+  ShelleyNewppState era
 updatePpup !coreNodeQuorum ppupState pp =
-  ppupState
-    { sgsCurProposals = curProposals
-    , sgsFutureProposals = emptyPPPUpdates
-    , sgsFuturePParams = votedFuturePParams curProposals pp coreNodeQuorum
-    }
+  NewppState pp $
+    ppupState
+      { sgsCurProposals = curProposals
+      , sgsFutureProposals = emptyPPPUpdates
+      , sgsFuturePParams = votedFuturePParams curProposals pp coreNodeQuorum
+      }
   where
     ProposedPPUpdates newProposals = sgsFutureProposals ppupState
     curProposals =

eras/shelley/impl/src/Cardano/Ledger/Shelley/Rules/Ppup.hs

@@ -57,6 +57,7 @@ import Cardano.Ledger.Slot (
   (*-),
  )
 import Control.DeepSeq (NFData)
+import Control.Monad (guard)
 import Control.Monad.Trans.Reader (asks)
 import Control.SetAlgebra (dom, eval, (⊆), (⨃))
 import Control.State.Transition
@@ -239,21 +240,24 @@ votedFuturePParams ::
   -- | Quorum needed to change the protocol parameters.
   Word64 ->
   Maybe (PParams era)
-votedFuturePParams (ProposedPPUpdates pppu) pp quorumN =
+votedFuturePParams (ProposedPPUpdates pppu) pp quorumN = do
   let votes =
         Map.foldr
           (\vote -> Map.insertWith (+) vote 1)
           (Map.empty :: Map.Map (PParamsUpdate era) Word64)
           pppu
       consensus = Map.filter (>= quorumN) votes
-   in case Map.keys consensus of
-        -- NOTE that `quorumN` is a global constant, and that we require
-        -- it to be strictly greater than half the number of genesis nodes.
-        -- The keys in the `pup` correspond to the genesis nodes,
-        -- and therefore either:
-        --   1) `consensus` is empty, or
-        --   2) `consensus` has exactly one element.
-        [ppu] -> Just $ applyPPUpdates pp ppu
-        -- NOTE that `updatePParams` corresponds to the union override right
-        -- operation in the formal spec.
-        _ -> Nothing
+  -- NOTE that `quorumN` is a global constant, and that we require
+  -- it to be strictly greater than half the number of genesis nodes.
+  -- The keys in the `pup` correspond to the genesis nodes,
+  -- and therefore either:
+  --   1) `consensus` is empty, or
+  --   2) `consensus` has exactly one element.
+  [ppu] <- Just $ Map.keys consensus
+  -- NOTE that `applyPPUpdates` corresponds to the union override right
+  -- operation in the formal spec.
+  let ppNew = applyPPUpdates pp ppu
+  guard $
+    toInteger (ppNew ^. ppMaxTxSizeL) + toInteger (ppNew ^. ppMaxBHSizeL)
+      < toInteger (ppNew ^. ppMaxBBSizeL)
+  pure ppNew