Use partial accessor to retrieve the only honest peer

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

@@ -5,7 +5,6 @@ module Test.Consensus.Genesis.Tests.CSJ (tests) where
 
 import           Data.Containers.ListUtils (nubOrd)
 import           Data.List (nub)
-import qualified Data.Map.Strict as Map
 import           Data.Maybe (mapMaybe)
 import           Ouroboros.Consensus.Block (blockSlot, succWithOrigin)
 import           Ouroboros.Consensus.MiniProtocol.ChainSync.Client
@@ -25,6 +24,7 @@ import           Test.Consensus.PointSchedule.Peers (Peers (..), peers')
 import           Test.Tasty
 import           Test.Tasty.QuickCheck
 import           Test.Util.Orphans.IOLike ()
+import           Test.Util.PartialAccessors
 import           Test.Util.TestBlock (Header, TestBlock)
 import           Test.Util.TestEnv (adjustQuickCheckMaxSize)
 
@@ -115,7 +115,7 @@ prop_happyPath synchronized =
     genDuplicatedHonestSchedule gt@GenesisTest{gtExtraHonestPeers} = do
       Peers {honestPeers} <- genUniformSchedulePoints gt
       pure $ peers'
-        (replicate (fromIntegral gtExtraHonestPeers + 1) (honestPeers Map.! 1))
+        (replicate (fromIntegral gtExtraHonestPeers + 1) (getHonestPeer honestPeers))
         []
 
     isNewerThanJumpSizeFromTip :: GenesisTestFull TestBlock -> Header TestBlock -> Bool

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

@@ -231,7 +231,7 @@ data UpdateEvent = UpdateEvent {
 
 snapshotTree :: Peers EvolvingPeer -> BlockTree (Header TestBlock)
 snapshotTree Peers {honestPeers, adversarialPeers} =
-  foldr addBranch' (mkTrunk (candidate (honestPeers Map.! 1))) (candidate <$> adversarialPeers)
+  foldr addBranch' (mkTrunk (candidate (getHonestPeer honestPeers))) (candidate <$> adversarialPeers)
 
 prettyUpdateEvent :: UpdateEvent -> [String]
 prettyUpdateEvent UpdateEvent {target, added, killed, bounds, tree, loeFrag, curChain} =

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

@@ -51,6 +51,7 @@ import           Test.QuickCheck
 import           Test.Tasty
 import           Test.Tasty.QuickCheck
 import           Test.Util.Orphans.IOLike ()
+import           Test.Util.PartialAccessors
 import           Test.Util.QuickCheck (le)
 import           Test.Util.TestBlock (TestBlock)
 import           Test.Util.TestEnv (adjustQuickCheckMaxSize,
@@ -128,7 +129,7 @@ theProperty genesisTest stateView@StateView{svSelectedChain} =
       [] -> "No peers were disconnected"
       peers -> "Some peers were disconnected: " ++ intercalate ", " (condense <$> peers)
 
-    honestTipSlot = At $ blockSlot $ snd $ last $ mapMaybe fromBlockPoint $ (Map.! 1) $ honestPeers $ gtSchedule genesisTest
+    honestTipSlot = At $ blockSlot $ snd $ last $ mapMaybe fromBlockPoint $ getHonestPeer $ honestPeers $ gtSchedule genesisTest
 
     GenesisTest {gtBlockTree, gtGenesisWindow = GenesisWindow s, gtDelay = Delta d} = genesisTest
 
@@ -270,15 +271,15 @@ prop_leashingAttackTimeLimited =
     -- | A schedule which doesn't run past the last event of the honest peer
     genTimeLimitedSchedule :: GenesisTest TestBlock () -> QC.Gen (PeersSchedule TestBlock)
     genTimeLimitedSchedule genesisTest = do
-      Peers honest advs0 <- genUniformSchedulePoints genesisTest
+      Peers honests advs0 <- genUniformSchedulePoints genesisTest
       let timeLimit = estimateTimeBound
             (gtChainSyncTimeouts genesisTest)
             (gtLoPBucketParams genesisTest)
-            (honest Map.! 1)
+            (getHonestPeer honests)
             (Map.elems advs0)
           advs = fmap (takePointsUntil timeLimit) advs0
-          extendedHonest = extendScheduleUntil timeLimit <$> honest
-      pure $ Peers extendedHonest advs
+          extendedHonests = extendScheduleUntil timeLimit <$> honests
+      pure $ Peers extendedHonests advs
 
     takePointsUntil limit = takeWhile ((<= limit) . fst)
 

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

@@ -27,6 +27,7 @@ import           Test.Consensus.PointSchedule (GenesisTest (..),
 import           Test.Consensus.PointSchedule.Peers (Peers (..))
 import           Test.Consensus.PointSchedule.SinglePeer (SchedulePoint (..))
 import           Test.QuickCheck (shrinkList)
+import           Test.Util.PartialAccessors
 import           Test.Util.TestBlock (TestBlock, isAncestorOf,
                      isStrictAncestorOf)
 
@@ -127,7 +128,7 @@ shrinkTheHonestPeer theSchedule otherHonestPeers otherAdversarialPeers = do
 -- shrinks it.
 shrinkHonestPeer :: PeersSchedule blk -> [PeersSchedule blk]
 shrinkHonestPeer Peers {honestPeers, adversarialPeers} =
-  shrinkTheHonestPeer (honestPeers Map.! 1) Map.empty adversarialPeers
+  shrinkTheHonestPeer (getHonestPeer honestPeers) Map.empty adversarialPeers
     & map
       ( \(schedule', _, otherAdversarialPeers') ->
           Peers

ouroboros-consensus-diffusion/test/consensus-test/Test/Util/PartialAccessors.hs

@@ -5,11 +5,13 @@
 -- We know they won't fail there, because we generated the structures
 -- with the correct properties.
 module Test.Util.PartialAccessors (
-    getOnlyBranch
+    getHonestPeer
+  , getOnlyBranch
   , getOnlyBranchTip
   , getTrunkTip
   ) where
 
+import qualified Data.Map as Map
 import qualified Ouroboros.Network.AnchoredFragment as AF
 import           Ouroboros.Network.Block (HasHeader)
 import           Test.Consensus.BlockTree
@@ -30,3 +32,11 @@ getOnlyBranchTip BlockTree {btBranches} = case btBranches of
     (AF.Empty _)       -> error "alternate branch must have at least one block"
     (_ AF.:> tipBlock) -> tipBlock
   _ -> error "tree must have exactly one alternate branch"
+
+getHonestPeer :: Map.Map Int a -> a
+getHonestPeer honests =
+  if Map.size honests /= 1
+    then error "there must be exactly one honest peer"
+    else case Map.lookup 1 honests of
+      Nothing -> error "the only honest peer must have id 1"
+      Just p  -> p