module Database.VCache.VTx
( VTx
, runVTx
, liftSTM
, markDurable
, markDurableIf
, getVTxSpace
) where
import Control.Monad
import Control.Monad.Trans.State.Strict
import Control.Concurrent.STM
import Control.Concurrent.MVar
import qualified Data.Map.Strict as Map
import Database.VCache.Types
runVTx :: VSpace -> VTx a -> IO a
runVTx vc action = do
mvWait <- newEmptyMVar
join (atomically (runVTx' vc mvWait action))
runVTx' :: VSpace -> MVar () -> VTx a -> STM (IO a)
runVTx' vc mvWait action =
let s0 = VTxState vc Map.empty False in
runStateT (_vtx action) s0 >>= \ (r,s) ->
let bWrite = not (Map.null (vtx_writes s)) in
let bSync = vtx_durable s in
let bDone = not (bWrite || bSync) in
if bDone then return (return r) else
readTVar (vcache_writes vc) >>= \ w ->
let wdata' = updateLog (vtx_writes s) (write_data w) in
let wsync' = updateSync bSync mvWait (write_sync w) in
let w' = Writes { write_data = wdata', write_sync = wsync' } in
writeTVar (vcache_writes vc) w' >>= \ () ->
return $ do
w' `seq` signalWriter vc
when bSync (takeMVar mvWait)
return r
signalWriter :: VSpace -> IO ()
signalWriter vc = void (tryPutMVar (vcache_signal vc) ())
updateLog :: WriteLog -> WriteLog -> WriteLog
updateLog updates writeLog = Map.union updates writeLog
updateSync :: Bool -> MVar () -> [MVar ()] -> [MVar ()]
updateSync bSync v = if bSync then (v:) else id
markDurable :: VTx ()
markDurable = VTx $ modify $ \ vtx ->
vtx { vtx_durable = True }
markDurableIf :: Bool -> VTx ()
markDurableIf b = VTx $ modify $ \ vtx ->
let bDurable = vtx_durable vtx || b in
vtx { vtx_durable = bDurable }