Skip to content

Commit e542170

Browse files
amesgenamesgen
committed
Add ChainDB test for ledger snapshots
1 parent be5d67a commit e542170

File tree

3 files changed

+377
-0
lines changed

3 files changed

+377
-0
lines changed

‎ouroboros-consensus/ouroboros-consensus.cabal

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -685,6 +685,7 @@ test-suite storage-test
685685
Test.Ouroboros.Storage.ChainDB.FollowerPromptness
686686
Test.Ouroboros.Storage.ChainDB.GcSchedule
687687
Test.Ouroboros.Storage.ChainDB.Iterator
688+
Test.Ouroboros.Storage.ChainDB.LedgerSnapshots
688689
Test.Ouroboros.Storage.ChainDB.Model
689690
Test.Ouroboros.Storage.ChainDB.Model.Test
690691
Test.Ouroboros.Storage.ChainDB.Paths

‎ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB.hs

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,7 @@ import System.Info (os)
2525
import qualified Test.Ouroboros.Storage.ChainDB.FollowerPromptness as FollowerPromptness
2626
import qualified Test.Ouroboros.Storage.ChainDB.GcSchedule as GcSchedule
2727
import qualified Test.Ouroboros.Storage.ChainDB.Iterator as Iterator
28+
import qualified Test.Ouroboros.Storage.ChainDB.LedgerSnapshots as LedgerSnapshots
2829
import qualified Test.Ouroboros.Storage.ChainDB.Model.Test as Model
2930
import qualified Test.Ouroboros.Storage.ChainDB.Paths as Paths
3031
import qualified Test.Ouroboros.Storage.ChainDB.StateMachine as StateMachine
@@ -36,6 +37,7 @@ tests =
3637
testGroup "ChainDB" $
3738
[ Iterator.tests
3839
, FollowerPromptness.tests
40+
, LedgerSnapshots.tests
3941
, GcSchedule.tests
4042
, Model.tests
4143
, Paths.tests

‎ouroboros-consensus/test/storage-test/Test/Ouroboros/Storage/ChainDB/LedgerSnapshots.hs

Lines changed: 374 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,374 @@
1+
{-# LANGUAGE BlockArguments #-}
2+
{-# LANGUAGE DerivingStrategies #-}
3+
{-# LANGUAGE FlexibleContexts #-}
4+
{-# LANGUAGE LambdaCase #-}
5+
{-# LANGUAGE NamedFieldPuns #-}
6+
{-# LANGUAGE RankNTypes #-}
7+
{-# LANGUAGE ScopedTypeVariables #-}
8+
{-# LANGUAGE TupleSections #-}
9+
{-# LANGUAGE ViewPatterns #-}
10+
11+
-- | Test that ledger snapshots are performed at /predictable/ points on the
12+
-- immutable chain (modulo rate limiting).
13+
--
14+
-- We open a ChainDB and add to it a (shuffled) list of blocks such that the
15+
-- immutable chain is predetermined. Then, we check that ledger snapshots were
16+
-- created for precisely the points we expect given the configured
17+
-- 'SnapshotFrequencyArgs'.
18+
module Test.Ouroboros.Storage.ChainDB.LedgerSnapshots (tests) where
19+
20+
import Cardano.Ledger.BaseTypes (unNonZero, unsafeNonZero)
21+
import Control.Monad (replicateM)
22+
import Control.Monad.IOSim (runSim)
23+
import Control.ResourceRegistry
24+
import Control.Tracer
25+
import Data.Foldable (for_)
26+
import qualified Data.List.NonEmpty as NE
27+
import Data.Maybe (mapMaybe)
28+
import qualified Data.Set as Set
29+
import Data.Time (secondsToDiffTime)
30+
import Data.Traversable (for)
31+
import Data.Word (Word64)
32+
import Ouroboros.Consensus.Block
33+
import Ouroboros.Consensus.Config
34+
import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB
35+
import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB)
36+
import qualified Ouroboros.Consensus.Storage.ChainDB.API.Types.InvalidBlockPunishment as Punishment
37+
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB
38+
import Ouroboros.Consensus.Storage.LedgerDB (LedgerDbFlavorArgs)
39+
import qualified Ouroboros.Consensus.Storage.LedgerDB as LedgerDB
40+
import Ouroboros.Consensus.Storage.LedgerDB.Snapshots
41+
import qualified Ouroboros.Consensus.Storage.LedgerDB.Snapshots as LedgerDB
42+
import qualified Ouroboros.Consensus.Storage.LedgerDB.V1.Args as LedgerDB
43+
import qualified Ouroboros.Consensus.Storage.LedgerDB.V2.Args as LedgerDB
44+
import Ouroboros.Consensus.Util (dropLast)
45+
import Ouroboros.Consensus.Util.Args
46+
import Ouroboros.Consensus.Util.Condense
47+
import Ouroboros.Consensus.Util.Enclose (Enclosing' (FallingEdgeWith))
48+
import Ouroboros.Consensus.Util.IOLike
49+
import Ouroboros.Network.AnchoredFragment (Anchor, AnchoredFragment)
50+
import qualified Ouroboros.Network.AnchoredFragment as AF
51+
import System.FS.API (SomeHasFS)
52+
import Test.Tasty
53+
import Test.Tasty.QuickCheck
54+
import Test.Util.ChainDB
55+
import Test.Util.Orphans.IOLike ()
56+
import Test.Util.QuickCheck
57+
import Test.Util.TestBlock
58+
import Test.Util.Tracer (recordingTracerTVar)
59+
60+
tests :: TestTree
61+
tests =
62+
testGroup
63+
"LedgerSnapshots"
64+
[ testProperty "InMemV1" $ prop_ledgerSnapshots inMemV1
65+
, testProperty "InMemV2" $ prop_ledgerSnapshots inMemV2
66+
]
67+
where
68+
inMemV1 =
69+
LedgerDB.LedgerDbFlavorArgsV1 $
70+
LedgerDB.V1Args LedgerDB.DisableFlushing LedgerDB.InMemoryBackingStoreArgs
71+
inMemV2 =
72+
LedgerDB.LedgerDbFlavorArgsV2 (LedgerDB.V2Args LedgerDB.InMemoryHandleArgs)
73+
74+
prop_ledgerSnapshots ::
75+
(forall m. Complete LedgerDbFlavorArgs m) ->
76+
TestSetup ->
77+
Property
78+
prop_ledgerSnapshots lgrDbFlavorArgs testSetup =
79+
case runSim (runTest lgrDbFlavorArgs testSetup) of
80+
Right testOutcome -> checkTestOutcome testSetup testOutcome
81+
Left err -> counterexample ("Failure: " <> show err) False
82+
83+
{-------------------------------------------------------------------------------
84+
Test setup
85+
-------------------------------------------------------------------------------}
86+
87+
data TestSetup = TestSetup
88+
{ tsSecParam :: SecurityParam
89+
, tsMainChain :: AnchoredFragment TestBlock
90+
, tsForks :: [AnchoredFragment TestBlock]
91+
-- ^ Forks anchored in the immutable prefix of the main chain. Must be of
92+
-- length at most @k@.
93+
, tsPerm :: Permutation
94+
-- ^ Shuffle the blocks when adding them to the ChainDB, see 'tsBlocksToAdd'.
95+
, tsTestSnapshotPolicyArgs :: TestSnapshotPolicyArgs
96+
}
97+
deriving stock Show
98+
99+
data TestSnapshotPolicyArgs = TestSnapshotPolicyArgs
100+
{ tspaNum :: Word
101+
, tspaInterval :: SlotNo
102+
, tspaOffset :: SlotNo
103+
, tspaRateLimit :: DiffTime
104+
}
105+
deriving stock Show
106+
107+
instance Arbitrary TestSnapshotPolicyArgs where
108+
arbitrary = do
109+
tspaNum <- choose (1, 10)
110+
tspaInterval <- SlotNo <$> choose (1, 10)
111+
tspaOffset <- SlotNo <$> choose (1, 20)
112+
tspaRateLimit <-
113+
frequency
114+
[ (2, pure 0)
115+
, (1, secondsToDiffTime <$> choose (1, 10))
116+
]
117+
pure
118+
TestSnapshotPolicyArgs
119+
{ tspaNum
120+
, tspaInterval
121+
, tspaOffset
122+
, tspaRateLimit
123+
}
124+
125+
-- | Add blocks to the ChainDB in this order.
126+
tsBlocksToAdd :: TestSetup -> [TestBlock]
127+
tsBlocksToAdd testSetup =
128+
permute tsPerm $
129+
foldMap AF.toOldestFirst (tsMainChain : tsForks)
130+
where
131+
TestSetup{tsMainChain, tsForks, tsPerm} = testSetup
132+
133+
tsSnapshotPolicyArgs :: TestSetup -> SnapshotPolicyArgs
134+
tsSnapshotPolicyArgs TestSetup{tsTestSnapshotPolicyArgs} =
135+
SnapshotPolicyArgs
136+
{ spaFrequency
137+
, spaNum = Override $ tspaNum tsTestSnapshotPolicyArgs
138+
}
139+
where
140+
spaFrequency =
141+
SnapshotFrequency
142+
SnapshotFrequencyArgs
143+
{ sfaInterval = Override $ tspaInterval tsTestSnapshotPolicyArgs
144+
, sfaOffset = Override $ tspaOffset tsTestSnapshotPolicyArgs
145+
, sfaRateLimit = Override $ tspaRateLimit tsTestSnapshotPolicyArgs
146+
}
147+
148+
instance Arbitrary TestSetup where
149+
arbitrary = do
150+
k <- choose (1, 6)
151+
let
152+
-- Generate an anchored fragment of the given length starting from the
153+
-- given block, with random slot gaps.
154+
genChain ::
155+
Int -> -- Length of the chain
156+
Word64 -> -- Fork number
157+
Anchor TestBlock ->
158+
Gen (AnchoredFragment TestBlock)
159+
genChain len forkNo anchor =
160+
go 0 (AF.Empty anchor)
161+
where
162+
go n acc
163+
| n >= len = pure acc
164+
| otherwise = do
165+
slotOffset <- SlotNo <$> choose (1, 10)
166+
let blk = modifyFork (\_ -> forkNo) $
167+
(\b -> b{tbSlot = tbSlot b + slotOffset}) $
168+
case AF.headPoint acc of
169+
GenesisPoint -> firstBlock forkNo
170+
BlockPoint slot hash ->
171+
(successorBlockWithPayload hash slot ())
172+
go (n + 1) (acc AF.:> blk)
173+
174+
immutableLength <- choose (0, 20)
175+
tsMainChain <- genChain (immutableLength + k) 0 AF.AnchorGenesis
176+
let immChain = AF.dropNewest k tsMainChain
177+
immAnchors = AF.anchor immChain : (AF.anchorFromBlock <$> AF.toOldestFirst immChain)
178+
numForks <- choose (0, 5)
179+
forkAnchors <- replicateM numForks $ elements immAnchors
180+
tsForks <- for ([1 ..] `zip` forkAnchors) $ \(forkNo, forkAnchor) -> do
181+
forkLength <- choose (1, k)
182+
genChain forkLength forkNo forkAnchor
183+
184+
tsPerm <- arbitrary
185+
tsTestSnapshotPolicyArgs <- arbitrary
186+
pure
187+
TestSetup
188+
{ tsSecParam = SecurityParam $ unsafeNonZero $ fromIntegral k
189+
, tsMainChain
190+
, tsForks
191+
, tsPerm
192+
, tsTestSnapshotPolicyArgs
193+
}
194+
195+
shrink testSetup@TestSetup{tsSecParam, tsMainChain, tsForks} =
196+
[ testSetup
197+
{ tsMainChain = tsMainChain'
198+
, tsForks = filter isStillAnchoredOnImmChain tsForks
199+
}
200+
| tsMainChain' <- [AF.dropNewest 1 tsMainChain | not $ AF.null tsMainChain]
201+
, let k = unNonZero $ maxRollbacks tsSecParam
202+
immChain' = AF.dropNewest (fromIntegral k) tsMainChain'
203+
isStillAnchoredOnImmChain f =
204+
AF.withinFragmentBounds (AF.anchorPoint f) immChain'
205+
]
206+
207+
{-------------------------------------------------------------------------------
208+
Run test
209+
-------------------------------------------------------------------------------}
210+
211+
data TestOutcome = TestOutcome
212+
{ toutImmutableTip :: Anchor TestBlock
213+
, toutTrace :: [(Time, ChainDB.TraceEvent TestBlock)]
214+
, toutFinalSnapshots :: [DiskSnapshot]
215+
}
216+
deriving stock Show
217+
218+
runTest ::
219+
forall m.
220+
IOLike m =>
221+
Complete LedgerDbFlavorArgs m ->
222+
TestSetup ->
223+
m TestOutcome
224+
runTest lgrDbFlavorArgs testSetup = withRegistry \registry -> do
225+
(withTime -> tracer, getTrace) <- recordingTracerTVar
226+
227+
(chainDB, lgrHasFS) <- openChainDB registry tracer
228+
229+
for_ (tsBlocksToAdd testSetup) \blk -> do
230+
ChainDB.addBlock_ chainDB Punishment.noPunishment blk
231+
threadDelay 1
232+
233+
toutImmutableTip <-
234+
AF.castAnchor . AF.anchor <$> atomically (ChainDB.getCurrentChain chainDB)
235+
toutTrace <- getTrace
236+
toutFinalSnapshots <- LedgerDB.listSnapshots lgrHasFS
237+
pure
238+
TestOutcome
239+
{ toutImmutableTip
240+
, toutTrace
241+
, toutFinalSnapshots
242+
}
243+
where
244+
openChainDB ::
245+
ResourceRegistry m ->
246+
Tracer m (ChainDB.TraceEvent TestBlock) ->
247+
m (ChainDB m TestBlock, SomeHasFS m)
248+
openChainDB registry cdbTracer = do
249+
chainDbArgs <- do
250+
mcdbNodeDBs <- emptyNodeDBs
251+
let mcdbTopLevelConfig = singleNodeTestConfigWithK (tsSecParam testSetup)
252+
cdbArgs =
253+
fromMinimalChainDbArgs
254+
MinimalChainDbArgs
255+
{ mcdbTopLevelConfig
256+
, mcdbNodeDBs
257+
, mcdbChunkInfo = mkTestChunkInfo mcdbTopLevelConfig
258+
, mcdbInitLedger = testInitExtLedger
259+
, mcdbRegistry = registry
260+
}
261+
updLgrDbArgs a =
262+
a
263+
{ ChainDB.cdbLgrDbArgs =
264+
(ChainDB.cdbLgrDbArgs a)
265+
{ LedgerDB.lgrFlavorArgs = lgrDbFlavorArgs
266+
, LedgerDB.lgrSnapshotPolicyArgs = tsSnapshotPolicyArgs testSetup
267+
}
268+
}
269+
pure $ updLgrDbArgs $ ChainDB.updateTracer cdbTracer cdbArgs
270+
(_, chainDB) <-
271+
allocate
272+
registry
273+
(\_ -> ChainDB.openDB chainDbArgs)
274+
(ChainDB.closeDB)
275+
pure (chainDB, LedgerDB.lgrHasFS . ChainDB.cdbLgrDbArgs $ chainDbArgs)
276+
277+
withTime = contramapM \ev -> (,ev) <$> getMonotonicTime
278+
279+
{-------------------------------------------------------------------------------
280+
Assess a test outcome
281+
-------------------------------------------------------------------------------}
282+
283+
checkTestOutcome :: TestSetup -> TestOutcome -> Property
284+
checkTestOutcome testSetup testOutcome =
285+
withLabelling . withTrace $
286+
conjoin
287+
[ counterexample "Unexpected immutable tip" $
288+
toutImmutableTip === AF.headAnchor immChain
289+
, counterexample "Snapshots not strictly increasing" $
290+
strictlyIncreasing (snd <$> actualSnapshots)
291+
, counterexample ("Unexpected number of on-disk snapshots " <> show toutFinalSnapshots) $
292+
length toutFinalSnapshots
293+
=== min (length actualSnapshots) (fromIntegral tspaNum)
294+
, counterexample ("Rate limit not respected...") $
295+
conjoin
296+
[ counterexample ("...between " <> condense pt1 <> " and " <> condense pt2) $
297+
tspaRateLimit `le` diffTime t2 t1
298+
| ((t1, pt1), (t2, pt2)) <- actualSnapshots `zip` drop 1 actualSnapshots
299+
]
300+
, counterexample "Unexpected snapshots performed" $
301+
counterexample ("Policy: " <> show policyArgs) $ do
302+
let actual = Set.fromList (snd <$> actualSnapshots)
303+
expect = Set.fromList expectedSnapshots
304+
counterexample ("Not expected: " <> condense (actual Set.\\ expect)) $
305+
if tspaRateLimit <= 0
306+
then
307+
counterexample ("Expected, but missing: " <> condense (expect Set.\\ actual)) $
308+
actual === expect
309+
else
310+
property $ actual `Set.isSubsetOf` expect
311+
]
312+
where
313+
TestSetup
314+
{ tsSecParam = unNonZero . maxRollbacks -> k
315+
, tsMainChain
316+
, tsTestSnapshotPolicyArgs =
317+
policyArgs@TestSnapshotPolicyArgs
318+
{ tspaNum
319+
, tspaInterval
320+
, tspaOffset
321+
, tspaRateLimit
322+
}
323+
} = testSetup
324+
325+
immChain = AF.dropNewest (fromIntegral k) tsMainChain
326+
327+
ppTrace (time, ev) = show time <> ": " <> show ev
328+
329+
isTookSnapshot :: ChainDB.TraceEvent blk -> Maybe SlotNo
330+
isTookSnapshot = \case
331+
ChainDB.TraceLedgerDBEvent
332+
( LedgerDB.LedgerDBSnapshotEvent
333+
(LedgerDB.TookSnapshot _ pt FallingEdgeWith{})
334+
) -> pure $ realPointSlot pt
335+
_ -> Nothing
336+
337+
TestOutcome
338+
{ toutImmutableTip
339+
, toutTrace
340+
, toutFinalSnapshots
341+
} = testOutcome
342+
343+
actualSnapshots :: [(Time, SlotNo)]
344+
actualSnapshots = mapMaybe (traverse isTookSnapshot) toutTrace
345+
346+
-- Group on @(s1 - offset) / interval@ and take the last entry from each group
347+
-- (apart from the last one).
348+
expectedSnapshots :: [SlotNo]
349+
expectedSnapshots =
350+
fmap NE.last
351+
-- For the last group, it is not yet necessarily clear what the last
352+
-- immutable block will be. (If there is a block in the last slot of a
353+
-- group, ie the predecessor of @offset + n * interval@ for some @n@,
354+
-- there can't be, but it doesn't seem important to handle this case in a
355+
-- special way.)
356+
. dropLast 1
357+
. NE.groupWith snapshotGroup
358+
. fmap blockSlot
359+
. AF.toOldestFirst
360+
$ immChain
361+
where
362+
snapshotGroup s1
363+
| s1 < tspaOffset = Nothing
364+
| otherwise = Just $ unSlotNo (s1 - tspaOffset) `div` unSlotNo tspaInterval
365+
366+
withTrace =
367+
counterexample ("Trace:\n" <> unlines (ppTrace <$> toutTrace))
368+
. counterexample ("Actual snapshots: " <> condense actualSnapshots)
369+
. counterexample ("Actual immutable tip: " <> condense (AF.anchorToPoint toutImmutableTip))
370+
. counterexample ("Immutable chain: " <> condense immChain)
371+
372+
withLabelling =
373+
tabulate "# actual snapshots" [show (length actualSnapshots)]
374+
. tabulate "length of immutable chain" [show (AF.anchorToBlockNo toutImmutableTip)]

0 commit comments

Comments
 (0)