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 qualified Data.Map as M
import Data.Binary
import Control.Monad(when,unless)
import Control.Exception
import System.FilePath
import System.Directory
import Prelude hiding(lookup,catch)
data BinaryBackend k a = BinaryBackend
{ workingDir :: FilePath
, tempDir :: FilePath
, entryLockMap :: TVar (M.Map k (TMVar ()))
}
mkBinaryBackend :: FilePath
-> IO (BinaryBackend k a)
mkBinaryBackend wd = do
ex <- doesDirectoryExist wd
tmp <- getTemporaryDirectory
unless ex $ throw (BackendException "mkBinaryBackend: Working directory does not exist.")
when (wd==tmp) $ throw (BackendException
"mkBinaryBackend: Cannot use the temporary directory as working directory.")
eLocks <- newTVarIO M.empty
return $ BinaryBackend wd tmp eLocks
withLockOnEntry :: (Ord k) => BinaryBackend k a -> k -> IO c -> IO c
withLockOnEntry b k m = do
atomically $ do
eLocks <- readTVar (entryLockMap b)
tmvar <- case M.lookup k eLocks of
Nothing -> do
tmvar <- newTMVar ()
eLock <- readTVar (entryLockMap b)
writeTVar (entryLockMap b) $ M.insert k tmvar eLock
return tmvar
Just tmvar -> return tmvar
takeTMVar tmvar
res <- m
atomically $ do
eLocks <- readTVar (entryLockMap b)
putTMVar (M.findWithDefault throwExc k eLocks) ()
return res
where
throwExc = throw $ BackendException "withLockOnEntry: Entry not found!"
instance (Show k,Ord k,Binary a) => Backend k a BinaryBackend where
insert b k a = do
let fp = workingDir b </> show k
exDir <- doesDirectoryExist (workingDir b)
unless exDir $ throw (BackendException "insert: Directory doesn't exist!")
ex <- doesFileExist fp
when ex $ throw $ BackendException "insert: Entry already exists!"
withLockOnEntry b k $ encodeFile fp a
lookup b k = do
let fp = workingDir b </> show k
exDir <- doesDirectoryExist (workingDir b)
unless exDir $ throw (BackendException "lookup: Directory doesn't exist!")
exFile <- doesFileExist fp
if not exFile
then return Nothing
else do
res <- withLockOnEntry b k $ decodeFile fp
return (Just $! res)
delete b k =
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
exDir <- doesDirectoryExist (workingDir b)
unless exDir $ throw (BackendException "adjust: Directory doesn't exist!")
ex <- doesFileExist fp
unless 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