Skip to content

Commit 014979e

Browse files
jeltschjeltsch
authored
Merge pull request #582 from IntersectMBO/jeltsch/constrained-serialized-key-generation
Improve the handling of serialized keys in the test suite
2 parents 5c7465b + 9c6432a commit 014979e

File tree

9 files changed

+159
-91
lines changed

9 files changed

+159
-91
lines changed

‎lsm-tree.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -371,6 +371,7 @@ test-suite lsm-tree-test
371371
Test.Database.LSMTree.Internal.Monkey
372372
Test.Database.LSMTree.Internal.PageAcc
373373
Test.Database.LSMTree.Internal.PageAcc1
374+
Test.Database.LSMTree.Internal.RawBytes
374375
Test.Database.LSMTree.Internal.RawOverflowPage
375376
Test.Database.LSMTree.Internal.RawPage
376377
Test.Database.LSMTree.Internal.Run

‎src-extras/Database/LSMTree/Extras/Generators.hs‎

Lines changed: 30 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -34,8 +34,9 @@ module Database.LSMTree.Extras.Generators (
3434
, genRawBytesSized
3535
, packRawBytesPinnedOrUnpinned
3636
, LargeRawBytes (..)
37+
, isKeyForIndexCompact
3738
, KeyForIndexCompact (..)
38-
, keyForIndexCompactInvariant
39+
, BiasedKeyForIndexCompact (..)
3940
) where
4041

4142
import Control.DeepSeq (NFData)
@@ -469,7 +470,6 @@ shrinkSlice (RawBytes pvec) =
469470
, m <- QC.shrink (VP.length pvec - n)
470471
]
471472

472-
-- TODO: makes collisions very unlikely
473473
deriving newtype instance Arbitrary SerialisedKey
474474

475475
instance Arbitrary SerialisedValue where
@@ -508,15 +508,36 @@ instance Arbitrary LargeRawBytes where
508508

509509
deriving newtype instance SerialiseValue LargeRawBytes
510510

511-
-- | Minimum length of 8 bytes.
511+
-- Serialised keys for the compact index must be at least 8 bytes long.
512+
513+
genKeyForIndexCompact :: Gen RawBytes
514+
genKeyForIndexCompact =
515+
genRawBytesN =<< QC.sized (\s -> QC.chooseInt (8, s + 8))
516+
517+
isKeyForIndexCompact :: RawBytes -> Bool
518+
isKeyForIndexCompact rb = RB.size rb >= 8
519+
512520
newtype KeyForIndexCompact =
513521
KeyForIndexCompact { getKeyForIndexCompact :: RawBytes }
514522
deriving stock (Eq, Ord, Show)
515523

