module Data.TCache.Defs where
import Data.Typeable
import Control.Concurrent.STM(TVar)
import Data.TCache.IResource
import System.IO.Unsafe
import Data.IORef
import System.Directory
import Control.Monad(when,replicateM)
import System.IO
import System.IO.Error
import Control.Exception as Exception
import Control.Concurrent
import Data.List(elemIndices,isInfixOf)
import Data.Maybe(fromJust)
import qualified Data.ByteString.Lazy.Char8 as B
type AccessTime = Integer
type ModifTime = Integer
data Status a= NotRead | DoNotExist | Exist a deriving Typeable
data Elem a= Elem !a !AccessTime !ModifTime deriving Typeable
type TPVar a= TVar (Status(Elem a))
data DBRef a= DBRef !String !(TPVar a) deriving Typeable
castErr a= r where
r= case cast a of
Nothing -> error $ "Type error: " ++ (show $ typeOf a) ++ " does not match "++ (show $ typeOf r)
++ "\nThis means that objects of these two types have the same key \nor the retrieved object type is not the stored one for the same key\n"
Just x -> x
class Indexable a where
key:: a -> String
defPath :: a -> String
defPath = const "TCacheData/"
class Serializable a where
serialize :: a -> B.ByteString
deserialize :: B.ByteString -> a
setPersist :: a -> Persist
setPersist _= defaultPersist
data Persist = Persist{
readByKey :: (String -> IO(Maybe B.ByteString))
, write :: (String -> B.ByteString -> IO())
, delete :: (String -> IO())}
defaultPersist= Persist
{readByKey= defaultReadByKey
,write= defaultWrite
,delete= defaultDelete}
getPersist x= return (setPersist x)
`Exception.catch` (\(e:: SomeException) -> error "setPersist must not depend on the type, not the value of the parameter: " )
defaultReadByKey :: String-> IO (Maybe B.ByteString)
defaultReadByKey k= iox
where
iox = handle handler $ do
s <- readFileStrict k
return $ Just s
handler :: IOError -> IO (Maybe B.ByteString)
handler e
| isAlreadyInUseError e = defaultReadByKey k
| isDoesNotExistError e = return Nothing
| otherwise= if ("invalid" `isInfixOf` ioeGetErrorString e)
then
error $ "defaultReadByKey: " ++ show e ++ " defPath and/or keyResource are not suitable for a file path:\n"++ k++"\""
else defaultReadByKey k
defaultWrite :: String-> B.ByteString -> IO()
defaultWrite filename x= safeWrite filename x
safeWrite filename str= handle handler $ B.writeFile filename str
where
handler e
| isDoesNotExistError e=do
createDirectoryIfMissing True $ take (1+(last $ elemIndices '/' filename)) filename
safeWrite filename str
| otherwise= if ("invalid" `isInfixOf` ioeGetErrorString e)
then
error $ "defaultWriteResource: " ++ show e ++ " defPath and/or keyResource are not suitable for a file path: "++ filename
else do
hPutStrLn stderr $ "defaultWriteResource: " ++ show e ++ " in file: " ++ filename ++ " retrying"
safeWrite filename str
defaultDelete :: String -> IO()
defaultDelete filename =do
handle (handler filename) $ removeFile filename
where
handler :: String -> IOException -> IO ()
handler file e
| isDoesNotExistError e= return ()
| isAlreadyInUseError e= do
hPutStrLn stderr $ "defaultDelResource: busy" ++ " in file: " ++ filename ++ " retrying"
defaultDelete filename
| otherwise = do
hPutStrLn stderr $ "defaultDelResource: " ++ show e ++ " in file: " ++ filename ++ " retrying"
defaultDelete filename
defReadResourceByKey k= iox where
iox= do
let Persist f _ _ = setPersist x
f file >>= return . fmap deserialize . castErr
where
file= defPath x ++ k
x= undefined `asTypeOf` (fromJust $ unsafePerformIO iox)
defWriteResource s= do
let Persist _ f _ = setPersist s
f (defPath s ++ key s) $ castErr $ serialize s
defDelResource s= do
let Persist _ _ f = setPersist s
f $ defPath s ++ key s
readFileStrict f = openFile f ReadMode >>= \ h -> readIt h `finally` hClose h
where
readIt h= do
s <- hFileSize h
let n= fromIntegral s
str <- B.hGet h n
return str