module Data.BTree.KVBackend.Files where
import Debug.Trace
import Prelude hiding (catch)
import Control.Exception
import Control.Concurrent
import Control.Monad.Reader
import System.Random
import System.FilePath
import System.Directory (removeFile, renameFile)
import Data.Serialize (Serialize, encode, decode)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Lazy as BL
import Data.Word
import Data.BTree.KVBackend.Util (atomicFileWrite, safeReadFile, safeWriteFile)
import qualified Data.BTree.KVBackend.Class as KV
import Codec.Compression.Snappy
type Param = FilePath
newtype FilesKV a = FilesKV { runFilesKV :: ReaderT Param IO a }
deriving (Monad, MonadIO, MonadReader Param)
evalFilesKV :: FilePath -> FilesKV a -> IO a
evalFilesKV p m =
runReaderT (runFilesKV m) p
traceThis a = traceShow a a
filePath :: Serialize k => k -> FilesKV FilePath
filePath path =
do dir <- ask
return $ dir </> (B.unpack $ B.map fix $ B64.encode $ encode path)
where
fix '/' = '-'
fix c = c
store k v = do path <- filePath k
e <- liftIO $! try $! safeWriteFile path bin
case e of
Left (e :: IOError) -> do
liftIO $ threadDelay 1
store k v
Right _ -> return ()
where
bin = compress $ encode v
fetch k = do path <- filePath k
liftIO $ do bin <- safeReadFile path
return $! either (const Nothing) Just $ decode $ decompress bin
`catch` \(_ :: IOError) -> return Nothing
remove k = do path <- filePath k
liftIO $ removeFile path
`catch` \(_ :: IOError) -> return ()
instance (Show k, Serialize k, Serialize v) => KV.KVBackend FilesKV k v where
store k v = store k v
fetch k = fetch k
remove k = remove k