add prop_supplyCredits for MergingTree

Author: mheinzel

src-extras/Database/LSMTree/Extras/RunData.hs

@@ -149,6 +149,9 @@ unsafeCreateRunAt ::
   -> SerialisedRunData
   -> IO (Ref (Run IO h))
 unsafeCreateRunAt fs hbio runParams fsPaths (RunData m) = do
+    -- the WBB file path doesn't have to be at a specific place relative to
+    -- the run we want to create, but fsPaths should already point to a unique
+    -- location, so we just append something to not conflict with that.
     let blobpath = FS.addExtension (runBlobPath fsPaths) ".wb"
     bracket (WBB.new fs blobpath) releaseRef $ \wbblobs -> do
       wb <- WB.fromMap <$> traverse (traverse (WBB.addBlob fs wbblobs)) m

src/Database/LSMTree/Internal/Merge.hs

@@ -174,6 +174,9 @@ new ::
 new hfs hbio runParams mergeType mergeMappend targetPaths runs = do
     -- no offset, no write buffer
     mreaders <- Readers.new Readers.NoOffsetKey Nothing runs
+    -- TODO: Exception safety! If Readers.new fails after already creating some
+    -- run readers, or Builder.new fails, the run readers will stay open,
+    -- holding handles of the input runs' files.
     for mreaders $ \mergeReaders -> do
       -- calculate upper bounds based on input runs
       let numEntries = V.foldMap' Run.size runs

src/Database/LSMTree/Internal/MergingRun.hs

@@ -388,7 +388,7 @@ might not finish in time, which will mess up the shape of the levels tree.
 -}
 
 newtype MergeCredits = MergeCredits Int
-  deriving stock (Eq, Ord)
+  deriving stock (Eq, Ord, Show)
   deriving newtype (Num, Real, Enum, Integral, NFData)
 
 newtype MergeDebt = MergeDebt MergeCredits
@@ -414,13 +414,14 @@ numEntriesToMergeDebt (NumEntries n) = MergeDebt (MergeCredits n)
 -- co-prime so that merge work at different levels is not synchronised.
 --
 newtype CreditThreshold = CreditThreshold UnspentCredits
+  deriving stock Show
 
 -- | The spent credits are supplied credits that have been spent on performing
 -- merging steps plus the supplied credits that are in the process of being
 -- spent (by some thread calling 'supplyCredits').
 --
 newtype SpentCredits = SpentCredits MergeCredits
-  deriving newtype (Eq, Ord)
+  deriving newtype (Eq, Ord, Show)
 
 -- | 40 bit unsigned number
 instance Bounded SpentCredits where
@@ -436,7 +437,7 @@ instance Bounded SpentCredits where
 -- current unspent credits being negative for a time.
 --
 newtype UnspentCredits = UnspentCredits MergeCredits
-  deriving newtype (Eq, Ord)
+  deriving newtype (Eq, Ord, Show)
 
 -- | 24 bit signed number
 instance Bounded UnspentCredits where

test/Test/Database/LSMTree/Generators.hs

@@ -19,10 +19,12 @@ import qualified Database.LSMTree.Internal.Index as Index
 import qualified Database.LSMTree.Internal.MergingRun as MR
 import           Database.LSMTree.Internal.PageAcc (entryWouldFitInPage,
                      sizeofEntry)
+import           Database.LSMTree.Internal.Paths (RunFsPaths (..))
 import           Database.LSMTree.Internal.RawBytes (RawBytes (..))
 import qualified Database.LSMTree.Internal.RawBytes as RB
 import qualified Database.LSMTree.Internal.RunAcc as RunAcc
 import qualified Database.LSMTree.Internal.RunBuilder as RunBuilder
+import           Database.LSMTree.Internal.RunNumber (RunNumber (..))
 import           Database.LSMTree.Internal.Serialise
 import           Database.LSMTree.Internal.UniqCounter
 import qualified System.FS.API as FS
@@ -155,7 +157,10 @@ prop_withRunDoesntLeak ::
   -> IO Property
 prop_withRunDoesntLeak hfs hbio rd = do
     let indexType = Index.Ordinary
-    withRunAt hfs hbio (runParams indexType) (simplePath 0) rd $ \_run -> do
+    let path = FS.mkFsPath ["something-1"]
+    let fsPaths = RunFsPaths path (RunNumber 0)
+    FS.createDirectory hfs path
+    withRunAt hfs hbio (runParams indexType) fsPaths rd $ \_run -> do
       return (QC.property True)
 
 prop_withMergingRunDoesntLeak ::
