From 1535a6a472203aca9df8e2fb11484688a4b6f274 Mon Sep 17 00:00:00 2001 From: Duncan Coutts Date: Tue, 17 Sep 2024 10:17:03 +0100 Subject: [PATCH] Enable Blobs in many tests, including StateMachine tests Only one fix in the code is needed, for the NoThunks test. The state machine test found two non-trivial differences between the spec and the model in relation to blobs: 1. blob retrieval after snapshot fails 2. blob retrieval after failed-snapshot (due to duplicate name) fails The reason for both of these is that the implementation currently works by modifying flushing the write buffer to disk, and modifing the table handle to use the updated set of runs and now-empty write buffer. This invalidates all blob references from the write buffer itself. For the moment I have "fixed" this difference by changing the model to behave like the implementation. For the TODO task to fix this, see https://github.com/IntersectMBO/lsm-tree/issues/392 --- .../LSMTree/Internal/WriteBufferBlobs.hs | 2 +- test/Database/LSMTree/Class/Normal.hs | 10 ++-------- test/Database/LSMTree/Model/Normal/Session.hs | 13 +++++++++++- test/Test/Database/LSMTree/Class/Normal.hs | 15 +++++++------- .../Database/LSMTree/Normal/StateMachine.hs | 20 ++++++++++--------- 5 files changed, 34 insertions(+), 26 deletions(-) diff --git a/src/Database/LSMTree/Internal/WriteBufferBlobs.hs b/src/Database/LSMTree/Internal/WriteBufferBlobs.hs index d867ec5a4..8519b37e9 100644 --- a/src/Database/LSMTree/Internal/WriteBufferBlobs.hs +++ b/src/Database/LSMTree/Internal/WriteBufferBlobs.hs @@ -170,7 +170,7 @@ addBlob fs WriteBufferBlobs {blobFileName, blobFileState} blob = do -- we can also be asked to retrieve blobs at any time. blobFileHandle <- FS.hOpen fs blobFileName (FS.ReadWriteMode FS.MustBeNew) blobFilePointer <- newFilePointer - P.writeMutVar blobFileState OpenBlobFile { + P.writeMutVar blobFileState $! OpenBlobFile { blobFileHandle, blobFilePointer } diff --git a/test/Database/LSMTree/Class/Normal.hs b/test/Database/LSMTree/Class/Normal.hs index c518350b5..8156b5a7d 100644 --- a/test/Database/LSMTree/Class/Normal.hs +++ b/test/Database/LSMTree/Class/Normal.hs @@ -245,14 +245,8 @@ instance IsTableHandle R.TableHandle where new = R.new close = R.close lookups = flip R.lookups - -- TODO: This is temporary, because it will otherwise make class tests fail. - -- Allow updates with blobs once blob retrieval is implemented. - updates th upds = flip R.updates th $ flip V.map upds $ \case - (k, R.Insert v _) -> (k, R.Insert v Nothing) - upd -> upd - -- TODO: This is temporary, because it will otherwise make class tests fail. - -- Allow inserts with blobs once blob retrieval is implemented. - inserts th ins = flip R.inserts th $ flip V.map ins $ \(k, v, _) -> (k, v, Nothing) + updates = flip R.updates + inserts = flip R.inserts deletes = flip R.deletes rangeLookup = flip R.rangeLookup diff --git a/test/Database/LSMTree/Model/Normal/Session.hs b/test/Database/LSMTree/Model/Normal/Session.hs index 03a1bb37c..e55825067 100644 --- a/test/Database/LSMTree/Model/Normal/Session.hs +++ b/test/Database/LSMTree/Model/Normal/Session.hs @@ -440,8 +440,19 @@ snapshot :: -> TableHandle k v blob -> m () snapshot name th@TableHandle{..} = do - table <- snd <$> guardTableHandleIsOpen th + (updc, table) <- guardTableHandleIsOpen th snaps <- gets snapshots + -- TODO: For the moment we allow snapshot to invalidate blob refs. + -- Ideally we should change the implementation to not invalidate on + -- snapshot, and then we can remove the artificial invalidation from + -- the model (i.e. delete the lines below that increments updc). + -- Furthermore, we invalidate them _before_ checking if there is a + -- duplicate snapshot. This is a bit barmy, but it matches the + -- implementation. The implementation should be fixed. + -- TODO: See https://github.com/IntersectMBO/lsm-tree/issues/392 + modify (\m -> m { + tableHandles = Map.insert tableHandleID (updc + 1, toSomeTable table) (tableHandles m) + }) when (Map.member name snaps) $ throwError ErrSnapshotExists modify (\m -> m { diff --git a/test/Test/Database/LSMTree/Class/Normal.hs b/test/Test/Database/LSMTree/Class/Normal.hs index 8d516d023..81776abed 100644 --- a/test/Test/Database/LSMTree/Class/Normal.hs +++ b/test/Test/Database/LSMTree/Class/Normal.hs @@ -59,24 +59,25 @@ tests = testGroup "Test.Database.LSMTree.Class.Normal" expectFailures2 = [ False , False - , True , False , False , False - , True , False - , True - , True , False , False , False - , True - , False - , False , False , False , False , False + , True + --TODO: Blobs are now enabled but cursors do not yet support them + , True + , True + , True + , True + , True + , True , False , False , False diff --git a/test/Test/Database/LSMTree/Normal/StateMachine.hs b/test/Test/Database/LSMTree/Normal/StateMachine.hs index 52fa3f8bd..8edf91214 100644 --- a/test/Test/Database/LSMTree/Normal/StateMachine.hs +++ b/test/Test/Database/LSMTree/Normal/StateMachine.hs @@ -197,6 +197,7 @@ propLockstepIO_RealImpl_RealFS = testProperty "propLockstepIO_RealImpl_RealFS" $ handler' (ErrSnapshotNotExists _snap) = Just Model.ErrSnapshotDoesNotExist handler' (ErrSnapshotExists _snap) = Just Model.ErrSnapshotExists handler' (ErrSnapshotWrongType _snap) = Just Model.ErrSnapshotWrongType + handler' (ErrBlobRefInvalid _) = Just Model.ErrBlobRefInvalidated handler' _ = Nothing {- TODO: temporarily disabled until we start on I/O fault testing. @@ -520,7 +521,7 @@ instance ( Eq (Class.TableConfig h) MLookupResult x -> OLookupResult $ fmap observeModel x MQueryResult x -> OQueryResult $ fmap observeModel x MSnapshotName x -> OId x - MBlob x -> OId x + MBlob x -> OBlob x MErr x -> OId x MUnit x -> OId x MPair x -> OPair $ bimap observeModel observeModel x @@ -591,8 +592,9 @@ instance Eq (Obs h a) where -- blob reference immediately after an update to the table, and if the SUT -- returns a blob, then that's okay. If both return a blob or both return -- an error, then those must match exactly. - (OEither (Right (OBlob (WrapBlob _))), OEither (Left (OId y))) - | Just Model.ErrBlobRefInvalidated <- cast y -> True + (OEither (Right (OVector vec)), OEither (Left (OId y))) + | Just (OBlob (WrapBlob _), _) <- V.uncons vec + , Just Model.ErrBlobRefInvalidated <- cast y -> True -- default equalities (OTableHandle, OTableHandle) -> True (OCursor, OCursor) -> True @@ -664,7 +666,7 @@ instance ( Eq (Class.TableConfig h) Updates{} -> OEither $ bimap OId OId result Inserts{} -> OEither $ bimap OId OId result Deletes{} -> OEither $ bimap OId OId result - RetrieveBlobs{} -> OEither $ bimap OId (OVector . fmap OId) result + RetrieveBlobs{} -> OEither $ bimap OId (OVector . fmap OBlob) result Snapshot{} -> OEither $ bimap OId OId result Open{} -> OEither $ bimap OId (const OTableHandle) result DeleteSnapshot{} -> OEither $ bimap OId OId result @@ -1041,9 +1043,8 @@ arbitraryActionWithVars _ findVars _st = QC.frequency $ concat [ withVars'' :: Gen (Var h (Either Model.Err (V.Vector (WrapBlobRef h IO blob)))) -> [(Int, Gen (Any (LockstepAction (ModelState h))))] - withVars'' _genBlobRefsVar = [ - -- TODO: enable generators as we implement the actions for the /real/ lsm-tree - -- fmap Some $ RetrieveBlobs <$> (fromRight <$> genBlobRefsVar) + withVars'' genBlobRefsVar = [ + (5, fmap Some $ RetrieveBlobs <$> (fromRight <$> genBlobRefsVar)) ] fromRight :: @@ -1082,9 +1083,10 @@ arbitraryActionWithVars _ findVars _st = QC.frequency $ concat [ genDeletes :: Gen (V.Vector k) genDeletes = QC.arbitrary - -- TODO: generate @Just blob@ once blob references are implemented genBlob :: Gen (Maybe blob) - genBlob = Nothing <$ QC.arbitrary @blob + genBlob = QC.oneof [ pure Nothing + , Just <$> QC.arbitrary @blob + ] genSnapshotName :: Gen R.SnapshotName genSnapshotName = QC.elements [