module Data.FixFile (
Fixed(..)
,Fix(..)
,Stored
,CataAlg
,cata
,AnaAlg
,ana
,ParaAlg
,para
,iso
,Root(..)
,Ptr
,Ref(..)
,ref
,FixFile
,createFixFile
,createFixFileHandle
,openFixFile
,openFixFileHandle
,closeFixFile
,vacuum
,Transaction
,alterT
,lookupT
,readTransaction
,writeTransaction
,subTransaction
,getFull
) where
import Prelude hiding (sequence, mapM, lookup)
import Control.Concurrent.MVar
import Control.Exception
import Control.Lens hiding (iso, para)
import qualified Control.Monad.RWS as RWS
import Control.Monad.Identity hiding (mapM)
import Control.Monad.Trans
import Data.Binary
import Data.ByteString.Lazy as BSL
import Data.Dynamic
import Data.Hashable
import Data.HashTable.IO
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
import Data.Traversable (mapM)
import GHC.Generics
import System.FilePath
import System.Directory
import System.IO
import System.IO.Unsafe
import Data.FixFile.Fixed
type HashTable k v = CuckooHashTable k v
data Cache f = Cache Int (HashTable (Ptr f) (f (Ptr f)))
(HashTable (Ptr f) (f (Ptr f)))
deriving (Typeable)
type Caches = M.Map TypeRep Dynamic
createCache :: IO (Cache f)
createCache = Cache 0 <$> new <*> new
cacheInsert :: Ptr f -> f (Ptr f) -> Cache f -> IO (Cache f)
cacheInsert p f (Cache i oc nc) =
if i >= 50
then new >>= cacheInsert p f . Cache 0 nc
else do
insert nc p f
return (Cache (i + 1) oc nc)
cacheLookup :: Ptr f -> Cache f -> IO (Cache f, Maybe (f (Ptr f)))
cacheLookup p c@(Cache _ oc nc) = do
nval <- lookup nc p
val <- maybe (lookup oc p) (return . Just) nval
case (nval, val) of
(Nothing, Just v) -> do
c' <- cacheInsert p v c
return (c', val)
_ -> return (c, val)
getCachedOrStored :: Typeable f => Ptr f -> IO (f (Ptr f)) -> MVar Caches ->
IO (f (Ptr f))
getCachedOrStored p m cs = do
mval <- withCache cs (cacheLookup p)
case mval of
Just v -> return v
Nothing -> do
v <- m
withCache_ cs (cacheInsert p v)
return v
withCache :: Typeable c => MVar Caches -> (Cache c -> IO (Cache c, a)) -> IO a
withCache cs f = modifyMVar cs $ \cmap -> do
let mc = M.lookup mt cmap >>= fromDynamic
mt = typeOf $ fromJust mc
c <- maybe createCache return mc
(c', a) <- f c
return (M.insert mt (toDyn c') cmap, a)
withCache_ :: Typeable c => MVar Caches -> (Cache c -> IO (Cache c)) -> IO ()
withCache_ cs f = withCache cs $ \c -> f c >>= \c' -> return (c', ())
type Pos = Word64
data FFH = FFH (MVar Handle) (MVar Caches)
getRawBlock :: Binary a => Handle -> Pos -> IO a
getRawBlock h p = do
hSeek h AbsoluteSeek (fromIntegral p)
(sb :: Word32) <- decode <$> (BSL.hGet h 4)
decode <$> BSL.hGet h (fromIntegral sb)
getBlock :: (Typeable f, Binary (f (Ptr f))) => (Ptr f) -> FFH -> IO (f (Ptr f))
getBlock p@(Ptr pos) (FFH mh mc) = getCachedOrStored p readFromFile mc where
readFromFile = withMVar mh $ flip getRawBlock pos
putRawBlock :: Binary a => a -> FFH -> IO Pos
putRawBlock a (FFH mh _) = putRaw where
putRaw = withMVar mh $ \h -> do
hSeek h SeekFromEnd 0
p <- fromIntegral <$> hTell h
let enc = encode a
len = fromIntegral $ BSL.length enc
len' = encode (len :: Word32)
enc' = mappend len' enc
BSL.hPut h enc'
return p
putBlock :: (Typeable f, Binary (f (Ptr f))) => (f (Ptr f)) -> FFH ->
IO (Ptr f)
putBlock a h@(FFH _ mc) = putRawBlock a h >>= cacheBlock . Ptr where
cacheBlock p = do
withCache_ mc (cacheInsert p a)
return p
data Stored s f =
Memory (f (Stored s f))
| Cached !(Ptr f) (f (Stored s f))
instance Fixed (Stored s) where
inf = Memory
outf (Memory a) = a
outf (Cached _ a) = a
sync :: (Traversable f, Binary (f (Ptr f)), Typeable f) =>
FFH -> Stored s f -> IO (Ptr f)
sync h = commit where
commit (Memory r) = do
r' <- mapM commit r
putBlock r' h
commit (Cached p _) = return p
newtype Ptr (f :: * -> *) = Ptr Pos
deriving (Generic, Eq, Ord, Read, Show)
instance Binary (Ptr f)
instance Hashable (Ptr f) where
hashWithSalt x (Ptr y) = hashWithSalt x y
class Root (r :: (((* -> *) -> *) -> *)) where
readRoot :: r Ptr -> Transaction r' s (r (Stored s))
writeRoot :: r (Stored s) -> Transaction r' s (r Ptr)
rootIso :: (Fixed g, Fixed h) => r g -> r h
data Ref (f :: * -> *) (g :: (* -> *) -> *) = Ref { deRef :: g f }
deriving (Generic)
instance (Typeable f, Binary (f (Ptr f)), Traversable f) => Root (Ref f) where
readRoot (Ref p) = Ref <$> (withHandle $ flip readStoredLazy p)
writeRoot (Ref a) = Ref <$> (withHandle $ flip sync a)
rootIso = Ref . iso . deRef
instance Binary (Ref f Ptr)
ref :: Lens' (Ref f g) (g f)
ref = lens (\(Ref a) -> a) (\_ b -> Ref b)
newtype Transaction r s a = Transaction {
runRT :: RWS.RWST FFH (Last (r Ptr)) (r (Stored s)) IO a
}
instance Functor (Transaction f s) where
fmap f (Transaction t) = Transaction $ fmap f t
instance Applicative (Transaction f s) where
pure = Transaction . pure
Transaction a <*> Transaction b = Transaction $ a <*> b
instance Monad (Transaction f s) where
return = pure
Transaction t >>= f = Transaction $ RWS.RWST $ \ffh root -> do
(a, root', w) <- RWS.runRWST t ffh root
(a', root'', w') <- RWS.runRWST (runRT $ f a) ffh root'
return (a', root'', w `mappend` w')
instance RWS.MonadState (r (Stored s)) (Transaction r s) where
get = Transaction $ RWS.get
put = Transaction . RWS.put
state = Transaction . RWS.state
subTransaction :: Lens' (r (Stored s)) (r' (Stored s)) -> Transaction r' s a ->
Transaction r s a
subTransaction l st = Transaction $ RWS.RWST $ \ffh root -> do
(a, r, _) <- RWS.runRWST (runRT st) ffh (root^.l)
return (a, set l r root, mempty)
withHandle :: (FFH -> IO a) -> Transaction r s a
withHandle f = Transaction $ RWS.ask >>= liftIO . f
readStoredLazy :: (Traversable f, Binary (f (Ptr f)), Typeable f) =>
FFH -> Ptr f -> IO (Stored s f)
readStoredLazy h p = do
f <- getBlock p h
let fcons = Cached p
fcons <$> mapM (unsafeInterleaveIO . readStoredLazy h) f
alterT :: (tr ~ Transaction (Ref f) s, Traversable f, Binary (f (Ptr f))) =>
(Stored s f -> Stored s f) -> tr ()
alterT f = ref %= f
lookupT :: (tr ~ Transaction (Ref f) s, Traversable f, Binary (f (Ptr f))) =>
(Stored s f -> a) -> tr a
lookupT f = f <$> use ref
data FixFile r = FixFile FilePath (MVar (FFH, r Ptr)) (MVar ())
acquireWriteLock :: FixFile f -> IO ()
acquireWriteLock (FixFile _ _ wl) = do
void $ takeMVar wl
releaseWriteLock :: FixFile f -> IO ()
releaseWriteLock (FixFile _ _ wl) = do
putMVar wl ()
withWriteLock :: FixFile f -> IO a -> IO a
withWriteLock ff f = do
acquireWriteLock ff
f `finally` releaseWriteLock ff
readHeader :: FFH -> IO (Pos)
readHeader (FFH mh _) = withMVar mh $ \h -> do
hSeek h AbsoluteSeek 0
decode <$> BSL.hGet h 8
updateHeader :: Pos -> Transaction r s ()
updateHeader p = do
withHandle $ \(FFH mh _) ->
withMVar mh $ \h -> do
hSeek h AbsoluteSeek 0
BSL.hPut h (encode p)
hFlush h
createFixFile :: (Root r, Binary (r Ptr), Typeable r) =>
r Fix -> FilePath -> IO (FixFile r)
createFixFile initial path =
openFile path ReadWriteMode >>= createFixFileHandle initial path
createFixFileHandle :: (Root r, Binary (r Ptr), Typeable r) =>
r Fix -> FilePath -> Handle -> IO (FixFile r)
createFixFileHandle initial path h = do
ffh <- FFH <$> newMVar h <*> newMVar M.empty
BSL.hPut h (encode (0 :: Pos))
let t = runRT $ do
dr <- writeRoot $ rootIso initial
(withHandle $ putRawBlock dr) >>= updateHeader
Transaction . RWS.tell . Last . Just $ dr
(_,_,root') <- RWS.runRWST t ffh undefined
let Just root = getLast root'
ffhmv <- newMVar (ffh, root)
FixFile path ffhmv <$> newMVar ()
openFixFile :: Binary (r Ptr) => FilePath -> IO (FixFile r)
openFixFile path =
openFile path ReadWriteMode >>= openFixFileHandle path
openFixFileHandle :: Binary (r Ptr) => FilePath -> Handle ->
IO (FixFile r)
openFixFileHandle path h = do
ffh <- FFH <$> newMVar h <*> newMVar M.empty
root <- readHeader ffh >>= getRawBlock h
ffhmv <- newMVar (ffh, root)
FixFile path ffhmv <$> newMVar ()
closeFixFile :: FixFile r -> IO ()
closeFixFile (FixFile path tmv _) = do
(FFH mh _, _) <- takeMVar tmv
h <- takeMVar mh
hClose h
putMVar mh $ error (path ++ " is closed.")
putMVar tmv $ error (path ++ " is closed.")
readTransaction :: Root r => FixFile r ->
(forall s. Transaction r s a) -> IO a
readTransaction (FixFile _ ffhmv _) t = do
(ffh, root) <- readMVar ffhmv
let t' = readRoot root >>= RWS.put >> t
(a, _) <- RWS.evalRWST (runRT t') ffh undefined
return a
writeTransaction :: (Root r, Binary (r Ptr), Typeable r) =>
FixFile r -> (forall s. Transaction r s a)
-> IO a
writeTransaction ff@(FixFile _ ffhmv _) t = res where
res = withWriteLock ff runTransaction
runTransaction = do
(ffh, root) <- readMVar ffhmv
let t' = readRoot root >>= RWS.put >> t >>= save
save a = do
dr <- RWS.get >>= writeRoot
(withHandle $ putRawBlock dr) >>= updateHeader
Transaction . RWS.tell . Last . Just $ dr
return a
(a, root') <- RWS.evalRWST (runRT t') ffh undefined
case getLast root' of
Nothing -> return ()
Just root'' -> do
void $ swapMVar ffhmv (ffh, root'')
return a
getFull :: Functor f => Transaction (Ref f) s (Fix f)
getFull = uses ref iso
vacuum :: (Root r, Binary (r Ptr), Typeable r) =>
FixFile r -> IO ()
vacuum ff@(FixFile path mv _) = withWriteLock ff runVacuum where
runVacuum = do
mval <- takeMVar mv
readFFHMV <- newMVar mval
readDB <- FixFile path readFFHMV <$> newMVar ()
(tp, th) <- openTempFile (takeDirectory path) ".ffile.tmp"
hClose th
rootMem <- readTransaction readDB (rootIso <$> RWS.get)
(FixFile _ newMV _) <- createFixFile rootMem tp
renameFile tp path
takeMVar newMV >>= putMVar mv