-----------------------------------------------------------------------------
-- |
-- 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 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)

-- | The binary-backend type
data BinaryBackend k a = BinaryBackend
  { workingDir :: FilePath 
  , tempDir    :: FilePath
  , entryLockMap :: TVar (M.Map 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 
  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