hashed-storage 0.4.6 → 0.4.7

raw patch · 5 files changed

+64/−61 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Storage/Hashed/Darcs.hs +0/−3
• Storage/Hashed/Monad.hs +40/−26
• Storage/Hashed/Plain.hs +2/−3
• Storage/Hashed/Tree.hs +21/−28
• hashed-storage.cabal +1/−1

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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