TFile.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Concurrent.TFile
-- Copyright   :  Peter Robinson 2009
-- License     :  LGPL
--
-- Maintainer  :  Peter Robinson <thaldyron@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable (requires STM)
--
-- 
-- A transactional variable that writes its content to a file on each update.
-- 
-- This module should be imported qualified.
--
-----------------------------------------------------------------------------
module Control.Concurrent.TFile( -- * Data type
              TFile,
              -- * Construction
              newEmptyIO,
              newIO,
              new,
              -- * Operations
              read,
              write,
              delete,
              isEmpty
            )


where
import Control.Concurrent.TBox.Class
import Control.Concurrent.TBox.Operations

import Data.Binary
import Data.Typeable
import Control.Concurrent.AdvSTM.TMVar
import Control.Concurrent.AdvSTM
import Control.Concurrent.AdvSTM.TVar
import Control.Monad
import Control.Exception 

import System.Directory
import System.IO.Error hiding(catch)
import System.IO.Cautious(writeFileL)

import Prelude hiding(lookup,catch,null,read,readIO,writeFile)

--------------------------------------------------------------------------------
-- | A transactional variable that writes its content to a file on each update.
--
-- * The updated memory content of the TFile is not visible to other threads
-- until the file has been written successfully. 
--
-- * If the 'TFile' is \"dirty\", the content is (re)read from the file on the next
-- 'read'.
--
data TFile a = TF 
  { filepath  :: FilePath
  , tfileTVar :: TVar (Maybe a)
  , dirtyTVar :: TVar Bool
  , fileLock  :: TMVar () 
  }
  deriving(Typeable)

-- | Constructs an initially empty 'TFile' that is marked dirty. 
-- That means, on the next 'read', the contents of the provided file (if it
-- exists) will be loaded into the 'TFile'.
newEmptyIO :: Binary a => FilePath -> IO (TFile a)
newEmptyIO fp = 
  TF fp `liftM` newTVarIO Nothing 
           `ap` (newTVarIO =<< doesFileExist fp)
           `ap` newTMVarIO ()

newIO :: Binary a => FilePath -> a -> IO (TFile a)
newIO fp = atomically . new fp

new :: Binary a => FilePath -> a -> AdvSTM (TFile a)
new fp a = do
  tbox <- TF fp `liftM` newTVar (Just a) 
                   `ap` newTVar False 
                   `ap` newTMVar ()
  write tbox a
  return tbox

instance Binary a => TBox TFile a where
  writeSTM tbox = writeTVar (tfileTVar tbox) . Just 

  writeIO (TF fp _ _ lock) = withTMVar lock . const . writeFileL fp . encode 

  readSTM = readTVar . tfileTVar 

  readIO (TF fp _ _ lock) = (do
    a <- withTMVar lock $ const $ decodeFile fp
    return $ Just a)
    `catch` \(e::IOException) -> 
      if isDoesNotExistError e then return Nothing else throw e

  deleteSTM tbox = writeTVar (tfileTVar tbox) Nothing

  deleteIO (TF fp _ _ lock) = withTMVar lock $ const $ removeFile fp
    `catch` \(e::IOException) -> unless (isDoesNotExistError e) $ throw e

  isDirty  = readTVar  . dirtyTVar 
  setDirty = writeTVar . dirtyTVar 

withTMVar :: TMVar a -> (a -> IO b) -> IO b
withTMVar tmvar ioac = do
  a <- atomically $ takeTMVar tmvar
  res <- ioac a
  atomically $ putTMVar tmvar a
  return res

--------------------------------------------------------------------------------