module Storage.Hashed.Monad
( hashedTreeIO, plainTreeIO, virtualTreeIO
, readFile, writeFile, createDirectory, rename, unlink
, fileExists, exists
, tree, cwd, TreeState, TreeIO
) where
import Prelude hiding ( read, catch, readFile, writeFile )
import Storage.Hashed.AnchoredPath
import Storage.Hashed.Tree
import Storage.Hashed.Utils
import Storage.Hashed.Darcs
import System.Directory( createDirectoryIfMissing, doesFileExist )
import System.FilePath( (</>) )
import Data.List( inits )
import Data.Int( Int64 )
import Data.Maybe( isNothing, isJust )
import Codec.Compression.GZip( decompress, compress )
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.ByteString.Char8 as BS
import Control.Monad.State.Strict
import qualified Data.Set as S
data TreeState = TreeState { cwd :: AnchoredPath
, tree :: Tree
, changed :: S.Set AnchoredPath
, changesize :: Int64
, sync :: TreeIO () }
type TreeIO = StateT TreeState IO
initialState :: Tree -> TreeIO () -> TreeState
initialState t s = TreeState { cwd = AnchoredPath []
, tree = t
, changed = S.empty
, changesize = 0
, sync = s }
runTreeIO :: TreeIO a -> TreeState -> IO (a, Tree)
runTreeIO action initial = do
(out, final) <- runStateT (do x <- action
get >>= sync
return x) initial
return (out, tree final)
virtualTreeIO :: TreeIO a -> Tree -> IO (a, Tree)
virtualTreeIO action t = runTreeIO action $ initialState t (return ())
fsCreateHashedFile :: FilePath -> BL.ByteString -> TreeIO ()
fsCreateHashedFile fn content =
liftIO $ do
exist <- doesFileExist fn
unless exist $ BL.writeFile fn content
replaceItemAbs :: AnchoredPath -> Maybe TreeItem -> TreeIO ()
replaceItemAbs path item =
modify $ \st -> st { tree = modifyTree (tree st) path item }
replaceItem :: AnchoredPath -> Maybe TreeItem -> TreeIO ()
replaceItem path item =
modify $ \st -> st { tree = modifyTree (tree st)
(cwd st `catPaths` path) item }
expandTo :: AnchoredPath -> TreeIO ()
expandTo p = do t <- gets tree
t' <- liftIO $ expandPath t p
modify $ \st -> st { tree = t' }
hashedTreeIO :: TreeIO a
-> Tree
-> FilePath
-> IO (a, Tree)
hashedTreeIO action t dir =
do runTreeIO action $ initialState t syncHashed
where syncHashed = do
ch <- gets changed
modify $ \st -> st { changed = S.empty }
forM_ (reverse $ S.toList ch) $ \c -> do
let path = anchorPath "" c
current <- gets tree
case find current c of
Just (File b) -> updateFile c b
Just (SubTree s) -> updateSub c s
_ -> fail $ "Bar at " ++ path
updateFile path b@(Blob _ (Just !h)) = do
let fn = dir </> BS.unpack (darcsFormatHash h)
nblob = File $ Blob (decompress `fmap` BL.readFile fn) (Just h)
newcontent <- liftIO $ compress `fmap` read b
fsCreateHashedFile fn newcontent
replaceItemAbs path (Just nblob)
updateFile path b@(Blob _ Nothing) = do
content <- liftIO $ read b
let h = hashSetSize (sha256 content) (BL.length content)
fn = dir </> BS.unpack (darcsFormatHash h)
nblob = File $ Blob (decompress `fmap` BL.readFile fn) (Just h)
newcontent = compress content
fsCreateHashedFile fn newcontent
replaceItemAbs path (Just nblob)
updateSub path s = do
let !hash = darcsTreeHash s
dirdata = darcsFormatDir s
fn = dir </> BS.unpack (darcsFormatHash $ hash)
ns = SubTree (s { treeHash = Just hash })
fsCreateHashedFile fn (compress dirdata)
replaceItemAbs path (Just ns)
plainTreeIO :: TreeIO a -> Tree -> FilePath -> IO (a, Tree)
plainTreeIO action t dir = runTreeIO action $ initialState t syncPlain
where syncPlain = do
ch <- gets changed
modify $ \st -> st { changed = S.empty }
current <- gets tree
forM_ (S.toList ch) $ \c -> do
let path = anchorPath dir c
case find current c of
Just (File b) -> do
liftIO $ read b >>= BL.writeFile path
let nblob = File $ Blob (BL.readFile path) Nothing
modify $ \st -> st { tree = modifyTree (tree st) c
(Just nblob) }
Just (SubTree _) ->
liftIO $ createDirectoryIfMissing False path
_ -> fail $ "Foo at " ++ path
fileExists :: AnchoredPath -> TreeIO Bool
fileExists p = do expandTo p
(isJust . (flip findFile p)) `fmap` gets tree
exists :: AnchoredPath -> TreeIO Bool
exists p = do expandTo p
(isJust . (flip find p)) `fmap` gets tree
readFile :: AnchoredPath -> TreeIO BL.ByteString
readFile p = do expandTo p
t <- gets tree
let f = findFile t p
case f of
Nothing -> fail $ "No such file " ++ show p
Just x -> liftIO (read x)
markChanged :: AnchoredPath -> TreeIO ()
markChanged p = do
x <- get
size <- liftIO $ case findFile (tree x) p of
Just b -> BL.length `fmap` read b
Nothing -> return 0
put $ x { changed = S.union paths (changed x)
, changesize = changesize x + size }
where paths = let (AnchoredPath x) = p
in S.fromList $ map AnchoredPath $ inits x
writeFile :: AnchoredPath -> BL.ByteString -> TreeIO ()
writeFile p con =
do replaceItem p (Just blob)
markChanged p
maybeSync
where blob = File $ Blob (return con) hash
hash = Just $ hashSetSize (sha256 con) (BL.length con)
createDirectory :: AnchoredPath -> TreeIO ()
createDirectory p = replaceItem p $ Just $ SubTree emptyTree
unlink :: AnchoredPath -> TreeIO ()
unlink p = replaceItem p Nothing
rename :: AnchoredPath -> AnchoredPath -> TreeIO ()
rename from to = do expandTo from
tr <- gets tree
let item = find tr from
unless (isNothing item) $ do
replaceItem to item
replaceItem from Nothing
maybeSync :: TreeIO ()
maybeSync = do x <- gets changesize
when (x > 16 * 1024 * 1024) $ get >>= sync