diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -10,7 +10,8 @@ haddockVerbosity, installVerbosity, sDistVerbosity) import Distribution.Verbosity ( Verbosity ) -import System( system, exitWith ) +import System.Exit( exitWith ) +import System.Cmd( system ) import System.FilePath( () ) -- for endianness check diff --git a/Storage/Hashed/Darcs.hs b/Storage/Hashed/Darcs.hs --- a/Storage/Hashed/Darcs.hs +++ b/Storage/Hashed/Darcs.hs @@ -143,14 +143,12 @@ do hash <- sha256 <$> readBlob blob return $ File (Blob con hash) +darcsHash (SubTree t) = return $ darcsTreeHash t +darcsHash (File blob) = sha256 <$> readBlob blob +darcshash _ = return NoHash + darcsAddMissingHashes :: (Monad m, Functor m) => Tree m -> m (Tree m) -darcsAddMissingHashes = updateTree update - where update (SubTree t) = return . SubTree $ t { treeHash = darcsTreeHash t } - update (File blob@(Blob con NoHash)) = - do hash <- sha256 <$> readBlob blob - return $ File (Blob con hash) - update (Stub _ NoHash) = fail "NoHash Stub encountered in darcsAddMissingHashes" - update x = return x +darcsAddMissingHashes = addMissingHashes darcsHash ------------------------------------------- -- Reading darcs pristine data @@ -226,29 +224,25 @@ -> FilePath -- ^ directory -> IO (a, Tree IO) hashedTreeIO action t dir = - do runTreeMonad action $ initialState t syncHashed - where syncHashed ch = do - hashed <- liftIO . darcsAddMissingHashes =<< gets tree - modify $ \st -> st { tree = hashed } - forM_ (reverse $ S.toList ch) $ \c -> do - current <- gets tree - case find current c of - Just (File b) -> updateFile c b - Just (SubTree s) -> updateSub c s - _ -> return () -- the file could have disappeared in the meantime + do runTreeMonad action $ initialState t darcsHash updateItem + where updateItem path (File b) = File <$> updateFile path b + updateItem path (SubTree s) = SubTree <$> updateSub path s + updateItem _ x = return x + updateFile path b@(Blob _ !h) = do content <- liftIO $ readBlob b let fn = dir BS8.unpack (encodeBase16 h) - nblob = File $ Blob (decompress <$> rblob) h + nblob = Blob (decompress <$> rblob) h rblob = BL.fromChunks <$> return <$> BS.readFile fn newcontent = compress content fsCreateHashedFile fn newcontent - replaceItem path (Just nblob) + return nblob updateSub path s = do let !hash = treeHash s Just dirdata = darcsFormatDir s fn = dir BS8.unpack (encodeBase16 hash) fsCreateHashedFile fn (compress dirdata) + return s -------------------------------------------------------------- -- Reading and writing packed pristine. EXPERIMENTAL. diff --git a/Storage/Hashed/Diff.hs b/Storage/Hashed/Diff.hs --- a/Storage/Hashed/Diff.hs +++ b/Storage/Hashed/Diff.hs @@ -7,7 +7,7 @@ import Data.List.LCS import Data.List ( groupBy ) -unidiff :: Tree -> Tree -> IO BL.ByteString +unidiff :: Tree IO -> Tree IO -> IO BL.ByteString unidiff l r = do (from, to) <- diffTrees l r diffs <- sequence $ zipCommonFiles diff from to diff --git a/Storage/Hashed/Hash.hs b/Storage/Hashed/Hash.hs --- a/Storage/Hashed/Hash.hs +++ b/Storage/Hashed/Hash.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} module Storage.Hashed.Hash( Hash(..), encodeBase64u, decodeBase64u , encodeBase16, decodeBase16, sha256, rawHash , match ) where @@ -13,10 +14,13 @@ import Data.Maybe( isJust, fromJust ) import Data.Char( toLower, toUpper ) +import Data.Data( Data ) +import Data.Typeable( Typeable ) + data Hash = SHA256 !BS.ByteString | SHA1 !BS.ByteString | NoHash - deriving (Show, Eq, Ord, Read) + deriving (Show, Eq, Ord, Read, Typeable, Data) base16 :: BS.ByteString -> BS.ByteString debase16 :: BS.ByteString -> Maybe BS.ByteString diff --git a/Storage/Hashed/Index.hs b/Storage/Hashed/Index.hs --- a/Storage/Hashed/Index.hs +++ b/Storage/Hashed/Index.hs @@ -7,7 +7,7 @@ -- index. Please note that tracking index validity is out of scope for this -- library: this is responsibility of your application. It is advisable that in -- your validity tracking code, you also check for format validity (see --- "indexFormatValid") and scrap and re-create index when needed. +-- 'indexFormatValid') and scrap and re-create index when needed. -- -- The index is a binary file that overlays a hashed tree over the working -- copy. This means that every working file and directory has an entry in the @@ -17,7 +17,7 @@ -- -- There are two entry types, a file entry and a directory entry. Both have a -- common binary format (see 'Item'). The on-disk format is best described by --- 'peekItem'. +-- the section /Index format/ below. -- -- For each file, the index has a copy of the file's last modification -- timestamp taken at the instant when the hash has been computed. This means @@ -35,6 +35,24 @@ -- when a file in a directory changes hash, this triggers recomputation of all -- of its parent directory hashes; moreover this is done efficiently -- each -- directory is updated at most once during an update run. +-- +-- /Index format/ +-- +-- The Index is organised into \"lines\" where each line describes a single +-- indexed item. Cf. 'Item'. +-- +-- The first word on the index \"line\" is the length of the file path (which is +-- the only variable-length part of the line). Then comes the path itself, then +-- fixed-length hash (sha256) of the file in question, then two words, one for +-- size and one "aux", which is used differently for directories and for files. +-- +-- With directories, this aux holds the offset of the next sibling line in the +-- index, so we can efficiently skip reading the whole subtree starting at a +-- given directory (by just seeking aux bytes forward). The lines are +-- pre-ordered with respect to directory structure -- the directory comes first +-- and after it come all its items. Cf. 'readIndex''. +-- +-- For files, the aux field holds a timestamp. module Storage.Hashed.Index( readIndex, updateIndexFrom, indexFormatValid , updateIndex , Index, filter ) @@ -147,7 +165,7 @@ -- the item can be filled out using 'update'. createItem :: ItemType -> AnchoredPath -> ForeignPtr () -> Int -> IO Item createItem typ apath fp off = - do let dsc = BS.concat [ BSC.singleton $ (typ == TreeType) ? ('D', 'F') + do let dsc = BS.concat [ BSC.singleton $ if typ == TreeType then 'D' else 'F' , flatten apath , BS.singleton 0 ] (dsc_fp, dsc_start, dsc_len) = toForeignPtr dsc @@ -159,22 +177,10 @@ (fromIntegral dsc_len) peekItem fp off --- | Read the on-disk representation into internal data structure. The Index is --- organised into "lines" where each line describes a single indexed --- item. Cf. 'Item'. --- --- The first word on the index "line" is the length of the file path (which is --- the only variable-length part of the line). Then comes the path itself, then --- fixed-length hash (sha256) of the file in question, then two words, one for --- size and one "aux", which is used differently for directories and for files. --- --- With directories, this aux holds the offset of the next sibling line in the --- index, so we can efficiently skip reading the whole subtree starting at a --- given directory (by just seeking aux bytes forward). The lines are --- pre-ordered with respect to directory structure -- the directory comes first --- and after it come all its items. Cf. 'readIndex''. +-- | Read the on-disk representation into internal data structure. -- --- For files, the aux field holds a timestamp. +-- See the module-level section /Index format/ for details on how the index +-- is structured. peekItem :: ForeignPtr () -> Int -> IO Item peekItem fp off = withForeignPtr fp $ \p -> do @@ -276,7 +282,7 @@ nullleaf = null inferiors && oldhash == nullsha nullsha = SHA256 (BS.replicate 32 0) tree' = makeTree [ (n, fromJust $ treeitem s) | (n, s) <- inferiors, isJust $ treeitem s ] - treehash = we_changed ? (hashtree index tree', oldhash) + treehash = if we_changed then hashtree index tree' else oldhash tree = tree' { treeHash = treehash } when we_changed $ updateItem item 0 treehash @@ -303,7 +309,7 @@ updateTime item mtime' return $ Result { changed = not exists || we_changed , next = start state + itemNext item - , treeitem = exists ? (Just $ File $ Blob readblob hash, Nothing) + , treeitem = if exists then Just $ File $ Blob readblob hash else Nothing , resitem = item } updateIndex :: Index -> IO (Tree IO) diff --git a/Storage/Hashed/Monad.hs b/Storage/Hashed/Monad.hs --- a/Storage/Hashed/Monad.hs +++ b/Storage/Hashed/Monad.hs @@ -9,11 +9,11 @@ -- filesystem reads as appropriate. module Storage.Hashed.Monad ( virtualTreeIO, virtualTreeMonad - , readFile, writeFile, createDirectory, rename, unlink + , readFile, writeFile, createDirectory, rename, copy, unlink , fileExists, directoryExists, exists, withDirectory , currentDirectory , tree, TreeState, TreeMonad, TreeIO, runTreeMonad - , PathSet, initialState, replaceItem + , initialState, replaceItem ) where import Prelude hiding ( readFile, writeFile ) @@ -23,23 +23,27 @@ import Storage.Hashed.Hash import Control.Monad.Error( catchError, MonadError ) +import Control.Applicative( (<$>) ) -import Data.List( inits ) +import Data.List( sortBy ) 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 +import qualified Data.Map as M -type PathSet = S.Set AnchoredPath +type Changed = M.Map AnchoredPath (Int64, Int64) -- size, age -- | Internal state of the 'TreeIO' monad. Keeps track of the current Tree -- content, unsync'd changes and a current working directory (of the monad). data TreeState m = TreeState { tree :: !(Tree m) - , changed :: !PathSet + , changed :: !Changed , changesize :: !Int64 - , sync :: PathSet -> TreeMonad m () } + , maxage :: !Int64 + , updateHash :: TreeItem m -> m Hash + , update :: AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m) } -- | A 'TreeIO' monad. A sort of like IO but it keeps a 'TreeState' around as well, -- which is a sort of virtual filesystem. Depending on how you obtained your @@ -71,34 +75,44 @@ createDirectory :: (MonadError e m) => AnchoredPath -> m () unlink :: (MonadError e m) => AnchoredPath -> m () rename :: (MonadError e m) => AnchoredPath -> AnchoredPath -> m () + copy :: (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 } +initialState :: Tree m -> (TreeItem m -> m Hash) + -> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)) -> TreeState m +initialState t uh u = TreeState { tree = t + , changed = M.empty + , changesize = 0 + , updateHash = uh + , maxage = 0 + , update = u } -flush :: (Monad m) => TreeMonad m () -flush = do - current <- get - modify $ \st -> st { changed = S.empty, changesize = 0 } - sync current (changed current) +flush :: (Functor m, MonadError e m, Monad m) => TreeMonad m () +flush = do current <- get + changed' <- map fst <$> M.toList <$> gets changed + dirs' <- gets tree >>= \t -> return [ path | (path, SubTree s) <- list t ] + modify $ \st -> st { changed = M.empty, changesize = 0 } + forM_ (changed' ++ dirs' ++ [AnchoredPath []]) flushItem -runTreeMonad :: (Monad m) => TreeMonad m a -> TreeState m -> m (a, Tree m) +runTreeMonad' :: (Functor m, MonadError e m, Monad m) => TreeMonad m a -> TreeState m -> m (a, Tree m) +runTreeMonad' action initial = do + (out, final, _) <- runRWST action (AnchoredPath []) initial + return (out, tree final) + +runTreeMonad :: (Functor m, MonadError e m, 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) + runTreeMonad' action' initial -- | Run a TreeIO action without storing any changes. This is useful for -- running monadic tree mutations for obtaining the resulting Tree (as opposed -- to their effect of writing a modified tree to disk). The actions can do both -- read and write -- reads are passed through to the actual filesystem, but the -- writes are held in memory in a form of modified Tree. -virtualTreeMonad :: (Monad m) => TreeMonad m a -> Tree m -> m (a, Tree m) -virtualTreeMonad action t = runTreeMonad action $ initialState t (\_ -> return ()) +virtualTreeMonad :: (Functor m, MonadError e m, Monad m) => TreeMonad m a -> Tree m -> m (a, Tree m) +virtualTreeMonad action t = runTreeMonad' action $ + initialState t (\_ -> return NoHash) (\_ x -> return x) virtualTreeIO :: TreeIO a -> Tree IO -> IO (a, Tree IO) virtualTreeIO = virtualTreeMonad @@ -110,17 +124,24 @@ => 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 + age <- gets maxage + changed' <- gets changed + let getsize (Just (File b)) = lift (BL.length `fmap` readBlob b) + getsize _ = return 0 + size <- getsize item + let change = case M.lookup path' changed' of + Nothing -> size + Just (oldsize, _) -> size - oldsize + modify $ \st -> st { tree = modifyTree (tree st) path' item - , changed = (S.union paths (changed st)) + , changed = M.insert path' (size, age) (changed st) + , maxage = age + 1 , changesize = (changesize st + change) } renameChanged from to = modify $ \st -> st { changed = rename' $ changed st } - where rename' = S.fromList . map renameone . S.toList - renameone x | from `isPrefix` x = to `catPaths` relative from x - | otherwise = x + where rename' = M.fromList . map renameone . M.toList + renameone (x, d) | from `isPrefix` x = (to `catPaths` relative from x, d) + | otherwise = (x, d) relative (AnchoredPath from) (AnchoredPath x) = AnchoredPath $ drop (length from) x -- | Replace an item with a new version without modifying the content of the @@ -134,21 +155,38 @@ 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) +flushItem :: forall e m. (Monad m, MonadError e m, Functor m) => AnchoredPath -> TreeMonad m () +flushItem path = + do current <- gets tree + case find current path of + Nothing -> return () -- vanished, do nothing + Just x -> do y <- fixHash x + new <- gets update >>= ($ y) . ($ path) + replaceItem path (Just new) + where fixHash :: TreeItem m -> TreeMonad m (TreeItem m) + fixHash f@(File (Blob con NoHash)) = do + hash <- gets updateHash >>= \x -> lift $ x f + return $ File $ Blob con hash + fixHash (SubTree s) | treeHash s == NoHash = + gets updateHash >>= \f -> SubTree <$> lift (addMissingHashes f s) + fixHash x = return x + -- | If buffers are becoming large, sync, otherwise do nothing. -maybeFlush :: (Monad m) => TreeMonad m () -maybeFlush = do x <- gets changesize - when (x > 100 * 1024 * 1024) $ flush +flushSome :: (Monad m, MonadError e m, Functor m) => TreeMonad m () +flushSome = do x <- gets changesize + when (x > megs 100) $ do + remaining <- go =<< sortBy age <$> M.toList <$> gets changed + modify $ \s -> s { changed = M.fromList remaining } + where go [] = return [] + go ((path, (size, age_)):chs) = do + x <- (\s -> s - size) <$> gets changesize + flushItem path + modify $ \s -> s { changesize = x } + if (x > megs 50) then go chs + else return $ chs + megs = (* (1024 * 1024)) + age (_, (_, a)) (_, (_, b)) = compare a b instance (Monad m, MonadError e m) => TreeRO (TreeMonad m) where expandTo p = @@ -191,7 +229,7 @@ writeFile p con = do expandTo p modifyItem p (Just blob) - maybeFlush + flushSome where blob = File $ Blob (return con) hash hash = NoHash -- we would like to say "sha256 con" here, but due -- to strictness of Hash in Blob, this would often @@ -219,3 +257,10 @@ modifyItem from Nothing modifyItem to item renameChanged from to + + copy from to = + do from' <- expandTo from + to' <- expandTo to + tr <- gets tree + let item = find tr from' + unless (isNothing item) $ modifyItem to item diff --git a/Storage/Hashed/Plain.hs b/Storage/Hashed/Plain.hs --- a/Storage/Hashed/Plain.hs +++ b/Storage/Hashed/Plain.hs @@ -28,7 +28,7 @@ import Storage.Hashed.Hash( Hash( NoHash) ) import Storage.Hashed.Tree( Tree(), TreeItem(..) , Blob(..), makeTree - , list, readBlob, find, modifyTree ) + , list, readBlob, find, modifyTree, expand ) import Storage.Hashed.Monad( TreeIO, runTreeMonad, initialState, tree, replaceItem ) import qualified Data.Set as S import Control.Monad.State( liftIO, gets, modify ) @@ -59,7 +59,7 @@ writePlainTree :: Tree IO -> FilePath -> IO () writePlainTree t dir = do createDirectoryIfMissing True dir - forM_ (list t) write + expand t >>= mapM_ write . list where write (p, File b) = write' p b write (p, SubTree _) = createDirectoryIfMissing True (anchorPath dir p) @@ -72,17 +72,10 @@ -- reading and put it back into st (ie. replace the in-memory Blobs with normal -- ones, so the memory can be GCd). plainTreeIO :: TreeIO a -> Tree IO -> FilePath -> IO (a, Tree IO) -plainTreeIO action t dir = runTreeMonad action $ initialState t syncPlain - where syncPlain ch = do - current <- gets tree - forM_ (S.toList ch) $ \c -> do - let path = anchorPath dir c - case find current c of - Just (File b) -> do - liftIO $ readBlob b >>= BL.writeFile path - let nblob = File $ Blob (BL.readFile path) NoHash - replaceItem c (Just nblob) - Just (SubTree _) -> - liftIO $ createDirectoryIfMissing False path - _ -> fail $ "Foo at " ++ path +plainTreeIO action t dir = runTreeMonad action $ initialState t (\_ -> return NoHash) updatePlain + where updatePlain path (File b) = + do liftIO $ createDirectoryIfMissing True (anchorPath "" $ parent path) + liftIO $ readBlob b >>= BL.writeFile (anchorPath "" path) + return $ File $ Blob (BL.readFile $ anchorPath "" path) NoHash + updatePlain _ x = return x diff --git a/Storage/Hashed/Tree.hs b/Storage/Hashed/Tree.hs --- a/Storage/Hashed/Tree.hs +++ b/Storage/Hashed/Tree.hs @@ -25,7 +25,8 @@ , FilterTree(..), restrict -- * Manipulating trees. - , modifyTree, updateTree, updateSubtrees, overlay ) where + , modifyTree, updateTree, partiallyUpdateTree, updateSubtrees, overlay + , addMissingHashes ) where import Prelude hiding( lookup, filter, all ) import Storage.Hashed.AnchoredPath @@ -344,11 +345,11 @@ _ -> error $ "Modify tree at " ++ show path go _ (AnchoredPath []) (Just (Stub _ _)) = - error "Bug in descent in modifyTree." + error $ "BUG: Error descending in modifyTree, path = " ++ show p_ go _ (AnchoredPath []) (Just (File _)) = - error "Bug in descent in modifyTree." + error $ "BUG: Error descending in modifyTree, path = " ++ show p_ go _ (AnchoredPath []) Nothing = - error "Bug in descent in modifyTree." + error $ "BUG: Error descending in modifyTree, path = " ++ show p_ countmap = M.fold (\_ i -> i + 1) 0 @@ -362,14 +363,23 @@ -- | Does /not/ expand the tree. updateTree :: (Functor m, Monad m) => (TreeItem m -> m (TreeItem m)) -> Tree m -> m (Tree m) -updateTree fun t = do - immediate <- mapM update $ listImmediate t - SubTree t' <- fun . SubTree $ t { items = M.fromList immediate - , treeHash = NoHash } - return t' - where update (k, SubTree tree) = (\new -> (k, SubTree new)) <$> updateTree fun tree - update (k, item) = (\new -> (k, new)) <$> fun item +updateTree fun t = partiallyUpdateTree fun (\_ _ -> True) t +-- | Does /not/ expand the tree. +partiallyUpdateTree :: (Functor m, Monad m) => (TreeItem m -> m (TreeItem m)) + -> (AnchoredPath -> TreeItem m -> Bool) -> Tree m -> m (Tree m) +partiallyUpdateTree fun pred t' = go (AnchoredPath []) t' + where go path t = do + items' <- M.fromList <$> mapM (maybeupdate path) (listImmediate t) + SubTree t' <- fun . SubTree $ t { items = items' + , treeHash = NoHash } + return t' + maybeupdate path (k, item) = case pred (path `appendPath` k) item of + True -> update (path `appendPath` k) (k, item) + False -> return (k, item) + update path (k, SubTree tree) = (\new -> (k, SubTree new)) <$> go path tree + update _ (k, item) = (\new -> (k, new)) <$> fun item + -- | Lay one tree over another. The resulting Tree will look like the base (1st -- parameter) Tree, although any items also present in the overlay Tree will be -- taken from the overlay. It is not allowed to overlay a different kind of an @@ -391,6 +401,14 @@ (Just x, _) -> x (_, _) -> error $ "Unexpected case in overlay at get " ++ show n ++ "." +addMissingHashes :: (Monad m, Functor m) => (TreeItem m -> m Hash) -> Tree m -> m (Tree m) +addMissingHashes make = updateTree update -- use partiallyUpdateTree here + where update (SubTree t) = make (SubTree t) >>= \x -> return $ SubTree (t { treeHash = x }) + update (File blob@(Blob con NoHash)) = + do hash <- make $ File blob + return $ File (Blob con hash) + update (Stub s NoHash) = update . SubTree =<< s + update x = return x ------ Private utilities shared among multiple functions. -------- diff --git a/Storage/Hashed/Utils.hs b/Storage/Hashed/Utils.hs --- a/Storage/Hashed/Utils.hs +++ b/Storage/Hashed/Utils.hs @@ -68,15 +68,10 @@ `catch` \(_::SomeException) -> return ()) . const --- Ternary kind of operator. Just a concise way to write if. -(?) :: Bool -> (a, a) -> a -w ? (a,b) = if w then a else b -{-# INLINE (?) #-} - makeAbsolute :: FilePath -> IO FilePath makeAbsolute p = do cwd <- getCurrentDirectory - return $! isAbsolute p ? (p, cwd p) + return $! if isAbsolute p then p else cwd p -- Wow, unsafe. unsafePokeBS :: BS8.ByteString -> BS8.ByteString -> IO () diff --git a/hashed-storage.cabal b/hashed-storage.cabal --- a/hashed-storage.cabal +++ b/hashed-storage.cabal @@ -1,5 +1,5 @@ name: hashed-storage -version: 0.5.2 +version: 0.5.3 synopsis: Hashed file storage support code. description: Support code for reading and manipulating hashed file storage