lsm-tree 1.0.0.2 → 1.1.0.0
raw patch · 20 files changed
+1013/−168 lines, 20 filesdep ~blockiodep ~filepath
Dependency ranges changed: blockio, filepath
Files
- CHANGELOG.md +47/−0
- app/Database/LSMTree/Demo.hs +6/−5
- lsm-tree.cabal +7/−4
- src-core/Database/LSMTree/Internal/Config/Override.hs +2/−0
- src-core/Database/LSMTree/Internal/FS.hs +117/−0
- src-core/Database/LSMTree/Internal/MergeSchedule.hs +121/−27
- src-core/Database/LSMTree/Internal/MergingTree.hs +28/−1
- src-core/Database/LSMTree/Internal/Snapshot.hs +18/−67
- src-core/Database/LSMTree/Internal/Snapshot/Codec.hs +32/−14
- src-core/Database/LSMTree/Internal/Unsafe.hs +137/−8
- src/Database/LSMTree.hs +242/−16
- src/Database/LSMTree/Simple.hs +10/−2
- test/Main.hs +2/−0
- test/Test/Database/LSMTree/Internal/Snapshot/Codec.hs +13/−3
- test/Test/Database/LSMTree/Internal/Snapshot/Codec/Golden.hs +15/−1
- test/Test/Database/LSMTree/Snapshots.hs +100/−0
- test/Test/Database/LSMTree/Tracer/Golden.hs +53/−11
- test/Test/Database/LSMTree/UnitTests.hs +56/−2
- test/Test/Util/FS.hs +5/−5
- test/Test/Util/FS/Error.hs +2/−2
CHANGELOG.md view
@@ -1,5 +1,52 @@ # Revision history for `lsm-tree` +## 1.1.0.0 -- 2026-05-13++### Breaking changes++* Move to snapshot version v2 due to changes to the internal table+ representation. While this change is backwards compatible (i.e. new code+ is still able to read old snapshots), be aware that v2 snapshots cannot be+ read by older versions of `lsm-tree`.+ See [PR #834](https://github.com/IntersectMBO/lsm-tree/pull/834).++### New features++#### Full API++* Add a new `importSnapshot` function for importing snapshots from outside a+ session into that session. See [PR+ #835](https://github.com/IntersectMBO/lsm-tree/pull/835).+* Add a new `SnapshotImportDirDoesNotExistError` exception, which can currently+ only be thrown by thrown by `importSnapshot`. See [PR+ #835](https://github.com/IntersectMBO/lsm-tree/pull/835).+* Add a new `exportSnapshot` function for exporting snapshots from inside a+ session to outside that session. See [PR+ #835](https://github.com/IntersectMBO/lsm-tree/pull/835).+* Add a new `SnapshotExportDirExistsError` exception, which can currently only+ be thrown by thrown by `exportSnapshot`. See [PR+ #835](https://github.com/IntersectMBO/lsm-tree/pull/835).+* Add a new `withOpenMountedSessionIO` function, a variant of+ `withOpenSessionIO` with more general control over where snapshots can be+ exported to and imported from. See [PR+ #835](https://github.com/IntersectMBO/lsm-tree/pull/835).++### Minor changes++* Optimise internal structure of tables containing a completed union.+ See [PR #838](https://github.com/IntersectMBO/lsm-tree/pull/838).++#### Full API++* Deprecate `withOpenSessionIO` in favour of `withOpenMountedSessionIO`.+ `withOpenSessionIO` is generally unsafe to use with the new `importSnapshot`+ and `exportSnapshot` functions. See [PR+ #835](https://github.com/IntersectMBO/lsm-tree/pull/835).++### Bug fixes++None+ ## 1.0.0.2 -- 2026-04-24 ### Breaking changes
app/Database/LSMTree/Demo.hs view
@@ -24,6 +24,7 @@ import Database.LSMTree as LSMT import qualified System.Directory as IO (createDirectoryIfMissing, doesDirectoryExist, removeDirectoryRecursive)+import System.FilePath ((</>)) import qualified System.FS.API as FS import qualified System.FS.BlockIO.API as FS import qualified System.FS.BlockIO.IO as FS@@ -41,8 +42,8 @@ -- functional requirement. demo :: Bool -> IO () demo interactive = do- freshDirectory "_demo"- withOpenSessionIO tracer "_demo" $ \session -> do+ freshDirectory ("_demo" </> "session")+ withOpenMountedSessionIO tracer "_demo" (FS.mkFsPath ["session"]) $ \session -> do withTableWith config session $ \(table :: Table IO K V B) -> do pause interactive -- [0] @@ -141,8 +142,8 @@ (LSMT.IOLike m, Typeable h) => FS.HasFS m h -> FS.HasBlockIO m h -> m () simpleAction hasFS hasBlockIO = do- let sessionDir = FS.mkFsPath ["_demo"]- FS.createDirectoryIfMissing hasFS False sessionDir+ let sessionDir = FS.mkFsPath ["_demo", "session"]+ FS.createDirectoryIfMissing hasFS True sessionDir withOpenSession tracer hasFS hasBlockIO 17 sessionDir $ \session -> do withTableWith config session $ \(table :: Table m K V B) -> do inserts table $ V.fromList [ (K i, V i, Just (B i)) | i <- [1 .. 10_000] ]@@ -215,7 +216,7 @@ freshDirectory path = do b <- IO.doesDirectoryExist path when b $ IO.removeDirectoryRecursive path- IO.createDirectoryIfMissing False path+ IO.createDirectoryIfMissing True path print' :: (Show a, MonadST m) => a -> m () print' x = stToIO $ unsafeIOToST $ print x
lsm-tree.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.4 name: lsm-tree-version: 1.0.0.2+version: 1.1.0.0 synopsis: Log-structured merge-trees description: This package contains an efficient implementation of on-disk key–value storage, implemented as a log-structured merge-tree, LSM-tree or LSMT.@@ -502,7 +502,7 @@ type: git location: https://github.com/IntersectMBO/lsm-tree subdir: lsm-tree- tag: lsm-tree-1.0.0.2+ tag: lsm-tree-1.1.0.0 common warnings ghc-options:@@ -542,7 +542,7 @@ build-depends: , base >=4.16 && <4.23- , blockio ^>=0.1+ , blockio ^>=0.1 || ^>=0.2 , contra-tracer ^>=0.1 || ^>=0.2 , deepseq ^>=1.4 || ^>=1.5 , fs-api ^>=0.4@@ -574,6 +574,7 @@ Database.LSMTree.Internal.CRC32C Database.LSMTree.Internal.Cursor Database.LSMTree.Internal.Entry+ Database.LSMTree.Internal.FS Database.LSMTree.Internal.IncomingRun Database.LSMTree.Internal.Index Database.LSMTree.Internal.Index.Compact@@ -620,7 +621,7 @@ build-depends: , base >=4.16 && <4.23 , bitvec ^>=1.1- , blockio ^>=0.1+ , blockio ^>=0.1 || ^>=0.2 , bloomfilter-blocked ^>=0.1 , bytestring ^>=0.11.4.0 || ^>=0.12.1.0 , cborg ^>=0.2.10.0@@ -741,6 +742,7 @@ Test.Database.LSMTree.Internal.WriteBufferReader.FS Test.Database.LSMTree.Model.Table Test.Database.LSMTree.Resolve+ Test.Database.LSMTree.Snapshots Test.Database.LSMTree.StateMachine Test.Database.LSMTree.StateMachine.DL Test.Database.LSMTree.StateMachine.Op@@ -1171,6 +1173,7 @@ , blockio:sim , contra-tracer , directory+ , filepath , fs-api , fs-sim , io-classes
src-core/Database/LSMTree/Internal/Config/Override.hs view
@@ -144,6 +144,8 @@ in override rdc x instance Override RunDataCaching (SnapLevel SnapshotRun) where+ override _ lvl@SnapEmptyLevel =+ lvl override rdc (SnapLevel (sir :: SnapIncomingRun SnapshotRun) (srs :: V.Vector SnapshotRun)) = SnapLevel (override rdc sir) (V.map (override rdc) srs)
+ src-core/Database/LSMTree/Internal/FS.hs view
@@ -0,0 +1,117 @@+module Database.LSMTree.Internal.FS (+ -- * Hard links+ hardLink+ , hardLinkDirectoryRecursive+ -- * Copy file+ , copyFile+ ) where++import Control.ActionRegistry+import Control.Monad (forM_, void)+import Control.Monad.Class.MonadThrow+import Control.Monad.Primitive (PrimMonad)++import qualified System.FS.API as FS+import System.FS.API+import qualified System.FS.API.Lazy as FSL+import qualified System.FS.BlockIO.API as FS+import System.FS.BlockIO.API (HasBlockIO)+import Text.Printf (printf)++{-------------------------------------------------------------------------------+ Hard links+-------------------------------------------------------------------------------}++{-# SPECIALISE+ hardLink ::+ HasFS IO h+ -> HasBlockIO IO h+ -> ActionRegistry IO+ -> FS.FsPath+ -> FS.FsPath+ -> IO ()+ #-}+-- | @'hardLink' hfs hbio reg sourcePath destinationPath@ creates a hard link from+-- @sourcePath@ to @destinationPath@.+--+-- Both the source path and destination path should be on the same disk volume.+hardLink ::+ (MonadMask m, PrimMonad m)+ => HasFS m h+ -> HasBlockIO m h+ -> ActionRegistry m+ -> FS.FsPath+ -> FS.FsPath+ -> m ()+hardLink hfs hbio reg sourcePath destinationPath = do+ withRollback_ reg+ (FS.createHardLink hbio sourcePath destinationPath)+ (FS.removeFile hfs destinationPath)++{-# SPECIALISE+ hardLinkDirectoryRecursive ::+ HasFS IO h+ -> HasBlockIO IO h+ -> ActionRegistry IO+ -> FS.FsPath+ -> FS.FsPath+ -> IO ()+ #-}+-- | Recursively create hard links for all the directory contents of the source+-- path at the destination path.+--+-- Both the source path and destination path should be on the same disk volume.+hardLinkDirectoryRecursive ::+ (MonadMask m, PrimMonad m)+ => HasFS m h+ -> HasBlockIO m h+ -> ActionRegistry m+ -- | Source path+ -> FS.FsPath+ -- | Destination path+ -> FS.FsPath+ -> m ()+hardLinkDirectoryRecursive hfs hbio reg sourcePath destinationPath = do+ entries <- FS.listDirectory hfs sourcePath+ forM_ entries $ \entry -> do+ let sourcePath' = sourcePath FS.</> FS.mkFsPath [entry]+ destinationPath' = destinationPath FS.</> FS.mkFsPath [entry]+ isFile <- FS.doesFileExist hfs sourcePath'+ if isFile then+ hardLink hfs hbio reg sourcePath' destinationPath'+ else do+ isDirectory <- FS.doesDirectoryExist hfs sourcePath'+ if isDirectory then do+ hardLinkDirectoryRecursive hfs hbio reg sourcePath' destinationPath'+ else+ error $ printf+ "hardLinkDirectoryRecursive: %s is not a file or directory"+ (show sourcePath')++{-------------------------------------------------------------------------------+ Copy file+-------------------------------------------------------------------------------}++{-# SPECIALISE+ copyFile ::+ HasFS IO h+ -> ActionRegistry IO+ -> FS.FsPath+ -> FS.FsPath+ -> IO ()+ #-}+-- | @'copyFile' hfs reg sourcePath destinationPath@ copies the file contents of+-- @sourcePath@ to the @destinationPath@.+copyFile ::+ (MonadMask m, PrimMonad m)+ => HasFS m h+ -> ActionRegistry m+ -> FS.FsPath+ -> FS.FsPath+ -> m ()+copyFile hfs reg sourcePath destinationPath =+ flip (withRollback_ reg) (FS.removeFile hfs destinationPath) $+ FS.withFile hfs sourcePath FS.ReadMode $ \sourceHandle ->+ FS.withFile hfs destinationPath (FS.WriteMode FS.MustBeNew) $ \targetHandle -> do+ bs <- FSL.hGetAll hfs sourceHandle+ void $ FSL.hPutAll hfs targetHandle bs
src-core/Database/LSMTree/Internal/MergeSchedule.hs view
@@ -30,7 +30,7 @@ , releaseUnionCache -- * Flushes and scheduled merges , updatesWithInterleavedFlushes- , flushWriteBuffer+ , migrateUnionLevel -- * Exported for cabal-docspec , maxRunSize -- * Credits@@ -67,6 +67,7 @@ MergeDebt (..), MergingRun, RunParams (..)) import qualified Database.LSMTree.Internal.MergingRun as MR import Database.LSMTree.Internal.MergingTree (MergingTree)+import qualified Database.LSMTree.Internal.MergingTree as MT import qualified Database.LSMTree.Internal.MergingTree.Lookup as MT import Database.LSMTree.Internal.Paths (ActiveDir, RunFsPaths (..), SessionRoot)@@ -118,6 +119,9 @@ -- | This is traced at the latest point the merge could complete. | TraceExpectCompletedMerge RunNumber+ | TraceMigrateUnionLevel+ NumEntries -- ^ Size of run+ RunNumber deriving stock (Show, Eq) {-------------------------------------------------------------------------------@@ -232,11 +236,13 @@ -> Levels m h -> m a foldRunAndMergeM k1 k2 ls =- fmap fold $ forMStrict ls $ \(Level ir rs) -> do- incoming <- case ir of- Single r -> k1 r- Merging _ _ _ mr -> k2 mr- (incoming <>) . fold <$> V.forM rs k1+ fmap fold $ forMStrict ls $ \case+ EmptyLevel -> pure mempty+ Level ir rs -> do+ incoming <- case ir of+ Single r -> k1 r+ Merging _ _ _ mr -> k2 mr+ (incoming <>) . fold <$> V.forM rs k1 {-# SPECIALISE rebuildCache :: ActionRegistry IO@@ -309,10 +315,13 @@ -- | A level is a sequence of resident runs at this level, prefixed by an -- incoming run, which is usually multiple runs that are being merged. Once -- completed, the resulting run will become a resident run at this level.-data Level m h = Level {- incomingRun :: !(IncomingRun m h)- , residentRuns :: !(V.Vector (Ref (Run m h)))- }+--+-- We create empty levels when we migrate a union run (see 'migrateUnionLevel')+-- but it is too large for the last level. Empty levels then allow us to migrate+-- it into a larger level without having to fill the levels inbetween.+data Level m h =+ Level !(IncomingRun m h) !(V.Vector (Ref (Run m h)))+ | EmptyLevel {-# SPECIALISE duplicateLevels :: ActionRegistry IO -> Levels IO h -> IO (Levels IO h) #-} duplicateLevels ::@@ -321,14 +330,14 @@ -> Levels m h -> m (Levels m h) duplicateLevels reg levels =- forMStrict levels $ \Level {incomingRun, residentRuns} -> do- incomingRun' <- withRollback reg (duplicateIncomingRun incomingRun) releaseIncomingRun- residentRuns' <- forMStrict residentRuns $ \r ->- withRollback reg (dupRef r) releaseRef- pure $! Level {- incomingRun = incomingRun',- residentRuns = residentRuns'- }+ forMStrict levels $ \case+ EmptyLevel ->+ pure EmptyLevel+ Level incomingRun residentRuns -> do+ incomingRun' <- withRollback reg (duplicateIncomingRun incomingRun) releaseIncomingRun+ residentRuns' <- forMStrict residentRuns $ \r ->+ withRollback reg (dupRef r) releaseRef+ pure $! Level incomingRun' residentRuns' {-# SPECIALISE releaseLevels :: ActionRegistry IO -> Levels IO h -> IO () #-} releaseLevels ::@@ -337,13 +346,18 @@ -> Levels m h -> m () releaseLevels reg levels =- V.forM_ levels $ \Level {incomingRun, residentRuns} -> do- delayedCommit reg (releaseIncomingRun incomingRun)- V.mapM_ (delayedCommit reg . releaseRef) residentRuns+ V.forM_ levels $ \case+ EmptyLevel ->+ pure ()+ Level incomingRun residentRuns -> do+ delayedCommit reg (releaseIncomingRun incomingRun)+ V.mapM_ (delayedCommit reg . releaseRef) residentRuns {-# SPECIALISE iforLevelM_ :: Levels IO h -> (LevelNo -> Level IO h -> IO ()) -> IO () #-} iforLevelM_ :: Monad m => Levels m h -> (LevelNo -> Level m h -> m ()) -> m ()-iforLevelM_ lvls k = V.iforM_ lvls $ \i lvl -> k (LevelNo (i + 1)) lvl+iforLevelM_ lvls k = V.iforM_ lvls $ \i -> \case+ EmptyLevel -> pure ()+ lvl@Level{} -> k (LevelNo (i + 1)) lvl {------------------------------------------------------------------------------- Union level@@ -388,6 +402,71 @@ releaseUnionLevel reg (Union tree cache) = delayedCommit reg (releaseRef tree) >> releaseUnionCache reg cache +{-# SPECIALISE migrateUnionLevel ::+ Tracer IO (AtLevel MergeTrace)+ -> TableConfig+ -> ActionRegistry IO+ -> TableContent IO h+ -> IO (TableContent IO h) #-}+migrateUnionLevel ::+ forall m h.+ (MonadMask m, MonadMVar m, MonadST m)+ => Tracer m (AtLevel MergeTrace)+ -> TableConfig+ -> ActionRegistry m+ -> TableContent m h+ -> m (TableContent m h)+migrateUnionLevel tr conf reg tc = do+ case tableUnionLevel tc of+ NoUnion ->+ -- No union, nothing to do.+ pure tc+ Union mt unionCache ->+ withRollbackMaybe reg (MT.getCompleted mt) releaseRef >>= \case+ Nothing ->+ -- Still in progress, nothing to do.+ pure tc+ Just r -> do+ tableLevels' <- migrate r (tableLevels tc)+ -- We need to rebuild the cache, since we changed the levels.+ tableCache' <- rebuildCache reg (tableCache tc) tableLevels'+ -- We migrated the union and return 'NoUnion' now, so we need to+ -- drop the old tree and union cache (we duplicated what we needed).+ delayedCommit reg (releaseRef mt)+ releaseUnionCache reg unionCache+ pure $! tc {+ tableLevels = tableLevels'+ , tableCache = tableCache'+ , tableUnionLevel = NoUnion+ }+ where+ migrate :: Ref (Run m h) -> Levels m h -> m (Levels m h)+ migrate r ls = do+ -- At which level does the migrated run belong?+ let levelNo = maximum+ [ 2 -- First level is tiering, don't migrate there.+ , V.length ls + 1 -- Run must come after existing levels.+ , runSizeToLevelNumber LevelLevelling (Run.size r)+ -- The level must be large enough for the run.+ ]+ traceWith tr $ AtLevel (LevelNo levelNo) $+ TraceMigrateUnionLevel (Run.size r) (Run.runFsPathsNumber r)+ let emptyLevels = V.replicate (levelNo - 1 - V.length ls) EmptyLevel+ migratedLevel <- do+ ir <- withRollback reg (newIncomingSingleRun r) releaseIncomingRun+ delayedCommit reg (releaseRef r)+ pure (Level ir V.empty)+ let ls' = tableLevels tc <> emptyLevels <> V.singleton migratedLevel+ assert (length ls' == levelNo) $ pure ()+ pure ls'++ -- We could calculate the inverse of maxRunSize directly, but this version+ -- is more obviously correct and the performance difference doesn't matter.+ runSizeToLevelNumber :: MergePolicyForLevel -> NumEntries -> Int+ runSizeToLevelNumber policy runSize =+ -- the list is guaranteed to be non-empty+ head [ln | ln <- [0 ..], runSize <= maxRunSize' conf policy (LevelNo ln)]+ {------------------------------------------------------------------------------- Union cache -------------------------------------------------------------------------------}@@ -507,7 +586,13 @@ pure $! tc' -- If the write buffer did reach capacity, then we flush. else do- tc'' <- flushWriteBuffer tr conf resolve hfs hbio refCtx root salt uc reg tc'+ -- But first try migrating the union level, in case the flush triggers a+ -- new last level merge that the union can become part of.+ -- We only do this after checking that the writebuffer is full, so we+ -- don't call 'migrateUnionLevel' for every single call to update.+ tc'' <-+ migrateUnionLevel tr conf reg tc'+ >>= flushWriteBuffer tr conf resolve hfs hbio refCtx root salt uc reg -- In the fortunate case where we have already performed all the updates, -- return, if V.null es' then@@ -623,7 +708,6 @@ , tableWriteBufferBlobs = wbblobs' , tableLevels = levels' , tableCache = tableCache'- -- TODO: move into regular levels if merge completed and size fits , tableUnionLevel = tableUnionLevel tc } @@ -673,7 +757,7 @@ go :: LevelNo -> V.Vector (Ref (Run m h))- -> V.Vector (Level m h )+ -> V.Vector (Level m h) -> m (V.Vector (Level m h)) go !ln rs (V.uncons -> Nothing) = do traceWith tr $ AtLevel ln TraceAddLevel@@ -681,6 +765,13 @@ let policyForLevel = mergePolicyForLevel confMergePolicy ln V.empty ul ir <- newMerge policyForLevel (mergeTypeForLevel V.empty ul) ln rs pure $! V.singleton $ Level ir V.empty++ go !ln rs (V.uncons -> Just (EmptyLevel, ls)) = do+ assert (not (V.null ls)) $ pure () -- no trailing empty levels+ let policyForLevel = mergePolicyForLevel confMergePolicy ln ls ul+ ir <- newMerge policyForLevel (mergeTypeForLevel ls ul) ln rs+ pure $! Level ir V.empty `V.cons` ls+ go !ln rs' (V.uncons -> Just (Level ir rs, ls)) = do r <- expectCompletedMerge ln ir case mergePolicyForLevel confMergePolicy ln ls ul of@@ -972,8 +1063,11 @@ -> Levels m h -> m () supplyCredits refCtx conf deposit levels =- iforLevelM_ levels $ \ln (Level ir _rs) ->- supplyCreditsIncomingRun refCtx conf ln ir deposit+ iforLevelM_ levels $ \ln -> \case+ EmptyLevel ->+ pure ()+ (Level ir _rs) ->+ supplyCreditsIncomingRun refCtx conf ln ir deposit --TODO: consider tracing supply of credits, -- supplyCreditsIncomingRun could easily return the supplied credits -- before & after, which may be useful for tracing.
src-core/Database/LSMTree/Internal/MergingTree.hs view
@@ -12,6 +12,7 @@ , newOngoingMerge , newPendingLevelMerge , newPendingUnionMerge+ , getCompleted , isStructurallyEmpty , remainingMergeDebt , supplyCredits@@ -26,7 +27,7 @@ import Control.Monad (foldM, (<$!>)) import Control.Monad.Class.MonadST (MonadST) import Control.Monad.Class.MonadSTM (MonadSTM (..))-import Control.Monad.Class.MonadThrow (MonadMask)+import Control.Monad.Class.MonadThrow (MonadMask, MonadThrow) import Control.Monad.Primitive import Control.RefCount import Data.Foldable (toList, traverse_)@@ -270,6 +271,32 @@ Just (mt, x) | V.null x -> pure mt _ -> mkMergingTree refCtx (PendingTreeMerge (PendingUnionMerge mts''))++{-# SPECIALISE getCompleted ::+ Ref (MergingTree IO h)+ -> IO (Maybe (Ref (Run IO h))) #-}+-- | If the merging tree is completed, return a new reference to the resulting+-- run.+--+-- Resource tracking:+-- * This allocates a new 'Ref' which the caller is responsible for releasing+-- eventually.+-- * The ownership of all input 'Ref's remains with the caller. This action+-- will create duplicate references, not adopt the given ones.+--+-- ASYNC: this should be called with asynchronous exceptions masked because it+-- allocates\/creates resources.+getCompleted ::+ (MonadMVar m, PrimMonad m, MonadThrow m)+ => Ref (MergingTree m h)+ -> m (Maybe (Ref (Run m h)))+getCompleted (DeRef MergingTree {mergeState}) =+ -- A simple read is sufficient. Once the merge is completed, it doesn't get+ -- mutated further, so we don't have to worry about concurrent mutation.+ readMVar mergeState >>= \case+ CompletedTreeMerge r -> Just <$> dupRef r+ OngoingTreeMerge{} -> pure Nothing+ PendingTreeMerge{} -> pure Nothing {-# SPECIALISE isStructurallyEmpty :: Ref (MergingTree IO h) -> IO Bool #-} -- | Test if a 'MergingTree' is \"obviously\" empty by virtue of its structure.
src-core/Database/LSMTree/Internal/Snapshot.hs view
@@ -38,7 +38,6 @@ import Control.Concurrent.Class.MonadMVar.Strict import Control.Concurrent.Class.MonadSTM (MonadSTM) import Control.DeepSeq (NFData (..))-import Control.Monad (void) import Control.Monad.Class.MonadST (MonadST) import Control.Monad.Class.MonadThrow (MonadMask, bracket, bracketOnError)@@ -52,6 +51,7 @@ import Database.LSMTree.Internal.Config import Database.LSMTree.Internal.CRC32C (checkCRC) import qualified Database.LSMTree.Internal.CRC32C as CRC+import qualified Database.LSMTree.Internal.FS as FS import Database.LSMTree.Internal.IncomingRun import qualified Database.LSMTree.Internal.Merge as Merge import Database.LSMTree.Internal.MergeSchedule@@ -76,8 +76,6 @@ import qualified Database.LSMTree.Internal.WriteBufferWriter as WBW import qualified System.FS.API as FS import System.FS.API (HasFS, (<.>), (</>))-import qualified System.FS.API.Lazy as FSL-import qualified System.FS.BlockIO.API as FS import System.FS.BlockIO.API (HasBlockIO) {-------------------------------------------------------------------------------@@ -126,13 +124,13 @@ deriving stock (Eq, Functor, Foldable, Traversable) deriving newtype NFData -data SnapLevel r = SnapLevel {- snapIncoming :: !(SnapIncomingRun r)- , snapResidentRuns :: !(V.Vector r)- }+data SnapLevel r =+ SnapEmptyLevel+ | SnapLevel !(SnapIncomingRun r) !(V.Vector r) deriving stock (Eq, Functor, Foldable, Traversable) instance NFData r => NFData (SnapLevel r) where+ rnf SnapEmptyLevel = () rnf (SnapLevel a b) = rnf a `seq` rnf b -- | Note that for snapshots of incoming runs, we store only the merge debt and@@ -385,7 +383,9 @@ (PrimMonad m, MonadMVar m) => Level m h -> m (SnapLevel (Ref (Run m h)))-toSnapLevel Level{..} = do+toSnapLevel EmptyLevel =+ pure SnapEmptyLevel+toSnapLevel (Level incomingRun residentRuns) = do sir <- toSnapIncomingRun incomingRun pure (SnapLevel sir residentRuns) @@ -472,13 +472,13 @@ -- Hard link the write buffer and write buffer blobs to the snapshot directory. snapWriteBufferNumber <- uniqueToRunNumber <$> incrUniqCounter snapUc let snapWriteBufferPaths = WriteBufferFsPaths (getNamedSnapshotDir snapDir) snapWriteBufferNumber- hardLink hfs hbio reg+ FS.hardLink hfs hbio reg (writeBufferKOpsPath activeWriteBufferPaths) (writeBufferKOpsPath snapWriteBufferPaths)- hardLink hfs hbio reg+ FS.hardLink hfs hbio reg (writeBufferBlobPath activeWriteBufferPaths) (writeBufferBlobPath snapWriteBufferPaths)- hardLink hfs hbio reg+ FS.hardLink hfs hbio reg (writeBufferChecksumsPath activeWriteBufferPaths) (writeBufferChecksumsPath snapWriteBufferPaths) pure snapWriteBufferPaths@@ -520,7 +520,7 @@ activeWriteBufferNumber <- uniqueToInt <$> incrUniqCounter uc let activeWriteBufferBlobPath = getActiveDir activeDir </> FS.mkFsPath [show activeWriteBufferNumber] <.> "wbblobs"- copyFile hfs reg (writeBufferBlobPath snapWriteBufferPaths) activeWriteBufferBlobPath+ FS.copyFile hfs reg (writeBufferBlobPath snapWriteBufferPaths) activeWriteBufferBlobPath writeBufferBlobs <- withRollback reg (WBB.open hfs refCtx activeWriteBufferBlobPath FS.AllowExisting)@@ -667,7 +667,9 @@ -- TODO: we may wish to trace the merges created during snapshot restore: fromSnapLevel :: LevelNo -> SnapLevel (Ref (Run m h)) -> m (Level m h)- fromSnapLevel ln SnapLevel{snapIncoming, snapResidentRuns} = do+ fromSnapLevel _ SnapEmptyLevel =+ pure EmptyLevel+ fromSnapLevel ln (SnapLevel snapIncoming snapResidentRuns) = do incomingRun <- withRollback reg (fromSnapIncomingRun ln snapIncoming) releaseIncomingRun@@ -675,7 +677,7 @@ withRollback reg (dupRef r) releaseRef- pure Level {incomingRun , residentRuns}+ pure (Level incomingRun residentRuns) fromSnapIncomingRun :: LevelNo@@ -764,56 +766,5 @@ hardLinkRunFiles hfs hbio reg sourceRunFsPaths targetRunFsPaths = do let sourcePaths = pathsForRunFiles sourceRunFsPaths targetPaths = pathsForRunFiles targetRunFsPaths- sequenceA_ (hardLink hfs hbio reg <$> sourcePaths <*> targetPaths)- hardLink hfs hbio reg (runChecksumsPath sourceRunFsPaths) (runChecksumsPath targetRunFsPaths)--{-# SPECIALISE- hardLink ::- HasFS IO h- -> HasBlockIO IO h- -> ActionRegistry IO- -> FS.FsPath- -> FS.FsPath- -> IO ()- #-}--- | @'hardLink' hfs hbio reg sourcePath targetPath@ creates a hard link from--- @sourcePath@ to @targetPath@.-hardLink ::- (MonadMask m, PrimMonad m)- => HasFS m h- -> HasBlockIO m h- -> ActionRegistry m- -> FS.FsPath- -> FS.FsPath- -> m ()-hardLink hfs hbio reg sourcePath targetPath = do- withRollback_ reg- (FS.createHardLink hbio sourcePath targetPath)- (FS.removeFile hfs targetPath)--{-------------------------------------------------------------------------------- Copy file--------------------------------------------------------------------------------}--{-# SPECIALISE- copyFile ::- HasFS IO h- -> ActionRegistry IO- -> FS.FsPath- -> FS.FsPath- -> IO ()- #-}--- | @'copyFile' hfs reg source target@ copies the @source@ path to the @target@ path.-copyFile ::- (MonadMask m, PrimMonad m)- => HasFS m h- -> ActionRegistry m- -> FS.FsPath- -> FS.FsPath- -> m ()-copyFile hfs reg sourcePath targetPath =- flip (withRollback_ reg) (FS.removeFile hfs targetPath) $- FS.withFile hfs sourcePath FS.ReadMode $ \sourceHandle ->- FS.withFile hfs targetPath (FS.WriteMode FS.MustBeNew) $ \targetHandle -> do- bs <- FSL.hGetAll hfs sourceHandle- void $ FSL.hPutAll hfs targetHandle bs+ sequenceA_ (FS.hardLink hfs hbio reg <$> sourcePaths <*> targetPaths)+ FS.hardLink hfs hbio reg (runChecksumsPath sourceRunFsPaths) (runChecksumsPath targetRunFsPaths)
src-core/Database/LSMTree/Internal/Snapshot/Codec.hs view
@@ -58,33 +58,34 @@ -- for more. Forwards compatibility is not provided at all: snapshots with a -- later version than the current version for the library release will always -- fail.-data SnapshotVersion = V0 | V1+data SnapshotVersion = V0 | V1 | V2 deriving stock (Show, Eq, Ord) -- | Pretty-print a snapshot version -- -- >>> prettySnapshotVersion currentSnapshotVersion--- "v1"+-- "v2" prettySnapshotVersion :: SnapshotVersion -> String prettySnapshotVersion V0 = "v0" prettySnapshotVersion V1 = "v1"+prettySnapshotVersion V2 = "v2" -- | The current snapshot version -- -- >>> currentSnapshotVersion--- V1+-- V2 currentSnapshotVersion :: SnapshotVersion-currentSnapshotVersion = V1+currentSnapshotVersion = V2 --- | All snapshot versions that the current snapshpt version is compatible with.+-- | All snapshot versions that the current snapshot version is compatible with. -- -- >>> allCompatibleSnapshotVersions--- [V0,V1]+-- [V0,V1,V2] -- -- >>> last allCompatibleSnapshotVersions == currentSnapshotVersion -- True allCompatibleSnapshotVersions :: [SnapshotVersion]-allCompatibleSnapshotVersions = [V0, V1]+allCompatibleSnapshotVersions = [V0, V1, V2] isCompatible :: SnapshotVersion -> Either String () isCompatible otherVersion@@ -216,6 +217,7 @@ <> case ver of V0 -> encodeWord 0 V1 -> encodeWord 1+ V2 -> encodeWord 2 instance Decode SnapshotVersion where decode = do@@ -224,6 +226,7 @@ case ver of 0 -> pure V0 1 -> pure V1+ 2 -> pure V2 _ -> fail ("Unknown snapshot format version number: " <> show ver) {-------------------------------------------------------------------------------@@ -308,7 +311,9 @@ <> encode mergeBatchSize instance DecodeVersioned TableConfig where- decodeVersioned v@V0 = do+ decodeVersioned v+ | v < V1 = do+ -- For backwards compatibility. We added confMergeBatchSize in V1. decodeListLenOf 7 confMergePolicy <- decodeVersioned v confMergeSchedule <- decodeVersioned v@@ -321,8 +326,7 @@ AllocNumEntries n -> MergeBatchSize n pure TableConfig {..} - -- We introduced the confMergeBatchSize in V1- decodeVersioned v@V1 = do+ | otherwise = do decodeListLenOf 8 confMergePolicy <- decodeVersioned v confMergeSchedule <- decodeVersioned v@@ -534,16 +538,30 @@ -- SnapLevel instance Encode r => Encode (SnapLevel r) where- encode (SnapLevel incomingRuns residentRuns) =- encodeListLen 2- <> encode incomingRuns+ encode SnapEmptyLevel =+ encodeListLen 1+ <> encodeWord 0+ encode (SnapLevel incomingRun residentRuns) =+ encodeListLen 3+ <> encodeWord 1+ <> encode incomingRun <> encode residentRuns instance DecodeVersioned r => DecodeVersioned (SnapLevel r) where- decodeVersioned v = do+ decodeVersioned v+ | v < V2 = do+ -- For backwards compatibility. There were no empty levels before V2. _ <- decodeListLenOf 2 SnapLevel <$> decodeVersioned v <*> decodeVersioned v++ | otherwise = do+ n <- decodeListLen+ tag <- decodeWord+ case (n, tag) of+ (1, 0) -> pure SnapEmptyLevel+ (3, 1) -> SnapLevel <$> decodeVersioned v <*> decodeVersioned v+ _ -> fail ("[SnapLevel] Unexpected combination of list length and tag: " <> show (n, tag)) -- Vector
src-core/Database/LSMTree/Internal/Unsafe.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedRecordDot #-} {-# OPTIONS_HADDOCK not-home #-} -- | This module brings together the internal parts to provide an API in terms@@ -23,6 +24,8 @@ , SnapshotDoesNotExistError (..) , SnapshotCorruptedError (..) , SnapshotNotCompatibleError (..)+ , SnapshotImportDirDoesNotExistError (..)+ , SnapshotExportDirExistsError (..) , BlobRefInvalidError (..) , CursorClosedError (..) , FileFormat (..)@@ -79,6 +82,8 @@ , deleteSnapshot , doesSnapshotExist , listSnapshots+ , importSnapshot+ , exportSnapshot -- * Multiple writable tables , duplicate -- * Table union@@ -126,6 +131,7 @@ FileFormat (..)) import qualified Database.LSMTree.Internal.Cursor as Cursor import Database.LSMTree.Internal.Entry (Entry)+import qualified Database.LSMTree.Internal.FS as FS import Database.LSMTree.Internal.IncomingRun (IncomingRun (..)) import Database.LSMTree.Internal.Lookup (TableCorruptedError (..), lookupsIO, lookupsIOWithWriteBuffer)@@ -243,6 +249,18 @@ -- | We are listing snapshots. | TraceListSnapshots + -- | We are importing a snapshot. A 'TraceImportedSnapshot' message should+ -- follow if successful.+ | TraceImportSnapshot SnapshotName FsPath+ -- | Importing a snapshot was successful.+ | TraceImportedSnapshot SnapshotName++ -- | We are exporting a snapshot. A 'TraceExportedSnapshot' message should+ -- follow if successful.+ | TraceExportSnapshot SnapshotName FsPath+ -- | Exporting a snapshot was successful.+ | TraceExportedSnapshot SnapshotName+ -- | We are retrieving blobs. | TraceRetrieveBlobs Int deriving stock (Show, Eq)@@ -1895,6 +1913,110 @@ if b then pure $ Just snap else pure $ Nothing +-- | A snapshot was intended to be imported, but the source directory does not+-- exist.+data SnapshotImportDirDoesNotExistError+ = SnapshotImportDirDoesNotExistError !FsPath+ deriving stock (Show, Eq)+ deriving anyclass (Exception)++{-# SPECIALISE importSnapshot ::+ Session IO h+ -> SnapshotName+ -> FsPath+ -> IO () #-}+-- | See 'Database.LSMTree.importSnapshot'.+importSnapshot ::+ (MonadMask m, MonadSTM m, PrimMonad m)+ => Session m h+ -> SnapshotName+ -> FsPath+ -> m ()+importSnapshot sesh snap sourcePath = do+ traceWith sesh.sessionTracer $ TraceImportSnapshot snap sourcePath+ withKeepSessionOpen sesh $ \seshEnv ->+ withActionRegistry $ \reg -> do+ let hfs = seshEnv.sessionHasFS+ hbio = seshEnv.sessionHasBlockIO++ -- Guard that the snapshot does not exist already+ let snapDir = Paths.namedSnapshotDir (sessionRoot seshEnv) snap+ snapshotExists <- doesSnapshotDirExist snap seshEnv+ when snapshotExists $ throwIO (ErrSnapshotExists snap)++ let destinationPath = Paths.getNamedSnapshotDir snapDir++ sourceExists <- FS.doesDirectoryExist hfs sourcePath+ unless sourceExists $ throwIO (SnapshotImportDirDoesNotExistError sourcePath)++ -- we assume the snapshots directory already exists, so we just have+ -- to create the directory for this specific snapshot.+ withRollback_ reg+ (FS.createDirectory hfs destinationPath)+ (FS.removeDirectoryRecursive hfs destinationPath)++ -- create hard links for all files in the destination directory+ FS.hardLinkDirectoryRecursive hfs hbio reg sourcePath destinationPath++ -- Make the destination directory and its contents durable+ FS.synchroniseDirectoryRecursive hfs hbio destinationPath++ -- Note: trace the success message only after all side effects have been+ -- succesfully performed+ delayedCommit reg $+ traceWith sesh.sessionTracer $ TraceImportedSnapshot snap++-- | A snapshot was intended to be exported, but the destination directory+-- already exists.+data SnapshotExportDirExistsError+ = SnapshotExportDirExistsError !FsPath+ deriving stock (Show, Eq)+ deriving anyclass (Exception)++{-# SPECIALISE exportSnapshot ::+ Session IO h+ -> SnapshotName+ -> FsPath+ -> IO () #-}+-- | See 'Database.LSMTree.exportSnapshot'.+exportSnapshot ::+ (MonadMask m, MonadSTM m, PrimMonad m)+ => Session m h+ -> SnapshotName+ -> FsPath+ -> m ()+exportSnapshot sesh snap destinationPath = do+ traceWith (sessionTracer sesh) $ TraceExportSnapshot snap destinationPath+ withKeepSessionOpen sesh $ \seshEnv ->+ withActionRegistry $ \reg -> do+ let hfs = seshEnv.sessionHasFS+ hbio = seshEnv.sessionHasBlockIO++ -- Guard that the snapshot exists already+ let snapDir = Paths.namedSnapshotDir (sessionRoot seshEnv) snap+ snapshotExists <- doesSnapshotDirExist snap seshEnv+ unless snapshotExists $ throwIO (ErrSnapshotDoesNotExist snap)++ let sourcePath = Paths.getNamedSnapshotDir snapDir++ destinationExists <- FS.doesDirectoryExist hfs destinationPath+ when destinationExists $ throwIO (SnapshotExportDirExistsError sourcePath)++ withRollback_ reg+ (FS.createDirectoryIfMissing hfs True destinationPath)+ (FS.removeDirectoryRecursive hfs destinationPath)++ -- Create hard links for all files in the destination directory+ FS.hardLinkDirectoryRecursive hfs hbio reg sourcePath destinationPath++ -- Make the directory and its contents durable.+ FS.synchroniseDirectoryRecursive hfs hbio destinationPath++ -- Note: trace the success message only after all side effects have been+ -- succesfully performed+ delayedCommit reg $+ traceWith sesh.sessionTracer $ TraceExportedSnapshot snap+ {------------------------------------------------------------------------------- Multiple writable tables -------------------------------------------------------------------------------}@@ -2076,7 +2198,9 @@ in newPendingLevelMerge (sessionRefCtx seshEnv) runs unionmt where levelToPreExistingRuns :: Level m h -> [PreExistingRun m h]- levelToPreExistingRuns Level{incomingRun, residentRuns} =+ levelToPreExistingRuns EmptyLevel =+ []+ levelToPreExistingRuns (Level incomingRun residentRuns) = case incomingRun of Single r -> PreExistingRun r Merging _ _ _ mr -> PreExistingMergingRun mr@@ -2176,7 +2300,9 @@ pure (UnionDebt 0) Union mt _ -> do (MergeDebt (MergeCredits c), _) <- MT.remainingMergeDebt mt- pure (UnionDebt c)+ -- As long as there is a union level, the union is not considered+ -- paid off, even if the merging tree is completed.+ pure (UnionDebt (c + 1)) {- | Union credits are passed to 'Database.LSMTree.supplyUnionCredits' to perform some amount of computation to incrementally complete a union.@@ -2227,9 +2353,12 @@ modifyWithActionRegistry_ (RW.unsafeAcquireWriteAccess (tableContent tEnv)) (atomically . RW.unsafeReleaseWriteAccess (tableContent tEnv))- $ \reg tc ->- case tableUnionLevel tc of- NoUnion -> pure tc+ $ \reg tc -> do+ -- We might have completed the merging tree, so try migrating.+ let tr' = contramapTraceMerge (tableTracer t)+ tc' <- migrateUnionLevel tr' (tableConfig t) reg tc+ case tableUnionLevel tc' of+ NoUnion -> pure tc' Union mt cache -> do unionLevel' <- MT.isStructurallyEmpty mt >>= \case True ->@@ -2238,5 +2367,5 @@ cache' <- mkUnionCache reg mt releaseUnionCache reg cache pure (Union mt cache')- pure tc { tableUnionLevel = unionLevel' }+ pure tc' { tableUnionLevel = unionLevel' } pure leftovers
src/Database/LSMTree.hs view
@@ -20,6 +20,7 @@ Session, withOpenSession, withOpenSessionIO,+ withOpenMountedSessionIO, withNewSession, withRestoreSession, openSession,@@ -101,6 +102,8 @@ doesSnapshotExist, deleteSnapshot, listSnapshots,+ importSnapshot,+ exportSnapshot, SnapshotName, isValidSnapshotName, toSnapshotName,@@ -178,6 +181,8 @@ SnapshotDoesNotExistError (..), SnapshotCorruptedError (..), SnapshotNotCompatibleError (..),+ SnapshotImportDirDoesNotExistError (..),+ SnapshotExportDirExistsError (..), BlobRefInvalidError (..), CursorClosedError (..), InvalidSnapshotNameError (..),@@ -250,6 +255,8 @@ SessionDirLockedError (..), SessionId (..), SessionTrace (..), SnapshotCorruptedError (..), SnapshotDoesNotExistError (..), SnapshotExistsError (..),+ SnapshotExportDirExistsError (..),+ SnapshotImportDirDoesNotExistError (..), SnapshotNotCompatibleError (..), TableClosedError (..), TableCorruptedError (..), TableTooLargeError (..), TableTrace, TableUnionNotCompatibleError (..),@@ -369,17 +376,28 @@ >>> import Data.Foldable (traverse_) >>> import qualified System.Directory as Dir >>> import System.FilePath ((</>))+>>> import System.FS.API (FsPath, mkFsPath)+>>> import qualified System.FS.API as FS >>> import System.Process (getCurrentPid)+ >>> :{+withTempDirectory :: String -> (FilePath -> IO a) -> IO a+withTempDirectory name k = do+ sysTmpDir <- Dir.getTemporaryDirectory+ pid <- getCurrentPid+ let tmpDir = sysTmpDir </> name </> show pid+ let createTmpDir = Dir.createDirectoryIfMissing True tmpDir+ let removeTmpDir = Dir.removeDirectoryRecursive tmpDir+ bracket_ createTmpDir removeTmpDir $ k tmpDir+:}++>>> :{ runExample :: (Session IO -> Table IO Key Value Blob -> IO a) -> IO a-runExample action = do- tmpDir <- Dir.getTemporaryDirectory- pid <- getCurrentPid- let sessionDir = tmpDir </> "doctest_Database_LSMTree" </> show pid- let createSessionDir = Dir.createDirectoryIfMissing True sessionDir- let removeSessionDir = Dir.removeDirectoryRecursive sessionDir- bracket_ createSessionDir removeSessionDir $ do- LSMT.withOpenSessionIO mempty sessionDir $ \session -> do+runExample action =+ withTempDirectory "doctest_Database_LSMTree" $ \tmpDir -> do+ let sessionPath = FS.mkFsPath ["session"]+ Dir.createDirectoryIfMissing True (tmpDir </> "session")+ LSMT.withOpenMountedSessionIO mempty tmpDir sessionPath $ \session -> do LSMT.withTable session $ \table -> action session table :}@@ -397,6 +415,26 @@ If the session directory is empty, a new session is created using the given salt. Otherwise, the session directory is restored as an existing session ignoring the given salt. +As a feature, @lsm-tree@ uses abstract 'HasFS' and 'HasBlockIO' interfaces to+abstract over interaction with the file system.+These abstract interfaces can be instantiated with a real file system (for use in practice) or+a simulated file system (for comprehensive testing).+For more information about the interfaces and their instantiations, see the Haddock+documentation of the @fs-api@, @fs-sim@, @blockio@ packages.++The session directory is a relative 'FsPath' path that is interpreted relative to the /root/ of+the given 'HasFS' and 'HasBlockio' interfaces.+If the interaces are instantiated with the real file system, then the root is an+(absolute or relative) file path.+In this case, the root is also called the /mount point/ of the interface.+If the interfaces are instantiated with a simulation, then the root is some abstract location.++Any 'FsPath' paths used with the session after the session is created are also interpreted+with respect to the root of these interfaces.+'importSnapshot' and 'exportSnapshot' are currently the only two functions that take+'FsPaths' as arguments.+'FsPath's are subject to a number of constraints, which are mentioned in its Haddock documentation.+ If there are no open tables or cursors when the session terminates, then the disk I\/O complexity of this operation is \(O(1)\). Otherwise, 'closeTable' is called for each open table and 'closeCursor' is called for each open cursor. Consequently, the worst-case disk I\/O complexity of this operation depends on the merge policy of the open tables in the session.@@ -426,6 +464,7 @@ HasFS IO HandleIO -> HasBlockIO IO HandleIO -> Salt ->+ -- | The session directory FsPath -> (Session IO -> IO a) -> IO a@@ -445,15 +484,52 @@ withOpenSession tracer hasFS hasBlockIO sessionSalt sessionDir action = do Internal.withOpenSession tracer hasFS hasBlockIO sessionSalt sessionDir (action . Session) --- | Variant of 'withOpenSession' that is specialised to 'IO' using the real filesystem.+{-# DEPRECATED withOpenSessionIO "withOpenSessionIO is not compatible with importSnapshot and exportSnapshot. Use withOpenMountedSessionIO instead." #-}+{- |+Variant of 'withOpenSession' that is specialised to 'IO' using the real filesystem.++Any 'FsPath' paths used with the session after the session is created are interpreted+with respect to the session directory.+'importSnapshot' and 'exportSnapshot' are currently the only two functions that take+'FsPaths' as arguments.+'FsPath's are subject to a number of constraints, which are mentioned in its Haddock documentation.++It is generally not advisable to use 'importSnapshot' and 'exportSnapshot' when the session is+created using 'withOpenSessionIO'.+Snapshots should only be exported to somewhere /outside/ the session directory, which is not possible+when the session is created using 'withOpenSessionIO'.+Use 'withOpenMountedSessionIO' or 'withOpenSession' instead.+-} withOpenSessionIO :: Tracer IO LSMTreeTrace ->+ -- | The session directory FilePath -> (Session IO -> IO a) -> IO a-withOpenSessionIO tracer sessionDir action = do- let mountPoint = MountPoint sessionDir- let sessionDirFsPath = mkFsPath []+withOpenSessionIO tracer sessionDir action =+ withOpenMountedSessionIO tracer sessionDir (mkFsPath []) action++{- |+Variant of 'withOpenSession' that is specialised to 'IO' using the real filesystem.++The session directory is an 'FsPath' path that is interpreted relative to the given mount point.+Any 'FsPath' paths used with the session after the session is created are also interpreted+with respect to the mount point.+'importSnapshot' and 'exportSnapshot' are currently the only two functions that take+'FsPaths' as arguments.+'FsPath's are subject to a number of constraints, which are mentioned in its haddock documentation.+-}+withOpenMountedSessionIO ::+ Tracer IO LSMTreeTrace ->+ -- | The mount point+ FilePath ->+ -- | Session directory+ FsPath ->+ (Session IO -> IO a) ->+ IO a+withOpenMountedSessionIO tracer mountPointDir sessionDir action = do+ let mountPoint = MountPoint mountPointDir+ let sessionDirFsPath = sessionDir sessionSalt <- randomIO withIOHasBlockIO mountPoint defaultIOCtxParams $ \hasFS hasBlockIO -> withOpenSession tracer hasFS hasBlockIO sessionSalt sessionDirFsPath action@@ -1976,6 +2052,13 @@ Get an /upper bound/ for the amount of remaining union debt. This includes the union debt of any table that was part of the union's input. +The exact amount of debt returned for a given table is an implementation detail+and not guaranteed to be stable across versions of @lsm-tree@.+Within the same version, the union debt of a table can never increase. However,+it can get decreased by operations on /another/ table if these tables share part+of their internal structure (e.g. due to one being a union input or duplicate of+the other).+ >>> :{ runExample $ \session table1 -> do LSMT.insert table1 0 "Hello" Nothing@@ -1985,7 +2068,7 @@ bracket (LSMT.incrementalUnion table1 table2) LSMT.closeTable $ \table3 -> do putStrLn . ("UnionDebt: "<>) . show =<< LSMT.remainingUnionDebt table3 :}-UnionDebt: 4+UnionDebt: 5 The worst-case disk I\/O complexity of this operation is \(O(0)\). @@ -2030,13 +2113,13 @@ putStrLn . ("UnionDebt: "<>) . show =<< LSMT.remainingUnionDebt table3 putStrLn . ("Leftovers: "<>) . show =<< LSMT.supplyUnionCredits table3 4 :}-UnionDebt: 4+UnionDebt: 5 Leftovers: 0-UnionDebt: 2+UnionDebt: 3 Leftovers: 3 __NOTE:__-The 'remainingUnionDebt' functions gets an /upper bound/ for the amount of remaning union debt.+The 'remainingUnionDebt' functions gets an /upper bound/ for the amount of remaining union debt. In the example above, the second call to 'remainingUnionDebt' reports @2@, but the union debt is @1@. Therefore, the second call to 'supplyUnionCredits' returns more leftovers than expected. @@ -2809,6 +2892,149 @@ m [SnapshotName] listSnapshots (Session session) = Internal.listSnapshots session+++{- |+Import a snapshot from an external directory.++The source directory should exist.+Snapshots should only be imported from a directory on the same volume as the session directory.++Importing does not not check whether the external directory is a snapshot, and+neither does importing verify the snapshot contents if it is a snapshot.+Open the snapshot to verify that it is a snapshot and that it is not corrupted.++The 'FsPath' path to the source directory is a relative path that is interpreted+relative to a /root/ (sometimes also called a mount point).+What the root is depends on which function was used to create the session.+See 'withOpenSession', 'withOpenSessionIO', and 'withOpenMountedSessionIO' for more+information about the root.++It is generally not advisable to use 'importSnapshot' and 'exportSnapshot' when the session is+created using 'withOpenSessionIO'.+Snapshots should only be exported to somewhere /outside/ the session directory, which is not possible+when the session is created using 'withOpenSessionIO'.+Use 'withOpenMountedSessionIO' or 'withOpenSession' instead.++>>> :{+runExample $ \session table -> do+ -- Save snapshot+ LSMT.insert table 0 "Hello" Nothing+ LSMT.insert table 1 "World" Nothing+ LSMT.saveSnapshot "example" "Key Value Blob" table+ -- Export then import snapshot+ let exportDir = mkFsPath ["export"]+ LSMT.exportSnapshot session "example" exportDir+ LSMT.importSnapshot session "example_new" exportDir+ -- Open the imported snapshot+ LSMT.withTableFromSnapshot @_ @_ @Value+ session "example_new" "Key Value Blob" $ \table' -> do+ print =<< LSMT.lookup table 0+ print =<< LSMT.lookup table 1+:}+Found (Value "Hello")+Found (Value "World")++The worst-case disk I\/O complexity of this operation depends on the merge policy of the table:++['LazyLevelling']:+ \(O(T \log_T \frac{n}{B})\).++Throws the following exceptions:++['SessionClosedError']:+ If the session is closed.+['SnapshotExistsError']:+ If a snapshot with the same name already exists.+['SnapshotImportDirDoesNotExistError']:+ If the source directory for the to-be-imported snapshot does not exist.+-}+{-# SPECIALISE+ importSnapshot ::+ Session IO ->+ SnapshotName ->+ FsPath ->+ IO ()+ #-}+importSnapshot ::+ forall m.+ (IOLike m) =>+ Session m ->+ SnapshotName ->+ -- | Source directory+ FsPath ->+ m ()+importSnapshot (Session session) =+ Internal.importSnapshot session++{- |+Export a snapshot to an external directory.++The destination directory should not exist already.+Snapshots should only be exported to a directory on the same volume as the session directory.++The 'FsPath' path to the destination directory is a relative path that is interpreted+relative to a /root/.+What the root is depends on which function was used to create the session.+See 'withOpenSession', 'withOpenSessionIO', and 'withOpenMountedSessionIO' for more+information about the root.++It is generally not advisable to use 'importSnapshot' and 'exportSnapshot' when the session is+created using 'withOpenSessionIO'.+Snapshots should only be exported to somewhere /outside/ the session directory, which is not possible+when the session is created using 'withOpenSessionIO'.+Use 'withOpenMountedSessionIO' or 'withOpenSession' instead.++>>> :{+runExample $ \session table -> do+ -- Save snapshot+ LSMT.insert table 0 "Hello" Nothing+ LSMT.insert table 1 "World" Nothing+ LSMT.saveSnapshot "example" "Key Value Blob" table+ -- Export then import snapshot+ let exportDir = mkFsPath ["export"]+ LSMT.exportSnapshot session "example" exportDir+ LSMT.importSnapshot session "example_new" exportDir+ -- Open the imported snapshot+ LSMT.withTableFromSnapshot @_ @_ @Value+ session "example_new" "Key Value Blob" $ \table' -> do+ print =<< LSMT.lookup table 0+ print =<< LSMT.lookup table 1+:}+Found (Value "Hello")+Found (Value "World")++The worst-case disk I\/O complexity of this operation depends on the merge policy of the table:++['LazyLevelling']:+ \(O(T \log_T \frac{n}{B})\).++Throws the following exceptions:++['SessionClosedError']:+ If the session is closed.+['SnapshotDoesNotExistError']:+ If no snapshot with the given name exists.+['SnapshotExportDirExistsError']:+ If the destination directory for the to-be-exported snapshot already exists.+-}+{-# SPECIALISE+ exportSnapshot ::+ Session IO ->+ SnapshotName ->+ FsPath ->+ IO ()+ #-}+exportSnapshot ::+ forall m.+ (IOLike m) =>+ Session m ->+ SnapshotName ->+ -- | Destination directory+ FsPath ->+ m ()+exportSnapshot (Session session) =+ Internal.exportSnapshot session -- | Internal helper. Get 'resolveSerialised' at type 'ResolveSerialisedValue'. _getResolveSerialisedValue ::
src/Database/LSMTree/Simple.hs view
@@ -186,6 +186,7 @@ import qualified Database.LSMTree.Internal.Types as LSMT import qualified Database.LSMTree.Internal.Unsafe as Internal import Prelude hiding (lookup, take, takeWhile)+import qualified System.FS.API as FS import System.FS.API (MountPoint (..), mkFsPath) import System.FS.BlockIO.API (HasBlockIO (..)) import System.FS.BlockIO.IO (defaultIOCtxParams, ioHasBlockIO)@@ -426,7 +427,7 @@ withOpenSession dir action = do let tracer = mempty _convertSessionDirErrors dir $- LSMT.withOpenSessionIO tracer dir (action . Session)+ LSMT.withOpenMountedSessionIO tracer dir (FS.mkFsPath []) (action . Session) {- | Open a session from a session directory.@@ -1140,8 +1141,15 @@ Table <$> LSMT.unions (coerce tables) {- |-Get the amount of remaining union debt.+Get an /upper bound/ for the amount of remaining union debt. This includes the union debt of any table that was part of the union's input.++The exact amount of debt returned for a given table is an implementation detail+and not guaranteed to be stable across versions of @lsm-tree@.+Within the same version, the union debt of a table can never increase. However,+it can get decreased by operations on /another/ table if these tables share part+of their internal structure (e.g. due to one being a union input or duplicate of+the other). The worst-case disk I\/O complexity of this operation is \(O(0)\). -}
test/Main.hs view
@@ -41,6 +41,7 @@ import qualified Test.Database.LSMTree.Internal.WriteBufferReader.FS import qualified Test.Database.LSMTree.Model.Table import qualified Test.Database.LSMTree.Resolve+import qualified Test.Database.LSMTree.Snapshots import qualified Test.Database.LSMTree.StateMachine import qualified Test.Database.LSMTree.StateMachine.DL import qualified Test.Database.LSMTree.Tracer.Golden@@ -90,6 +91,7 @@ , Test.Database.LSMTree.Internal.WriteBufferReader.FS.tests , Test.Database.LSMTree.Model.Table.tests , Test.Database.LSMTree.Resolve.tests+ , Test.Database.LSMTree.Snapshots.tests , Test.Database.LSMTree.StateMachine.tests , Test.Database.LSMTree.StateMachine.DL.tests , Test.Database.LSMTree.Tracer.Golden.tests
test/Test/Database/LSMTree/Internal/Snapshot/Codec.hs view
@@ -9,6 +9,8 @@ import Codec.CBOR.Write import Control.DeepSeq (NFData) import qualified Data.ByteString.Lazy as BSL+import qualified Data.List as List+import Data.Ord (comparing) import Data.Proxy import qualified Data.Text as Text import Data.Typeable@@ -29,7 +31,12 @@ tests :: TestTree tests = testGroup "Test.Database.LSMTree.Internal.Snapshot.Codec" [ testGroup "SnapshotVersion" [- testProperty "roundtripCBOR" $ roundtripCBOR (Proxy @SnapshotVersion)+ testProperty "lastVersionIsCurrent" $+ currentSnapshotVersion === last allCompatibleSnapshotVersions+ , testProperty "versionOrderingCorrect" $+ List.sort allCompatibleSnapshotVersions+ === List.sortBy (comparing show) allCompatibleSnapshotVersions+ , testProperty "roundtripCBOR" $ roundtripCBOR (Proxy @SnapshotVersion) , testProperty "roundtripFlatTerm" $ roundtripFlatTerm (Proxy @SnapshotVersion) ] , testGroup "Versioned SnapshotMetaData" [@@ -191,9 +198,10 @@ -------------------------------------------------------------------------------} instance Arbitrary SnapshotVersion where- arbitrary = elements [V0, V1]+ arbitrary = elements [V0, V1, V2] shrink V0 = [] shrink V1 = [V0]+ shrink V2 = [V0, V1] deriving newtype instance Arbitrary a => Arbitrary (Versioned a) @@ -288,7 +296,9 @@ instance Arbitrary r => Arbitrary (SnapLevel r) where arbitrary = SnapLevel <$> arbitrary <*> arbitraryShortVector- shrink (SnapLevel a b) = [SnapLevel a' b' | (a', b') <- shrink (a, b)]+ shrink SnapEmptyLevel = []+ shrink (SnapLevel a b) = SnapEmptyLevel+ : [SnapLevel a' b' | (a', b') <- shrink (a, b)] arbitraryShortVector :: Arbitrary a => Gen (V.Vector a) arbitraryShortVector = V.fromList <$> vectorOfUpTo 5 arbitrary
test/Test/Database/LSMTree/Internal/Snapshot/Codec/Golden.hs view
@@ -35,6 +35,7 @@ import System.FS.API.Types (MountPoint (..)) import System.FS.IO (ioHasFS) import System.IO.Unsafe+import Test.Database.LSMTree.Internal.Snapshot.Codec () import Test.QuickCheck (Property, counterexample, ioProperty, once, (.&&.)) import qualified Test.Tasty as Tasty@@ -54,6 +55,7 @@ ] , testGroup "Backwards compatibility" [ testCase "test_compatTableConfigV0" test_compatTableConfigV0+ , testCase "test_compatSnapLevelV1" test_compatSnapLevelV1 ] ] @@ -151,6 +153,13 @@ , confMergeBatchSize = MergeBatchSize magicNumber2 } +test_compatSnapLevelV1 :: Assertion+test_compatSnapLevelV1 =+ assertGoldenFileDecodesTo (Proxy @(SnapLevel SnapshotRun)) "A" V1 $+ -- Until V2, there was only a single constructor, so there was no tag+ -- in the serialisation format to distinguish constructors.+ SnapLevel (singGolden V1) (singGolden V1)+ -- | For types that changed their snapshot format between versions, we should -- also test that we can in fact still decode the old format. assertGoldenFileDecodesTo ::@@ -396,9 +405,14 @@ SnapLevels{} -> () instance EnumGolden (SnapLevel SnapshotRun) where- singGolden v = SnapLevel (singGolden v) (singGolden v)+ enumGolden v = [+ SnapLevel (singGolden v) (singGolden v)+ ] ++ [+ SnapEmptyLevel | v >= V2+ ] where _coveredAllCases = \case+ SnapEmptyLevel{} -> () SnapLevel{} -> () instance EnumGolden (SnapIncomingRun SnapshotRun) where
+ test/Test/Database/LSMTree/Snapshots.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.Database.LSMTree.Snapshots (tests) where++import Control.Tracer (nullTracer)+import Data.Monoid (Sum (Sum))+import qualified Data.Vector as V+import Data.Void (Void)+import Data.Word (Word64)+import Database.LSMTree (ResolveValue, Salt, SerialiseKey,+ SerialiseValue, Table, TableConfig (confWriteBufferAlloc),+ WriteBufferAlloc (AllocNumEntries), defaultTableConfig,+ exportSnapshot, getValue, importSnapshot, inserts, lookups,+ saveSnapshot, withOpenSession, withTableFromSnapshot,+ withTableWith)++import Database.LSMTree.Extras (showRangesOf)+import qualified System.FS.API as FS+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.QuickCheck (Arbitrary, Property, Small (Small),+ checkCoverage, ioProperty, tabulate, testProperty, (===))+import Test.Util.FS (withTempIOHasBlockIO)++tests :: TestTree+tests = testGroup "Test.Database.LSMTree.Snapshots" [+ testProperty "prop_exportImportSnapshot" prop_exportImportSnapshot+ ]++{-------------------------------------------------------------------------------+ Snapshot import and export+-------------------------------------------------------------------------------}++newtype Key = Key Word64+ deriving stock (Show, Eq, Ord)+ deriving newtype SerialiseKey+ deriving Arbitrary via Small Word64++newtype Value = Value Word64+ deriving stock (Show, Eq)+ deriving newtype (SerialiseValue)+ deriving ResolveValue via Sum Word64+ deriving Arbitrary via Small Word64++-- | Tables opened from imported snapshots behave the same as the original table+-- that the snapshot was created for.+--+-- We test this by looking at the observable behaviour of the two tables. If+-- lookups on both tables produce the same result, then they are logically+-- equivalent.+--+-- Moreover, if importing or exporting were to corrupt the snapshots, then+-- opening the snapshot would throw an error, which this test would catch.+prop_exportImportSnapshot ::+ V.Vector (Key, Value)+ -> V.Vector Key+ -> Property+prop_exportImportSnapshot ins los =+ checkCoverage $+ ioProperty $+ withTempIOHasBlockIO "prop_exportImportSnapshot" $ \hfs hbio -> do+ FS.createDirectoryIfMissing hfs True sessionDir++ -- Open a session and create a snapshot for some arbitrary table contents+ withOpenSession nullTracer hfs hbio salt sessionDir $ \session ->+ withTableWith conf session $ \(table1 :: Table IO Key Value Void) -> do+ inserts table1 $ V.map (\(k, v) -> (k, v, Nothing)) ins+ saveSnapshot "snap1" "KeyValueBlob" table1++ -- Export then re-import the snapshot+ exportSnapshot session "snap1" exportDir+ importSnapshot session "snap2" exportDir++ -- Open a table from the re-imported snapshot. Any corruption of the+ -- snapshot would be identified here.+ withTableFromSnapshot session "snap2" "KeyValueBlob" $ \(table2 :: Table IO Key Value Void) -> do++ -- Check that lookups on both the original and re-imported table+ -- match+ lrs1 <- V.map getValue <$> lookups table1 los+ lrs2 <- V.map getValue <$> lookups table2 los++ pure $+ tabulate "# of physical table entries" [ showRangesOf 5 $ V.length ins ] $+ tabulate "# of lookups" [ showRangesOf 5 $ V.length los ] $+ tabulate "# of successful lookups" [ showRangesOf 5 $ V.length $ V.catMaybes lrs1 ] $+ tabulate "# of unsuccessful lookups" [ showRangesOf 5 $ V.length $ V.filter (==Nothing) lrs1 ] $+ lrs1 === lrs2+ where+ sessionDir = FS.mkFsPath ["session"]++ -- | Directory for storing exported snapshots+ exportDir = FS.mkFsPath ["export"]++ salt :: Salt+ salt = 17++ conf :: TableConfig+ conf = defaultTableConfig {+ confWriteBufferAlloc = AllocNumEntries 3+ }
test/Test/Database/LSMTree/Tracer/Golden.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} @@ -8,6 +9,7 @@ import Control.Tracer import qualified Data.List.NonEmpty as NE import Data.Monoid (Sum (..))+import qualified Data.Vector as V import Data.Word import Database.LSMTree as R import Paths_lsm_tree@@ -18,6 +20,7 @@ import System.IO.Unsafe import Test.Tasty (TestTree, localOption, testGroup) import Test.Tasty.Golden+import qualified Test.Tasty.HUnit as HU import Test.Util.FS (withTempIOHasBlockIO) @@ -25,23 +28,41 @@ tests = localOption OnPass $ testGroup "Test.Database.LSMTree.Tracer.Golden" [- goldenVsFile- "golden_traceMessages"- goldenDataFile- dataFile- (golden_traceMessages dataFile)+ testTraceMessages Debug+ , testTraceMessages Release ]+ where+ testTraceMessages :: BuildType -> TestTree+ testTraceMessages buildType =+ if buildType == currentBuildType+ then goldenVsFile testName goldenFile file (golden_traceMessages file)+ else HU.testCaseInfo testName (pure "Skipped")+ where+ testName = "golden_traceMessages (" ++ show buildType ++ ")"+ file = dataFile buildType+ goldenFile = goldenDataFile buildType ++data BuildType = Debug | Release+ deriving stock (Eq, Show)++currentBuildType :: BuildType+#ifdef NO_IGNORE_ASSERTS+currentBuildType = Debug+#else+currentBuildType = Release+#endif+ goldenDataDirectory :: FilePath goldenDataDirectory = unsafePerformIO getDataDir </> "tracer" -- | Path to the /golden/ file for 'golden_traceMessages'-goldenDataFile :: FilePath-goldenDataFile = dataFile <.> "golden"+goldenDataFile :: BuildType -> FilePath+goldenDataFile buildType = dataFile buildType <.> "golden" -- | Path to the output file for 'golden_traceMessages'-dataFile :: FilePath-dataFile = goldenDataDirectory </> "golden_traceMessages"+dataFile :: BuildType -> FilePath+dataFile buildType = goldenDataDirectory </> "golden_traceMessages" ++ show buildType -- | A monadic action that traces messages emitted by the public API of -- @lsm-tree@ to a file.@@ -67,13 +88,18 @@ -- Open and close a session withOpenSession tr hfs hbio 4 sessionPath $ \s -> do -- Open and close a table- withTable s $ \(t1 :: Table IO K V B) -> do+ withTableWith tableConfig s $ \(t1 :: Table IO K V B) -> do -- Try out all the update variants update t1 (K 0) (Insert (V 0) Nothing) insert t1 (K 1) (V 1) (Just (B 1)) delete t1 (K 2) upsert t1 (K 3) (V 3) + -- Do a bigger update to trigger a merge+ let numInserts = fromIntegral (writeBufferSize * (sizeRatioInt + 1))+ inserts t1 $ V.fromList $+ [(K n, V n, Nothing) | n <- [4 .. numInserts+4]]+ -- Perform a lookup and its member variant FoundWithBlob (V 1) bref <- lookup t1 (K 1) void $ member t1 (K 2)@@ -126,10 +152,26 @@ pure () +tableConfig :: TableConfig+tableConfig =+ defaultTableConfig {+ confSizeRatio = sizeRatio+ , confWriteBufferAlloc = AllocNumEntries writeBufferSize+ , confMergeBatchSize = MergeBatchSize writeBufferSize+ }++sizeRatioInt :: Int+sizeRatioInt = 4++sizeRatio :: SizeRatio+sizeRatio = Four++writeBufferSize :: Int+writeBufferSize = 1000 -- little less than by default, no need to do much work+ -- | A tracer that emits trace messages to a file handle fileHandleTracer :: IO.Handle -> Tracer IO String fileHandleTracer h = Tracer $ emit (IO.hPutStrLn h)- -- | A tracer that emits trace messages to a binary file withBinaryFileTracer :: FilePath -> (Tracer IO String -> IO a) -> IO a
test/Test/Database/LSMTree/UnitTests.hs view
@@ -37,6 +37,7 @@ , testCase "unit_union_credits" unit_union_credits , testCase "unit_union_credit_0" unit_union_credit_0 , testCase "unit_union_blobref_invalidation" unit_union_blobref_invalidation+ , testCase "unit_union_complete_via_sharing" unit_union_complete_via_sharing ] testSalt :: R.Salt@@ -204,7 +205,7 @@ withTable @_ @Key1 @Value1 @Blob1 sess $ \table -> do inserts table [(Key1 17, Value1 42, Nothing)] - bracket (table `union` table) closeTable $ \table' -> do+ bracket (table `incrementalUnion` table) closeTable $ \table' -> do -- Supplying 0 credits works and returns 0 leftovers. UnionCredits leftover <- supplyUnionCredits table' (UnionCredits 0) leftover @?= 0@@ -226,7 +227,7 @@ t1 <- newTableWith @_ @Key1 @Value1 @Blob1 config sess for_ ([0..99] :: [Word64]) $ \i -> inserts t1 [(Key1 i, Value1 i, Just (Blob1 i))]- t2 <- t1 `union` t1+ t2 <- t1 `incrementalUnion` t1 -- do lookups on the union table (the result contains blob refs) res <- lookups t2 (Key1 <$> [0..99])@@ -245,6 +246,56 @@ confWriteBufferAlloc = AllocNumEntries 4 } +-- | Paying off union debt in one table can complete the merging tree of another+-- table through sharing. However, the other table's debt still remains at 1+-- until the union is migrated. Flushing the writebuffer will then migrate the+-- union (which is useful in case the union run can become part of a new merge).+unit_union_complete_via_sharing :: Assertion+unit_union_complete_via_sharing =+ withTempIOHasBlockIO "test" $ \hfs hbio ->+ withOpenSession nullTracer hfs hbio testSalt (FS.mkFsPath []) $ \sess -> do+ t1 <- newTableWith @_ @Key1 @Value1 @Blob1 config sess+ let size1 = 50+ inserts t1 $ V.fromList+ [(Key1 i, Value1 i, Just (Blob1 i)) | i <- [1 .. fromIntegral size1]]++ t2 <- t1 `incrementalUnion` t1++ -- Initially, there is significant union debt (conservative lower bound).+ assertUnionDebt t2 (@>= UnionDebt (2 * size1))++ -- Create a new table that shares the merging tree. Instead of duplicating+ -- we could also have created a new union with t2 as an input.+ t3 <- duplicate t2+ payOffUnionDebt t3++ -- Through sharing, we indirectly completed the merging tree in t2, too.+ -- However, there remains a union level, so the debt is 1.+ assertUnionDebt t2 (@?= UnionDebt 1)++ -- Trigger a writebuffer flush.+ inserts t2 (V.fromList [(Key1 i, Value1 i, Nothing) | i <- [0..4]])++ -- Because of the flush, the union level got migrated.+ assertUnionDebt t2 (@?= UnionDebt 0)++ closeTable t1+ closeTable t2+ closeTable t3+ where+ config = defaultTableConfig {+ confWriteBufferAlloc = AllocNumEntries 4+ }++ assertUnionDebt t p = do+ debt <- remainingUnionDebt t+ p debt++ payOffUnionDebt t = do+ UnionDebt debt <- remainingUnionDebt t+ _ <- supplyUnionCredits t (UnionCredits debt)+ pure ()+ ignoreBlobRef :: Functor f => f (BlobRef m b) -> f () ignoreBlobRef = fmap (const ()) @@ -252,6 +303,9 @@ assertException e assertion = do r <- try assertion r @?= Left e++(@>=) :: (HasCallStack, Ord a, Show a) => a -> a -> Assertion+x @>= y = (x >= y) @? ("expected: " ++ show x ++ " >= " ++ show y) {------------------------------------------------------------------------------- Key and value types
test/Test/Util/FS.hs view
@@ -55,7 +55,7 @@ import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (assert) import Control.Monad (void)-import Control.Monad.Class.MonadThrow (MonadCatch, MonadThrow)+import Control.Monad.Class.MonadThrow (MonadMask, MonadThrow) import Control.Monad.IOSim (runSimOrThrow) import Control.Monad.Primitive (PrimMonad) import Data.Bit (MVector (..), flipBit)@@ -108,7 +108,7 @@ {-# INLINABLE withSimHasFS #-} withSimHasFS ::- (MonadSTM m, MonadThrow m, PrimMonad m, Testable prop1, Testable prop2)+ (MonadSTM m, MonadMask m, PrimMonad m, Testable prop1, Testable prop2) => (MockFS -> prop1) -> MockFS -> ( HasFS m HandleMock@@ -125,7 +125,7 @@ {-# INLINABLE withSimHasBlockIO #-} withSimHasBlockIO ::- (MonadMVar m, MonadSTM m, MonadCatch m, PrimMonad m, Testable prop1, Testable prop2)+ (MonadMVar m, MonadSTM m, MonadMask m, PrimMonad m, Testable prop1, Testable prop2) => (MockFS -> prop1) -> MockFS -> ( HasFS m HandleMock@@ -145,7 +145,7 @@ {-# INLINABLE withSimErrorHasFS #-} withSimErrorHasFS ::- (MonadSTM m, MonadThrow m, PrimMonad m, Testable prop1, Testable prop2)+ (MonadSTM m, MonadMask m, PrimMonad m, Testable prop1, Testable prop2) => (MockFS -> prop1) -> MockFS -> Errors@@ -165,7 +165,7 @@ {-# INLINABLE withSimErrorHasBlockIO #-} withSimErrorHasBlockIO ::- ( MonadSTM m, MonadCatch m, MonadMVar m, PrimMonad m+ ( MonadSTM m, MonadMask m, MonadMVar m, PrimMonad m , Testable prop1, Testable prop2 ) => (MockFS -> prop1)
test/Test/Util/FS/Error.hs view
@@ -107,7 +107,7 @@ -- | Like 'simErrorHasFSLogged', but also produces a simulated 'HasBlockIO'. simErrorHasBlockIOLogged ::- forall m. (MonadCatch m, MonadMVar m, PrimMonad m, MonadSTM m)+ forall m. (MonadMask m, MonadMVar m, PrimMonad m, MonadSTM m) => StrictTMVar m MockFS -> StrictTVar m Errors -> StrictTVar m (HKD [])@@ -123,7 +123,7 @@ -- Every time a 'HasFS' primitive is used and an error from 'Errors' is used, it -- will be logged in 'ErrorsLog'. simErrorHasFSLogged ::- forall m. (MonadSTM m, MonadThrow m, PrimMonad m)+ forall m. (MonadSTM m, MonadMask m, PrimMonad m) => StrictTMVar m MockFS -> StrictTVar m Errors -> StrictTVar m ErrorsLog