References for file paths

lsm-tree.cabal

@@ -131,6 +131,7 @@ library
     Database.LSMTree.Internal.CRC32C
     Database.LSMTree.Internal.Cursor
     Database.LSMTree.Internal.Entry
+    Database.LSMTree.Internal.FS.File
     Database.LSMTree.Internal.Index
     Database.LSMTree.Internal.Index.Compact
     Database.LSMTree.Internal.Index.CompactAcc
@@ -362,6 +363,7 @@ test-suite lsm-tree-test
     Test.Database.LSMTree.Internal.Chunk
     Test.Database.LSMTree.Internal.CRC32C
     Test.Database.LSMTree.Internal.Entry
+    Test.Database.LSMTree.Internal.FS.File
     Test.Database.LSMTree.Internal.Index.Compact
     Test.Database.LSMTree.Internal.Index.Ordinary
     Test.Database.LSMTree.Internal.Lookup

src-extras/Database/LSMTree/Extras/NoThunks.hs

@@ -41,6 +41,7 @@ import           Database.LSMTree.Internal.Chunk
 import           Database.LSMTree.Internal.Config
 import           Database.LSMTree.Internal.CRC32C
 import           Database.LSMTree.Internal.Entry
+import           Database.LSMTree.Internal.FS.File
 import           Database.LSMTree.Internal.Index
 import           Database.LSMTree.Internal.Index.Compact
 import           Database.LSMTree.Internal.Index.CompactAcc
@@ -267,7 +268,7 @@ instance NoThunks WriteBuffer where
       !y = toMap x
 
 {-------------------------------------------------------------------------------
-  BlobFile
+  WriteBufferBlobs
 -------------------------------------------------------------------------------}
 
 deriving stock instance Generic (WriteBufferBlobs m h)
@@ -278,6 +279,24 @@ deriving stock instance Generic (FilePointer m)
 deriving anyclass instance Typeable (PrimState m)
                         => NoThunks (FilePointer m)
 
+{-------------------------------------------------------------------------------
+  BlobFile
+-------------------------------------------------------------------------------}
+
+deriving stock instance Generic (BlobFile m h)
+deriving anyclass instance (Typeable h, Typeable (PrimState m), Typeable m)
+                        => NoThunks (BlobFile m h)
+
+deriving stock instance Generic BlobSpan
+deriving anyclass instance NoThunks BlobSpan
+
+{-------------------------------------------------------------------------------
+  File
+-------------------------------------------------------------------------------}
+
+deriving stock instance Generic (File m)
+deriving anyclass instance Typeable (PrimState m) => NoThunks (File m)
+
 {-------------------------------------------------------------------------------
   Index
 -------------------------------------------------------------------------------}
@@ -533,15 +552,8 @@ deriving anyclass instance NoThunks RawOverflowPage
   BlobRef
 -------------------------------------------------------------------------------}
 
-deriving stock instance Generic BlobSpan
-deriving anyclass instance NoThunks BlobSpan
-
-deriving stock instance Generic (BlobFile m h)
-deriving anyclass instance (Typeable h, Typeable (PrimState m))
-                        => NoThunks (BlobFile m h)
-
 deriving stock instance Generic (RawBlobRef m h)
-deriving anyclass instance (Typeable h, Typeable (PrimState m))
+deriving anyclass instance (Typeable h, Typeable (PrimState m), Typeable m)
                         => NoThunks (RawBlobRef m h)
 
 deriving stock instance Generic (WeakBlobRef m h)

src/Database/LSMTree/Internal/BlobFile.hs

