module Control.Concurrent.TFile(
TFile,
new,
newIO,
newFromFileIO,
newEmpty,
newEmptyIO,
newEmptyFromFileIO,
read,
write,
clear,
isEmpty,
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
data TFile k a = TF
{ filepath :: FilePath
, tfileTVar :: TVar (Maybe a)
, dirtyTVar :: TVar Bool
, fileLock :: TMVar ()
}
deriving(Typeable)
basedir :: FilePath
basedir = "_TFile"
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)
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)
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