WIP: make BlobFile functions exception safe

src/Database/LSMTree/Internal/BlobFile.hs

@@ -9,7 +9,8 @@ module Database.LSMTree.Internal.BlobFile (
   ) where
 
 import           Control.DeepSeq (NFData (..))
-import           Control.Monad.Class.MonadThrow (MonadThrow)
+import           Control.Monad.Class.MonadThrow (MonadCatch (bracketOnError),
+                     MonadThrow (..))
 import           Control.Monad.Primitive (PrimMonad)
 import           Control.RefCount
 import qualified Data.Primitive.ByteArray as P
@@ -51,24 +52,30 @@ instance NFData BlobSpan where
 
 -- | Open the given file to make a 'BlobFile'. The finaliser will close and
 -- delete the file.
+--
+-- REF: the resulting reference must be released once it is no longer used.
+--
+-- ASYNC: this should be called with asynchronous exceptions masked.
 {-# SPECIALISE openBlobFile :: HasCallStack => HasFS IO h -> FS.FsPath -> FS.OpenMode -> IO (Ref (BlobFile IO h)) #-}
 openBlobFile ::
-     PrimMonad m
+     (PrimMonad m, MonadCatch m)
   => HasCallStack
   => HasFS m h
   -> FS.FsPath
   -> FS.OpenMode
   -> m (Ref (BlobFile m h))
-openBlobFile fs path mode = do
-    blobFileHandle <- FS.hOpen fs path mode
-    let finaliser = do
-          FS.hClose fs blobFileHandle
-          FS.removeFile fs (FS.handlePath blobFileHandle)
-    newRef finaliser $ \blobFileRefCounter ->
-      BlobFile {
-        blobFileHandle,
-        blobFileRefCounter
-      }
+openBlobFile fs path mode =
+    bracketOnError (FS.hOpen fs path mode) (FS.hClose fs) $ \blobFileHandle -> do
+      let finaliser = do
+            FS.hClose fs blobFileHandle
+            -- If we fail to close the file handle, then we won't try to remove
+            -- the file.
+            FS.removeFile fs (FS.handlePath blobFileHandle)
+      newRef finaliser $ \blobFileRefCounter ->
+        BlobFile {
+          blobFileHandle,
+          blobFileRefCounter
+        }
 
 {-# INLINE readBlob #-}
 readBlob ::

src/Database/LSMTree/Internal/Run.hs

@@ -183,6 +183,7 @@ setRunDataCaching hbio runKOpsFile NoCacheRunData = do
      RunDataCaching
   -> RunBuilder IO h
   -> IO (Ref (Run IO h)) #-}
+-- TODO: make exception safe
 fromMutable ::
      (MonadST m, MonadSTM m, MonadMask m)
   => RunDataCaching
@@ -192,6 +193,7 @@ fromMutable runRunDataCaching builder = do
     (runHasFS, runHasBlockIO, runRunFsPaths, runFilter, runIndex, runNumEntries) <-
       Builder.unsafeFinalise (runRunDataCaching == NoCacheRunData) builder
     runKOpsFile <- FS.hOpen runHasFS (runKOpsPath runRunFsPaths) FS.ReadMode
+    -- TODO: openBlobFile should be called with exceptions masked
     runBlobFile <- openBlobFile runHasFS (runBlobPath runRunFsPaths) FS.ReadMode
     setRunDataCaching runHasBlockIO runKOpsFile runRunDataCaching
     newRef (finaliser runHasFS runKOpsFile runBlobFile runRunFsPaths)
@@ -263,6 +265,7 @@ openFromDisk ::
   -> RunDataCaching
   -> RunFsPaths
   -> m (Ref (Run m h))
+-- TODO: make exception safe
 openFromDisk fs hbio runRunDataCaching runRunFsPaths = do
     expectedChecksums <-
        expectValidFile (runChecksumsPath runRunFsPaths) . fromChecksumsFile
@@ -282,6 +285,7 @@ openFromDisk fs hbio runRunDataCaching runRunFsPaths = do
         =<< readCRC (forRunIndexRaw expectedChecksums) (forRunIndexRaw paths)
 
     runKOpsFile <- FS.hOpen fs (runKOpsPath runRunFsPaths) FS.ReadMode
+    -- TODO: openBlobFile should be called with exceptions masked
     runBlobFile <- openBlobFile fs (runBlobPath runRunFsPaths) FS.ReadMode
     setRunDataCaching hbio runKOpsFile runRunDataCaching
     newRef (finaliser fs runKOpsFile runBlobFile runRunFsPaths) $ \runRefCounter ->

src/Database/LSMTree/Internal/WriteBufferBlobs.hs

@@ -134,9 +134,12 @@ open ::
   -> FS.FsPath
   -> FS.AllowExisting
   -> m (Ref (WriteBufferBlobs m h))
+-- TODO: make exception safe
 open fs blobFileName blobFileAllowExisting = do
     -- Must use read/write mode because we write blobs when adding, but
     -- we can also be asked to retrieve blobs at any time.
+    --
+    -- TODO: openBlobFile should be called with exceptions masked
     fromBlobFile fs =<< openBlobFile fs blobFileName (FS.ReadWriteMode blobFileAllowExisting)
 
 {-# SPECIALISE fromBlobFile :: HasFS IO h -> Ref (BlobFile IO h) -> IO (Ref (WriteBufferBlobs IO h)) #-}