Skip to content

Commit 24a4ed1

Browse files
jasagredojasagredo
authored
[CTC 1] Generalize point schedule tests to parametric blk (#1879)
Node-vs-Environment tests (a.k.a. point schedule tests, represented by `GenesisTest`) are currently hardcoded to use `TestBlock`. As part of the [approved Conformance Testing of Consensus (CTC) proposal](https://github.com/tweag/cardano-conformance-testing-of-consensus), we are tasked with exposing these tests to the wider ecosystem and therefore must support real Cardano blocks. This PR generalizes the relevant types to make the tests block-agnostic. To accomplish this: 1. The existing code is parameterized over an arbitrary block type, subject to the necessary constraints. 2. New code implementing `deforestBlockTree` is introduced to generalize property test computations that previously depended on the `TestHash` implementation. This function constructs a map enabling *prefix* lookups by `HeaderHash`, where a prefix is the `AnchoredFragment` from genesis to the block corresponding to the given hash at its tip. 3. A new type class, `HasPointScheduleTestParams`, is introduced to construct the `ProtocolInfo` and other pieces of state required for a test run. 4. A new type class, `IssueTestBlock`, defining the interface for producing blocks in tests, is introduced. Care has been taken to document the previously implicit `TestHash`-related logic (based on the use of ad hoc fork numbers) and to include comprehensive property tests for the *deforestation* code under `ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/BlockTree/Tests.hs`.
2 parents bc15cdc + afe45d7 commit 24a4ed1

File tree

26 files changed

+1176
-490
lines changed

26 files changed

+1176
-490
lines changed

‎ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -222,6 +222,7 @@ test-suite consensus-test
222222
main-is: Main.hs
223223
other-modules:
224224
Test.Consensus.BlockTree
225+
Test.Consensus.BlockTree.Tests
225226
Test.Consensus.GSM
226227
Test.Consensus.Genesis.Setup
227228
Test.Consensus.Genesis.Setup.Classifiers

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
module Main (main) where
22

3+
import qualified Test.Consensus.BlockTree.Tests (tests)
34
import qualified Test.Consensus.GSM (tests)
45
import qualified Test.Consensus.Genesis.Tests (tests)
56
import qualified Test.Consensus.HardFork.Combinator (tests)
@@ -33,4 +34,5 @@ tests =
3334
, Test.Consensus.PeerSimulator.Tests.tests
3435
, Test.Consensus.PointSchedule.Shrinking.Tests.tests
3536
, Test.Consensus.PointSchedule.Tests.tests
37+
, Test.Consensus.BlockTree.Tests.tests
3638
]

‎ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/BlockTree.hs‎

Lines changed: 118 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
{-# LANGUAGE CPP #-}
2-
{-# LANGUAGE NamedFieldPuns #-}
2+
{-# LANGUAGE PatternSynonyms #-}
33
{-# LANGUAGE RecordWildCards #-}
44

55
#if __GLASGOW_HASKELL__ >= 908
@@ -11,28 +11,40 @@
1111
-- duplication.
1212

1313
module Test.Consensus.BlockTree
14-
( BlockTree (..)
14+
( BlockTree (BlockTree, btTrunk, btBranches)
1515
, BlockTreeBranch (..)
1616
, PathAnchoredAtSource (..)
1717
, addBranch
1818
, addBranch'
1919
, allFragments
20+
, deforestBlockTree
2021
, findFragment
2122
, findPath
23+
, isAncestorOf
24+
, isStrictAncestorOf
2225
, mkTrunk
26+
, nonemptyPrefixesOf
27+
, onTrunk
2328
, prettyBlockTree
2429
) where
2530

26-
import Cardano.Slotting.Slot (SlotNo (unSlotNo))
27-
import Data.Foldable (asum)
31+
import Cardano.Slotting.Slot (SlotNo (unSlotNo), WithOrigin (..))
32+
import Data.Foldable (asum, fold)
2833
import Data.Function ((&))
2934
import Data.Functor ((<&>))
30-
import Data.List (sortOn)
35+
import Data.List (inits, sortOn)
36+
import qualified Data.Map.Strict as M
3137
import Data.Maybe (fromJust, fromMaybe)
3238
import Data.Ord (Down (Down))
3339
import qualified Data.Vector as Vector
3440
import Ouroboros.Consensus.Block.Abstract
35-
( blockNo
41+
( GetHeader (..)
42+
, HasHeader
43+
, Header
44+
, HeaderHash
45+
, Point
46+
, blockHash
47+
, blockNo
3648
, blockSlot
3749
, fromWithOrigin
3850
, pointSlot
@@ -72,17 +84,35 @@ data BlockTreeBranch blk = BlockTreeBranch
7284
-- INVARIANT: for all @BlockTreeBranch{..}@ in the tree, @btTrunk == fromJust $
7385
-- AF.join btbPrefix btbTrunkSuffix@.
7486
--
87+
-- INVARIANT: In @RawBlockTree trunk branches deforested@, we must have
88+
-- @deforested == deforestRawBlockTree trunk branches@.
89+
--
7590
-- REVIEW: Find another name so as not to clash with 'BlockTree' from
7691
-- `unstable-consensus-testlib/Test/Util/TestBlock.hs`.
77-
data BlockTree blk = BlockTree
78-
{ btTrunk :: AF.AnchoredFragment blk
79-
, btBranches :: [BlockTreeBranch blk]
92+
data BlockTree blk = RawBlockTree
93+
{ btTrunk' :: AF.AnchoredFragment blk
94+
, btBranches' :: [BlockTreeBranch blk]
95+
, -- Cached deforestation of the block tree. This gets queried
96+
-- many times and there's no reason to rebuild the tree every time.
97+
btDeforested :: DeforestedBlockTree blk
8098
}
8199
deriving Show
82100

101+
pattern BlockTree :: AF.AnchoredFragment blk -> [BlockTreeBranch blk] -> BlockTree blk
102+
pattern BlockTree{btTrunk, btBranches} <- RawBlockTree btTrunk btBranches _
103+
104+
{-# COMPLETE BlockTree #-}
105+
106+
deforestBlockTree :: BlockTree blk -> DeforestedBlockTree blk
107+
deforestBlockTree = btDeforested
108+
109+
-- Smart constructor to cache the deforested block tree at creation time.
110+
mkBlockTree :: HasHeader blk => AF.AnchoredFragment blk -> [BlockTreeBranch blk] -> BlockTree blk
111+
mkBlockTree trunk branches = RawBlockTree trunk branches (deforestRawBlockTree trunk branches)
112+
83113
-- | Make a block tree made of only a trunk.
84-
mkTrunk :: AF.AnchoredFragment blk -> BlockTree blk
85-
mkTrunk btTrunk = BlockTree{btTrunk, btBranches = []}
114+
mkTrunk :: HasHeader blk => AF.AnchoredFragment blk -> BlockTree blk
115+
mkTrunk btTrunk = mkBlockTree btTrunk []
86116

87117
-- | Add a branch to an existing block tree.
88118
--
@@ -99,7 +129,7 @@ addBranch branch bt = do
99129
-- NOTE: We could use the monadic bind for @Maybe@ here but we would rather
100130
-- catch bugs quicker.
101131
let btbFull = fromJust $ AF.join btbPrefix btbSuffix
102-
pure $ bt{btBranches = BlockTreeBranch{..} : btBranches bt}
132+
pure $ mkBlockTree (btTrunk bt) (BlockTreeBranch{..} : btBranches bt)
103133

104134
-- | Same as @addBranch@ but calls to 'error' if the former yields 'Nothing'.
105135
addBranch' :: AF.HasHeader blk => AF.AnchoredFragment blk -> BlockTree blk -> BlockTree blk
@@ -229,3 +259,79 @@ prettyBlockTree blockTree =
229259
case AF.anchor frag of
230260
AF.AnchorGenesis -> 0
231261
AF.Anchor slotNo _ _ -> slotNo + 1
262+
263+
-- | An 'AF.AnchoredFragment' is a list where the last element (the anchor) is a ghost.
264+
-- Here they represent the partial ancestry of a block, where the anchor is either
265+
-- @Genesis@ (start of the chain, not itself an actual block) or the hash of a block.
266+
-- Say we have blocks B1 through B5 (each succeeded by the next) and anchor A. You
267+
-- can think of the chain as growing __from left to right__ like this:
268+
--
269+
-- > A :> B1 :> B2 :> B3 :> B4 :> B5
270+
--
271+
-- 'nonemptyPrefixesOf' builds the list of prefixes of an 'AF.AnchoredFragment' with at
272+
-- least one non-anchor entry. The name is a little confusing because the way we
273+
-- usually think of cons-lists these would be suffixes:
274+
--
275+
-- > A :> B1 A :> B1 :> B2 A :> B1 :> B2 :> B3
276+
-- > A :> B1 :> B2 :> B3 :> B4 A :> B1 :> B2 :> B3 :> B4 :> B5
277+
--
278+
-- However this is consistent with 'Ouroboros.Network.AnchoredSeq.isPrefixOf'.
279+
nonemptyPrefixesOf ::
280+
AF.HasHeader blk => AF.AnchoredFragment blk -> [AF.AnchoredFragment blk]
281+
nonemptyPrefixesOf frag =
282+
fmap (AF.fromOldestFirst (AF.anchor frag)) . drop 1 . inits . AF.toOldestFirst $ frag
283+
284+
type DeforestedBlockTree blk = M.Map (HeaderHash blk) (AF.AnchoredFragment blk)
285+
286+
deforestRawBlockTree ::
287+
HasHeader blk =>
288+
AF.AnchoredFragment blk ->
289+
[BlockTreeBranch blk] ->
290+
DeforestedBlockTree blk
291+
deforestRawBlockTree trunk branches =
292+
let folder = foldMap $ \af -> either (const mempty) (flip M.singleton af . blockHash) $ AF.head af
293+
in fold $
294+
folder (prefixes (AF.Empty AF.AnchorGenesis) $ AF.toOldestFirst trunk)
295+
: fmap (\btb -> folder $ prefixes (btbPrefix btb) $ AF.toOldestFirst $ btbSuffix btb) branches
296+
297+
prefixes :: AF.HasHeader blk => AF.AnchoredFragment blk -> [blk] -> [AF.AnchoredFragment blk]
298+
prefixes = scanl (AF.:>)
299+
300+
-- | A check used in some of the handlers, determining whether the first argument
301+
-- is on the chain that ends in the second argument.
302+
--
303+
-- REVIEW: Using 'AF.withinFragmentBounds' for this might be cheaper.
304+
--
305+
-- TODO: Unify with 'Test.Util.TestBlock.isAncestorOf' which basically does the
306+
-- same thing except not on 'WithOrigin'.
307+
isAncestorOf ::
308+
(HasHeader blk, Eq blk) =>
309+
BlockTree blk ->
310+
WithOrigin blk ->
311+
WithOrigin blk ->
312+
Bool
313+
isAncestorOf tree (At ancestor) (At descendant) =
314+
let deforested = btDeforested tree
315+
in fromMaybe False $ do
316+
afD <- M.lookup (blockHash descendant) deforested
317+
afA <- M.lookup (blockHash ancestor) deforested
318+
pure $ AF.isPrefixOf afA afD
319+
isAncestorOf _ (At _) Origin = False
320+
isAncestorOf _ Origin _ = True
321+
322+
-- | Variant of 'isAncestorOf' that returns @False@ when the two blocks are
323+
-- equal.
324+
--
325+
-- TODO: Unify with 'Test.Util.TestBlock.isStrictAncestorOf' which basically does the
326+
-- same thing except not on 'WithOrigin'.
327+
isStrictAncestorOf ::
328+
(HasHeader blk, Eq blk) =>
329+
BlockTree blk ->
330+
WithOrigin blk ->
331+
WithOrigin blk ->
332+
Bool
333+
isStrictAncestorOf bt b1 b2 = b1 /= b2 && isAncestorOf bt b1 b2
334+
335+
-- | Check if a block (represented by its header 'Point') is on the 'BlockTree' trunk.
336+
onTrunk :: GetHeader blk => BlockTree blk -> Point (Header blk) -> Bool
337+
onTrunk blockTree = flip AF.withinFragmentBounds (AF.mapAnchoredFragment getHeader $ btTrunk blockTree)

‎ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/BlockTree/Tests.hs‎

Lines changed: 173 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,173 @@
1+
{-# LANGUAGE ScopedTypeVariables #-}
2+
{-# OPTIONS_GHC -Wno-orphans #-}
3+
4+
module Test.Consensus.BlockTree.Tests (tests) where
5+
6+
import Data.Function (on)
7+
import qualified Data.List as L
8+
import qualified Data.Map as M
9+
import Ouroboros.Consensus.Block.Abstract (HasHeader, HeaderHash)
10+
import qualified Ouroboros.Network.AnchoredFragment as AF
11+
import Ouroboros.Network.Block (blockHash)
12+
import Test.Consensus.BlockTree
13+
import Test.Consensus.Genesis.Setup.GenChains
14+
( GenesisTest (..)
15+
, genChains
16+
)
17+
import Test.QuickCheck
18+
import qualified Test.QuickCheck as QC
19+
import Test.Tasty
20+
import Test.Tasty.QuickCheck
21+
import Test.Util.TestBlock (TestBlock)
22+
23+
genTestBlockTree :: QC.Gen Word -> QC.Gen (BlockTree TestBlock)
24+
genTestBlockTree = fmap gtBlockTree . genChains
25+
26+
genTestAnchoredFragment :: QC.Gen (AF.AnchoredFragment TestBlock)
27+
genTestAnchoredFragment = fmap btTrunk $ genTestBlockTree (pure 0)
28+
29+
tests :: TestTree
30+
tests =
31+
let branchFactor = pure 4
32+
in testGroup
33+
"BlockTree"
34+
[ testGroup
35+
"nonemptyPrefixesOf"
36+
[ testProperty "nonemptyPrefixesArePrefixes" $
37+
forAll genTestAnchoredFragment $
38+
prop_nonemptyPrefixesOf_nonemptyPrefixesArePrefixes
39+
, testProperty "nonemptyPrefixesAreNonempty" $
40+
forAll genTestAnchoredFragment $
41+
prop_nonemptyPrefixesOf_nonemptyPrefixesAreNonempty
42+
, testProperty "nonemptyPrefixesAreUnique" $
43+
forAll genTestAnchoredFragment $
44+
prop_nonemptyPrefixesOf_nonemptyPrefixesAreUnique
45+
, testProperty "allShareInputAnchor" $
46+
forAll genTestAnchoredFragment $
47+
prop_nonemptyPrefixesOf_allShareInputAnchor
48+
]
49+
, testGroup
50+
"deforestBlockTree"
51+
[ testProperty "headPointsAreDistinct" $
52+
forAll (genTestBlockTree branchFactor) $
53+
prop_deforestBlockTree_headPointsAreDistinct
54+
, testProperty "imagesAreNonempty" $
55+
forAll (genTestBlockTree branchFactor) $
56+
prop_deforestBlockTree_imagesAreNonempty
57+
, testProperty "allShareTrunkAnchor" $
58+
forAll (genTestBlockTree branchFactor) $
59+
prop_deforestBlockTree_allShareTrunkAnchor
60+
, testProperty "fullBranchesAreBranches" $
61+
forAll (genTestBlockTree branchFactor) $
62+
prop_deforestBlockTree_fullBranchesAreBranches
63+
, testProperty "everyHeaderHashIsInTheMap" $
64+
forAll (genTestBlockTree branchFactor) $
65+
prop_deforestBlockTree_everyHeaderHashIsInTheMap
66+
, testProperty "prefixMaximalPrefixesAreBranches" $
67+
forAll (genTestBlockTree branchFactor) $
68+
prop_deforestBlockTree_prefixMaximalPrefixesAreBranches
69+
]
70+
]
71+
72+
-- | The nonempty prefixes of an `AF.AnchoredFragment` are in fact prefixes.
73+
prop_nonemptyPrefixesOf_nonemptyPrefixesArePrefixes ::
74+
(Eq blk, HasHeader blk) => AF.AnchoredFragment blk -> QC.Property
75+
prop_nonemptyPrefixesOf_nonemptyPrefixesArePrefixes fragment =
76+
QC.property . all (flip AF.isPrefixOf fragment) . nonemptyPrefixesOf $ fragment
77+
78+
-- | The nonempty prefixes of an `AF.AnchoredFragment` are in fact nonempty.
79+
prop_nonemptyPrefixesOf_nonemptyPrefixesAreNonempty ::
80+
HasHeader blk => AF.AnchoredFragment blk -> QC.Property
81+
prop_nonemptyPrefixesOf_nonemptyPrefixesAreNonempty fragment =
82+
QC.property . all (not . AF.null) . nonemptyPrefixesOf $ fragment
83+
84+
-- | The nonempty prefixes of an `AF.AnchoredFragment` are unique.
85+
prop_nonemptyPrefixesOf_nonemptyPrefixesAreUnique ::
86+
forall blk. HasHeader blk => AF.AnchoredFragment blk -> QC.Property
87+
prop_nonemptyPrefixesOf_nonemptyPrefixesAreUnique =
88+
QC.property . noDuplicates . fmap (fmap blockHash . AF.toOldestFirst) . nonemptyPrefixesOf
89+
90+
noDuplicates :: Ord a => [a] -> Bool
91+
noDuplicates =
92+
let tally k = M.insertWith (+) k (1 :: Int)
93+
in all (== 1) . M.elems . foldr tally mempty
94+
95+
-- | All the nonempty prefixes should share the original fragment's anchor.
96+
prop_nonemptyPrefixesOf_allShareInputAnchor ::
97+
HasHeader blk => AF.AnchoredFragment blk -> QC.Property
98+
prop_nonemptyPrefixesOf_allShareInputAnchor fragment =
99+
let sharesTrunkAnchor = ((==) `on` AF.anchor) fragment
100+
in QC.property . all sharesTrunkAnchor . nonemptyPrefixesOf $ fragment
101+
102+
-- | The head points of all the branches are distinct.
103+
-- (Points uniquely determine positions in the tree.)
104+
prop_deforestBlockTree_headPointsAreDistinct ::
105+
HasHeader blk => BlockTree blk -> QC.Property
106+
prop_deforestBlockTree_headPointsAreDistinct =
107+
QC.property . noDuplicates . fmap AF.headPoint . M.elems . deforestBlockTree
108+
109+
-- | The deforested branches are all populated.
110+
prop_deforestBlockTree_imagesAreNonempty ::
111+
BlockTree blk -> QC.Property
112+
prop_deforestBlockTree_imagesAreNonempty =
113+
QC.property . all (not . AF.null) . deforestBlockTree
114+
115+
-- | All the deforested branches share the trunk's anchor.
116+
prop_deforestBlockTree_allShareTrunkAnchor ::
117+
HasHeader blk => BlockTree blk -> QC.Property
118+
prop_deforestBlockTree_allShareTrunkAnchor tree =
119+
let sharesTrunkAnchor = ((==) `on` AF.anchor) (btTrunk tree)
120+
in QC.property . all sharesTrunkAnchor . deforestBlockTree $ tree
121+
122+
-- | Full branches are in the deforestation.
123+
prop_deforestBlockTree_fullBranchesAreBranches ::
124+
(Eq blk, HasHeader blk) => BlockTree blk -> QC.Property
125+
prop_deforestBlockTree_fullBranchesAreBranches tree =
126+
let inDeforestation = flip elem (deforestBlockTree tree)
127+
in QC.property . all inDeforestation . fmap btbFull . btBranches $ tree
128+
129+
-- | Every block header from the `BlockTree` is in the deforestation map.
130+
prop_deforestBlockTree_everyHeaderHashIsInTheMap ::
131+
forall blk. HasHeader blk => BlockTree blk -> QC.Property
132+
prop_deforestBlockTree_everyHeaderHashIsInTheMap tree@(BlockTree trunk branches) =
133+
let
134+
allBranchHeaderHashes :: BlockTreeBranch blk -> [HeaderHash blk]
135+
allBranchHeaderHashes (BlockTreeBranch prefix suffix restOfTrunk full) =
136+
fmap blockHash $ concatMap AF.toOldestFirst [prefix, suffix, restOfTrunk, full]
137+
138+
allHeaderHashes :: [HeaderHash blk]
139+
allHeaderHashes =
140+
fmap blockHash (AF.toOldestFirst trunk)
141+
<> concatMap allBranchHeaderHashes branches
142+
in
143+
QC.property $ all (flip M.member $ deforestBlockTree tree) allHeaderHashes
144+
145+
-- | An `AF.AnchoredFragment` is /prefix maximal/ in a list if it is not a nontrivial
146+
-- prefix of another fragment in the list. After deforesting a tree, the maximal
147+
-- prefixes in the result are precisely the trunk and branches of the tree in
148+
-- some order.
149+
prop_deforestBlockTree_prefixMaximalPrefixesAreBranches ::
150+
forall blk. (Ord blk, HasHeader blk) => BlockTree blk -> QC.Property
151+
prop_deforestBlockTree_prefixMaximalPrefixesAreBranches tree@(BlockTree trunk branches) =
152+
QC.property $
153+
((==) `on` (L.sort . fmap AF.toOldestFirst))
154+
(foldr (insertIfMaximalBy AF.isPrefixOf) [] $ deforestBlockTree tree)
155+
(trunk : fmap btbFull branches)
156+
157+
-- | If @u@ is smaller than any of the elements of @xs@, return @xs@.
158+
-- Otherwise, remove any elements of @xs@ smaller than @u@ and append @u@ to
159+
-- the remainder on the right.
160+
insertIfMaximalBy :: forall u. (u -> u -> Bool) -> u -> [u] -> [u]
161+
insertIfMaximalBy lessThan u =
162+
let
163+
go xs = case xs of
164+
[] -> [u]
165+
x : rest -> case x `lessThan` u of
166+
True -> go rest
167+
False ->
168+
x
169+
: case u `lessThan` x of
170+
True -> rest
171+
False -> go rest
172+
in
173+
go

0 commit comments

Comments
 (0)