diff --git a/src/Database/LSMTree.hs b/src/Database/LSMTree.hs index 25495f1f5..4b2fb4eac 100644 --- a/src/Database/LSMTree.hs +++ b/src/Database/LSMTree.hs @@ -24,7 +24,6 @@ module Database.LSMTree ( withNewSession, withRestoreSession, openSession, - openSessionIO, newSession, restoreSession, closeSession, @@ -275,7 +274,7 @@ import qualified Database.LSMTree.Internal.Unsafe as Internal import Prelude hiding (lookup, take, takeWhile) import System.FS.API (FsPath, HasFS (..), MountPoint (..), mkFsPath) import System.FS.BlockIO.API (HasBlockIO (..), defaultIOCtxParams) -import System.FS.BlockIO.IO (ioHasBlockIO, withIOHasBlockIO) +import System.FS.BlockIO.IO (withIOHasBlockIO) import System.FS.IO (HandleIO, ioHasFS) import System.Random (randomIO) @@ -622,22 +621,6 @@ openSession :: openSession tracer hasFS hasBlockIO sessionSalt sessionDir = Session <$> Internal.openSession tracer hasFS hasBlockIO sessionSalt sessionDir --- | Variant of 'openSession' that is specialised to 'IO' using the real filesystem. -openSessionIO :: - Tracer IO LSMTreeTrace -> - -- | The session directory. - FilePath -> - IO (Session IO) -openSessionIO tracer sessionDir = do - let mountPoint = MountPoint sessionDir - let sessionDirFsPath = mkFsPath [] - let hasFS = ioHasFS mountPoint - sessionSalt <- randomIO - let acquireHasBlockIO = ioHasBlockIO hasFS defaultIOCtxParams - let releaseHasBlockIO HasBlockIO{close} = close - bracketOnError acquireHasBlockIO releaseHasBlockIO $ \hasBlockIO -> - openSession tracer hasFS hasBlockIO sessionSalt sessionDirFsPath - {- | Create a new session. diff --git a/src/Database/LSMTree/Simple.hs b/src/Database/LSMTree/Simple.hs index 403760885..4978fae42 100644 --- a/src/Database/LSMTree/Simple.hs +++ b/src/Database/LSMTree/Simple.hs @@ -157,7 +157,8 @@ module Database.LSMTree.Simple ( ) where import Control.ActionRegistry (mapExceptionWithActionRegistry) -import Control.Exception.Base (Exception, SomeException (..)) +import Control.Exception (Exception, SomeException (..), + bracketOnError, finally) import Data.Bifunctor (Bifunctor (..)) import Data.Coerce (coerce) import Data.Kind (Type) @@ -185,7 +186,14 @@ import Database.LSMTree (BloomFilterAlloc, CursorClosedError (..), serialiseValueIdentity, serialiseValueIdentityUpToSlicing, toSnapshotName) import qualified Database.LSMTree as LSMT +import qualified Database.LSMTree.Internal.Types as LSMT +import qualified Database.LSMTree.Internal.Unsafe as Internal import Prelude hiding (lookup, take, takeWhile) +import System.FS.API (MountPoint (..), mkFsPath) +import System.FS.BlockIO.API (HasBlockIO (..), defaultIOCtxParams) +import System.FS.BlockIO.IO (ioHasBlockIO) +import System.FS.IO (ioHasFS) +import System.Random (randomIO) -------------------------------------------------------------------------------- -- Example @@ -450,7 +458,14 @@ openSession :: openSession dir = do let tracer = mempty _convertSessionDirErrors dir $ do - Session <$> LSMT.openSessionIO tracer dir + let mountPoint = MountPoint dir + let sessionDirFsPath = mkFsPath [] + let hasFS = ioHasFS mountPoint + sessionSalt <- randomIO + let acquireHasBlockIO = ioHasBlockIO hasFS defaultIOCtxParams + let releaseHasBlockIO HasBlockIO{close} = close + bracketOnError acquireHasBlockIO releaseHasBlockIO $ \hasBlockIO -> + Session <$> LSMT.openSession tracer hasFS hasBlockIO sessionSalt sessionDirFsPath {- | Close a session. @@ -471,8 +486,10 @@ All other operations on a closed session will throw an exception. closeSession :: Session -> IO () -closeSession (Session session) = - LSMT.closeSession session +closeSession (Session session@(LSMT.Session session')) = do + HasBlockIO{close} <- Internal.withKeepSessionOpen session' $ + pure . Internal.sessionHasBlockIO + LSMT.closeSession session `finally` close -------------------------------------------------------------------------------- -- Tables