@@ -165,7 +170,8 @@ prop_withMergingRunDoesntLeak ::
   -> IO Property
 prop_withMergingRunDoesntLeak hfs hbio mrd = do
     let indexType = Index.Ordinary
-    let path = FS.mkFsPath []
+    let path = FS.mkFsPath ["something-2"]
+    FS.createDirectory hfs path
     counter <- newUniqCounter 0
     withMergingRun hfs hbio resolveVal (runParams indexType) path counter mrd $
       \_mr -> do
@@ -180,7 +186,8 @@ prop_withMergingTreeDoesntLeak ::
   -> IO Property
 prop_withMergingTreeDoesntLeak hfs hbio mrd = do
     let indexType = Index.Ordinary
-    let path = FS.mkFsPath []
+    let path = FS.mkFsPath ["something-3"]
+    FS.createDirectory hfs path
     counter <- newUniqCounter 0
     withMergingTree hfs hbio resolveVal (runParams indexType) path counter mrd $
       \_tree -> do

test/Test/Database/LSMTree/Internal/MergingRun.hs

@@ -37,10 +37,6 @@ prop_CreditsPair spentCredits unspentCredits =
 deriving newtype instance Enum SpentCredits
 deriving newtype instance Enum UnspentCredits
 
-deriving stock instance Show MergeCredits
-deriving stock instance Show SpentCredits
-deriving stock instance Show UnspentCredits
-
 instance Arbitrary SpentCredits where
   arbitrary =
     frequency [ (1, pure minBound)

test/Test/Database/LSMTree/Internal/MergingTree.hs

@@ -1,13 +1,18 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
 module Test.Database.LSMTree.Internal.MergingTree (tests) where
 
 import           Control.ActionRegistry
 import           Control.Exception (bracket)
 import           Control.Monad.Class.MonadAsync as Async
 import           Control.RefCount
 import           Data.Arena (newArenaManager)
+import           Data.Coerce (coerce)
 import           Data.Foldable (toList)
+import           Data.List.NonEmpty (NonEmpty)
 import           Data.Map (Map)
 import qualified Data.Map as Map
+import           Data.Traversable (for)
 import qualified Data.Vector as V
 import           Database.LSMTree.Extras.MergingRunData
 import           Database.LSMTree.Extras.MergingTreeData
@@ -17,9 +22,10 @@ import           Database.LSMTree.Internal.Entry (Entry)
 import qualified Database.LSMTree.Internal.Entry as Entry
 import qualified Database.LSMTree.Internal.Index as Index
 import qualified Database.LSMTree.Internal.Lookup as Lookup
-import           Database.LSMTree.Internal.MergingRun
+import qualified Database.LSMTree.Internal.MergingRun as MR
 import           Database.LSMTree.Internal.MergingTree
 import           Database.LSMTree.Internal.MergingTree.Lookup
+import qualified Database.LSMTree.Internal.Paths as Paths
 import qualified Database.LSMTree.Internal.Run as Run
 import qualified Database.LSMTree.Internal.RunAcc as RunAcc
 import qualified Database.LSMTree.Internal.RunBuilder as RunBuilder
@@ -40,6 +46,10 @@ tests = testGroup "Test.Database.LSMTree.Internal.MergingTree"
         ioProperty $
           withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ ->
             prop_lookupTree hfs hbio keys mtd
+    , testProperty "prop_supplyCredits" $ \threshold credits mtd ->
+        ioProperty $
+          withSimHasBlockIO propNoOpenHandles MockFS.empty $ \hfs hbio _ ->
+            prop_supplyCredits hfs hbio threshold credits mtd
     ]
 
 runParams :: RunBuilder.RunParams
@@ -112,7 +122,7 @@ prop_lookupTree ::
   -> V.Vector SerialisedKey
   -> MergingTreeData SerialisedKey SerialisedValue SerialisedBlob
   -> IO Property
-prop_lookupTree hfs hbio keys (serialiseMergingTreeData -> mtd) = do
+prop_lookupTree hfs hbio keys mtd = do
     let path = FS.mkFsPath []
     counter <- newUniqCounter 0
     withMergingTree hfs hbio resolveVal runParams path counter mtd $ \tree -> do
@@ -178,24 +188,67 @@ modelFoldMergingTree = goMergingTree
         OngoingTreeMergeData mr ->
           goMergingRun mr
         PendingLevelMergeData prs t ->
