Binary.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.TMap.Backend.Binary
-- Copyright   :  Peter Robinson 2009
-- License     :  LGPL
--
-- Maintainer  :  Peter Robinson <thaldyron@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable (requires STM)
--
-- Proivides a (very simplistic) backend using the binary package.
-- Every entry of the map is written to a separate file where the filename
-- is the key. 
--
-- Note: This interface is only thread-safe when being used via TMap!
--
-----------------------------------------------------------------------------
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)

-- | The binary-backend type
data BinaryBackend k a = BinaryBackend
  { workingDir :: FilePath 
  , tempDir    :: FilePath
  , entryLock :: TVar (k -> TMVar ())
  }

-- | Creates a new backend that stores one file per entry in the given working directory.
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)
    exDir  <- doesDirectoryExist (workingDir b)
    when (not exDir) $ throw (BackendException "insert: Directory doesn't exist!")
    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)
    exDir  <- doesDirectoryExist (workingDir b)
    when (not 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 = 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)
    exDir  <- doesDirectoryExist (workingDir b)
    when (not exDir) $ throw (BackendException "adjust: Directory doesn't exist!")
    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