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 when updated.
-- Due to the atomicity guarantees of the 'AdvSTM' monad, an update to a
-- 'TFile' is only committed when the file operation succeeds.   
-- 
-- This module should be imported qualified.
--
-----------------------------------------------------------------------------
module Control.Concurrent.TFile( 
              -- * Data type
              TFile,
--              -- * Construction
--              newIO,
--              new,
              new,
              newIO,
              newFromFileIO,
              newEmpty,
              newEmptyIO,
              newEmptyFromFileIO,
              -- * Operations
              read,
              write,
              clear,
              isEmpty,
              -- * Utilities
              basedir,
            )


where
import Control.Concurrent.TBox

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.Monad.IfElse(unlessM)
import Control.Exception 

import System.FilePath((</>),takeFileName)
import System.Directory
import System.IO.Error hiding(catch)
import System.IO.Cautious(writeFileL)

import Prelude hiding(lookup,catch,null,read,readIO,writeFile)
import qualified Prelude as P
import qualified Safe.Failure as Safe

--------------------------------------------------------------------------------
-- | A transactional variable that writes its content to a file on each update.
-- The file is created in directory \".\/_TFile\/\".
--
-- * The 'onCommit' hook of the 'AdvSTM' monad guarantee that the updated memory content 
-- of the TFile is only visible to other threads /iff/ 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 k a = TF 
  { filepath  :: FilePath
  , tfileTVar :: TVar (Maybe a)
  , dirtyTVar :: TVar Bool
  , fileLock  :: TMVar () 
  }
  deriving(Typeable)


-- | Currently set to \".\/_TFile\"
-- TODO: provide interface for updating base directory within a transaction(?)
basedir :: FilePath
basedir = "_TFile"


-- | Tries to construct a 'TFile' from a given filepath. 
-- Reads the content of the file into memory.
newFromFileIO :: (Read k,TBox TFile k a) => FilePath -> IO (TFile k a,k)
newFromFileIO fp = do
  (t,k) <- newEmptyFromFileIO fp 
  _ <- atomically $ read t
  return (t,k) 

-- | Tries to construct a 'TFile' from a given filepath. 
-- Note that the content of the file is read into memory only on demand, i.e.,
-- when executing 'TBox.read'.
-- Throws 'AssertionFailed' if the filename could not be parsed.
newEmptyFromFileIO :: (Read k,TBox TFile k a) => FilePath -> IO (TFile k a,k)
newEmptyFromFileIO fp = do
  k <- Safe.read (takeFileName fp) `catch` (\(_::Safe.SafeException) ->
         throw $ AssertionFailed ("Could not parse filename: " ++ fp))
  t <- newEmptyIO k
  return (t,k)
  
{-  maybe (throw $ AssertionFailed ("Could not parse filename: " ++ fp))
        (\k -> do
            t <- newEmptyIO k
            return (t,k))
        $ Safe.read (takeFileName fp)
-}

instance (Binary a,Show k) => TBox TFile k a where
  newEmpty k = 
    let fp = basedir </> show k
    in TF fp `liftM` newTVar Nothing 
                `ap` newTVar True
                `ap` newTMVar ()

  newEmptyIO k = do
    unlessM (doesDirectoryExist basedir) $ 
      createDirectory basedir
    let fp = basedir </> show k
    TF fp `liftM` newTVarIO Nothing 
             `ap` (newTVarIO =<< doesFileExist fp)
             `ap` newTMVarIO ()

  new k a    = do
    let fp = basedir </> show k
    tbox <- TF fp `liftM` newTVar (Just a) 
                     `ap` newTVar False 
                     `ap` newTMVar ()
    write tbox a
    return tbox

  writeSTM tfile = writeTVar (tfileTVar tfile) . Just 

  writeIO (TF fp _ _ lock) a = do 
    unlessM (doesDirectoryExist basedir) $ 
      createDirectory basedir
    withTMVar lock $ const $ writeFileL fp $ encode a

  readSTM = readTVar . tfileTVar 

  readIO tmap = do
    a <- withTMVar (fileLock tmap) $ const $ decodeFile (filepath tmap)
    return (Just a)
    `catch` \(e::IOException) -> 
      if isDoesNotExistError e then return Nothing else throw e

  clearSTM tbox = writeTVar (tfileTVar tbox) Nothing

  clearIO (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

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