muesli-0.1.1.0: src/Database/Muesli/Backend/File.hs
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_HADDOCK show-extensions #-}
-----------------------------------------------------------------------------
-- |
-- Module : Database.Muesli.Backend.File
-- Copyright : (c) 2015 Călin Ardelean
-- License : MIT
--
-- Maintainer : Călin Ardelean <calinucs@gmail.com>
-- Stability : experimental
-- Portability : portable
--
-- Binary seekable file backend that uses 'Prelude' functions.
--
-- Only one process at a time can safely use the files, but file locking is not
-- yet implemented.
----------------------------------------------------------------------------
module Database.Muesli.Backend.File
( FileHandle
, FileLogState (..)
) where
import Control.Exception (throw)
import Control.Monad (forM_, replicateM, unless, when)
import Control.Monad.Trans (MonadIO (liftIO))
import Data.ByteString (hGet, hPut)
import Data.Word (Word16, Word8)
import Database.Muesli.Backend.Types
import Database.Muesli.Types
import Foreign (Storable, alloca, peek, sizeOf,
with)
import System.Directory (renameFile)
import System.IO (BufferMode (..), Handle,
IOMode (..), SeekMode (..),
hClose, hFileSize, hGetBuf,
hPutBuf, hSeek, hSetBuffering,
hSetFileSize, hTell,
openBinaryFile, withBinaryFile)
-- | @newtype@ wrapper around 'Handle', so that we can accomodate other instances.
newtype FileHandle = FileHandle { unIOHandle :: Handle }
deriving (Eq, Show)
instance DbHandle FileHandle where
openDb path = liftIO $ do
hnd <- openBinaryFile path ReadWriteMode
hSetBuffering hnd NoBuffering
return $ FileHandle hnd
closeDb hnd = liftIO . hClose $ unIOHandle hnd
withDb path f = liftIO . withBinaryFile path ReadWriteMode $ f . FileHandle
swapDb oldPath path = liftIO (renameFile path oldPath) >> openDb oldPath
instance DataHandle FileHandle where
readDocument hnd r = do
liftIO . hSeek (unIOHandle hnd) AbsoluteSeek . fromIntegral $ recAddress r
liftIO . hGet (unIOHandle hnd) . fromIntegral $ recSize r
writeDocument r bs hnd = unless (recDeleted r) . liftIO $ do
let sz = fromIntegral $ recAddress r + recSize r
let h = unIOHandle hnd
osz <- hFileSize h
when (osz < sz) $ do
let nsz = max sz $ osz + 4096
hSetFileSize h nsz
hSeek h AbsoluteSeek . fromIntegral $ recAddress r
hPut h bs
-- | Implements a stateful binary log file backend.
--
-- It uses a 'FileHandle' for both the log and data files.
data FileLogState = FileLogState
{
-- | The 'Handle' for the log file
flogHandle :: FileHandle
-- | Current valid position in the (quasi)append-only log file.
-- Located at address 0 of the log file, it is the last write performd as
-- part of a batch 'logAppend' operation, which makes it atomic.
, flogPos :: DocAddress
-- | Current size of the log file. 'logAppend' first checks the file size
-- and increases it with minimum 4KB if necessary, then writes the records,
-- and then updates the 'flogPos'.
, flogSize :: DocSize
} deriving (Show)
instance LogState FileLogState where
type LogHandleOf FileLogState = FileHandle
type DataHandleOf FileLogState = FileHandle
logHandle = flogHandle
logInit hnd = do
(pos, sz) <- readLogPos (unIOHandle hnd)
return $ FileLogState hnd pos sz
logAppend l rs = do
let hnd = unIOHandle $ logHandle l
let pos = flogPos l
let pos' = pos + sum (map sizeTransRecord rs)
sz <- checkFileSize hnd (flogSize l) pos'
liftIO . hSeek hnd AbsoluteSeek $ fromIntegral pos
forM_ rs $ writeTransRecord hnd
writeLogPos hnd $ fromIntegral pos'
return l { flogPos = pos', flogSize = sz }
logRead l = do
let hnd = unIOHandle $ logHandle l
pos <- liftIO $ hTell hnd
if flogSize l == 0 || pos >= fromIntegral (flogPos l) - 1
then return Nothing
else do
r <- readTransRecord hnd
return $ Just r
sizeTransRecord :: TransRecord -> DocSize
sizeTransRecord r = fromIntegral $ case r of
Pending dr -> 16 + ws * (3 + 2 * (length (recUniques dr) +
length (recSortables dr) +
length (recReferences dr)))
Completed _ -> 9
where ws = sizeOf (0 :: IxKey)
readBits :: forall a m. (Storable a, MonadIO m) => Handle -> m a
readBits h = liftIO . alloca $ \ptr ->
hGetBuf h ptr (sizeOf (undefined :: a)) >> peek ptr
writeBits :: (Storable a, MonadIO m) => Handle -> a -> m ()
writeBits h w = liftIO . with w $ \ptr ->
hPutBuf h ptr (sizeOf w)
readLogPos :: MonadIO m => Handle -> m (DocAddress, DocSize)
readLogPos h = liftIO $ do
sz <- hFileSize h
if sz >= fromIntegral (sizeOf (0 :: DocAddress)) then do
hSeek h AbsoluteSeek 0
w <- readBits h
return (w, fromIntegral sz)
else
return (fromIntegral $ sizeOf (0 :: DocAddress), 0)
writeLogPos :: MonadIO m => Handle -> DocAddress -> m ()
writeLogPos h p = liftIO $ do
hSeek h AbsoluteSeek 0
writeBits h p
checkFileSize :: MonadIO m => Handle -> DocSize -> DocAddress -> m DocSize
checkFileSize hnd osz pos =
if pos > osz then do
let sz = max pos $ osz + 4096
liftIO . hSetFileSize hnd $ fromIntegral sz
return sz
else return osz
readTransRecord :: MonadIO m => Handle -> m TransRecord
readTransRecord h = do
tag <- readBits h
case tag of
x | x == pndTag -> do
tid <- readBits h
did <- readBits h
adr <- readBits h
siz <- readBits h
del <- readBits h
dlb <- case del of
y | y == truTag -> return True
y | y == flsTag -> return False
_ -> logError h $
showString "True ('T') or False ('F') tag expected but " .
shows del . showString " found."
us <- readWordList h
is <- readWordList h
ds <- readWordList h
return $ Pending LogRecord { recDocumentKey = did
, recTransactionId = tid
, recUniques = us
, recSortables = is
, recReferences = ds
, recAddress = adr
, recSize = siz
, recDeleted = dlb
}
x | x == cmpTag -> do
tid <- readBits h
return $ Completed tid
_ -> logError h $ showString "Pending ('p') or Completed ('c') tag expected but " .
shows tag . showString " found."
readWordList :: MonadIO m => Handle -> m [(PropertyKey, IxKey)]
readWordList h = do
sz <- readBits h
replicateM (fromIntegral (sz :: Word16)) $ do
pid <- readBits h
val <- readBits h
return (pid, val)
writeTransRecord :: MonadIO m => Handle -> TransRecord -> m ()
writeTransRecord h t =
case t of
Pending doc -> do
writeBits h pndTag
writeBits h $ recTransactionId doc
writeBits h $ recDocumentKey doc
writeBits h $ recAddress doc
writeBits h $ recSize doc
writeBits h $ if recDeleted doc then truTag else flsTag
writeWordList h $ recUniques doc
writeWordList h $ recSortables doc
writeWordList h $ recReferences doc
Completed tid -> do
writeBits h cmpTag
writeBits h tid
writeWordList :: MonadIO m => Handle -> [(PropertyKey, IxKey)] -> m ()
writeWordList h rs = do
writeBits h (fromIntegral (length rs) :: Word16)
forM_ rs $ \(pid, val) -> do
writeBits h pid
writeBits h val
pndTag :: Word8
pndTag = 0x70 -- ASCII 'p'
cmpTag :: Word8
cmpTag = 0x63 -- ASCII 'c'
truTag :: Word8
truTag = 0x54 -- ASCII 'T'
flsTag :: Word8
flsTag = 0x46 -- ASCII 'F'
logError :: MonadIO m => Handle -> ShowS -> m a
logError h err = liftIO $ do
pos <- hTell h
throw . LogParseError . showString "Log corrupted at position " . shows pos .
showString ". " $ err ""