module Data.TMap.Backend.Binary( mkBinaryBackend, BinaryBackend)
where
import Data.TMap.Backend
import Data.TMap.Exception
import Control.Concurrent.AdvSTM
import Control.Concurrent.AdvSTM.TVar
import Control.Concurrent.AdvSTM.TMVar
import Data.Binary
import Control.Monad(when)
import Control.Exception
import System.FilePath
import System.Directory
import Prelude hiding(lookup,catch)
data BinaryBackend k a = BinaryBackend
{ workingDir :: FilePath
, tempDir :: FilePath
, entryLock :: TVar (k -> TMVar ())
}
mkBinaryBackend :: FilePath
-> IO (BinaryBackend k a)
mkBinaryBackend wd = do
ex <- doesDirectoryExist wd
tmp <- getTemporaryDirectory
when (not ex) $ throw (BackendException "mkBinaryBackend: Working directory does not exist.")
when (wd==tmp) $ throw (BackendException
"mkBinaryBackend: Cannot use the temporary directory as working directory.")
l <- newTMVarIO ()
eLock <- newTVarIO (\_ -> l)
return (BinaryBackend wd tmp eLock)
withLockOnEntry :: BinaryBackend k a -> k -> IO c -> IO c
withLockOnEntry b k m = do
eLocks <- atomically $ do
eLocks <- readTVar (entryLock b)
takeTMVar (eLocks k)
return eLocks
res <- m
atomically $ putTMVar (eLocks k) ()
return res
instance (Show k,Ord k,Binary a) => Backend k a BinaryBackend where
insert b k a = do
let fp = workingDir b </> (show k)
ex <- doesFileExist fp
when ex $ throw $ BackendException "insert: Entry already exists!"
l <- newTMVarIO ()
atomically $ do
eLock <- readTVar (entryLock b)
writeTVar (entryLock b) (\k' -> if k'==k then l
else eLock k')
withLockOnEntry b k $ encodeFile fp a
lookup b k = do
let fp = workingDir b </> (show k)
ex <- doesFileExist fp
if not ex
then return Nothing
else do
res <- withLockOnEntry b k $ decodeFile fp
return (Just $! res)
delete b k = do
withLockOnEntry b k $ removeFile (workingDir b </> (show k))
adjust b f k = do
let fp = workingDir b </> (show k)
let tmp = tempDir b </> (show k)
ex <- doesFileExist fp
when (not ex) $ throw (BackendException "adjust: Did not find entry in backend.")
withLockOnEntry b k $ do
a <- (decodeFile fp :: IO a)
encodeFile tmp (f a)
renameFile tmp fp