-          modelMerge MergeLevel (map goPreExistingRun prs <> map goMergingTree (toList t))
+          modelMerge MR.MergeLevel (map goPreExistingRun prs <> map goMergingTree (toList t))
         PendingUnionMergeData ts ->
-          modelMerge MergeUnion (map goMergingTree ts)
+          modelMerge MR.MergeUnion (map goMergingTree ts)
 
     goPreExistingRun = \case
         PreExistingRunData r -> unRunData r
         PreExistingMergingRunData mr -> goMergingRun mr
 
-    goMergingRun :: IsMergeType t => SerialisedMergingRunData t -> Map SerialisedKey SerialisedEntry
+    goMergingRun :: MR.IsMergeType t => SerialisedMergingRunData t -> Map SerialisedKey SerialisedEntry
     goMergingRun = \case
         CompletedMergeData _ r -> unRunData r
         OngoingMergeData mt rs -> modelMerge mt (map (unRunData . toRunData) rs)
 
-modelMerge :: (Ord k, IsMergeType t) => t -> [Map k SerialisedEntry] -> Map k SerialisedEntry
+modelMerge :: (Ord k, MR.IsMergeType t) => t -> [Map k SerialisedEntry] -> Map k SerialisedEntry
 modelMerge mt = handleDeletes . Map.unionsWith (combine resolveVal)
   where
-    handleDeletes = if isLastLevel mt then Map.filter (/= Entry.Delete) else id
-    combine = if isUnion mt then Entry.combineUnion else Entry.combine
+    handleDeletes = if MR.isLastLevel mt then Map.filter (/= Entry.Delete) else id
+    combine = if MR.isUnion mt then Entry.combineUnion else Entry.combine
 
 resolveVal :: SerialisedValue -> SerialisedValue -> SerialisedValue
 resolveVal (SerialisedValue x) (SerialisedValue y) = SerialisedValue (x <> y)
+
+{-------------------------------------------------------------------------------
+  Supplying Credits
+-------------------------------------------------------------------------------}
+
+prop_supplyCredits ::
+     forall h.
+     FS.HasFS IO h
+  -> FS.HasBlockIO IO h
+  -> MR.CreditThreshold
+  -> NonEmpty MR.MergeCredits
+  -> MergingTreeData SerialisedKey SerialisedValue SerialisedBlob
+  -> IO Property
+prop_supplyCredits hfs hbio threshold credits mtd = do
+    FS.createDirectory hfs setupPath
+    FS.createDirectory hfs (FS.mkFsPath ["active"])
+    counter <- newUniqCounter 0
+    withMergingTree hfs hbio resolveVal runParams setupPath counter mtd $ \tree -> do
+      props <- for credits $ \c -> do
+        (MR.MergeDebt debt, _) <- remainingMergeDebt tree
+        leftovers <-
+          supplyCredits hfs hbio resolveVal runParams threshold root counter tree c
+        (MR.MergeDebt debt', _) <- remainingMergeDebt tree
+        return $
+          counterexample (show (debt, leftovers, debt')) $ conjoin [
+              counterexample "negative values" $
+                debt >= 0 && leftovers >= 0 && debt' >= 0
+            , counterexample "did not reduce debt sufficiently" $
+                debt' <= debt - (c - leftovers)
+            ]
+      return (conjoin (toList props))
+  where
+    root = Paths.SessionRoot (FS.mkFsPath [])
+    setupPath = FS.mkFsPath ["setup"]  -- separate dir, so it doesn't clash
+
+instance Arbitrary MR.MergeCredits where
+  arbitrary = MR.MergeCredits . getPositive <$> arbitrary
+  shrink (MR.MergeCredits c) = [MR.MergeCredits c' | c' <- shrink c, c' > 0]
+
+instance Arbitrary MR.CreditThreshold where
+  arbitrary = coerce (arbitrary @MR.MergeCredits)
+  shrink = coerce (shrink @MR.MergeCredits)
+  -- TODO: does this make sense? in a way a larger threshold is "simpler".

test/Test/Database/LSMTree/Internal/Snapshot/Codec.hs

@@ -384,7 +384,6 @@ deriving stock instance Show r => Show (SnapPendingMerge r)
 deriving stock instance Show r => Show (SnapPreExistingRun r)
 
 deriving stock instance Show MergeDebt
-deriving stock instance Show MergeCredits
 deriving stock instance Show NominalDebt
 deriving stock instance Show NominalCredits