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/ouroboros-consensus-diffusion.cabal

@@ -227,6 +227,7 @@ test-suite consensus-test
     , quiet
     , serialise
     , si-timers
+    , sop-core
     , sop-extras
     , strict-sop-core
     , tasty

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 ::

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 =

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