Skip to content

Commit 4c1afc8

Browse files
amesgenamesgen
committed
Add test for PerasWeightSnapshot 
1 parent bff1bf9 commit 4c1afc8

File tree

3 files changed

+179
-0
lines changed

3 files changed

+179
-0
lines changed

‎ouroboros-consensus/ouroboros-consensus.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -598,6 +598,7 @@ test-suite consensus-test
598598
Test.Consensus.MiniProtocol.ChainSync.CSJ
599599
Test.Consensus.MiniProtocol.ChainSync.Client
600600
Test.Consensus.MiniProtocol.LocalStateQuery.Server
601+
Test.Consensus.Peras.WeightSnapshot
601602
Test.Consensus.Util.MonadSTM.NormalForm
602603
Test.Consensus.Util.Versioned
603604

‎ouroboros-consensus/test/consensus-test/Main.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,7 @@ import qualified Test.Consensus.MiniProtocol.BlockFetch.Client (tests)
1616
import qualified Test.Consensus.MiniProtocol.ChainSync.CSJ (tests)
1717
import qualified Test.Consensus.MiniProtocol.ChainSync.Client (tests)
1818
import qualified Test.Consensus.MiniProtocol.LocalStateQuery.Server (tests)
19+
import qualified Test.Consensus.Peras.WeightSnapshot (tests)
1920
import qualified Test.Consensus.Util.MonadSTM.NormalForm (tests)
2021
import qualified Test.Consensus.Util.Versioned (tests)
2122
import Test.Tasty
@@ -43,6 +44,7 @@ tests =
4344
, Test.Consensus.Mempool.Fairness.tests
4445
, Test.Consensus.Mempool.StateMachine.tests
4546
]
47+
, Test.Consensus.Peras.WeightSnapshot.tests
4648
, Test.Consensus.Util.MonadSTM.NormalForm.tests
4749
, Test.Consensus.Util.Versioned.tests
4850
, testGroup

‎ouroboros-consensus/test/consensus-test/Test/Consensus/Peras/WeightSnapshot.hs

