From 93384cc3f4308481bb8ec0d00095389b4ab15d46 Mon Sep 17 00:00:00 2001 From: Wen Kokke Date: Fri, 28 Mar 2025 15:42:11 +0000 Subject: [PATCH] fix: restructure TableNotCompatibleError to TableUnionNotCompatibleError --- src/Database/LSMTree.hs | 7 +- src/Database/LSMTree/Common.hs | 2 +- src/Database/LSMTree/Internal.hs | 89 +++++++++++----------- src/Database/LSMTree/Monoidal.hs | 8 +- src/Database/LSMTree/Normal.hs | 7 +- test/Database/LSMTree/Model/Session.hs | 4 +- test/Test/Database/LSMTree/StateMachine.hs | 15 ++-- 7 files changed, 66 insertions(+), 66 deletions(-) diff --git a/src/Database/LSMTree.hs b/src/Database/LSMTree.hs index 99392670e..50a0e39ca 100644 --- a/src/Database/LSMTree.hs +++ b/src/Database/LSMTree.hs @@ -16,7 +16,7 @@ module Database.LSMTree ( , Common.TableClosedError (..) , Common.TableCorruptedError (..) , Common.TableTooLargeError (..) - , Common.TableNotCompatibleError (..) + , Common.TableUnionNotCompatibleError (..) , Common.SnapshotExistsError (..) , Common.SnapshotDoesNotExistError (..) , Common.SnapshotCorruptedError (..) @@ -129,7 +129,8 @@ import Data.Bifunctor (Bifunctor (..)) import Data.Coerce (coerce) import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty (..)) -import Data.Typeable (Proxy (..), Typeable, eqT, type (:~:) (Refl)) +import Data.Typeable (Proxy (..), Typeable, eqT, type (:~:) (Refl), + typeRep) import qualified Data.Vector as V import Database.LSMTree.Common (BlobRef (BlobRef), IOLike, Range (..), SerialiseKey, SerialiseValue, Session, UnionCredits (..), @@ -570,7 +571,7 @@ unions (t :| ts) = -> m (Internal.Table m h) checkTableType _ i (Internal.Table' (t' :: Internal.Table m h')) | Just Refl <- eqT @h @h' = pure t' - | otherwise = throwIO (Common.ErrTableTypeMismatch 0 i) + | otherwise = throwIO $ Common.ErrTableUnionHandleTypeMismatch 0 (typeRep $ Proxy @h) i (typeRep $ Proxy @h') {-# SPECIALISE remainingUnionDebt :: Table IO k v b -> IO UnionDebt #-} remainingUnionDebt :: IOLike m => Table m k v b -> m UnionDebt diff --git a/src/Database/LSMTree/Common.hs b/src/Database/LSMTree/Common.hs index f287b6a09..a45a7556e 100644 --- a/src/Database/LSMTree/Common.hs +++ b/src/Database/LSMTree/Common.hs @@ -9,7 +9,7 @@ module Database.LSMTree.Common ( , Internal.TableClosedError (..) , Internal.TableCorruptedError (..) , Internal.TableTooLargeError (..) - , Internal.TableNotCompatibleError (..) + , Internal.TableUnionNotCompatibleError (..) , Internal.SnapshotExistsError (..) , Internal.SnapshotDoesNotExistError (..) , Internal.SnapshotCorruptedError (..) diff --git a/src/Database/LSMTree/Internal.hs b/src/Database/LSMTree/Internal.hs index 2ae8b5e46..b1431e53c 100644 --- a/src/Database/LSMTree/Internal.hs +++ b/src/Database/LSMTree/Internal.hs @@ -28,7 +28,7 @@ module Database.LSMTree.Internal ( , TableClosedError (..) , TableCorruptedError (..) , TableTooLargeError (..) - , TableNotCompatibleError (..) + , TableUnionNotCompatibleError (..) , SnapshotExistsError (..) , SnapshotDoesNotExistError (..) , SnapshotCorruptedError (..) @@ -1534,27 +1534,30 @@ duplicate t@Table{..} = do tableArenaManager content - {------------------------------------------------------------------------------- Table union -------------------------------------------------------------------------------} --- | An operation was called with two tables that are not compatible. -data TableNotCompatibleError - = -- | An operation was called with two tables that are not of the same type. - -- - -- TODO: This error is no longer used by 'unions'. - ErrTableTypeMismatch - -- | Vector index of table @t1@ involved in the mismatch - Int - -- | Vector index of table @t2@ involved in the mismatch - Int - | -- | An operation was called with two tables that are not in the same session. - ErrTableSessionMismatch - -- | Vector index of table @t1@ involved in the mismatch - Int - -- | Vector index of table @t2@ involved in the mismatch - Int +-- | A table union was constructed with two tables that are not compatible. +data TableUnionNotCompatibleError + = ErrTableUnionHandleTypeMismatch + -- | The index of the first table. + !Int + -- | The type of the filesystem handle of the first table. + !TypeRep + -- | The index of the second table. + !Int + -- | The type of the filesystem handle of the second table. + !TypeRep + | ErrTableUnionSessionMismatch + -- | The index of the first table. + !Int + -- | The session directory of the first table. + !FsErrorPath + -- | The index of the second table. + !Int + -- | The session directory of the second table. + !FsErrorPath deriving stock (Show, Eq) deriving anyclass (Exception) @@ -1565,10 +1568,7 @@ unions :: => NonEmpty (Table m h) -> m (Table m h) unions ts = do - sesh <- - matchSessions ts >>= \case - Left (i, j) -> throwIO $ ErrTableSessionMismatch i j - Right sesh -> pure sesh + sesh <- ensureSessionsMatch ts traceWith (sessionTracer sesh) $ TraceUnions (NE.map tableId ts) @@ -1706,37 +1706,34 @@ writeBufferToNewRun SessionEnv { tableWriteBuffer tableWriteBufferBlobs --- | Check that all tables in the session match. If so, return the matched --- session. If there is a mismatch, return the list indices of the mismatching --- tables. --- --- TODO: compare LockFileHandle instead of SessionRoot (?). We can write an Eq --- instance for LockFileHandle based on pointer equality, just like base does --- for Handle. -matchSessions :: +{-# SPECIALISE ensureSessionsMatch :: + NonEmpty (Table IO h) + -> IO (Session IO h) #-} +-- | Check if all tables have the same session. +-- If so, return the session. +-- Otherwise, throw a 'TableUnionNotCompatibleError'. +ensureSessionsMatch :: (MonadSTM m, MonadThrow m) => NonEmpty (Table m h) - -> m (Either (Int, Int) (Session m h)) -matchSessions = \(t :| ts) -> - withSessionRoot t $ \root -> do - eith <- go root 1 ts - pure $ case eith of - Left i -> Left (0, i) - Right () -> Right (tableSession t) - where + -> m (Session m h) +ensureSessionsMatch (t :| ts) = do + let sesh = tableSession t + withOpenSession sesh $ \seshEnv -> do + let root = FS.mkFsErrorPath (sessionHasFS seshEnv) (getSessionRoot (sessionRoot seshEnv)) -- Check that the session roots for all tables are the same. There can only -- be one *open/active* session per directory because of cooperative file -- locks, so each unique *open* session has a unique session root. We check -- that all the table's sessions are open at the same time while comparing -- the session roots. - go _ _ [] = pure (Right ()) - go root !i (t':ts') = - withSessionRoot t' $ \root' -> - if root == root' - then go root (i+1) ts' - else pure (Left i) - - withSessionRoot t k = withOpenSession (tableSession t) $ k . sessionRoot + for_ (zip [1..] ts) $ \(i, t') -> do + let sesh' = tableSession t' + withOpenSession sesh' $ \seshEnv' -> do + let root' = FS.mkFsErrorPath (sessionHasFS seshEnv') (getSessionRoot (sessionRoot seshEnv')) + -- TODO: compare LockFileHandle instead of SessionRoot (?). + -- We can write an Eq instance for LockFileHandle based on pointer equality, + -- just like base does for Handle. + unless (root == root') $ throwIO $ ErrTableUnionSessionMismatch 0 root i root' + pure sesh {------------------------------------------------------------------------------- Table union: debt and credit diff --git a/src/Database/LSMTree/Monoidal.hs b/src/Database/LSMTree/Monoidal.hs index 6666c5b34..5e28fdcd7 100644 --- a/src/Database/LSMTree/Monoidal.hs +++ b/src/Database/LSMTree/Monoidal.hs @@ -31,7 +31,7 @@ module Database.LSMTree.Monoidal ( , Common.TableClosedError (..) , Common.TableCorruptedError (..) , Common.TableTooLargeError (..) - , Common.TableNotCompatibleError (..) + , Common.TableUnionNotCompatibleError (..) , Common.SnapshotExistsError (..) , Common.SnapshotDoesNotExistError (..) , Common.SnapshotCorruptedError (..) @@ -149,8 +149,8 @@ import Data.Coerce (coerce) import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty (..)) import Data.Monoid (Sum (..)) -import Data.Proxy (Proxy (Proxy)) -import Data.Typeable (Typeable, eqT, type (:~:) (Refl)) +import Data.Typeable (Proxy (..), Typeable, eqT, type (:~:) (Refl), + typeRep) import qualified Data.Vector as V import Database.LSMTree.Common (IOLike, Range (..), SerialiseKey, SerialiseValue (..), Session, UnionCredits (..), @@ -719,7 +719,7 @@ unions (t :| ts) = -> m (Internal.Table m h) checkTableType _ i (Internal.MonoidalTable (t' :: Internal.Table m h')) | Just Refl <- eqT @h @h' = pure t' - | otherwise = throwIO (Common.ErrTableTypeMismatch 0 i) + | otherwise = throwIO $ Common.ErrTableUnionHandleTypeMismatch 0 (typeRep $ Proxy @h) i (typeRep $ Proxy @h') {-# SPECIALISE remainingUnionDebt :: Table IO k v -> IO UnionDebt #-} -- | Return the current union debt. This debt can be reduced until it is paid diff --git a/src/Database/LSMTree/Normal.hs b/src/Database/LSMTree/Normal.hs index be2a38a83..a8a5767a6 100644 --- a/src/Database/LSMTree/Normal.hs +++ b/src/Database/LSMTree/Normal.hs @@ -30,7 +30,7 @@ module Database.LSMTree.Normal ( , Common.TableClosedError (..) , Common.TableCorruptedError (..) , Common.TableTooLargeError (..) - , Common.TableNotCompatibleError (..) + , Common.TableUnionNotCompatibleError (..) , Common.SnapshotExistsError (..) , Common.SnapshotDoesNotExistError (..) , Common.SnapshotCorruptedError (..) @@ -140,7 +140,8 @@ import Control.Monad.Class.MonadThrow import Data.Bifunctor (Bifunctor (..)) import Data.Kind (Type) import Data.List.NonEmpty (NonEmpty (..)) -import Data.Typeable (Typeable, eqT, type (:~:) (Refl)) +import Data.Typeable (Proxy (..), Typeable, eqT, type (:~:) (Refl), + typeRep) import qualified Data.Vector as V import Database.LSMTree.Common (BlobRef (BlobRef), IOLike, Range (..), SerialiseKey, SerialiseValue, Session, UnionCredits (..), @@ -839,7 +840,7 @@ unions (t :| ts) = -> m (Internal.Table m h) checkTableType _ i (Internal.NormalTable (t' :: Internal.Table m h')) | Just Refl <- eqT @h @h' = pure t' - | otherwise = throwIO (Common.ErrTableTypeMismatch 0 i) + | otherwise = throwIO $ Common.ErrTableUnionHandleTypeMismatch 0 (typeRep $ Proxy @h) i (typeRep $ Proxy @h') {-# SPECIALISE remainingUnionDebt :: Table IO k v b -> IO UnionDebt #-} -- | Return the current union debt. This debt can be reduced until it is paid diff --git a/test/Database/LSMTree/Model/Session.hs b/test/Database/LSMTree/Model/Session.hs index 08a4fff20..5da1cb344 100644 --- a/test/Database/LSMTree/Model/Session.hs +++ b/test/Database/LSMTree/Model/Session.hs @@ -267,8 +267,8 @@ data Err | ErrSessionClosed | ErrTableClosed | ErrTableCorrupted - | ErrTableTypeMismatch - | ErrTableSessionMismatch + | ErrTableUnionHandleTypeMismatch + | ErrTableUnionSessionMismatch | ErrSnapshotExists !SnapshotName | ErrSnapshotDoesNotExist !SnapshotName | ErrSnapshotCorrupted !SnapshotName diff --git a/test/Test/Database/LSMTree/StateMachine.hs b/test/Test/Database/LSMTree/StateMachine.hs index 86378e292..8b5852819 100644 --- a/test/Test/Database/LSMTree/StateMachine.hs +++ b/test/Test/Database/LSMTree/StateMachine.hs @@ -94,7 +94,8 @@ import Database.LSMTree.Common (BlobRefInvalidError (..), SessionDirLockedError (..), SnapshotCorruptedError (..), SnapshotDoesNotExistError (..), SnapshotExistsError (..), SnapshotNotCompatibleError (..), TableClosedError (..), - TableCorruptedError (..), TableNotCompatibleError (..)) + TableCorruptedError (..), + TableUnionNotCompatibleError (..)) import Database.LSMTree.Extras (showPowersOf) import Database.LSMTree.Extras.Generators (KeyForIndexCompact) import Database.LSMTree.Extras.NoThunks (propNoThunks) @@ -483,7 +484,7 @@ handleSomeException e = , handleSessionClosedError <$> fromException e , handleTableClosedError <$> fromException e , handleTableCorruptedError <$> fromException e - , handleTableNotCompatibleError <$> fromException e + , handleTableUnionNotCompatibleError <$> fromException e , handleSnapshotExistsError <$> fromException e , handleSnapshotDoesNotExistError <$> fromException e , handleSnapshotCorruptedError <$> fromException e @@ -528,12 +529,12 @@ handleTableClosedError = \case handleTableCorruptedError :: TableCorruptedError -> Model.Err handleTableCorruptedError = \case - ErrLookupByteCountDiscrepancy _ _ -> Model.ErrTableCorrupted + ErrLookupByteCountDiscrepancy{} -> Model.ErrTableCorrupted -handleTableNotCompatibleError :: TableNotCompatibleError -> Model.Err -handleTableNotCompatibleError = \case - ErrTableTypeMismatch _ _ -> Model.ErrTableTypeMismatch - ErrTableSessionMismatch _ _ -> Model.ErrTableSessionMismatch +handleTableUnionNotCompatibleError :: TableUnionNotCompatibleError -> Model.Err +handleTableUnionNotCompatibleError = \case + ErrTableUnionHandleTypeMismatch{} -> Model.ErrTableUnionHandleTypeMismatch + ErrTableUnionSessionMismatch{} -> Model.ErrTableUnionSessionMismatch handleSnapshotExistsError :: SnapshotExistsError -> Model.Err handleSnapshotExistsError = \case