Skip to content

Commit 0ae95b6

Browse files
amesgenamesgen
committed
Add test for PerasWeightSnapshot 
1 parent 9f7c1be commit 0ae95b6

File tree

3 files changed

+174
-0
lines changed

3 files changed

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

0 commit comments

Comments
 (0)