Lines changed: 176 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,176 @@
1+
{-# LANGUAGE BlockArguments #-}
2+
{-# LANGUAGE CPP #-}
3+
{-# LANGUAGE DerivingStrategies #-}
4+
{-# LANGUAGE NamedFieldPuns #-}
5+
{-# LANGUAGE ScopedTypeVariables #-}
6+
{-# LANGUAGE TupleSections #-}
7+
{-# LANGUAGE TypeApplications #-}
8+
9+
#if __GLASGOW_HASKELL__ >= 910
10+
{-# OPTIONS_GHC -Wno-x-partial #-}
11+
#endif
12+
13+
-- | Test that 'PerasWeightSnapshot' can correctly compute the weight of points
14+
-- and fragments.
15+
module Test.Consensus.Peras.WeightSnapshot (tests) where
16+
17+
import Cardano.Ledger.BaseTypes (unNonZero)
18+
import Data.Containers.ListUtils (nubOrd)
19+
import Data.Map.Strict (Map)
20+
import qualified Data.Map.Strict as Map
21+
import Data.Maybe (catMaybes)
22+
import Data.Traversable (for)
23+
import Ouroboros.Consensus.Block
24+
import Ouroboros.Consensus.Config.SecurityParam
25+
import Ouroboros.Consensus.Peras.Weight
26+
import Ouroboros.Consensus.Util.Condense
27+
import Ouroboros.Network.AnchoredFragment (AnchoredFragment)
28+
import qualified Ouroboros.Network.AnchoredFragment as AF
29+
import qualified Ouroboros.Network.Mock.Chain as Chain
30+
import Test.QuickCheck
31+
import Test.Tasty
32+
import Test.Tasty.QuickCheck
33+
import Test.Util.Orphans.Arbitrary ()
34+
import Test.Util.QuickCheck
35+
import Test.Util.TestBlock
36+
37+
tests :: TestTree
38+
tests =
39+
testGroup
40+
"PerasWeightSnapshot"
41+
[ testProperty "correctness" prop_perasWeightSnapshot
42+
]
43+
44+
prop_perasWeightSnapshot :: TestSetup -> Property
45+
prop_perasWeightSnapshot testSetup =
46+
tabulate "log₂ # of points" [show $ round @Double @Int $ logBase 2 (fromIntegral (length tsPoints))]
47+
. counterexample ("PerasWeightSnapshot: " <> show snap)
48+
$ conjoin
49+
[ conjoin
50+
[ counterexample ("Incorrect weight for " <> condense pt) $
51+
weightBoostOfPointReference pt =:= weightBoostOfPoint snap pt
52+
| pt <- tsPoints
53+
]
54+
, conjoin
55+
[ counterexample ("Incorrect weight for " <> condense frag) $
56+
weightBoostOfFragmentReference frag =:= weightBoostOfFragment snap frag
57+
| frag <- tsFragments
58+
]
59+
, conjoin
60+
[ conjoin
61+
[ counterexample ("Incorrect volatile suffix for " <> condense frag) $
62+
takeVolatileSuffixReference frag =:= volSuffix
63+
, counterexample ("Volatile suffix must be a suffix of" <> condense frag) $
64+
AF.headPoint frag =:= AF.headPoint volSuffix
65+
.&&. AF.withinFragmentBounds (AF.anchorPoint volSuffix) frag
66+
, counterexample ("Volatile suffix of " <> condense frag <> " must contain at most k blocks") $
67+
AF.length volSuffix `le` fromIntegral (unNonZero (maxRollbacks tsSecParam))
68+
]
69+
| frag <- tsFragments
70+
, let volSuffix = takeVolatileSuffix snap tsSecParam frag
71+
]
72+
]
73+
where
74+
TestSetup
75+
{ tsWeights
76+
, tsPoints
77+
, tsFragments
78+
, tsSecParam
79+
} = testSetup
80+
81+
snap = mkPerasWeightSnapshot $ Map.toList tsWeights
82+
83+
weightBoostOfPointReference :: Point TestBlock -> PerasWeight
84+
weightBoostOfPointReference pt = Map.findWithDefault mempty pt tsWeights
85+
86+
weightBoostOfFragmentReference :: AnchoredFragment TestBlock -> PerasWeight
87+
weightBoostOfFragmentReference frag =
88+
foldMap
89+
(weightBoostOfPointReference . blockPoint)
90+
(AF.toOldestFirst frag)
91+
92+
takeVolatileSuffixReference ::
93+
AnchoredFragment TestBlock -> AnchoredFragment TestBlock
94+
takeVolatileSuffixReference frag =
95+
head
96+
[ suffix
97+
| len <- reverse [0 .. AF.length frag]
98+
, -- Consider suffixes of @frag@, longest first
99+
let suffix = AF.anchorNewest (fromIntegral len) frag
100+
weightBoost = weightBoostOfFragmentReference suffix
101+
lengthWeight = PerasWeight (fromIntegral (AF.length suffix))
102+
totalWeight = lengthWeight <> weightBoost
103+
, totalWeight <= maxRollbackWeight tsSecParam
104+
]
105+
106+
data TestSetup = TestSetup
107+
{ tsWeights :: Map (Point TestBlock) PerasWeight
108+
, tsPoints :: [Point TestBlock]
109+
-- ^ Check the weight of these points.
110+
, tsFragments :: [AnchoredFragment TestBlock]
111+
-- ^ Check the weight of these fragments.
112+
, tsSecParam :: SecurityParam
113+
}
114+
deriving stock Show
115+
116+
instance Arbitrary TestSetup where
117+
arbitrary = do
118+
tree :: BlockTree <- arbitrary
119+
let tsPoints = nubOrd $ GenesisPoint : (blockPoint <$> treeToBlocks tree)
120+
treeChains = treeToChains tree
121+
tsWeights <- do
122+
boostedChain <- elements treeChains
123+
let boostablePts =
124+
GenesisPoint : (blockPoint <$> Chain.toOldestFirst boostedChain)
125+
Map.fromList . catMaybes <$> for boostablePts \pt -> do
126+
weight <-
127+
frequency
128+
[ (3, pure Nothing)
129+
, (1, Just . PerasWeight <$> choose (1, 10))
130+
]
131+
pure $ (pt,) <$> weight
132+
tsFragments <- for treeChains \chain -> do
133+
let lenChain = Chain.length chain
134+
fullFrag = Chain.toAnchoredFragment chain
135+
nTakeNewest <- choose (0, lenChain)
136+
nDropNewest <- choose (0, nTakeNewest)
137+
pure $
138+
AF.dropNewest nDropNewest $
139+
AF.anchorNewest (fromIntegral nTakeNewest) fullFrag
140+
tsSecParam <- arbitrary
141+
pure
142+
TestSetup
143+
{ tsWeights
144+
, tsPoints
145+
, tsFragments
146+
, tsSecParam
147+
}
148+
149+
shrink ts =
150+
concat
151+
[ [ ts{tsWeights = Map.fromList tsWeights'}
152+
| tsWeights' <-
153+
shrinkList
154+
-- Shrink boosted points to have weight 1.
155+
(\(pt, w) -> [(pt, w1) | w1 /= w])
156+
$ Map.toList tsWeights
157+
]
158+
, [ ts{tsPoints = tsPoints'}
159+
| tsPoints' <- shrinkList (\_pt -> []) tsPoints
160+
]
161+
, [ ts{tsFragments = tsFragments'}
162+
| tsFragments' <- shrinkList (\_frag -> []) tsFragments
163+
]
164+
, [ ts{tsSecParam = tsSecParam'}
165+
| tsSecParam' <- shrink tsSecParam
166+
]
167+
]
168+
where
169+
w1 = PerasWeight 1
170+
171+
TestSetup
172+
{ tsWeights
173+
, tsPoints
174+
, tsFragments
175+
, tsSecParam
176+
} = ts

0 commit comments

Comments
 (0)