From 98c252435767eb3d2f4b4c612c6eed6ff82a9f02 Mon Sep 17 00:00:00 2001
From: Joris Dral <joris@well-typed.com>
Date: Wed, 8 Jan 2025 17:06:22 +0100
Subject: [PATCH] TOSQUASH: blobfile

---
 lsm-tree.cabal                                |  1 +
 test/Main.hs                                  |  2 +
 .../Database/LSMTree/Internal/BlobFile/FS.hs  | 63 +++++++++++++++++++
 3 files changed, 66 insertions(+)
 create mode 100644 test/Test/Database/LSMTree/Internal/BlobFile/FS.hs

diff --git a/lsm-tree.cabal b/lsm-tree.cabal
index c2ff75d00..ba9465661 100644
--- a/lsm-tree.cabal
+++ b/lsm-tree.cabal
@@ -356,6 +356,7 @@ test-suite lsm-tree-test
     Test.Database.LSMTree.Class
     Test.Database.LSMTree.Generators
     Test.Database.LSMTree.Internal
+    Test.Database.LSMTree.Internal.BlobFile.FS
     Test.Database.LSMTree.Internal.BloomFilter
     Test.Database.LSMTree.Internal.Chunk
     Test.Database.LSMTree.Internal.CRC32C
diff --git a/test/Main.hs b/test/Main.hs
index 1f94b8f95..ac067bc9b 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -8,6 +8,7 @@ import qualified Test.Data.Arena
 import qualified Test.Database.LSMTree.Class
 import qualified Test.Database.LSMTree.Generators
 import qualified Test.Database.LSMTree.Internal
+import qualified Test.Database.LSMTree.Internal.BlobFile.FS
 import qualified Test.Database.LSMTree.Internal.BloomFilter
 import qualified Test.Database.LSMTree.Internal.Chunk
 import qualified Test.Database.LSMTree.Internal.CRC32C
@@ -48,6 +49,7 @@ main = do
     , Test.Database.LSMTree.Class.tests
     , Test.Database.LSMTree.Generators.tests
     , Test.Database.LSMTree.Internal.tests
+    , Test.Database.LSMTree.Internal.BlobFile.FS.tests
     , Test.Database.LSMTree.Internal.BloomFilter.tests
     , Test.Database.LSMTree.Internal.Chunk.tests
     , Test.Database.LSMTree.Internal.CRC32C.tests
diff --git a/test/Test/Database/LSMTree/Internal/BlobFile/FS.hs b/test/Test/Database/LSMTree/Internal/BlobFile/FS.hs
new file mode 100644
index 000000000..77b8cb46f
--- /dev/null
+++ b/test/Test/Database/LSMTree/Internal/BlobFile/FS.hs
@@ -0,0 +1,63 @@
+module Test.Database.LSMTree.Internal.BlobFile.FS (tests) where
+
+import           Control.Concurrent.Class.MonadSTM.Strict
+import           Control.Monad.Class.MonadThrow
+import           Control.RefCount
+import           Database.LSMTree.Internal.BlobFile
+import           System.FS.API
+import           System.FS.Sim.Error hiding (genErrors)
+import qualified System.FS.Sim.MockFS as MockFS
+import qualified System.FS.Sim.Stream as Stream
+import           Test.Tasty
+import           Test.Tasty.QuickCheck as QC
+import           Test.Util.FS
+
+tests :: TestTree
+tests = testGroup "Test.Database.LSMTree.Internal.BlobFile.FS" [
+      testProperty "prop_fault_openRelease" prop_fault_openRelease
+    ]
+
+-- Test that opening and releasing a blob file properly cleans handles and files
+-- in the presence of disk faults.
+prop_fault_openRelease ::
+     TestErrors
+  -> TestErrors
+  -> Property
+prop_fault_openRelease (TestErrors openErrors) (TestErrors releaseErrors) =
+    ioProperty $
+    withSimErrorHasFS propPost MockFS.empty emptyErrors $ \hfs fsVar errsVar -> do
+      eith <- try @_ @FsError $
+        bracket (acquire hfs errsVar) (release errsVar) $ \_blobFile -> do
+          fs' <- atomically $ readTMVar fsVar
+          pure $ propNumOpenHandles 1 fs' .&&. propNumDirEntries (mkFsPath []) 1 fs'
+      pure $ case eith of
+        Left{}     ->
+          label "FsError" $ property True
+        Right prop ->
+          label "Success" $ prop
+  where
+    acquire hfs errsVar =
+        withErrors errsVar openErrors $
+          openBlobFile hfs (mkFsPath ["blobfile"]) (ReadWriteMode MustBeNew)
+
+    release errsVar blobFile =
+      withErrors errsVar releaseErrors $ releaseRef blobFile
+
+    propPost fs = propNoOpenHandles fs .&&. propNoDirEntries (mkFsPath []) fs
+
+-- | No errors on closing file handles and removing files
+data TestErrors = TestErrors Errors
+  deriving stock Show
+
+mkTestErrors :: Errors -> TestErrors
+mkTestErrors errs = TestErrors $ errs {
+      hCloseE = Stream.empty
+    , removeFileE = Stream.empty
+    }
+
+instance Arbitrary TestErrors where
+  arbitrary = do
+      errs <- arbitrary
+      pure $ mkTestErrors errs
+
+  shrink (TestErrors errs) = TestErrors <$> shrink errs