Some cleanup

IntersectMBO · May 7, 2024 · c899201 · c899201
1 parent 27e877f
commit c899201
Show file tree

Hide file tree

Showing 4 changed files with 15 additions and 6 deletions.
diff --git a/...boros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/Classifiers.hs b/...boros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/Classifiers.hs
@@ -252,8 +252,7 @@ scheduleClassifiers GenesisTest{gtSchedule = schedule} =
     rollbacks = hasRollback <$> schedule
 
     adversaryRollback = any id $ adversarialPeers rollbacks
-
-    honestRollback = honestPeers rollbacks Map.! 1
+    honestRollback = any id $ honestPeers rollbacks
 
     allAdversariesEmpty = all id $ adversarialPeers $ null <$> schedule
 

diff --git a/...consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/DensityDisconnect.hs b/...consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/DensityDisconnect.hs
@@ -133,8 +133,8 @@ prop_densityDisconnectStatic =
     let (disconnect, _) = densityDisconnect sgen k (mkState <$> suffixes) suffixes loeFrag
     counterexample "it should disconnect some node" (not (null disconnect))
       .&&.
-     counterexample "it should not disconnect the honest peer"
-       (HonestPeer 1 `notElem` disconnect)
+     counterexample "it should not disconnect the honest peers"
+       (not $ any isHonestPeerId disconnect)
   where
     mkState :: AnchoredFragment (Header TestBlock) -> ChainSyncState TestBlock
     mkState frag =

diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs
@@ -40,7 +40,7 @@ import           Test.Consensus.PeerSimulator.Run (SchedulerConfig (..),
                      defaultSchedulerConfig)
 import           Test.Consensus.PeerSimulator.StateView
 import           Test.Consensus.PointSchedule
-import           Test.Consensus.PointSchedule.Peers (PeerId (..), Peers (..))
+import           Test.Consensus.PointSchedule.Peers (Peers (..), isHonestPeerId)
 import           Test.Consensus.PointSchedule.Shrinking
                      (shrinkByRemovingAdversaries, shrinkPeerSchedules)
 import           Test.Consensus.PointSchedule.SinglePeer
@@ -88,7 +88,7 @@ theProperty genesisTest stateView@StateView{svSelectedChain} =
   -- to the governor that the density is too low.
   longerThanGenesisWindow ==>
   conjoin [
-    counterexample "The honest peer was disconnected" (HonestPeer 1 `notElem` disconnected),
+    counterexample "An honest peer was disconnected" (not $ any isHonestPeerId disconnected),
     counterexample ("The immutable tip is not honest: " ++ show immutableTip) $
     property (isHonest immutableTipHash),
     immutableTipIsRecent

diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule/Peers.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule/Peers.hs
@@ -25,6 +25,8 @@ module Test.Consensus.PointSchedule.Peers (
   , getPeerIds
   , honestPeers'
   , honestPeers''
+  , isAdversarialPeerId
+  , isHonestPeerId
   , peers'
   , peersFromPeerIdList
   , peersFromPeerIdList'
@@ -248,3 +250,11 @@ deletePeer (HonestPeer n) Peers {honestPeers, adversarialPeers} =
   Peers {honestPeers = Map.delete n honestPeers, adversarialPeers}
 deletePeer (AdversarialPeer n) Peers {honestPeers, adversarialPeers} =
   Peers {honestPeers, adversarialPeers = Map.delete n adversarialPeers}
+
+isHonestPeerId :: PeerId -> Bool
+isHonestPeerId (HonestPeer _) = True
+isHonestPeerId _              = False
+
+isAdversarialPeerId :: PeerId -> Bool
+isAdversarialPeerId (AdversarialPeer _) = True
+isAdversarialPeerId _                   = False