Use chain hash comparison for properties on parametric blk

Some genesis tests still depend on 'TestBlock' specific logic.
Specifically, the `TestHash` (the `HeaderHash TestBlock` type family
instance) stores a number list representation of the path on the
`BlockTree` leading to the corresponding block (i.e. its prefix
`AnchoredFragment`); this is used to implement certain properties.

Here, such properties are refactored to parametric blocks by using direct
hash comparison (in some cases on the `BlockTree` trunk).

tweag/ouroboros-consensus-testing@3e83852
holds a test showcasing a property of a previous refactor: namely that
the order of _fork numbers_ in a `TestHash` are not relevant for the
properties that depended on it. This alternative refactor (on
tweag/ouroboros-consensus-testing@dab5349)
intended to preserve existing code structure, which was confusing, and
as such was changed in the end in search for clarity.

Author: ninioArtillero

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup.hs

@@ -2,15 +2,19 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
 module Test.Consensus.Genesis.Setup
   ( module Test.Consensus.Genesis.Setup.GenChains
+  , castHeaderHash
   , forAllGenesisTest
+  , honestImmutableTip
   , runGenesisTest
   , runGenesisTest'
+  , selectedHonestChain
   ) where
 
 import Control.Exception (throw)
@@ -20,7 +24,12 @@ import Control.Monad.Class.MonadAsync
 import Control.Monad.IOSim (IOSim, runSimStrictShutdown)
 import Control.Tracer (debugTracer, traceWith)
 import Data.Maybe (mapMaybe)
-import Ouroboros.Consensus.Block.Abstract (ConvertRawHash, Header)
+import Ouroboros.Consensus.Block.Abstract
+  ( ChainHash (..)
+  , ConvertRawHash
+  , GetHeader
+  , Header
+  )
 import Ouroboros.Consensus.Block.SupportsDiffusionPipelining
   ( BlockSupportsDiffusionPipelining
   )
@@ -40,10 +49,12 @@ import Ouroboros.Consensus.Storage.LedgerDB.API
   )
 import Ouroboros.Consensus.Util.Condense
 import Ouroboros.Consensus.Util.IOLike (Exception, fromException)
+import qualified Ouroboros.Network.AnchoredFragment as AF
 import Ouroboros.Network.Driver.Limits
   ( ProtocolLimitFailure (ExceededTimeLimit)
   )
 import Ouroboros.Network.Util.ShowProxy
