diff --git a/Storage/Hashed/Darcs.hs b/Storage/Hashed/Darcs.hs --- a/Storage/Hashed/Darcs.hs +++ b/Storage/Hashed/Darcs.hs @@ -213,9 +213,6 @@ -- | Run a 'TreeIO' @action@ in a hashed setting. The @initial@ tree is assumed -- to be fully available from the @directory@, and any changes will be written -- out to same. Please note that actual filesystem files are never removed. --- --- XXX This somehow manages to leak memory, in some usege scenarios (apparently --- not even all). The only reproducer known so far is \"gorsvet pull\". hashedTreeIO :: TreeIO a -- ^ action -> Tree IO -- ^ initial -> FilePath -- ^ directory diff --git a/Storage/Hashed/Monad.hs b/Storage/Hashed/Monad.hs --- a/Storage/Hashed/Monad.hs +++ b/Storage/Hashed/Monad.hs @@ -7,13 +7,11 @@ -- generic, and a number of actual implementations can be used. This module -- provides just 'virtualTreeIO' that never writes any changes, but may trigger -- filesystem reads as appropriate. --- --- XXX This currently does not work as advertised and the monads leak --- memory. So far, I'm at a loss why this happens. 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 @@ -31,7 +29,6 @@ import Data.Maybe( isNothing, isJust ) import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Data.ByteString.Char8( ) import Control.Monad.RWS.Strict import qualified Data.Set as S @@ -39,9 +36,9 @@ -- | 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 - , changesize :: Int64 +data TreeState m = TreeState { tree :: !(Tree m) + , changed :: !PathSet + , changesize :: !Int64 , sync :: PathSet -> TreeMonad m () } -- | A 'TreeIO' monad. A sort of like IO but it keeps a 'TreeState' around as well, @@ -106,23 +103,41 @@ virtualTreeIO :: TreeIO a -> Tree IO -> IO (a, Tree IO) virtualTreeIO = virtualTreeMonad -replaceItem :: (MonadError e m, Monad m) => AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m () +-- | Modifies an item in the current Tree. This action keeps an account of the +-- modified data, in changed and changesize, for subsequent flush +-- operations. Any modifications (as in "modifyTree") are allowed. +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) } + +-- | Replace an item with a new version without modifying the content of the +-- tree. This does not do any change tracking. Ought to be only used from a +-- 'sync' implementation for a particular storage format. The presumed use-case +-- is that an existing in-memory Blob is replaced with a one referring to an +-- on-disk file. +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 } --- | Internal. Mark a given path as changed, so the next sync will flush the --- modified object to disk. -markChanged :: (Functor m, Monad m) => AnchoredPath -> TreeMonad m () -markChanged p = do - x <- get - size <- lift $ case findFile (tree x) p of - Just b -> BL.length `fmap` readBlob 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 +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) -- | If buffers are becoming large, sync, otherwise do nothing. maybeFlush :: (Monad m) => TreeMonad m () @@ -163,8 +178,7 @@ instance (Functor m, Monad m, MonadError e m) => TreeRW (TreeMonad m) where writeFile p con = do expandTo p - replaceItem p (Just blob) - markChanged p + modifyItem p (Just blob) maybeFlush where blob = File $ Blob (return con) hash hash = NoHash -- we would like to say "sha256 con" here, but due @@ -175,11 +189,11 @@ createDirectory p = do expandTo p - replaceItem p $ Just $ SubTree emptyTree + modifyItem p $ Just $ SubTree emptyTree unlink p = do expandTo p - replaceItem p Nothing + modifyItem p Nothing rename from to = do expandTo from @@ -189,5 +203,5 @@ unless (isNothing found_to) $ fail $ "Error renaming: destination " ++ show to ++ " exists." unless (isNothing item) $ do - replaceItem to item - replaceItem from Nothing + modifyItem to item + modifyItem from Nothing 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.Tree( Tree(), TreeItem(..) , Blob(..), makeTree , list, readBlob, find, modifyTree ) -import Storage.Hashed.Monad( TreeIO, runTreeMonad, initialState, tree ) +import Storage.Hashed.Monad( TreeIO, runTreeMonad, initialState, tree, replaceItem ) import qualified Data.Set as S import Control.Monad.State( liftIO, gets, modify ) @@ -81,8 +81,7 @@ Just (File b) -> do liftIO $ readBlob b >>= BL.writeFile path let nblob = File $ Blob (BL.readFile path) NoHash - modify $ \st -> st { tree = modifyTree (tree st) c - (Just nblob) } + replaceItem c (Just nblob) Just (SubTree _) -> liftIO $ createDirectoryIfMissing False path _ -> fail $ "Foo at " ++ path diff --git a/Storage/Hashed/Tree.hs b/Storage/Hashed/Tree.hs --- a/Storage/Hashed/Tree.hs +++ b/Storage/Hashed/Tree.hs @@ -64,13 +64,15 @@ -- A Tree may have a Hash associated with it. A pair of Tree's is identical -- whenever their hashes are (the reverse need not hold, since not all Trees -- come equipped with a hash). -data Tree m = Tree { items :: M.Map Name (TreeItem m) - , listImmediate :: [(Name, TreeItem m)] +data Tree m = Tree { items :: (M.Map Name (TreeItem m)) -- | Get hash of a Tree. This is guaranteed to uniquely -- identify the Tree (including any blob content), as far as -- cryptographic hashes are concerned. Sha256 is recommended. , treeHash :: !Hash } +listImmediate :: Tree m -> [(Name, TreeItem m)] +listImmediate = M.toList . items + -- | Get a hash of a TreeItem. May be Nothing. itemHash :: TreeItem m -> Hash itemHash (File (Blob _ h)) = h @@ -84,7 +86,6 @@ emptyTree :: (Monad m) => Tree m emptyTree = Tree { items = M.empty - , listImmediate = [] , treeHash = NoHash } emptyBlob :: (Monad m) => Blob m @@ -98,12 +99,10 @@ makeTree :: (Monad m) => [(Name,TreeItem m)] -> Tree m makeTree l = Tree { items = M.fromList l - , listImmediate = l , treeHash = NoHash } makeTreeWithHash :: (Monad m) => [(Name,TreeItem m)] -> Hash -> Tree m makeTreeWithHash l h = Tree { items = M.fromList l - , listImmediate = l , treeHash = h } ----------------------------------- @@ -157,8 +156,7 @@ let orig = [ i | i <- listImmediate t, not $ isSub $ snd i ] orig_map = M.filter (not . isSub) (items t) expanded_map = M.fromList expanded - tree = t { items = M.union orig_map expanded_map - , listImmediate = orig ++ expanded } + tree = t { items = M.union orig_map expanded_map } update path tree unstub (Stub s _) = s unstub (SubTree t) = return t @@ -187,8 +185,7 @@ amend t name rest sub = do sub' <- expand' sub (AnchoredPath rest) let orig_l = [ i | i@(n',_) <- listImmediate t, name /= n' ] - tree = t { items = M.insert name (SubTree sub') (items t) - , listImmediate = (name, SubTree sub') : orig_l } + tree = t { items = M.insert name (SubTree sub') (items t) } return tree class (Monad m) => FilterTree a m where @@ -203,8 +200,7 @@ where filter' t path = let subs = (catMaybes [ (,) name `fmap` wibble path name item | (name,item) <- listImmediate t ]) - in t { items = M.mapMaybeWithKey (wibble path) $ items t - , listImmediate = subs } + in t { items = M.mapMaybeWithKey (wibble path) $ items t } wibble path name item = let npath = path `appendPath` name in if predicate npath item @@ -324,33 +320,31 @@ is_r = [ (n, r) | (n, _, Just r) <- is ] return (makeTree is_l, makeTree is_r) +-- | Modify a Tree (by replacing, or removing or adding items). modifyTree :: (Monad m) => Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m modifyTree _ (AnchoredPath []) (Just (SubTree sub)) = sub modifyTree t (AnchoredPath [n]) (Just item) = - t { items = M.insert n item (items t) - , listImmediate = (n,item) : subs + t { items = countmap items' `seq` items' , treeHash = NoHash } - where subs = [ x | x@(n', _) <- listImmediate t, n /= n' ] + where !items' = M.insert n item (items t) modifyTree t (AnchoredPath [n]) Nothing = - t { items = M.delete n (items t) - , listImmediate = subs + t { items = countmap items' `seq` items' , treeHash = NoHash } - where subs = [ x | x@(n', _) <- listImmediate t, n /= n' ] + where !items' = M.delete n (items t) modifyTree t path@(AnchoredPath (n:r)) item = - t { items = M.insert n sub (items t) - , listImmediate = (n,sub) : subs + t { items = countmap items' `seq` items' , treeHash = NoHash } - where subs = [ x | x@(n', _) <- listImmediate t, n /= n' ] - modSubtree s = modifyTree s (AnchoredPath r) item - sub = case lookup t n of - Just (SubTree s) -> SubTree $ modSubtree s + where subtree s = modifyTree s (AnchoredPath r) item + !items' = M.insert n sub (items t) + !sub = case lookup t n of + Just (SubTree s) -> SubTree $! subtree s Just (Stub s _) -> Stub (do x <- s - return $ modSubtree x) NoHash - Nothing -> SubTree $ modSubtree emptyTree + return $! subtree x) NoHash + Nothing -> SubTree $! subtree emptyTree _ -> error $ "Modify tree at " ++ show path modifyTree _ (AnchoredPath []) (Just (Stub _ _)) = @@ -360,10 +354,11 @@ modifyTree _ (AnchoredPath []) Nothing = error "Bug in descent in modifyTree." +countmap = M.fold (\_ i -> i + 1) 0 + updateSubtrees :: (Tree m -> Tree m) -> Tree m -> Tree m updateSubtrees fun t = fun $ t { items = M.mapWithKey (curry $ snd . update) $ items t - , listImmediate = map update $ listImmediate t , treeHash = NoHash } where update (k, SubTree s) = (k, SubTree $ updateSubtrees fun s) update (k, File f) = (k, File f) @@ -374,7 +369,6 @@ updateTree fun t = do immediate <- mapM update $ listImmediate t SubTree t' <- fun . SubTree $ t { items = M.fromList immediate - , listImmediate = immediate , treeHash = NoHash } return t' where update (k, SubTree tree) = (\new -> (k, SubTree new)) <$> updateTree fun tree @@ -388,7 +382,6 @@ -- any extraneous items will be ignored by the implementation). overlay :: (Functor m, Monad m) => Tree m -> Tree m -> Tree m overlay base over = Tree { items = M.fromList immediate - , listImmediate = immediate , treeHash = NoHash } where immediate = [ (n, get n) | (n, _) <- listImmediate base ] get n = case (M.lookup n $ items base, M.lookup n $ items over) of 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.4.6 +version: 0.4.7 synopsis: Hashed file storage support code. description: Support code for reading and manipulating hashed file storage