From 26bfefcce3837630731e5f12c9d48cccfd0e7bf7 Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Tue, 10 Dec 2024 21:56:10 +0100 Subject: [PATCH 1/3] Put generator and shrinker test utilities in their own module Just a small preparatory refactoring, since we'll be importing these test utilities in following commits --- lsm-tree.cabal | 1 + test/Test/Database/LSMTree/Generators.hs | 28 ++------------- test/Test/Database/LSMTree/Internal/Lookup.hs | 6 ++-- test/Test/Util/Arbitrary.hs | 34 +++++++++++++++++++ 4 files changed, 40 insertions(+), 29 deletions(-) create mode 100644 test/Test/Util/Arbitrary.hs diff --git a/lsm-tree.cabal b/lsm-tree.cabal index 78125e5d1..bfaf6dd9f 100644 --- a/lsm-tree.cabal +++ b/lsm-tree.cabal @@ -384,6 +384,7 @@ test-suite lsm-tree-test Test.Database.LSMTree.StateMachine.Op Test.Database.LSMTree.UnitTests Test.System.Posix.Fcntl.NoCache + Test.Util.Arbitrary Test.Util.FS Test.Util.Orphans Test.Util.PrettyProxy diff --git a/test/Test/Database/LSMTree/Generators.hs b/test/Test/Database/LSMTree/Generators.hs index 7acc0564b..682246ff4 100644 --- a/test/Test/Database/LSMTree/Generators.hs +++ b/test/Test/Database/LSMTree/Generators.hs @@ -3,12 +3,8 @@ module Test.Database.LSMTree.Generators ( tests - , prop_arbitraryAndShrinkPreserveInvariant - , prop_forAllArbitraryAndShrinkPreserveInvariant - , deepseqInvariant ) where -import Control.DeepSeq (NFData, deepseq) import Data.Bifoldable (bifoldMap) import Data.Coerce (coerce) import qualified Data.Map.Strict as Map @@ -26,9 +22,10 @@ import Database.LSMTree.Internal.RawBytes (RawBytes (..)) import Database.LSMTree.Internal.Serialise import qualified Test.QuickCheck as QC -import Test.QuickCheck (Arbitrary (..), Gen, Property, Testable (..)) +import Test.QuickCheck (Property) import Test.Tasty (TestTree, localOption, testGroup) import Test.Tasty.QuickCheck (QuickCheckMaxSize (..), testProperty) +import Test.Util.Arbitrary tests :: TestTree tests = testGroup "Test.Database.LSMTree.Generators" [ @@ -54,27 +51,6 @@ tests = testGroup "Test.Database.LSMTree.Generators" [ ] ] -prop_arbitraryAndShrinkPreserveInvariant :: - forall a. (Arbitrary a, Show a) => (a -> Bool) -> [TestTree] -prop_arbitraryAndShrinkPreserveInvariant = - prop_forAllArbitraryAndShrinkPreserveInvariant arbitrary shrink - -prop_forAllArbitraryAndShrinkPreserveInvariant :: - forall a. Show a => Gen a -> (a -> [a]) -> (a -> Bool) -> [TestTree] -prop_forAllArbitraryAndShrinkPreserveInvariant gen shr inv = - [ testProperty "Arbitrary satisfies invariant" $ - property $ QC.forAllShrink gen shr inv - , testProperty "Shrinking satisfies invariant" $ - property $ QC.forAll gen $ \x -> - case shr x of - [] -> QC.label "no shrinks" $ property True - xs -> QC.forAll (QC.growingElements xs) inv - ] - --- | Trivial invariant, but checks that the value is finite -deepseqInvariant :: NFData a => a -> Bool -deepseqInvariant x = x `deepseq` True - prop_packRawBytesPinnedOrUnpinned :: Bool -> [Word8] -> Bool prop_packRawBytesPinnedOrUnpinned pinned ws = packRawBytesPinnedOrUnpinned pinned ws == RawBytes (VP.fromList ws) diff --git a/test/Test/Database/LSMTree/Internal/Lookup.hs b/test/Test/Database/LSMTree/Internal/Lookup.hs index 5c513ca17..a5fe9ca3a 100644 --- a/test/Test/Database/LSMTree/Internal/Lookup.hs +++ b/test/Test/Database/LSMTree/Internal/Lookup.hs @@ -66,12 +66,12 @@ import qualified System.FS.API as FS import System.FS.API (Handle (..), mkFsPath) import qualified System.FS.BlockIO.API as FS import System.FS.BlockIO.API -import Test.Database.LSMTree.Generators (deepseqInvariant, - prop_arbitraryAndShrinkPreserveInvariant, - prop_forAllArbitraryAndShrinkPreserveInvariant) import Test.QuickCheck import Test.Tasty import Test.Tasty.QuickCheck +import Test.Util.Arbitrary (deepseqInvariant, + prop_arbitraryAndShrinkPreserveInvariant, + prop_forAllArbitraryAndShrinkPreserveInvariant) import Test.Util.FS (withTempIOHasBlockIO) tests :: TestTree diff --git a/test/Test/Util/Arbitrary.hs b/test/Test/Util/Arbitrary.hs new file mode 100644 index 000000000..861a5cf34 --- /dev/null +++ b/test/Test/Util/Arbitrary.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Util.Arbitrary ( + prop_arbitraryAndShrinkPreserveInvariant + , prop_forAllArbitraryAndShrinkPreserveInvariant + , deepseqInvariant + ) where + +import Control.DeepSeq (NFData, deepseq) +import Test.QuickCheck +import Test.Tasty (TestTree) +import Test.Tasty.QuickCheck (testProperty) + +prop_arbitraryAndShrinkPreserveInvariant :: + forall a. (Arbitrary a, Show a) => (a -> Bool) -> [TestTree] +prop_arbitraryAndShrinkPreserveInvariant = + prop_forAllArbitraryAndShrinkPreserveInvariant arbitrary shrink + +prop_forAllArbitraryAndShrinkPreserveInvariant :: + forall a. Show a => Gen a -> (a -> [a]) -> (a -> Bool) -> [TestTree] +prop_forAllArbitraryAndShrinkPreserveInvariant gen shr inv = + [ testProperty "Arbitrary satisfies invariant" $ + property $ forAllShrink gen shr inv + , testProperty "Shrinking satisfies invariant" $ + property $ forAll gen $ \x -> + case shr x of + [] -> label "no shrinks" $ property True + xs -> forAll (growingElements xs) inv + ] + +-- | Trivial invariant, but checks that the value is finite +deepseqInvariant :: NFData a => a -> Bool +deepseqInvariant x = x `deepseq` True From be4552d8092f9bb710fd90553f3df9acb478cf92 Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Tue, 10 Dec 2024 21:56:56 +0100 Subject: [PATCH 2/3] Add some missing `NFData` instances We'll use these instances in the new tests that are added by the next commit --- src/Database/LSMTree/Internal/Merge.hs | 5 ++++ .../LSMTree/Internal/MergeSchedule.hs | 10 ++++++++ src/Database/LSMTree/Internal/Snapshot.hs | 25 +++++++++++++++++++ 3 files changed, 40 insertions(+) diff --git a/src/Database/LSMTree/Internal/Merge.hs b/src/Database/LSMTree/Internal/Merge.hs index a5f30903c..b779e5b6d 100644 --- a/src/Database/LSMTree/Internal/Merge.hs +++ b/src/Database/LSMTree/Internal/Merge.hs @@ -15,6 +15,7 @@ module Database.LSMTree.Internal.Merge ( , steps ) where +import Control.DeepSeq (NFData (..)) import Control.Exception (assert) import Control.Monad (when) import Control.Monad.Class.MonadST (MonadST) @@ -74,6 +75,10 @@ data MergeState = data Level = MidLevel | LastLevel deriving stock (Eq, Show) +instance NFData Level where + rnf MidLevel = () + rnf LastLevel = () + type Mappend = SerialisedValue -> SerialisedValue -> SerialisedValue {-# SPECIALISE new :: diff --git a/src/Database/LSMTree/Internal/MergeSchedule.hs b/src/Database/LSMTree/Internal/MergeSchedule.hs index a6bf2058b..dfe414c2d 100644 --- a/src/Database/LSMTree/Internal/MergeSchedule.hs +++ b/src/Database/LSMTree/Internal/MergeSchedule.hs @@ -45,6 +45,7 @@ module Database.LSMTree.Internal.MergeSchedule ( ) where import Control.Concurrent.Class.MonadMVar.Strict +import Control.DeepSeq (NFData (..)) import Control.Monad (void, when, (<$!>)) import Control.Monad.Class.MonadST (MonadST) import Control.Monad.Class.MonadSTM (MonadSTM (..)) @@ -399,6 +400,10 @@ duplicateMergingRunRuns reg (DeRef mr) = data MergePolicyForLevel = LevelTiering | LevelLevelling deriving stock (Show, Eq) +instance NFData MergePolicyForLevel where + rnf LevelTiering = () + rnf LevelLevelling = () + mergePolicyForLevel :: MergePolicy -> LevelNo -> Levels m h -> MergePolicyForLevel mergePolicyForLevel MergePolicyLazyLevelling (LevelNo n) nextLevels | n == 1 @@ -409,6 +414,7 @@ mergePolicyForLevel MergePolicyLazyLevelling (LevelNo n) nextLevels newtype NumRuns = NumRuns { unNumRuns :: Int } deriving stock (Show, Eq) + deriving newtype NFData newtype UnspentCreditsVar s = UnspentCreditsVar { getUnspentCreditsVar :: PrimVar s Int } @@ -430,6 +436,10 @@ newtype SpentCreditsVar s = SpentCreditsVar { getSpentCreditsVar :: PrimVar s In data MergeKnownCompleted = MergeKnownCompleted | MergeMaybeCompleted deriving stock (Show, Eq, Read) +instance NFData MergeKnownCompleted where + rnf MergeKnownCompleted = () + rnf MergeMaybeCompleted = () + {-# SPECIALISE duplicateLevels :: TempRegistry IO -> Levels IO h -> IO (Levels IO h) #-} duplicateLevels :: (PrimMonad m, MonadMVar m, MonadMask m) diff --git a/src/Database/LSMTree/Internal/Snapshot.hs b/src/Database/LSMTree/Internal/Snapshot.hs index 149988e2d..d7f55bcc0 100644 --- a/src/Database/LSMTree/Internal/Snapshot.hs +++ b/src/Database/LSMTree/Internal/Snapshot.hs @@ -24,6 +24,7 @@ module Database.LSMTree.Internal.Snapshot ( import Control.Concurrent.Class.MonadMVar.Strict import Control.Concurrent.Class.MonadSTM (MonadSTM) +import Control.DeepSeq (NFData (..)) import Control.Monad (when) import Control.Monad.Class.MonadST (MonadST) import Control.Monad.Class.MonadThrow (MonadMask) @@ -66,11 +67,17 @@ import System.FS.BlockIO.API (HasBlockIO) -- is opened at the correct key\/value\/blob type. newtype SnapshotLabel = SnapshotLabel Text deriving stock (Show, Eq) + deriving newtype NFData -- TODO: revisit if we need three table types. data SnapshotTableType = SnapNormalTable | SnapMonoidalTable | SnapFullTable deriving stock (Show, Eq) +instance NFData SnapshotTableType where + rnf SnapNormalTable = () + rnf SnapMonoidalTable = () + rnf SnapFullTable = () + data SnapshotMetaData = SnapshotMetaData { -- | See 'SnapshotLabel'. -- @@ -94,12 +101,16 @@ data SnapshotMetaData = SnapshotMetaData { } deriving stock (Show, Eq) +instance NFData SnapshotMetaData where + rnf (SnapshotMetaData a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d + {------------------------------------------------------------------------------- Levels snapshot format -------------------------------------------------------------------------------} newtype SnapLevels r = SnapLevels { getSnapLevels :: V.Vector (SnapLevel r) } deriving stock (Show, Eq, Functor, Foldable, Traversable) + deriving newtype NFData data SnapLevel r = SnapLevel { snapIncoming :: !(SnapIncomingRun r) @@ -107,27 +118,41 @@ data SnapLevel r = SnapLevel { } deriving stock (Show, Eq, Functor, Foldable, Traversable) +instance NFData r => NFData (SnapLevel r) where + rnf (SnapLevel a b) = rnf a `seq` rnf b + data SnapIncomingRun r = SnapMergingRun !MergePolicyForLevel !NumRuns !NumEntries !UnspentCredits !MergeKnownCompleted !(SnapMergingRunState r) | SnapSingleRun !r deriving stock (Show, Eq, Functor, Foldable, Traversable) +instance NFData r => NFData (SnapIncomingRun r) where + rnf (SnapMergingRun a b c d e f) = + rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e `seq` rnf f + rnf (SnapSingleRun a) = rnf a + -- | The total number of unspent credits. This total is used in combination with -- 'SpentCredits' on snapshot load to restore merging work that was lost when -- the snapshot was created. newtype UnspentCredits = UnspentCredits { getUnspentCredits :: Int } deriving stock (Show, Eq, Read) + deriving newtype NFData data SnapMergingRunState r = SnapCompletedMerge !r | SnapOngoingMerge !(V.Vector r) !SpentCredits !Merge.Level deriving stock (Show, Eq, Functor, Foldable, Traversable) +instance NFData r => NFData (SnapMergingRunState r) where + rnf (SnapCompletedMerge a) = rnf a + rnf (SnapOngoingMerge a b c) = rnf a `seq` rnf b `seq` rnf c + -- | The total number of spent credits. This total is used in combination with -- 'UnspentCedits' on snapshot load to restore merging work that was lost when -- the snapshot was created. newtype SpentCredits = SpentCredits { getSpentCredits :: Int } deriving stock (Show, Eq, Read) + deriving newtype NFData {------------------------------------------------------------------------------- Conversion to levels snapshot format From f1828759646a4e9507a38bc26bf594bd05ae5f4c Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Tue, 10 Dec 2024 22:47:50 +0100 Subject: [PATCH 3/3] Test generators and shrinkers for snapshot metadata --- .../LSMTree/Internal/Snapshot/Codec.hs | 104 +++++++++++------- 1 file changed, 67 insertions(+), 37 deletions(-) diff --git a/test/Test/Database/LSMTree/Internal/Snapshot/Codec.hs b/test/Test/Database/LSMTree/Internal/Snapshot/Codec.hs index 4186d6e33..c5bc36f78 100644 --- a/test/Test/Database/LSMTree/Internal/Snapshot/Codec.hs +++ b/test/Test/Database/LSMTree/Internal/Snapshot/Codec.hs @@ -7,10 +7,12 @@ import Codec.CBOR.Encoding import Codec.CBOR.FlatTerm import Codec.CBOR.Read import Codec.CBOR.Write +import Control.DeepSeq (NFData) import qualified Data.ByteString.Lazy as BSL import Data.Proxy import Data.Text (Text) import qualified Data.Text as Text +import Data.Typeable import qualified Data.Vector as V import Database.LSMTree.Internal.Config import Database.LSMTree.Internal.Entry @@ -21,6 +23,7 @@ import Database.LSMTree.Internal.Snapshot import Database.LSMTree.Internal.Snapshot.Codec import Test.Tasty import Test.Tasty.QuickCheck +import Test.Util.Arbitrary -- TODO: we should add golden tests for the CBOR encoders. This should prevent -- accidental breakage in the format. @@ -34,45 +37,20 @@ tests = testGroup "Test.Database.LSMTree.Internal.Snapshot.Codec" [ testProperty "roundtripCBOR" $ roundtripCBOR (Proxy @(Versioned SnapshotMetaData)) , testProperty "roundtripFlatTerm" $ roundtripFlatTerm (Proxy @(Versioned SnapshotMetaData)) ] - , testGroup "roundtripCBOR'" (propAll roundtripCBOR') - , testGroup "roundtripFlatTerm'" (propAll roundtripFlatTerm') + , testGroup "roundtripCBOR'" $ + propAll roundtripCBOR' + , testGroup "roundtripFlatTerm'" $ + propAll roundtripFlatTerm' + -- Test generators and shrinkers + , testGroup "Generators and shrinkers are finite" $ + testAll $ \(p :: Proxy a) -> + testGroup (show $ typeRep p) $ + prop_arbitraryAndShrinkPreserveInvariant @a deepseqInvariant ] --- | Run a property on all types in the snapshot metadata hierarchy. -propAll :: - ( forall a. (Encode a, DecodeVersioned a, Eq a, Show a) - => Proxy a -> a -> Property - ) - -> [TestTree] -propAll prop = [ - -- SnapshotMetaData - testProperty "SnapshotMetaData" $ prop (Proxy @SnapshotMetaData) - , testProperty "SnapshotLabel" $ prop (Proxy @SnapshotLabel) - , testProperty "SnapshotTableType" $ prop (Proxy @SnapshotTableType) - -- TableConfig - , testProperty "TableConfig" $ prop (Proxy @TableConfig) - , testProperty "MergePolicy" $ prop (Proxy @MergePolicy) - , testProperty "SizeRatio" $ prop (Proxy @SizeRatio) - , testProperty "WriteBufferAlloc" $ prop (Proxy @WriteBufferAlloc) - , testProperty "NumEntries" $ prop (Proxy @NumEntries) - , testProperty "BloomFilterAlloc" $ prop (Proxy @BloomFilterAlloc) - , testProperty "FencePointerIndex" $ prop (Proxy @FencePointerIndex) - , testProperty "DiskCachePolicy" $ prop (Proxy @DiskCachePolicy) - , testProperty "MergeSchedule" $ prop (Proxy @MergeSchedule) - -- SnapLevels - , testProperty "SnapLevels" $ prop (Proxy @(SnapLevels RunNumber)) - , testProperty "SnapLevel" $ prop (Proxy @(SnapLevel RunNumber)) - , testProperty "Vector RunNumber" $ prop (Proxy @(V.Vector RunNumber)) - , testProperty "RunNumber" $ prop (Proxy @RunNumber) - , testProperty "SnapIncomingRun" $ prop (Proxy @(SnapIncomingRun RunNumber)) - , testProperty "NumRuns" $ prop (Proxy @NumRuns) - , testProperty "MergePolicyForLevel" $ prop (Proxy @MergePolicyForLevel) - , testProperty "UnspentCredits" $ prop (Proxy @UnspentCredits) - , testProperty "MergeKnownCompleted" $ prop (Proxy @MergeKnownCompleted) - , testProperty "SnapMergingRunState" $ prop (Proxy @(SnapMergingRunState RunNumber)) - , testProperty "SpentCredits" $ prop (Proxy @SpentCredits) - , testProperty "Merge.Level" $ prop (Proxy @Merge.Level) - ] +{------------------------------------------------------------------------------- + Properties +-------------------------------------------------------------------------------} -- | @decode . encode = id@ explicitRoundtripCBOR :: @@ -148,6 +126,58 @@ roundtripFlatTerm' :: -> Property roundtripFlatTerm' _ = explicitRoundtripFlatTerm encode (decodeVersioned currentSnapshotVersion) +{------------------------------------------------------------------------------- + Test and property runners +-------------------------------------------------------------------------------} + +type Constraints a = ( + Eq a, Show a, Typeable a, Arbitrary a + , Encode a, DecodeVersioned a, NFData a + ) + +-- | Run a property on all types in the snapshot metadata hierarchy. +propAll :: + (forall a. Constraints a => Proxy a -> a -> Property) + -> [TestTree] +propAll prop = testAll mkTest + where + mkTest :: forall a. Constraints a => Proxy a -> TestTree + mkTest pa = testProperty (show $ typeRep pa) (prop pa) + +-- | Run a test on all types in the snapshot metadata hierarchy. +testAll :: + (forall a. Constraints a => Proxy a -> TestTree) + -> [TestTree] +testAll test = [ + -- SnapshotMetaData + test (Proxy @SnapshotMetaData) + , test (Proxy @SnapshotLabel) + , test (Proxy @SnapshotTableType) + -- TableConfig + , test (Proxy @TableConfig) + , test (Proxy @MergePolicy) + , test (Proxy @SizeRatio) + , test (Proxy @WriteBufferAlloc) + , test (Proxy @NumEntries) + , test (Proxy @BloomFilterAlloc) + , test (Proxy @FencePointerIndex) + , test (Proxy @DiskCachePolicy) + , test (Proxy @MergeSchedule) + -- SnapLevels + , test (Proxy @(SnapLevels RunNumber)) + , test (Proxy @(SnapLevel RunNumber)) + , test (Proxy @(V.Vector RunNumber)) + , test (Proxy @RunNumber) + , test (Proxy @(SnapIncomingRun RunNumber)) + , test (Proxy @NumRuns) + , test (Proxy @MergePolicyForLevel) + , test (Proxy @UnspentCredits) + , test (Proxy @MergeKnownCompleted) + , test (Proxy @(SnapMergingRunState RunNumber)) + , test (Proxy @SpentCredits) + , test (Proxy @Merge.Level) + ] + {------------------------------------------------------------------------------- Arbitrary: versioning -------------------------------------------------------------------------------}