@@ -2,6 +2,8 @@
 module Database.LSMTree.Internal.BlobFile (
     BlobFile (..)
   , BlobSpan (..)
+  , unsafeOpenBlobFile
+  , newBlobFile
   , openBlobFile
   , readBlob
   , readBlobRaw
@@ -10,12 +12,13 @@
 
 import           Control.DeepSeq (NFData (..))
 import           Control.Monad.Class.MonadThrow (MonadCatch (bracketOnError),
-                     MonadThrow (..))
+                     MonadMask, MonadThrow (..))
 import           Control.Monad.Primitive (PrimMonad)
 import           Control.RefCount
 import qualified Data.Primitive.ByteArray as P
 import qualified Data.Vector.Primitive as VP
 import           Data.Word (Word32, Word64)
+import           Database.LSMTree.Internal.FS.File
 import qualified Database.LSMTree.Internal.RawBytes as RB
 import           Database.LSMTree.Internal.Serialise (SerialisedBlob (..))
 import qualified System.FS.API as FS
@@ -29,16 +32,19 @@
 -- and deleted.
 --
 data BlobFile m h = BlobFile {
-       blobFileHandle     :: {-# UNPACK #-} !(FS.Handle h),
-       blobFileRefCounter :: {-# UNPACK #-} !(RefCounter m)
-     }
+      blobFileHandle     :: {-# UNPACK #-} !(FS.Handle h)
+      -- | TODO: once 'unsafeOpenBlobFile' is removed, replace this by just a
+      -- @Ref (File m)@.
+    , blobFileFile       :: {-# UNPACK #-} !(Maybe (Ref (File m)))
+    , blobFileRefCounter :: {-# UNPACK #-} !(RefCounter m)
+    }
   deriving stock (Show)
 
 instance RefCounted m (BlobFile m h) where
     getRefCounter = blobFileRefCounter
 
 instance NFData h => NFData (BlobFile m h) where
-  rnf (BlobFile a b) = rnf a `seq` rnf b
+  rnf (BlobFile a b c) = rnf a `seq` rnf b `seq` rnf c
 
 -- | The location of a blob inside a blob file.
 data BlobSpan = BlobSpan {
@@ -50,22 +56,17 @@
 instance NFData BlobSpan where
   rnf (BlobSpan a b) = rnf a `seq` rnf b
 
--- | 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 because it
--- allocates/creates resources.
-{-# SPECIALISE openBlobFile :: HasCallStack => HasFS IO h -> FS.FsPath -> FS.OpenMode -> IO (Ref (BlobFile IO h)) #-}
-openBlobFile ::
+{-# SPECIALISE unsafeOpenBlobFile :: HasCallStack => HasFS IO h -> FS.FsPath -> FS.OpenMode -> IO (Ref (BlobFile IO h)) #-}
+-- | TODO: replace at use sites by 'newBlobFile' or 'openBlobFile', and then
+-- remove this function.
+unsafeOpenBlobFile ::
      (PrimMonad m, MonadCatch m)
   => HasCallStack
   => HasFS m h
   -> FS.FsPath
   -> FS.OpenMode
   -> m (Ref (BlobFile m h))
-openBlobFile fs path mode =
+unsafeOpenBlobFile fs path mode =
     bracketOnError (FS.hOpen fs path mode) (FS.hClose fs) $ \blobFileHandle -> do
       let finaliser =
             FS.hClose fs blobFileHandle `finally`
@@ -77,9 +78,68 @@
       newRef finaliser $ \blobFileRefCounter ->
         BlobFile {
           blobFileHandle,
+          blobFileFile = Nothing,
           blobFileRefCounter
         }
 
+{-# SPECIALISE fromFile :: HasFS IO h -> Ref (File IO) -> Mode -> IO (Ref (BlobFile IO h)) #-}
+-- | Create a 'BlobFile' from a 'File'.
+--
+-- REF: the resulting reference must be released once it is no longer used.
+--
+-- ASYNC: this should be called with asynchronous exceptions masked because it
+-- allocates/creates resources.
+fromFile ::
+     (PrimMonad m, MonadMask m)
+  => HasFS m h
+  -> Ref (File m)
+  -> Mode
+  -> m (Ref (BlobFile m h))
+fromFile hfs blobFileFile mode =
+    bracketOnError (openHandle hfs blobFileFile mode) (FS.hClose hfs) $ \blobFileHandle -> do
+      let finaliser = FS.hClose hfs blobFileHandle `finally` releaseRef blobFileFile
+      newRef finaliser $ \blobFileRefCounter -> BlobFile {
+          blobFileHandle
+        , blobFileFile = Just $! blobFileFile
+        , blobFileRefCounter
+        }
+
+{-# SPECIALISE newBlobFile :: HasCallStack => HasFS IO h -> FS.FsPath -> Mode -> IO (Ref (BlobFile IO h)) #-}
+-- | Create a new 'BlobFile'.
+--
+-- REF: the resulting reference must be released once it is no longer used.
+--
+-- ASYNC: this should be called with asynchronous exceptions masked because it
+-- allocates/creates resources.
+newBlobFile ::
+     (PrimMonad m, MonadMask m)
+  => HasCallStack
+  => HasFS m h
+  -> FS.FsPath
+  -> Mode
+  -> m (Ref (BlobFile m h))
+newBlobFile hfs path mode =
+    bracketOnError (newFile hfs path) releaseRef $
+      \file -> fromFile hfs file mode
+
+{-# SPECIALISE openBlobFile :: HasCallStack => HasFS IO h -> Ref (File IO) -> Mode -> IO (Ref (BlobFile IO h)) #-}
+-- | Open an existing 'File' to make a 'BlobFile'.
+--
+-- REF: the resulting reference must be released once it is no longer used.
+--
+-- ASYNC: this should be called with asynchronous exceptions masked because it
+-- allocates/creates resources.
+openBlobFile ::
+     (PrimMonad m, MonadMask m)
+  => HasCallStack
+  => HasFS m h
+  -> Ref (File m)
+  -> Mode
+  -> m (Ref (BlobFile m h))
+openBlobFile hfs file mode =
+    bracketOnError (dupRef file) releaseRef $
+      \file' -> fromFile hfs file' mode
+
 {-# INLINE readBlob #-}
 readBlob ::
      (MonadThrow m, PrimMonad m)

src/Database/LSMTree/Internal/FS/File.hs

@@ -0,0 +1,141 @@
+module Database.LSMTree.Internal.FS.File (
+    File (..)
+    -- * Construction
+  , newFile
+  , copyFile
+    -- * Opening handles
+  , Mode (..)
+  , openHandle
+  ) where
+
+import           Control.DeepSeq
+import           Control.Monad
+import           Control.Monad.Class.MonadThrow
+import           Control.Monad.Primitive (PrimMonad)
+import           Control.RefCount
+import qualified System.FS.API as FS
+import           System.FS.API (AllowExisting (..), FsPath, Handle, HasFS)
+import qualified System.FS.API.Lazy as FSL
+
+-- | A reference counted file.
+--
+-- When all references are released, the file will be deleted from disk.
+--
+-- INVARIANT: 'filePath' /must/ exist on disk.
+data File m = File {
+    filePath       :: {-# UNPACK #-} !FsPath,
+    fileRefCounter :: {-# UNPACK #-} !(RefCounter m)
+  }
+  deriving stock Show
+
+instance RefCounted m (File m) where
+    getRefCounter = fileRefCounter
+
+instance NFData (File m) where
+  rnf (File a b) = rnf a `seq` rnf b
+
+-- | Create a 'File' from a file path. This functions assumes the file path
+-- exists.
+--
+-- REF: the resulting reference must be released once it is no longer used.
+--
+-- ASYNC: this should be called with asynchronous exceptions masked because it
+-- allocates/creates resources.
+fromFsPath :: PrimMonad m => HasFS m h -> FsPath -> m (Ref (File m))
+fromFsPath hfs path = do
+    let finaliser = FS.removeFile hfs path
+    newRef finaliser $ \fileRefCounter ->
+        File {
+            filePath = path
+          , fileRefCounter
+          }
+
+{-------------------------------------------------------------------------------
+  Construction
+-------------------------------------------------------------------------------}
+
+{-# SPECIALISE newFile :: HasFS IO h -> FsPath -> IO (Ref (File IO)) #-}
+{-# INLINABLE newFile #-}
+-- | Create a new file.
+--
+-- REF: the resulting reference must be released once it is no longer used.
+--
+-- ASYNC: this should be called with asynchronous exceptions masked because it
+-- allocates/creates resources.
+newFile :: (MonadCatch m, PrimMonad m) => HasFS m h -> FsPath -> m (Ref (File m))
+newFile hfs path = withCreateFile hfs path $ \_h -> fromFsPath hfs path
+
+{-# SPECIALISE copyFile :: HasFS IO h -> FsPath -> FsPath -> IO (Ref (File IO)) #-}
+{-# INLINABLE copyFile #-}
+-- | @'copyFile' hfs source target@ copies the @source@ path to the /new/
+-- @target@ path.
+--
+-- REF: the resulting reference must be released once it is no longer used.
+--
+-- ASYNC: this should be called with asynchronous exceptions masked because it
+-- allocates/creates resources.
+copyFile ::
+     (MonadCatch m, PrimMonad m)
+  => HasFS m h
+  -> FsPath
+  -> FsPath
+  -> m (Ref (File m))
+copyFile hfs sourcePath targetPath =
+    FS.withFile hfs sourcePath FS.ReadMode $ \sourceHandle -> do
+      withCreateFile hfs targetPath $ \targetHandle -> do
+        bs <- FSL.hGetAll hfs sourceHandle
+        void $ FSL.hPutAll hfs targetHandle bs
+        fromFsPath hfs targetPath
+
+{-# SPECIALISE withCreateFile :: HasFS IO h -> FsPath -> (Handle h -> IO a) -> IO a #-}
+{-# INLINABLE withCreateFile #-}
+-- | Run an action on a handle to a newly created file.
+--
+-- The handle is closed automatically when the action is finished, even if an
+-- exception is thrown in the action.
+--
+-- If an exception happens in the action, the file is removed.
+--
+-- ASYNC: this should be called with asynchronous exceptions masked because it
+-- allocates/creates resources.
+withCreateFile :: MonadCatch m => HasFS m h -> FsPath -> (Handle h -> m a) -> m a
+withCreateFile hfs path k = fst <$> generalBracket acquire release k
+  where
+    acquire = FS.hOpen hfs path (FS.WriteMode MustBeNew)
+    release h = \case
+      ExitCaseSuccess _ -> FS.hClose hfs h
+      ExitCaseException e -> do
+          FS.hClose hfs h
+        `finally`
+          FS.removeFile hfs path
+        `finally`
+          throwIO e
+      ExitCaseAbort -> do
+          FS.hClose hfs h
+        `finally`
+          FS.removeFile hfs path
+
+{-------------------------------------------------------------------------------
+  Opening handles
+-------------------------------------------------------------------------------}
+
+-- | File open mode. The file is assumed to exist already on disk.
+data Mode = Read | ReadWrite | Write | Append
+  deriving stock (Show, Eq)
+
+modeOpenMode :: Mode -> FS.OpenMode
+modeOpenMode = \case
+    Read -> FS.ReadMode
+    ReadWrite -> FS.ReadWriteMode MustExist
+    Write -> FS.WriteMode MustExist
+    Append -> FS.AppendMode MustExist
+
+{-# INLINABLE openHandle #-}
+-- | Open a handle to a 'File'.
+--
+-- REF: the resulting handle should be closed when it is no longer used.
+--
+-- ASYNC: this should be called with asynchronous exceptions masked because it
+-- allocates/creates resources.
+openHandle :: HasFS m h -> Ref (File m) -> Mode -> m (Handle h)
+openHandle hfs (DeRef file) mode = FS.hOpen hfs (filePath file) (modeOpenMode mode)