module Data.TCache.DefaultPersistence(Indexable(..),Serializable(..),Persist(..)) where
import Data.TCache.IResource
import Data.Typeable
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 Data.TCache.Defs(castErr)
import qualified Data.ByteString.Lazy.Char8 as B
class Indexable a where
key:: a -> String
defPath :: a -> String
defPath = const "TCacheData/"
class Serializable a | a -> where
serialize :: a -> B.ByteString --serialFormat
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: " )
instance (Typeable a, Indexable a, Serializable a ) => IResource a where
keyResource = key
writeResource s=do
Persist _ f _ <- getPersist s
f (defPath s ++ key s) $ castErr $ serialize s
readResourceByKey k= iox where
iox= do
Persist f _ _ <- getPersist x
f file >>= return . fmap deserialize . castErr
where
file= defPath x ++ k
x= undefined `asTypeOf` (fromJust $ unsafePerformIO iox)
delResource s= do
Persist _ _ f <- getPersist s
f $ defPath s ++ key s
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 $ "readResource: " ++ show e ++ " defPath and/or keyResource are not suitable for a file path"
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 $ "writeResource: " ++ show e ++ " defPath and/or keyResource are not suitable for a file path"
else do
hPutStrLn stderr $ "defaultWriteResource: " ++ show e ++ " in file: " ++ filename ++ " retrying"
safeWrite filename str
defaultDelete :: String -> IO()
defaultDelete filename =do
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
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