{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_HADDOCK not-home #-}

module Database.LSMTree.Internal.BlobFile (
    BlobFile (..)
  , BlobSpan (..)
  , openBlobFile
  , readBlob
  , readBlobRaw
  , writeBlob
  ) where

import           Control.DeepSeq (NFData (..))
import           Control.Monad.Class.MonadThrow (MonadCatch (bracketOnError),
                     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 qualified Database.LSMTree.Internal.RawBytes as RB
import           Database.LSMTree.Internal.Serialise (SerialisedBlob (..))
import qualified System.FS.API as FS
import           System.FS.API (HasFS)
import qualified System.FS.BlockIO.API as FS
import           System.FS.CallStack (HasCallStack)

-- | A handle to a file containing blobs.
--
-- This is a reference counted object. Upon finalisation, the file is closed
-- and deleted.
--
data BlobFile m h = BlobFile {
       forall (m :: * -> *) h. BlobFile m h -> Handle h
blobFileHandle     :: {-# UNPACK #-} !(FS.Handle h),
       forall (m :: * -> *) h. BlobFile m h -> RefCounter m
blobFileRefCounter :: {-# UNPACK #-} !(RefCounter m)
     }
  deriving stock (Int -> BlobFile m h -> ShowS
[BlobFile m h] -> ShowS
BlobFile m h -> String
(Int -> BlobFile m h -> ShowS)
-> (BlobFile m h -> String)
-> ([BlobFile m h] -> ShowS)
-> Show (BlobFile m h)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (m :: * -> *) h. Int -> BlobFile m h -> ShowS
forall (m :: * -> *) h. [BlobFile m h] -> ShowS
forall (m :: * -> *) h. BlobFile m h -> String
$cshowsPrec :: forall (m :: * -> *) h. Int -> BlobFile m h -> ShowS
showsPrec :: Int -> BlobFile m h -> ShowS
$cshow :: forall (m :: * -> *) h. BlobFile m h -> String
show :: BlobFile m h -> String
$cshowList :: forall (m :: * -> *) h. [BlobFile m h] -> ShowS
showList :: [BlobFile m h] -> ShowS
Show)

instance RefCounted m (BlobFile m h) where
    getRefCounter :: BlobFile m h -> RefCounter m
getRefCounter = BlobFile m h -> RefCounter m
forall (m :: * -> *) h. BlobFile m h -> RefCounter m
blobFileRefCounter

instance NFData h => NFData (BlobFile m h) where
  rnf :: BlobFile m h -> ()
rnf (BlobFile Handle h
a RefCounter m
b) = Handle h -> ()
forall a. NFData a => a -> ()
rnf Handle h
a () -> () -> ()
forall a b. a -> b -> b
`seq` RefCounter m -> ()
forall a. NFData a => a -> ()
rnf RefCounter m
b

-- | The location of a blob inside a blob file.
data BlobSpan = BlobSpan {
    BlobSpan -> Word64
blobSpanOffset :: {-# UNPACK #-} !Word64
  , BlobSpan -> Word32
blobSpanSize   :: {-# UNPACK #-} !Word32
  }
  deriving stock (Int -> BlobSpan -> ShowS
[BlobSpan] -> ShowS
BlobSpan -> String
(Int -> BlobSpan -> ShowS)
-> (BlobSpan -> String) -> ([BlobSpan] -> ShowS) -> Show BlobSpan
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BlobSpan -> ShowS
showsPrec :: Int -> BlobSpan -> ShowS
$cshow :: BlobSpan -> String
show :: BlobSpan -> String
$cshowList :: [BlobSpan] -> ShowS
showList :: [BlobSpan] -> ShowS
Show, BlobSpan -> BlobSpan -> Bool
(BlobSpan -> BlobSpan -> Bool)
-> (BlobSpan -> BlobSpan -> Bool) -> Eq BlobSpan
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BlobSpan -> BlobSpan -> Bool
== :: BlobSpan -> BlobSpan -> Bool
$c/= :: BlobSpan -> BlobSpan -> Bool
/= :: BlobSpan -> BlobSpan -> Bool
Eq)

instance NFData BlobSpan where
  rnf :: BlobSpan -> ()
rnf (BlobSpan Word64
a Word32
b) = Word64 -> ()
forall a. NFData a => a -> ()
rnf Word64
a () -> () -> ()
forall a b. a -> b -> b
`seq` Word32 -> ()
forall a. NFData a => a -> ()
rnf Word32
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 ::
     (PrimMonad m, MonadCatch m)
  => HasCallStack
  => HasFS m h
  -> FS.FsPath
  -> FS.OpenMode
  -> m (Ref (BlobFile m h))
openBlobFile :: forall (m :: * -> *) h.
(PrimMonad m, MonadCatch m, HasCallStack) =>
HasFS m h -> FsPath -> OpenMode -> m (Ref (BlobFile m h))
openBlobFile HasFS m h
fs FsPath
path OpenMode
mode =
    m (Handle h)
-> (Handle h -> m ())
-> (Handle h -> m (Ref (BlobFile m h)))
-> m (Ref (BlobFile m h))
forall a b c. m a -> (a -> m b) -> (a -> m c) -> m c
forall (m :: * -> *) a b c.
MonadCatch m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracketOnError (HasFS m h -> HasCallStack => FsPath -> OpenMode -> m (Handle h)
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => FsPath -> OpenMode -> m (Handle h)
FS.hOpen HasFS m h
fs FsPath
path OpenMode
mode) (HasFS m h -> HasCallStack => Handle h -> m ()
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m ()
FS.hClose HasFS m h
fs) ((Handle h -> m (Ref (BlobFile m h))) -> m (Ref (BlobFile m h)))
-> (Handle h -> m (Ref (BlobFile m h))) -> m (Ref (BlobFile m h))
forall a b. (a -> b) -> a -> b
$ \Handle h
blobFileHandle -> do
      let finaliser :: m ()
finaliser =
            HasFS m h -> HasCallStack => Handle h -> m ()
forall (m :: * -> *) h.
HasFS m h -> HasCallStack => Handle h -> m ()
FS.hClose HasFS m h
fs Handle h
blobFileHandle m () -> m () -> m ()
forall a b. m a -> m b -> m a
forall (m :: * -> *) a b. MonadThrow m => m a -> m b -> m a
`finally`
              -- TODO: this function takes ownership of the file path. The file is
              -- removed when the blob file is finalised, which may lead to
              -- surprise errors when the file is also deleted elsewhere. Maybe
              -- file paths should be guarded by 'Ref's as well?
              HasFS m h -> HasCallStack => FsPath -> m ()
forall (m :: * -> *) h. HasFS m h -> HasCallStack => FsPath -> m ()
FS.removeFile HasFS m h
fs (Handle h -> FsPath
forall h. Handle h -> FsPath
FS.handlePath Handle h
blobFileHandle)
      m () -> (RefCounter m -> BlobFile m h) -> m (Ref (BlobFile m h))
forall (m :: * -> *) obj.
(RefCounted m obj, PrimMonad m, HasCallStack) =>
m () -> (RefCounter m -> obj) -> m (Ref obj)
newRef m ()
finaliser ((RefCounter m -> BlobFile m h) -> m (Ref (BlobFile m h)))
-> (RefCounter m -> BlobFile m h) -> m (Ref (BlobFile m h))
forall a b. (a -> b) -> a -> b
$ \RefCounter m
blobFileRefCounter ->
        BlobFile {
          Handle h
blobFileHandle :: Handle h
blobFileHandle :: Handle h
blobFileHandle,
          RefCounter m
blobFileRefCounter :: RefCounter m
blobFileRefCounter :: RefCounter m
blobFileRefCounter
        }

{-# INLINE readBlob #-}
readBlob ::
     (MonadThrow m, PrimMonad m)
  => HasFS m h
  -> Ref (BlobFile m h)
  -> BlobSpan
  -> m SerialisedBlob
readBlob :: forall (m :: * -> *) h.
(MonadThrow m, PrimMonad m) =>
HasFS m h -> Ref (BlobFile m h) -> BlobSpan -> m SerialisedBlob
readBlob HasFS m h
fs (DeRef BlobFile m h
blobfile) BlobSpan
blobspan = HasFS m h -> BlobFile m h -> BlobSpan -> m SerialisedBlob
forall (m :: * -> *) h.
(MonadThrow m, PrimMonad m) =>
HasFS m h -> BlobFile m h -> BlobSpan -> m SerialisedBlob
readBlobRaw HasFS m h
fs BlobFile m h
blobfile BlobSpan
blobspan

{-# SPECIALISE readBlobRaw :: HasFS IO h -> BlobFile IO h -> BlobSpan -> IO SerialisedBlob #-}
readBlobRaw ::
     (MonadThrow m, PrimMonad m)
  => HasFS m h
  -> BlobFile m h
  -> BlobSpan
  -> m SerialisedBlob
readBlobRaw :: forall (m :: * -> *) h.
(MonadThrow m, PrimMonad m) =>
HasFS m h -> BlobFile m h -> BlobSpan -> m SerialisedBlob
readBlobRaw HasFS m h
fs BlobFile {Handle h
blobFileHandle :: forall (m :: * -> *) h. BlobFile m h -> Handle h
blobFileHandle :: Handle h
blobFileHandle}
            BlobSpan {Word64
blobSpanOffset :: BlobSpan -> Word64
blobSpanOffset :: Word64
blobSpanOffset, Word32
blobSpanSize :: BlobSpan -> Word32
blobSpanSize :: Word32
blobSpanSize} = do
    let off :: AbsOffset
off = Word64 -> AbsOffset
FS.AbsOffset Word64
blobSpanOffset
        len :: Int
        len :: Int
len = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
blobSpanSize
    MutableByteArray (PrimState m)
mba <- Int -> m (MutableByteArray (PrimState m))
forall (m :: * -> *).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
P.newPinnedByteArray Int
len
    ByteCount
_ <- HasFS m h
-> Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
forall (m :: * -> *) h.
(HasCallStack, MonadThrow m) =>
HasFS m h
-> Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
FS.hGetBufExactlyAt HasFS m h
fs Handle h
blobFileHandle MutableByteArray (PrimState m)
mba BufferOffset
0
                             (Int -> ByteCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len :: FS.ByteCount) AbsOffset
off
    ByteArray
ba <- MutableByteArray (PrimState m) -> m ByteArray
forall (m :: * -> *).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
P.unsafeFreezeByteArray MutableByteArray (PrimState m)
mba
    let !rb :: RawBytes
rb = Int -> Int -> ByteArray -> RawBytes
RB.fromByteArray Int
0 Int
len ByteArray
ba
    SerialisedBlob -> m SerialisedBlob
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (RawBytes -> SerialisedBlob
SerialisedBlob RawBytes
rb)

{-# SPECIALISE writeBlob :: HasFS IO h -> Ref (BlobFile IO h) -> SerialisedBlob -> Word64 -> IO () #-}
writeBlob ::
     (MonadThrow m, PrimMonad m)
  => HasFS m h
  -> Ref (BlobFile m h)
  -> SerialisedBlob
  -> Word64
  -> m ()
writeBlob :: forall (m :: * -> *) h.
(MonadThrow m, PrimMonad m) =>
HasFS m h -> Ref (BlobFile m h) -> SerialisedBlob -> Word64 -> m ()
writeBlob HasFS m h
fs (DeRef BlobFile {Handle h
blobFileHandle :: forall (m :: * -> *) h. BlobFile m h -> Handle h
blobFileHandle :: Handle h
blobFileHandle})
          (SerialisedBlob' (VP.Vector Int
boff Int
blen ByteArray
ba)) Word64
off = do
    MutableByteArray (PrimState m)
mba <- ByteArray -> m (MutableByteArray (PrimState m))
forall (m :: * -> *).
PrimMonad m =>
ByteArray -> m (MutableByteArray (PrimState m))
P.unsafeThawByteArray ByteArray
ba
    ByteCount
_   <- HasFS m h
-> Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
forall (m :: * -> *) h.
(HasCallStack, MonadThrow m) =>
HasFS m h
-> Handle h
-> MutableByteArray (PrimState m)
-> BufferOffset
-> ByteCount
-> AbsOffset
-> m ByteCount
FS.hPutBufExactlyAt
             HasFS m h
fs Handle h
blobFileHandle MutableByteArray (PrimState m)
mba
             (Int -> BufferOffset
FS.BufferOffset Int
boff)
             (Int -> ByteCount
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
blen :: FS.ByteCount)
             (Word64 -> AbsOffset
FS.AbsOffset Word64
off)
    () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()