Introduce peersOnlyAdversary and classify abnormal test peers as adversarial

Author: nbacquey

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

@@ -22,7 +22,8 @@ import           Test.Consensus.PeerSimulator.Run (SchedulerConfig (..),
                      defaultSchedulerConfig)
 import           Test.Consensus.PeerSimulator.StateView
 import           Test.Consensus.PointSchedule
-import           Test.Consensus.PointSchedule.Peers (peers', peersOnlyHonest)
+import           Test.Consensus.PointSchedule.Peers (peers', peersOnlyAdversary,
+                     peersOnlyHonest)
 import           Test.Consensus.PointSchedule.Shrinking (shrinkPeerSchedules)
 import           Test.Consensus.PointSchedule.SinglePeer (scheduleBlockPoint,
                      scheduleHeaderPoint, scheduleTipPoint)
@@ -82,7 +83,9 @@ prop_wait mustTimeout =
     dullSchedule timeout (_ AF.:> tipBlock) =
       let offset :: DiffTime = if mustTimeout then 1 else -1
        in PointSchedule
-            { psSchedule = peersOnlyHonest [(Time 0, scheduleTipPoint tipBlock)]
+            { psSchedule =
+                (if mustTimeout then peersOnlyAdversary else peersOnlyHonest)
+                [(Time 0, scheduleTipPoint tipBlock)]
             , psStartOrder = []
             , psMinEndTime = Time $ timeout + offset
             }
@@ -174,7 +177,7 @@ prop_serve mustTimeout =
     makeSchedule fragment@(_ AF.:> tipBlock) =
       PointSchedule {
         psSchedule =
-        peersOnlyHonest $
+        (if mustTimeout then peersOnlyAdversary else peersOnlyHonest) $
         (Time 0, scheduleTipPoint tipBlock)
           : ( flip concatMap (zip [1 ..] (AF.toOldestFirst fragment)) $ \(i, block) ->
                 [ (Time (secondsRationalToDiffTime (i * timeBetweenBlocks)), scheduleHeaderPoint block),

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Tests/Timeouts.hs

@@ -18,7 +18,8 @@ import           Test.Consensus.Genesis.Setup
 import           Test.Consensus.PeerSimulator.Run (defaultSchedulerConfig)
 import           Test.Consensus.PeerSimulator.StateView
 import           Test.Consensus.PointSchedule
-import           Test.Consensus.PointSchedule.Peers (peersOnlyHonest)
+import           Test.Consensus.PointSchedule.Peers (peersOnlyAdversary,
+                     peersOnlyHonest)
 import           Test.Consensus.PointSchedule.SinglePeer (scheduleBlockPoint,
                      scheduleHeaderPoint, scheduleTipPoint)
 import           Test.QuickCheck
@@ -63,7 +64,7 @@ prop_timeouts mustTimeout = do
     dullSchedule _ (AF.Empty _) = error "requires a non-empty block tree"
     dullSchedule timeout (_ AF.:> tipBlock) =
       let offset :: DiffTime = if mustTimeout then 1 else -1
-          psSchedule = peersOnlyHonest $ [
+          psSchedule = (if mustTimeout then peersOnlyAdversary else peersOnlyHonest) $ [
               (Time 0, scheduleTipPoint tipBlock),
               (Time 0, scheduleHeaderPoint tipBlock),
               (Time 0, scheduleBlockPoint tipBlock)

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule/Peers.hs

@@ -32,6 +32,7 @@ module Test.Consensus.PointSchedule.Peers (
   , peersFromPeerIdList'
   , peersFromPeerList
   , peersList
+  , peersOnlyAdversary
   , peersOnlyHonest
   , toMap
   , toMap'
@@ -147,6 +148,13 @@ peersOnlyHonest value =
       adversarialPeers = Map.empty
     }
 
+peersOnlyAdversary :: a -> Peers a
+peersOnlyAdversary value =
+  Peers
+    { adversarialPeers = Map.singleton 1 value,
+      honestPeers = Map.empty
+    }
+
 -- | Extract all 'PeerId's.
 getPeerIds :: Peers a -> [PeerId]
 getPeerIds Peers {honestPeers, adversarialPeers} =