From e55c607ba31a9f74a7fa9deb986e47ec60783526 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Tue, 19 Sep 2023 10:37:00 +0200 Subject: [PATCH] HFC ThreadNet: add protocol versions as regression test This adds an extremely simple mechanism that increments protocol versions on era boundaries. The motivation is to showcase that due to how HFC ticking is implemented, this does not do what one would expect. See #340 for a concrete scenario where this behavior is problematic. --- .../ouroboros-consensus-diffusion.cabal | 1 + .../Test/Consensus/HardFork/Combinator.hs | 27 ++++++++++++++++- .../Test/Consensus/HardFork/Combinator/A.hs | 29 +++++++++++++++++-- .../Test/Consensus/HardFork/Combinator/B.hs | 8 +++-- 4 files changed, 60 insertions(+), 5 deletions(-) diff --git a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal index af38eb0b96..df22d66451 100644 --- a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal +++ b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal @@ -227,6 +227,7 @@ test-suite consensus-test , quiet , serialise , si-timers + , sop-core , sop-extras , strict-sop-core , tasty diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs index 7bf6fa304a..c4b1fa2c0b 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator.hs @@ -22,6 +22,7 @@ module Test.Consensus.HardFork.Combinator (tests) where import qualified Data.Map.Strict as Map +import Data.SOP.BasicFunctors import Data.SOP.Counting import Data.SOP.InPairs (RequiringBoth (..)) import qualified Data.SOP.InPairs as InPairs @@ -138,7 +139,8 @@ prop_simple_hfc_convergence testSetup@TestSetup{..} = counterexample ("eraSizeA: " <> show eraSizeA) $ tabulate "epochs in era A" [labelEraSizeA] $ prop_general args testOutput .&&. - prop_allExpectedBlocks + prop_allExpectedBlocks .&&. + prop_finalProtVers where k :: SecurityParam k = testSetupK @@ -239,10 +241,13 @@ prop_simple_hfc_convergence testSetup@TestSetup{..} = $ OptNil ] + initProtVer = 0 + initLedgerState :: LedgerState BlockA initLedgerState = LgrA { lgrA_tip = GenesisPoint , lgrA_transition = Nothing + , lgrA_protVer = initProtVer } initChainDepState :: ChainDepState ProtocolA @@ -353,6 +358,25 @@ prop_simple_hfc_convergence testSetup@TestSetup{..} = . filter p $ Mock.chainToList nodeOutputFinalChain + prop_finalProtVers :: Property + prop_finalProtVers = + counterexample ("final protocol versions: " <> show finalProtVers) $ + -- TODO This property is showcasing a problem with the HFC: even though + -- we will definitely end up in era B (and hence, the protocol version + -- should be @'succ' 'initProtVer'@), this is currently not the case. + -- Subsequent commits will fix this. + all (== initProtVer) finalProtVers + + + finalProtVers :: Map.Map NodeId Word16 + finalProtVers = getProtVer `Map.map` testOutputNodes testOutput + where + getProtVer = + hcollapse + . hap (fn (K . lgrA_protVer) :* fn (K . lgrB_protVer) :* Nil) + . hardForkLedgerStatePerEra + . nodeOutputFinalLedger + -- We ignore the mempool for these tests instance TxGen TestBlock where testGenTxs _ _ _ _ _ _ = return [] @@ -411,6 +435,7 @@ ledgerState_AtoB :: BlockB ledgerState_AtoB = InPairs.ignoringBoth $ Translate $ \_ LgrA{..} -> LgrB { lgrB_tip = castPoint lgrA_tip + , lgrB_protVer = lgrA_protVer } chainDepState_AtoB :: diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs index 7af23764f6..d8c7d6e3a5 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs @@ -45,7 +45,7 @@ import Control.Monad.Except (runExcept) 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.Functor.Identity import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Set (Set) @@ -65,6 +65,7 @@ import Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common import Ouroboros.Consensus.HardFork.History (Bound (..), EraParams (..)) import qualified Ouroboros.Consensus.HardFork.History as History +import Ouroboros.Consensus.HardFork.History.Util (addSlots) import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.CommonProtocolParams @@ -179,6 +180,10 @@ data instance LedgerState BlockA = LgrA { -- | The 'SlotNo' of the block containing the 'InitiateAtoB' transaction , lgrA_transition :: Maybe SlotNo + + -- | The protocol version. Increments at epoch boundaries whenever + -- 'InitiateAtoB' would signal an era transition. + , lgrA_protVer :: Word16 } deriving (Show, Eq, Generic, Serialise) deriving NoThunks via OnlyCheckWhnfNamed "LgrA" (LedgerState BlockA) @@ -211,7 +216,27 @@ instance IsLedger (LedgerState BlockA) where type AuxLedgerEvent (LedgerState BlockA) = VoidLedgerEvent (LedgerState BlockA) - applyChainTickLedgerResult _ _ = pureLedgerResult . TickedLedgerStateA + applyChainTickLedgerResult (ei, cfg) targetSlot st = + pureLedgerResult + . TickedLedgerStateA + . incrProtVer + $ st + where + incrProtVer + | targetSlot >= firstSlotNextEpoch -- cross-epoch tick + , Just (_, confirmationDepth) <- getConfirmationDepth st + -- block with transition tx is doubly stable + , confirmationDepth >= safeFromTipA k + stabilityWindowA k + = \s -> s { lgrA_protVer = succ (lgrA_protVer s) } + | otherwise = id + + k = lcfgA_k cfg + + firstSlotNextEpoch = runIdentity $ do + currentEpoch <- epochInfoEpoch ei (fromWithOrigin 0 $ getTipSlot st) + firstSlot <- epochInfoFirst ei currentEpoch + EpochSize epochSize <- epochInfoSize ei currentEpoch + pure $ addSlots epochSize firstSlot instance ApplyBlock (LedgerState BlockA) BlockA where applyBlockLedgerResult cfg blk = diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs index 35d3436542..1b6ed50699 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs @@ -41,6 +41,7 @@ import qualified Data.ByteString.Lazy as Lazy import Data.Set (Set) import qualified Data.Set as Set import Data.Void +import Data.Word import GHC.Generics (Generic) import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..)) import Ouroboros.Consensus.Block @@ -67,6 +68,7 @@ import Ouroboros.Consensus.Node.Serialisation import Ouroboros.Consensus.Protocol.Abstract import Ouroboros.Consensus.Storage.ImmutableDB (simpleChunkInfo) import Ouroboros.Consensus.Storage.Serialisation +import Ouroboros.Consensus.Util ((..:)) import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.Orphans () import Ouroboros.Network.Block (Serialised, unwrapCBORinCBOR, @@ -161,6 +163,7 @@ instance ValidateEnvelope BlockB where data instance LedgerState BlockB = LgrB { lgrB_tip :: Point BlockB + , lgrB_protVer :: Word16 } deriving (Show, Eq, Generic, Serialise) deriving NoThunks via OnlyCheckWhnfNamed "LgrB" (LedgerState BlockB) @@ -188,8 +191,9 @@ instance IsLedger (LedgerState BlockB) where applyChainTickLedgerResult _ _ = pureLedgerResult . TickedLedgerStateB instance ApplyBlock (LedgerState BlockB) BlockB where - applyBlockLedgerResult = \_ b _ -> return $ pureLedgerResult $ LgrB (blockPoint b) - reapplyBlockLedgerResult = \_ b _ -> pureLedgerResult $ LgrB (blockPoint b) + applyBlockLedgerResult = return ..: reapplyBlockLedgerResult + reapplyBlockLedgerResult _cfg b (TickedLedgerStateB st) = + pureLedgerResult st{lgrB_tip = blockPoint b} instance UpdateLedger BlockB