516524
instance Arbitrary KeyForIndexCompact where
525+
arbitrary =
526+
KeyForIndexCompact <$> genKeyForIndexCompact
527+
shrink (KeyForIndexCompact rawBytes) =
528+
[KeyForIndexCompact rawBytes' | rawBytes' <- shrink rawBytes,
529+
isKeyForIndexCompact rawBytes']
530+
531+
deriving newtype instance SerialiseKey KeyForIndexCompact
532+
533+
newtype BiasedKeyForIndexCompact =
534+
BiasedKeyForIndexCompact { getBiasedKeyForIndexCompact :: RawBytes }
535+
deriving stock (Eq, Ord, Show)
536+
537+
instance Arbitrary BiasedKeyForIndexCompact where
517538
-- we try to make collisions and close keys more likely (very crudely)
518-
arbitrary = KeyForIndexCompact <$> frequency
519-
[ (6, genRawBytesN =<< QC.sized (\s -> QC.chooseInt (8, s + 8)))
539+
arbitrary = BiasedKeyForIndexCompact <$> frequency
540+
[ (6, genKeyForIndexCompact)
520541
, (1, do
521542
lastByte <- QC.sized $ skewedWithMax . fromIntegral
522543
return (RB.pack ([1,3,3,7,0,1,7] <> [lastByte]))
@@ -529,17 +550,13 @@ instance Arbitrary KeyForIndexCompact where
529550
ub2 <- QC.chooseBoundedIntegral (0, ub1)
530551
QC.chooseBoundedIntegral (0, ub2)
531552

532-
shrink (KeyForIndexCompact rb) =
533-
[ k'
553+
shrink (BiasedKeyForIndexCompact rb) =
554+
[ BiasedKeyForIndexCompact rb'
534555
| rb' <- shrink rb
535-
, let k' = KeyForIndexCompact rb'
536-
, keyForIndexCompactInvariant k'
556+
, isKeyForIndexCompact rb'
537557
]
538558

539-
deriving newtype instance SerialiseKey KeyForIndexCompact
540-
541-
keyForIndexCompactInvariant :: KeyForIndexCompact -> Bool
542-
keyForIndexCompactInvariant (KeyForIndexCompact rb) = RB.size rb >= 8
559+
deriving newtype instance SerialiseKey BiasedKeyForIndexCompact
543560

544561
{-------------------------------------------------------------------------------
545562
Unsliced

‎test/Main.hs‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -22,6 +22,7 @@ import qualified Test.Database.LSMTree.Internal.MergingTree
2222
import qualified Test.Database.LSMTree.Internal.Monkey
2323
import qualified Test.Database.LSMTree.Internal.PageAcc
2424
import qualified Test.Database.LSMTree.Internal.PageAcc1
25+
import qualified Test.Database.LSMTree.Internal.RawBytes
2526
import qualified Test.Database.LSMTree.Internal.RawOverflowPage
2627
import qualified Test.Database.LSMTree.Internal.RawPage
2728
import qualified Test.Database.LSMTree.Internal.Run
@@ -68,8 +69,9 @@ main = do
6869
, Test.Database.LSMTree.Internal.Monkey.tests
6970
, Test.Database.LSMTree.Internal.PageAcc.tests
7071
, Test.Database.LSMTree.Internal.PageAcc1.tests
71-
, Test.Database.LSMTree.Internal.RawPage.tests
72+
, Test.Database.LSMTree.Internal.RawBytes.tests
7273
, Test.Database.LSMTree.Internal.RawOverflowPage.tests
74+
, Test.Database.LSMTree.Internal.RawPage.tests
7375
, Test.Database.LSMTree.Internal.Run.tests
7476
, Test.Database.LSMTree.Internal.RunAcc.tests
7577
, Test.Database.LSMTree.Internal.RunBuilder.tests

‎test/Test/Database/LSMTree/Generators.hs‎

Lines changed: 6 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -44,7 +44,11 @@ tests = testGroup "Test.Database.LSMTree.Generators" [
4444
]
4545
++ prop_arbitraryAndShrinkPreserveInvariant (deepseqInvariant @RawBytes)
4646
, testGroup "KeyForIndexCompact" $
47-
prop_arbitraryAndShrinkPreserveInvariant keyForIndexCompactInvariant
47+
prop_arbitraryAndShrinkPreserveInvariant $
48+
isKeyForIndexCompact . getKeyForIndexCompact
49+
, testGroup "BiasedKeyForIndexCompact" $
50+
prop_arbitraryAndShrinkPreserveInvariant $
51+
isKeyForIndexCompact . getBiasedKeyForIndexCompact
4852
, testGroup "lists of key/op pairs" $
4953
[ testProperty "prop_distributionKOps" $
5054
prop_distributionKOps
@@ -56,7 +60,7 @@ prop_packRawBytesPinnedOrUnpinned pinned ws =
5660
packRawBytesPinnedOrUnpinned pinned ws == RawBytes (VP.fromList ws)
5761

5862
type TestEntry = Entry SerialisedValue BlobSpan
59-
type TestKOp = (KeyForIndexCompact, TestEntry)
63+
type TestKOp = (BiasedKeyForIndexCompact, TestEntry)
6064

6165
prop_distributionKOps :: [TestKOp] -> Property
6266
prop_distributionKOps kops' =

‎test/Test/Database/LSMTree/Internal/Index/Compact.hs‎

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -49,14 +49,14 @@ import Text.Printf (printf)
4949

5050
tests :: TestTree
5151
tests = testGroup "Test.Database.LSMTree.Internal.Index.Compact" [
52-
testProperty "prop_distribution @KeyForIndexCompact" $
53-
prop_distribution @KeyForIndexCompact
52+
testProperty "prop_distribution @BiasedKeyForIndexCompact" $
53+
prop_distribution @BiasedKeyForIndexCompact
5454
, testProperty "prop_searchMinMaxKeysAfterConstruction" $
55-
prop_searchMinMaxKeysAfterConstruction @KeyForIndexCompact 100
55+
prop_searchMinMaxKeysAfterConstruction @BiasedKeyForIndexCompact 100
5656
, testProperty "prop_differentChunkSizesSameResults" $
57-
prop_differentChunkSizesSameResults @KeyForIndexCompact
57+
prop_differentChunkSizesSameResults @BiasedKeyForIndexCompact
5858
, testProperty "prop_singlesEquivMulti" $
59-
prop_singlesEquivMulti @KeyForIndexCompact
59+
prop_singlesEquivMulti @BiasedKeyForIndexCompact
6060
, testGroup "(De)serialisation" [
6161
testGroup "test Chunks generator" [
6262
testProperty "Arbitrary satisfies invariant" $
@@ -120,7 +120,7 @@ tests = testGroup "Test.Database.LSMTree.Internal.Index.Compact" [
120120
, testProperty "prop_roundtrip_chunks" $
121121
prop_roundtrip_chunks
122122
, testProperty "prop_roundtrip" $
123-
prop_roundtrip @KeyForIndexCompact
123+
prop_roundtrip @BiasedKeyForIndexCompact
124124
, testProperty "prop_total_deserialisation" $ withMaxSuccess 10000
125125
prop_total_deserialisation
126126
, testProperty "prop_total_deserialisation_whitebox" $ withMaxSuccess 10000

‎test/Test/Database/LSMTree/Internal/RawBytes.hs‎

Lines changed: 97 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,97 @@
1+
{- HLINT ignore "Avoid restricted alias" -}
2+
{- HLINT ignore "Use /=" -}
3+
4+
module Test.Database.LSMTree.Internal.RawBytes (tests) where
5+
6+
import Database.LSMTree.Extras.Generators ()
7+
import Database.LSMTree.Internal.RawBytes (RawBytes)
8+
import qualified Database.LSMTree.Internal.RawBytes as RawBytes (size)
9+
import Test.QuickCheck (Property, classify, collect, mapSize,
10+
withDiscardRatio, withMaxSuccess, (.||.), (===), (==>))
11+
import Test.Tasty (TestTree, testGroup)
12+
import Test.Tasty.QuickCheck (testProperty)
13+
14+
-- * Tests
15+
16+
tests :: TestTree
17+
tests = testGroup "Test.Database.LSMTree.Internal.RawBytes" $
18+
[
19+
testGroup "Eq laws" $
20+
[
21+
testProperty "Reflexivity" prop_eqReflexivity,
22+
testProperty "Symmetry" prop_eqSymmetry,
23+
testProperty "Transitivity" prop_eqTransitivity,
24+
testProperty "Negation" prop_eqNegation
25+
],
26+
testGroup "Ord laws" $
27+
[
28+
testProperty "Comparability" prop_ordComparability,
29+
testProperty "Transitivity" prop_ordTransitivity,
30+
testProperty "Reflexivity" prop_ordReflexivity,
31+
testProperty "Antisymmetry" prop_ordAntisymmetry
32+
]
33+
]
34+
35+
-- * Utilities
36+
37+
twoBlocksProp :: String -> RawBytes -> RawBytes -> Property -> Property
38+
twoBlocksProp msgAddition block1 block2
39+
= withMaxSuccess 10000 .
40+
classify (block1 == block2) ("equal blocks" ++ msgAddition)
41+
42+
withFirstBlockSizeInfo :: RawBytes -> Property -> Property
43+
withFirstBlockSizeInfo firstBlock
44+
= collect ("Size of first block is " ++ show (RawBytes.size firstBlock))
45+
46+
-- * Properties to test
47+
48+
-- ** 'Eq' laws
49+
50+
prop_eqReflexivity :: RawBytes -> Property
51+
prop_eqReflexivity block = block === block
52+
53+
prop_eqSymmetry :: RawBytes -> RawBytes -> Property
54+
prop_eqSymmetry block1 block2 = twoBlocksProp "" block1 block2 $
55+
(block1 == block2) === (block2 == block1)
56+
57+
prop_eqTransitivity :: Property
58+
prop_eqTransitivity = mapSize (const 3) $
59+
withDiscardRatio 1000 $
60+
untunedProp
61+
where
62+
63+
untunedProp :: RawBytes -> RawBytes -> RawBytes -> Property
64+
untunedProp block1 block2 block3
65+
= withFirstBlockSizeInfo block1 $
66+
block1 == block2 && block2 == block3 ==> block1 === block3
67+
68+
prop_eqNegation :: RawBytes -> RawBytes -> Property
69+
prop_eqNegation block1 block2 = twoBlocksProp "" block1 block2 $
70+
(block1 /= block2) === not (block1 == block2)
71+
72+
-- ** 'Ord' laws
73+
74+
prop_ordComparability :: RawBytes -> RawBytes -> Property
75+
prop_ordComparability block1 block2 = twoBlocksProp "" block1 block2 $
76+
block1 <= block2 .||. block2 <= block1
77+
78+
prop_ordTransitivity :: RawBytes -> RawBytes -> RawBytes -> Property
79+
prop_ordTransitivity block1 block2 block3
80+
= twoBlocksProp " front-side" block1 block2 $
81+
twoBlocksProp " rear-side" block2 block3 $
82+
twoBlocksProp " at the edges" block1 block3 $
83+
block1 <= block2 && block2 <= block3 ==> block1 <= block3
84+
85+
prop_ordReflexivity :: RawBytes -> Bool
86+
prop_ordReflexivity block = block <= block
87+
88+
prop_ordAntisymmetry :: Property
89+
prop_ordAntisymmetry = mapSize (const 4) $
90+
withDiscardRatio 100 $
91+
untunedProp
92+
where
93+
94+
untunedProp :: RawBytes -> RawBytes -> Property
95+
untunedProp block1 block2
96+
= withFirstBlockSizeInfo block1 $
97+
block1 <= block2 && block2 <= block1 ==> block1 === block2

‎test/Test/Database/LSMTree/Internal/RunReader.hs‎

Lines changed: 9 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -8,7 +8,8 @@ module Test.Database.LSMTree.Internal.RunReader (
88
import Control.RefCount
99
import Data.Coerce (coerce)
1010
import qualified Data.Map as Map
11-
import Database.LSMTree.Extras.Generators (KeyForIndexCompact (..))
11+
import Database.LSMTree.Extras.Generators
12+
(BiasedKeyForIndexCompact (..))
1213
import Database.LSMTree.Extras.RunData
1314
import Database.LSMTree.Internal.BlobRef
1415
import Database.LSMTree.Internal.Entry (Entry)
@@ -75,8 +76,8 @@ tests = testGroup "Database.LSMTree.Internal.RunReader"
7576
prop_readAtOffset ::
7677
FS.HasFS IO h
7778
-> FS.HasBlockIO IO h
78-
-> RunData KeyForIndexCompact SerialisedValue SerialisedBlob
79-
-> Maybe KeyForIndexCompact
79+
-> RunData BiasedKeyForIndexCompact SerialisedValue SerialisedBlob
80+
-> Maybe BiasedKeyForIndexCompact
8081
-> IO Property
8182
prop_readAtOffset fs hbio rd offsetKey =
8283
withRun fs hbio Index.Compact (simplePath 42) rd' $ \run -> do
@@ -98,15 +99,15 @@ prop_readAtOffset fs hbio rd offsetKey =
9899
prop_readAtOffsetExisting ::
99100
FS.HasFS IO h
100101
-> FS.HasBlockIO IO h
101-
-> RunData KeyForIndexCompact SerialisedValue SerialisedBlob
102+
-> RunData BiasedKeyForIndexCompact SerialisedValue SerialisedBlob
102103
-> NonNegative Int
103104
-> IO Property
104105
prop_readAtOffsetExisting fs hbio rd (NonNegative index)
105106
| null kops = pure discard
106107
| otherwise =
107108
prop_readAtOffset fs hbio rd (Just (keys !! (index `mod` length keys)))
108109
where
109-
keys :: [KeyForIndexCompact]
110+
keys :: [BiasedKeyForIndexCompact]
110111
keys = coerce (fst <$> kops)
111112
kops = Map.toList (unRunData rd)
112113

@@ -119,8 +120,8 @@ prop_readAtOffsetExisting fs hbio rd (NonNegative index)
119120
prop_readAtOffsetIdempotence ::
120121
FS.HasFS IO h
121122
-> FS.HasBlockIO IO h
122-
-> RunData KeyForIndexCompact SerialisedValue SerialisedBlob
123-
-> Maybe KeyForIndexCompact
123+
-> RunData BiasedKeyForIndexCompact SerialisedValue SerialisedBlob
124+
-> Maybe BiasedKeyForIndexCompact
124125
-> IO Property
125126
prop_readAtOffsetIdempotence fs hbio rd offsetKey =
126127
withRun fs hbio Index.Compact (simplePath 42) rd' $ \run -> do
@@ -144,7 +145,7 @@ prop_readAtOffsetIdempotence fs hbio rd offsetKey =
144145
prop_readAtOffsetReadHead ::
145146
FS.HasFS IO h
146147
-> FS.HasBlockIO IO h
147-
-> RunData KeyForIndexCompact SerialisedValue SerialisedBlob
148+
-> RunData BiasedKeyForIndexCompact SerialisedValue SerialisedBlob
148149
-> IO Property
149150
prop_readAtOffsetReadHead fs hbio rd =
150151
withRun fs hbio Index.Compact (simplePath 42) rd' $ \run -> do

‎test/Test/Database/LSMTree/Internal/RunReaders.hs‎

Lines changed: 6 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -16,7 +16,8 @@ import qualified Data.Map.Strict as Map
1616
import Data.Proxy (Proxy (..))
1717
import qualified Data.Vector as V
1818
import Database.LSMTree.Extras (showPowersOf)
19-
import Database.LSMTree.Extras.Generators (KeyForIndexCompact (..))
19+
import Database.LSMTree.Extras.Generators
20+
(BiasedKeyForIndexCompact (..))
2021
import Database.LSMTree.Extras.RunData
2122
import Database.LSMTree.Internal.BlobRef
2223
import Database.LSMTree.Internal.Entry
@@ -83,7 +84,7 @@ size :: MockReaders -> Int
8384
size (MockReaders xs) = length xs
8485

8586
newMock :: Maybe SerialisedKey
86-
-> [RunData KeyForIndexCompact SerialisedValue SerialisedBlob]
87+
-> [RunData BiasedKeyForIndexCompact SerialisedValue SerialisedBlob]
8788
-> MockReaders
8889
newMock offset =
8990
MockReaders . Map.assocs . Map.unions
@@ -132,9 +133,9 @@ deriving stock instance Eq (Action (Lockstep ReadersState) a)
132133

133134
instance StateModel (Lockstep ReadersState) where
134135
data Action (Lockstep ReadersState) a where
135-
New :: Maybe KeyForIndexCompact -- ^ optional offset
136-
-> Maybe (RunData KeyForIndexCompact SerialisedValue SerialisedBlob)
137-
-> [RunData KeyForIndexCompact SerialisedValue SerialisedBlob]
136+
New :: Maybe BiasedKeyForIndexCompact -- ^ optional offset
137+
-> Maybe (RunData BiasedKeyForIndexCompact SerialisedValue SerialisedBlob)
138+
-> [RunData BiasedKeyForIndexCompact SerialisedValue SerialisedBlob]
138139
-> ReadersAct ()
139140
PeekKey :: ReadersAct SerialisedKey
140141
Pop :: Int -- allow popping many at once to drain faster

0 commit comments

Comments
 (0)