+import Test.Consensus.BlockTree (onTrunk)
 import Test.Consensus.Genesis.Setup.Classifiers
   ( Classifiers (..)
   , ResultClassifiers (..)
@@ -209,3 +220,25 @@ forAllGenesisTest generator schedulerConfig shrinker mkProperty = idempotentIOPr
     e :: Exception e => Maybe e
     e = fromException exn
     true = property True
+
+-- | The 'StateView.svSelectedChain' produces an 'AnchoredFragment (Header blk)';
+-- this function casts this type's hash to its instance, so that it can be used
+-- for lookups on a 'BlockTree'.
+castHeaderHash :: ChainHash (Header blk) -> ChainHash blk
+castHeaderHash = \case
+  BlockHash hash -> BlockHash hash
+  GenesisHash -> GenesisHash
+
+-- | Check if the immutable tip of the selected chain of a 'GenesisTest' is honest.
+-- In this setting, the immutable tip corresponds to the selected chain anchor
+-- (see 'Ouroboros.Consensus.Storage.ChainDB.API.getCurrentChain') and
+-- the honest chain is represented by the test 'BlockTree' trunk.
+honestImmutableTip :: GetHeader blk => GenesisTestFull blk -> StateView blk -> Bool
+honestImmutableTip GenesisTest{gtBlockTree} StateView{svSelectedChain} =
+  onTrunk gtBlockTree $ AF.anchorPoint svSelectedChain
+
+-- | Check if the tip of the selected chain of a 'GenesisTest' is honest.
+-- In this setting, the honest chain corresponds to the test 'BlockTree' trunk.
+selectedHonestChain :: GetHeader blk => GenesisTestFull blk -> StateView blk -> Bool
+selectedHonestChain GenesisTest{gtBlockTree} StateView{svSelectedChain} =
+  onTrunk gtBlockTree $ AF.headPoint $ svSelectedChain

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/Classifiers.hs

@@ -3,7 +3,6 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE TypeOperators #-}
 
 module Test.Consensus.Genesis.Setup.Classifiers
   ( Classifiers (..)
@@ -12,20 +11,15 @@ module Test.Consensus.Genesis.Setup.Classifiers
   , classifiers
   , resultClassifiers
   , scheduleClassifiers
-  , simpleHash
   ) where
 
 import Cardano.Ledger.BaseTypes (unNonZero)
 import Cardano.Slotting.Slot (WithOrigin (..))
 import Data.List (sortOn, tails)
-import qualified Data.List.NonEmpty as NonEmpty
 import qualified Data.Map as Map
 import Data.Maybe (mapMaybe)
-import Data.Word (Word64)
 import Ouroboros.Consensus.Block.Abstract
-  ( ChainHash (..)
-  , HasHeader
-  , HeaderHash
+  ( HasHeader
   , SlotNo (SlotNo)
   , blockSlot
   , succWithOrigin
@@ -60,7 +54,6 @@ import Test.Consensus.PointSchedule
 import Test.Consensus.PointSchedule.Peers (PeerId (..), Peers (..))
 import Test.Consensus.PointSchedule.SinglePeer (SchedulePoint (..))
 import Test.Util.Orphans.IOLike ()
-import Test.Util.TestBlock (TestHash (TestHash))
 
 -- | Interesting categories to classify test inputs
 data Classifiers
@@ -284,11 +277,3 @@ scheduleClassifiers GenesisTest{gtSchedule = schedule, gtBlockTree} =
     (t0, _) : points -> all ((== t0) . fst) points
 
   allAdversariesTrivial = all id $ adversarialPeers $ isTrivial <$> psSchedule schedule
-
-simpleHash ::
-  HeaderHash block ~ TestHash =>
-  ChainHash block ->
-  [Word64]
-simpleHash = \case
-  BlockHash (TestHash h) -> reverse (NonEmpty.toList h)
-  GenesisHash -> []

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/DensityDisconnect.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
 
@@ -514,7 +515,7 @@ prop_densityDisconnectMonotonic =
 -- it gets disconnected and then the selection progresses.
 prop_densityDisconnectTriggersChainSel :: Property
 prop_densityDisconnectTriggersChainSel =
-  forAllGenesisTest
+  forAllGenesisTest @TestBlock
     ( do
         gt@GenesisTest{gtBlockTree} <- genChains (pure 1)
         let ps = lowDensitySchedule gtBlockTree

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoE.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE ViewPatterns #-}
 
 module Test.Consensus.Genesis.Tests.LoE (tests) where
@@ -33,6 +34,7 @@ import Test.Tasty
 import Test.Tasty.QuickCheck
 import Test.Util.Orphans.IOLike ()
 import Test.Util.PartialAccessors
+import Test.Util.TestBlock (TestBlock)
 import Test.Util.TestEnv
   ( adjustQuickCheckMaxSize
   , adjustQuickCheckTests
@@ -66,7 +68,7 @@ prop_adversaryHitsTimeouts timeoutsEnabled =
   -- at the end of the test for the adversaries to get disconnected, by adding an extra point.
   -- If this point gets removed by the shrinker, we lose that property and the test becomes useless.
   noShrinking $
-    forAllGenesisTest
+    forAllGenesisTest @TestBlock
       ( do
           gt@GenesisTest{gtBlockTree} <- genChains (pure 1)
           let ps = delaySchedule gtBlockTree

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LoP.hs

@@ -2,6 +2,7 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE ViewPatterns #-}
 
 module Test.Consensus.Genesis.Tests.LoP (tests) where
@@ -45,6 +46,7 @@ import Test.Tasty
 import Test.Tasty.QuickCheck
 import Test.Util.Orphans.IOLike ()
 import Test.Util.PartialAccessors
+import Test.Util.TestBlock (TestBlock)
 import Test.Util.TestEnv
   ( adjustQuickCheckMaxSize
   , adjustQuickCheckTests
@@ -84,7 +86,7 @@ tests =
 -- no exception in the ChainSync client.
 prop_wait :: Bool -> Property
 prop_wait mustTimeout =
-  forAllGenesisTest
+  forAllGenesisTest @TestBlock
     ( do
         gt@GenesisTest{gtBlockTree} <- genChains (pure 0)
         let ps = dullSchedule 10 (btTrunk gtBlockTree)
@@ -122,7 +124,7 @@ prop_wait mustTimeout =
 -- no exception.
 prop_waitBehindForecastHorizon :: Property
 prop_waitBehindForecastHorizon =
-  forAllGenesisTest
+  forAllGenesisTest @TestBlock
     ( do
         gt@GenesisTest{gtBlockTree} <- genChains (pure 0)
         let ps = dullSchedule (btTrunk gtBlockTree)
@@ -170,7 +172,7 @@ prop_waitBehindForecastHorizon =
 -- serve the @n@th block, barely.
 prop_serve :: Bool -> Property
 prop_serve mustTimeout =
-  forAllGenesisTest
+  forAllGenesisTest @TestBlock
     ( do
         gt@GenesisTest{gtBlockTree} <- genChains (pure 0)
         let lbpRate = borderlineRate (AF.length (btTrunk gtBlockTree))
@@ -228,7 +230,7 @@ prop_delayAttack lopEnabled =
   -- at the end of the test for the adversaries to get disconnected, by adding an extra point.
   -- If this point gets removed by the shrinker, we lose that property and the test becomes useless.
   noShrinking $
-    forAllGenesisTest
+    forAllGenesisTest @TestBlock
       ( do
           gt@GenesisTest{gtBlockTree} <- genChains (pure 1)
           let gt' = gt{gtLoPBucketParams = LoPBucketParams{lbpCapacity = 10, lbpRate = 1}}

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/LongRangeAttack.hs

@@ -1,28 +1,26 @@
 {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 
 module Test.Consensus.Genesis.Tests.LongRangeAttack (tests) where
 
 import Data.Functor (($>))
-import Ouroboros.Consensus.Block.Abstract (Header, HeaderHash)
-import Ouroboros.Network.AnchoredFragment (headAnchor)
-import qualified Ouroboros.Network.AnchoredFragment as AF
 import Test.Consensus.Genesis.Setup
 import Test.Consensus.Genesis.Setup.Classifiers
   ( allAdversariesForecastable
   , allAdversariesSelectable
   , classifiers
   )
 import Test.Consensus.PeerSimulator.Run (defaultSchedulerConfig)
-import Test.Consensus.PeerSimulator.StateView
 import Test.Consensus.PointSchedule
 import Test.Consensus.PointSchedule.Shrinking (shrinkPeerSchedules)
 import Test.Tasty
 import Test.Tasty.QuickCheck
 import Test.Util.Orphans.IOLike ()
-import Test.Util.TestBlock (TestBlock, unTestHash)
+import Test.Util.TestBlock (TestBlock)
 import Test.Util.TestEnv (adjustQuickCheckTests)
 
 tests :: TestTree
@@ -49,7 +47,7 @@ prop_longRangeAttack =
   -- honest node to win. Hence the `noShrinking`.
 
   noShrinking $
-    forAllGenesisTest
+    forAllGenesisTest @TestBlock
       ( do
           -- Create a block tree with @1@ alternative chain.
           gt@GenesisTest{gtBlockTree} <- genChains (pure 1)
@@ -64,13 +62,5 @@ prop_longRangeAttack =
       shrinkPeerSchedules
       -- NOTE: This is the expected behaviour of Praos to be reversed with
       -- Genesis. But we are testing Praos for the moment. Do not forget to remove
-      -- `noShrinking` above when removing this negation.
-      (\_ -> not . isHonestTestFragH . svSelectedChain)
- where
-  isHonestTestFragH :: AF.AnchoredFragment (Header TestBlock) -> Bool
-  isHonestTestFragH frag = case headAnchor frag of
-    AF.AnchorGenesis -> True
-    AF.Anchor _ hash _ -> isHonestTestHeaderHash hash
-
-  isHonestTestHeaderHash :: HeaderHash TestBlock -> Bool
-  isHonestTestHeaderHash = all (0 ==) . unTestHash
+      -- 'noShrinking' above when removing this negation.
+      (\genesisTest -> not . selectedHonestChain genesisTest)

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs

@@ -4,6 +4,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 
 -- | Peer simulator tests based on randomly generated schedules. They share the
@@ -26,7 +27,11 @@ import qualified Data.Map.Strict as Map
 import Data.Maybe (fromMaybe, mapMaybe)
 import Data.Word (Word64)
 import GHC.Stack (HasCallStack)
-import Ouroboros.Consensus.Block.Abstract (WithOrigin (NotOrigin))
+import Ouroboros.Consensus.Block.Abstract
+  ( ChainHash (..)
+  , GetHeader
+  , WithOrigin (NotOrigin)
+  )
 import Ouroboros.Consensus.Util.Condense (condense)
 import qualified Ouroboros.Network.AnchoredFragment as AF
 import Ouroboros.Network.Block (blockNo, blockSlot, unBlockNo)
@@ -93,13 +98,10 @@ tests =
 --  * no honest peer has been disconnected,
 --  * the immutable tip is on the best chain, and
 --  * the immutable tip is no older than s + d + 1 slots
-theProperty ::
-  GenesisTestFull TestBlock ->
-  StateView TestBlock ->
-  Property
+theProperty :: (AF.HasHeader blk, GetHeader blk) => GenesisTestFull blk -> StateView blk -> Property
 theProperty genesisTest stateView@StateView{svSelectedChain} =
   classify genesisWindowAfterIntersection "Full genesis window after intersection" $
-    classify (isOrigin immutableTipHash) "Immutable tip is Origin" $
+    classify (immutableTipHash == GenesisHash) "Immutable tip is Origin" $
       label disconnectedLabel $
         classify (advCount < length (btBranches gtBlockTree)) "Some adversaries performed rollbacks" $
           counterexample killedPeers $
@@ -109,7 +111,7 @@ theProperty genesisTest stateView@StateView{svSelectedChain} =
               conjoin
                 [ counterexample "Honest peers shouldn't be disconnected" (not $ any isHonestPeerId disconnected)
                 , counterexample ("The immutable tip should be honest: " ++ show immutableTip) $
-                    property (isHonest immutableTipHash)
+                    honestImmutableTip genesisTest stateView
                 , immutableTipIsRecent
                 ]
  where
@@ -124,11 +126,7 @@ theProperty genesisTest stateView@StateView{svSelectedChain} =
     (At h, Origin) -> h
     _ -> 0
 
-  isOrigin = null
-
-  isHonest = all (0 ==)
-
-  immutableTipHash = simpleHash (AF.anchorToHash immutableTip)
+  immutableTipHash = AF.anchorToHash immutableTip
 
   immutableTip = AF.anchor svSelectedChain
 
@@ -370,22 +368,20 @@ prop_loeStalling =
     shrinkPeerSchedules
     prop
  where
-  prop GenesisTest{gtBlockTree = BlockTree{btTrunk, btBranches}} StateView{svSelectedChain} =
+  prop ::
+    forall blk. (AF.HasHeader blk, GetHeader blk) => GenesisTestFull blk -> StateView blk -> Property
+  prop gt@GenesisTest{gtBlockTree = BlockTree{btTrunk, btBranches}} sv@StateView{svSelectedChain} =
     classify (any (== selectionTip) allTips) "The selection is at a branch tip" $
       classify (any anchorIsImmutableTip suffixes) "The immutable tip is at a fork intersection" $
-        property (isHonest immutableTipHash)
+        honestImmutableTip gt sv
    where
-    anchorIsImmutableTip branch = simpleHash (AF.anchorToHash (AF.anchor branch)) == immutableTipHash
+    anchorIsImmutableTip branch = AF.anchorToHash (AF.anchor branch) == immutableTipHash
 
-    isHonest = all (0 ==)
+    immutableTipHash = castHeaderHash . AF.anchorToHash $ AF.anchor svSelectedChain
 
-    immutableTipHash = simpleHash (AF.anchorToHash immutableTip)
+    selectionTip = castHeaderHash $ AF.headHash svSelectedChain
 
-    immutableTip = AF.anchor svSelectedChain
-
-    selectionTip = simpleHash (AF.headHash svSelectedChain)
-
-    allTips = simpleHash . AF.headHash <$> (btTrunk : suffixes)
+    allTips = AF.headHash <$> (btTrunk : suffixes)
 
     suffixes = btbSuffix <$> btBranches
 
@@ -395,7 +391,7 @@ prop_loeStalling =
 -- This ensures that a user may shut down their machine while syncing without additional vulnerabilities.
 prop_downtime :: Property
 prop_downtime =
-  forAllGenesisTest
+  forAllGenesisTest @TestBlock
     ( genChains (QC.choose (1, 4)) `enrichedWith` \gt ->
         ensureScheduleDuration gt <$> stToGen (uniformPoints (pointsGeneratorParams gt) (gtBlockTree gt))
     )