hashed-storage 0.5.2 → 0.5.3

raw patch · 10 files changed

+173/−117 lines, 10 filessetup-changedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Setup.hs +2/−1
• Storage/Hashed/Darcs.hs +13/−19
• Storage/Hashed/Diff.hs +1/−1
• Storage/Hashed/Hash.hs +5/−1
• Storage/Hashed/Index.hs +26/−20
• Storage/Hashed/Monad.hs +87/−42
• Storage/Hashed/Plain.hs +8/−15
• Storage/Hashed/Tree.hs +29/−11
• Storage/Hashed/Utils.hs +1/−6
• hashed-storage.cabal +1/−1

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

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

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

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

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

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

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

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

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

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