module Storage.Hashed.Monad
( virtualTreeIO, virtualTreeMonad
, readFile, writeFile, createDirectory, rename, unlink
, fileExists, directoryExists, exists, withDirectory
, currentDirectory
, tree, TreeState, TreeMonad, TreeIO, runTreeMonad
, PathSet, initialState, replaceItem
) where
import Prelude hiding ( readFile, writeFile )
import Storage.Hashed.AnchoredPath
import Storage.Hashed.Tree
import Storage.Hashed.Hash
import Control.Monad.Error( catchError, MonadError )
import Data.List( inits )
import Data.Int( Int64 )
import Data.Maybe( isNothing, isJust )
import qualified Data.ByteString.Lazy.Char8 as BL
import Control.Monad.RWS.Strict
import qualified Data.Set as S
type PathSet = S.Set AnchoredPath
data TreeState m = TreeState { tree :: !(Tree m)
, changed :: !PathSet
, changesize :: !Int64
, sync :: PathSet -> TreeMonad m () }
type TreeMonad m = RWST AnchoredPath () (TreeState m) m
type TreeIO = TreeMonad IO
class (Functor m, Monad m) => TreeRO m where
currentDirectory :: m AnchoredPath
withDirectory :: (MonadError e m) => AnchoredPath -> m a -> m a
expandTo :: (MonadError e m) => AnchoredPath -> m AnchoredPath
readFile :: (MonadError e m) => AnchoredPath -> m BL.ByteString
exists :: (MonadError e m) => AnchoredPath -> m Bool
directoryExists :: (MonadError e m) => AnchoredPath -> m Bool
fileExists :: (MonadError e m) => AnchoredPath -> m Bool
class TreeRO m => TreeRW m where
writeFile :: (MonadError e m) => AnchoredPath -> BL.ByteString -> m ()
createDirectory :: (MonadError e m) => AnchoredPath -> m ()
unlink :: (MonadError e m) => AnchoredPath -> m ()
rename :: (MonadError e m) => AnchoredPath -> AnchoredPath -> m ()
initialState :: Tree m -> (PathSet -> TreeMonad m ()) -> TreeState m
initialState t s = TreeState { tree = t
, changed = S.empty
, changesize = 0
, sync = s }
flush :: (Monad m) => TreeMonad m ()
flush = do
current <- get
modify $ \st -> st { changed = S.empty, changesize = 0 }
sync current (changed current)
runTreeMonad :: (Monad m) => TreeMonad m a -> TreeState m -> m (a, Tree m)
runTreeMonad action initial = do
let action' = do x <- action
flush
return x
(out, final, _) <- runRWST action' (AnchoredPath []) initial
return (out, tree final)
virtualTreeMonad :: (Monad m) => TreeMonad m a -> Tree m -> m (a, Tree m)
virtualTreeMonad action t = runTreeMonad action $ initialState t (\_ -> return ())
virtualTreeIO :: TreeIO a -> Tree IO -> IO (a, Tree IO)
virtualTreeIO = virtualTreeMonad
modifyItem :: (MonadError e m, Functor m, Monad m)
=> AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
modifyItem path item = do
path' <- (`catPaths` path) `fmap` currentDirectory
let paths = let (AnchoredPath x) = path'
in S.fromList $ map AnchoredPath $ inits x
change <- changedSize path' item
modify $ \st -> st { tree = modifyTree (tree st) path' item
, changed = (S.union paths (changed st))
, changesize = (changesize st + change) }
replaceItem :: (MonadError e m, Functor m, Monad m)
=> AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()
replaceItem path item = do
path' <- (`catPaths` path) `fmap` currentDirectory
modify $ \st -> st { tree = modifyTree (tree st) path' item }
changedSize :: (MonadError e m, Functor m, Monad m)
=> AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m Int64
changedSize path item = do
x <- get
let ch = S.member path (changed x)
size (Just (File b)) = lift (BL.length `fmap` readBlob b)
size _ = return 0
oldsize <- size $ find (tree x) path
newsize <- size item
return $! (if ch then newsize oldsize else newsize)
maybeFlush :: (Monad m) => TreeMonad m ()
maybeFlush = do x <- gets changesize
when (x > 100 * 1024 * 1024) $ flush
instance (Monad m, MonadError e m) => TreeRO (TreeMonad m) where
expandTo p =
do t <- gets tree
p' <- (`catPaths` p) `fmap` ask
let amend = do t' <- lift $ expandPath t p'
modify $ \st -> st { tree = t' }
case find t p' of
Nothing -> amend
Just (Stub _ _) -> amend
_ -> return ()
return p'
fileExists p =
do p' <- expandTo p
(isJust . (flip findFile p')) `fmap` gets tree
directoryExists p =
do p' <- expandTo p
(isJust . (flip findTree p')) `fmap` gets tree
exists p =
do p' <- expandTo p
(isJust . (flip find p')) `fmap` gets tree
readFile p =
do p' <- expandTo p
t <- gets tree
let f = findFile t p'
case f of
Nothing -> fail $ "No such file " ++ show p'
Just x -> lift (readBlob x)
currentDirectory = ask
withDirectory dir act = do
dir' <- expandTo dir
local (\old -> dir') act
instance (Functor m, Monad m, MonadError e m) => TreeRW (TreeMonad m) where
writeFile p con =
do expandTo p
modifyItem p (Just blob)
maybeFlush
where blob = File $ Blob (return con) hash
hash = NoHash
createDirectory p =
do expandTo p
modifyItem p $ Just $ SubTree emptyTree
unlink p =
do expandTo p
modifyItem p Nothing
rename from to =
do from' <- expandTo from
to' <- expandTo to
tr <- gets tree
let item = find tr from'
found_to = find tr to'
unless (isNothing found_to) $
fail $ "Error renaming: destination " ++ show to ++ " exists."
unless (isNothing item) $ do
modifyItem from Nothing
modifyItem to item