packages feed

hashed-storage 0.3.2 → 0.3.3

raw patch · 9 files changed

+357/−162 lines, 9 filesdep −binarydep −bytestring-mmap

Dependencies removed: binary, bytestring-mmap

Files

Storage/Hashed.hs view
@@ -3,9 +3,9 @@     --     -- | Please note that Trees obtained this way will contain Stub     -- items. These need to be executed (they are IO actions) in order to be-    -- accessed. Use 'unfold' to do this. However, many operations are+    -- accessed. Use 'expand' to do this. However, many operations are     -- perfectly fine to be used on a stubbed Tree (and it is often more-    -- efficient to do everything that can be done before unfolding a Tree).+    -- efficient to do everything that can be done before expanding a Tree).     readPlainTree, readDarcsHashed, readDarcsPristine      -- * Blob access.@@ -26,6 +26,7 @@ import qualified Data.ByteString.Lazy.Char8 as BL import Storage.Hashed.AnchoredPath import Storage.Hashed.Utils+import Storage.Hashed.Darcs import Storage.Hashed.Tree( Tree( listImmediate ), TreeItem(..), ItemType(..)                           , Blob(..), emptyTree, makeTree, makeTreeWithHash                           , list, read, find )
Storage/Hashed/AnchoredPath.hs view
@@ -49,14 +49,10 @@  -- | List all parents of a given path. foo/bar/baz -> [foo, foo/bar] parents :: AnchoredPath -> [AnchoredPath]-parents (AnchoredPath x) =-    case x of-      [] -> []-      [_] -> [AnchoredPath []]-      _ -> map AnchoredPath $ tail $ inits (init x)+parents (AnchoredPath x) = map AnchoredPath . inits . init $ x  -- | Take a "root" directory and an anchored path and produce a full--- 'FilePath'. Moreover, you can use anchorPath "" to get a relative+-- 'FilePath'. Moreover, you can use @anchorPath \"\"@ to get a relative -- 'FilePath'. anchorPath :: FilePath -> AnchoredPath -> FilePath anchorPath dir p = dir </> BS.unpack (flatten p)
+ Storage/Hashed/Darcs.hs view
@@ -0,0 +1,55 @@+-- | A few darcs-specific utility functions. These are used for reading and+-- writing darcs and darcs-compatible hashed trees.+module Storage.Hashed.Darcs where++import Storage.Hashed.Tree hiding ( read )+import Storage.Hashed.AnchoredPath+import Storage.Hashed.Utils++import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as BL++import Data.List( sortBy )+import Data.Char( chr )++darcsFormatSize :: (Num a) => a -> BS.ByteString+darcsFormatSize s = BS.pack $ replicate (10 - length n) '0' ++ n+    where n = show s++darcsFormatHash :: Hash -> BS.ByteString+darcsFormatHash (Hash (Just s, h)) =+    BS.concat [ darcsFormatSize s+              , BS.singleton '-'+              , h ]+darcsFormatHash (Hash (Nothing, h)) = h++darcsDecodeWhite :: String -> FilePath+darcsDecodeWhite ('\\':cs) =+    case break (=='\\') cs of+    (theord, '\\':rest) ->+        chr (read theord) : darcsDecodeWhite rest+    _ -> error "malformed filename"+darcsDecodeWhite (c:cs) = c: darcsDecodeWhite cs+darcsDecodeWhite "" = ""++darcsFormatDir :: Tree -> BL.ByteString+darcsFormatDir t = BL.fromChunks $ concatMap string+                     (sortBy cmp $ listImmediate t)+    where cmp (Name a, _) (Name b, _) = compare a b+          string (Name name, item) =+              [ case item of+                  File _ -> BS.pack "file:\n"+                  SubTree _ -> BS.pack "directory:\n"+                  Stub _ _ ->+                      error "Trees with stubs not supported in darcsFormatDir.",+                name, BS.singleton '\n',+                case itemHash item of+                  Nothing -> error $ "darcsFormatDir: missing hash on "+                                 ++ show name+                  Just h -> darcsFormatHash h,+                BS.singleton '\n' ]++-- | Compute a darcs-compatible hash value for a tree-like structure.+darcsTreeHash :: Tree -> Hash+darcsTreeHash d = hashSetSize (sha256 bl) $ BL.length bl+    where bl = darcsFormatDir d
Storage/Hashed/Index.hs view
@@ -1,7 +1,36 @@ {-# LANGUAGE ScopedTypeVariables #-} -module Storage.Hashed.Index where+-- | This module contains plain tree indexing code. +--+-- 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+-- index, that contains its path and hash and validity data. The validity data+-- is a "last seen" timestamp plus the file size. The file hashes are sha256's+-- of the file's content.+--+-- 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'.+--+-- For each file, the index has a copy of the timestamp taken at the instant+-- when the hash has been computed. This means that when file size and+-- timestamp of a file in working copy matches those in the index, we assume+-- that the hash stored in the index for given file is valid. These hashes are+-- then exposed in the resulting 'Tree' object, and can be leveraged by eg.+-- 'diffTrees' to compare many files quickly.+--+-- You may have noticed that we also keep hashes of directories. These are+-- assumed to be valid whenever the complete subtree has had valid+-- timestamps. At any point, as soon as a size or timestamp mismatch is found,+-- the working file in question is opened, its hash (and timestamp and size) is+-- recomputed and updated in-place in the index file (everything lives at a+-- fixed offset and is fixed size, so this isn't an issue). This is also true+-- of directories: 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 a run. +module Storage.Hashed.Index( readIndex, updateIndexFrom ) where+ import Prelude hiding ( lookup, readFile, writeFile, catch ) import Storage.Hashed.Utils import Storage.Hashed.Tree@@ -28,18 +57,19 @@ import Foreign.ForeignPtr import Foreign.Ptr -hashToString :: Hash -> String-hashToString (Hash (_,s)) = BS.unpack s- -------------------------- -- Indexed trees -- --- |A recursive-ish index structure (as opposed to flat-ish structure, which is--- used by git... It turns out that it's hard to efficiently read a flat index+-- | Description of a a single indexed item. The structure itself does not+-- contain any data, just pointers to the underlying mmap (bytestring is a+-- pointer + offset + length).+--+-- The structure is recursive-ish (as opposed to flat-ish structure, which is+-- used by git...) It turns out that it's hard to efficiently read a flat index -- with our internal data structures -- we need to turn the flat index into a--- recursive Tree object, which is rather expensive...). As a bonus, we can--- also efficiently implement subtree queries this way (cf. 'readIndex').+-- recursive Tree object, which is rather expensive... As a bonus, we can also+-- efficiently implement subtree queries this way (cf. 'readIndex'). data Item = Item { iPath :: BS.ByteString                  , iName :: BS.ByteString                  , iHash :: BS.ByteString@@ -56,6 +86,10 @@ itemIsDir :: Item -> Bool itemIsDir i = BS.last (iPath i) == '/' +-- | Lay out the basic index item structure in memory. The memory location is+-- given by a ForeignPointer () and an offset. The path and type given are+-- written out, and a corresponding Item is given back. The remaining bits of+-- the item can be filled out using 'update'. createItem :: ItemType -> AnchoredPath -> ForeignPtr () -> Int -> IO Item createItem typ path fp off =  do let name = BS.concat [ flatten path,@@ -70,16 +104,34 @@                       (fromIntegral namel)                peekItem fp off Nothing +-- | 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''.+--+-- For files, the aux field holds a timestamp. peekItem :: ForeignPtr () -> Int -> Maybe Int -> IO Item peekItem fp off dirlen =     withForeignPtr fp $ \p -> do       nl' :: Int32 <- peekByteOff p off       let nl = fromIntegral nl'           path = fromForeignPtr (castForeignPtr fp) (off + 4) (nl - 1)+          path_noslash = (BS.last path == '/') ? (BS.init path, path)           hash = fromForeignPtr (castForeignPtr fp) (off + 4 + nl) 64-          name' = snd $ BS.splitAt (fromJust dirlen) path-          name = (BS.last name' == '/') ? (BS.init name', name')-      return $! Item { iName = isJust dirlen ? (name, undefined)+          name = snd $ case dirlen of+                         Just split -> BS.splitAt split path_noslash+                         Nothing -> BS.spanEnd (/= '/') path_noslash+      return $! Item { iName = name                      , iPath = path                      , iHash = hash                      , iSize = plusPtr p (off + 4 + nl + 64)@@ -89,7 +141,7 @@ -- | Update an existing item with new hash and optionally mtime (give Nothing -- when updating directory entries). update :: Item -> Maybe EpochTime -> Hash -> IO ()-update item mtime (Hash (Just size,hash)) =+update item mtime (Hash (Just size, hash)) =     do poke (iSize item) size        pokeBS (iHash item) hash        when (isJust mtime) $ poke (iAux item)@@ -100,25 +152,28 @@ iHash' i = do size <- peek $ iSize i               return $ hashSetSize (Hash (undefined, iHash i)) size -mmapIndex :: forall a. Int -> IO (ForeignPtr a, Int)-mmapIndex req_size = do-  exist <- doesFileExist "_darcs/index"-  act_size <- if exist then fileSize `fmap` getFileStatus "_darcs/index"+-- | Gives a ForeignPtr to mmapped index, which can be used for reading and+-- updates.+mmapIndex :: forall a. FilePath -> Int -> IO (ForeignPtr a, Int)+mmapIndex indexpath req_size = do+  exist <- doesFileExist indexpath+  act_size <- if exist then fileSize `fmap` getFileStatus indexpath                        else return 0   let size = fromIntegral $                  if req_size > 0 then fromIntegral req_size else act_size   case size of     0 -> return (castForeignPtr nullForeignPtr, size)-    _ -> do (x, _) <- mmapFileForeignPtr "_darcs/index"+    _ -> do (x, _) <- mmapFileForeignPtr indexpath                                          ReadWrite (Just (0, size))             return (x, size) --- |See 'readIndex'. This version also gives a map from paths to items, so the+-- | See 'readIndex'. This version also gives a map from paths to items, so the -- extra per-item data can be used (hash and mtime) directly. The map is in a--- form of 'IORef', since the data is not available until the tree is unfolded.-readIndex' :: IO (Tree, IORef (M.Map AnchoredPath Item))-readIndex' = do-  (mmap, mmap_size) <- mmapIndex 0+-- form of 'IORef', since the data is not available until the tree is expanded.+readIndex' :: FilePath -> (Tree -> Hash)+           -> IO (Tree, IORef (M.Map AnchoredPath Item))+readIndex' indexpath hashtree = do+  (mmap, mmap_size) <- mmapIndex indexpath 0   dirs_changed <- newIORef S.empty   item_map <- newIORef M.empty   let readItem :: AnchoredPath -> Int -> Int -> IO (Item, Maybe TreeItem)@@ -150,7 +205,7 @@                            | otherwise = fail "Offset mismatch."                  updateHash path tree =                      do changed <- S.member path `fmap` readIORef dirs_changed-                        let hash = darcsTreeHash tree+                        let hash = hashtree tree                             tree' = tree { treeHash = Just hash }                         if changed                            then do update item Nothing hash@@ -186,32 +241,33 @@          return (tree { treeHash = h }, item_map)     else return (emptyTree, item_map) --- |Read an index and build up a 'Tree' object from it, referring to current+-- | Read an index and build up a 'Tree' object from it, referring to current -- working directory. Any parts of the index that are out of date are updated--- in-place. The result is always an up-to-date index. Also, the 'Tree' is stubby--- and only the pieces of the index that are unfolded will be actually updated!--- To implement a subtree query, you can use 'Tree.filter' and then unfold the--- result. Otherwise just unfold the whole tree to avoid unexpected problems.-readIndex :: IO Tree-readIndex = fst `fmap` readIndex'+-- in-place. The result is always an up-to-date index. Also, the 'Tree' is+-- stubby and only the pieces of the index that are expanded will be actually+-- updated!  To implement a subtree query, you can use 'Tree.filter' and then+-- expand the result. Otherwise just expand the whole tree to avoid unexpected+-- problems.+readIndex :: FilePath -> (Tree -> Hash) -> IO Tree+readIndex x y = fst `fmap` readIndex' x y -- pointfree is uglier --- |Will add and remove files in index to make it match the 'Tree' object given--- (it is an error for the 'Tree' to contain a file or directory that does not--- exist in a plain form under 'FilePath').-updateIndexFrom :: Tree -> IO Tree-updateIndexFrom ref =-    do (oldidx', item_map') <- readIndex'-       unfold oldidx'+-- | Will add and remove files in index to make it match the 'Tree' object+-- given (it is an error for the 'Tree' to contain a file or directory that+-- does not exist in a plain form in current working directory).+updateIndexFrom :: FilePath -> (Tree -> Hash) -> Tree -> IO Tree+updateIndexFrom indexpath hashtree ref =+    do (oldidx', item_map') <- readIndex' indexpath hashtree+       expand oldidx'        item_map <- readIORef item_map'-       reference <- unfold ref+       reference <- expand ref        let typeLen TreeType = 1            typeLen BlobType = 0            paths = [ (p, itemType i) | (p, i) <- list reference ]            len = 87 + sum [ typeLen typ + 84 + 1 + length (anchorPath "" p)                                 | (p, typ) <- paths ]-       exist <- doesFileExist "_darcs/index"-       when exist $ removeFile "_darcs/index" -- to avoid clobbering oldidx-       (mmap, _) <- mmapIndex len+       exist <- doesFileExist indexpath+       when exist $ removeFile indexpath -- to avoid clobbering oldidx+       (mmap, _) <- mmapIndex indexpath len        let create (File _) path off =                do i <- createItem BlobType path mmap off                   case M.lookup path item_map of@@ -236,4 +292,4 @@            create (Stub _ _) path _ =                fail $ "Cannot create index from stubbed Tree at " ++ show path        create (SubTree reference) (AnchoredPath []) 0-       readIndex+       readIndex indexpath hashtree
Storage/Hashed/Monad.hs view
@@ -9,7 +9,8 @@ module Storage.Hashed.Monad     ( hashedTreeIO, plainTreeIO, virtualTreeIO     , readFile, writeFile, createDirectory, rename, unlink-    , tree, cwd, TreeState+    , fileExists, exists+    , tree, cwd, TreeState, TreeIO     ) where  import Prelude hiding ( read, catch, readFile, writeFile )@@ -17,12 +18,13 @@ 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 )+import Data.Maybe( isNothing, isJust )  import Codec.Compression.GZip( decompress, compress ) @@ -87,9 +89,9 @@     modify $ \st -> st { tree = modifyTree (tree st)                                            (cwd st `catPaths` path) item } -unfoldTo :: AnchoredPath -> TreeIO ()-unfoldTo p = do t <- gets tree-                t' <- liftIO $ unfoldPath t p+expandTo :: AnchoredPath -> TreeIO ()+expandTo p = do t <- gets tree+                t' <- liftIO $ expandPath t p                 modify $ \st -> st { tree = t' }  -- | Run a 'TreeIO' @action@ in a hashed setting. The @initial@ tree is assumed@@ -158,9 +160,19 @@                       liftIO $ createDirectoryIfMissing False path                   _ -> fail $ "Foo at " ++ path +-- | Check for existence of a file.+fileExists :: AnchoredPath -> TreeIO Bool+fileExists p = do expandTo p+                  (isJust . (flip findFile p)) `fmap` gets tree++-- | Check for existence of a node (file or directory, doesn't matter).+exists :: AnchoredPath -> TreeIO Bool+exists p = do expandTo p+              (isJust . (flip find p)) `fmap` gets tree+ -- | Grab content of a file in the current Tree at the given path. readFile :: AnchoredPath -> TreeIO BL.ByteString-readFile p = do unfoldTo p+readFile p = do expandTo p                 t <- gets tree                 let f = findFile t p                 case f of@@ -197,7 +209,7 @@ unlink p = replaceItem p Nothing  rename :: AnchoredPath -> AnchoredPath -> TreeIO ()-rename from to = do unfoldTo from+rename from to = do expandTo from                     tr <- gets tree                     let item = find tr from                     unless (isNothing item) $ do
+ Storage/Hashed/Test.hs view
@@ -0,0 +1,123 @@+module Storage.Hashed.Test where++import Prelude hiding ( read )+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.ByteString.Char8 as BS+import Test.HUnit+import System.Process+import Control.Monad( forM_ )+import Data.Maybe+import Data.List( (\\), sort )+import Storage.Hashed+import Storage.Hashed.AnchoredPath+import Storage.Hashed.Tree+import Storage.Hashed.Index+import Storage.Hashed.Utils+import Storage.Hashed.Darcs++testsDarcsBasic :: Test+testsDarcsBasic =+    TestList [ TestLabel "have_files" have_files+             , TestLabel "have_pristine_files" have_pristine_files+             , TestLabel "darcs_manifest" darcs_manifest+             , TestLabel "darcs_contents" darcs_contents ]+    where+      files = [ floatPath "hashed-storage.cabal"+              , floatPath "Storage/Hashed.hs"+              , floatPath "Storage/Hashed/Index.hs" ]+      check_file t f = assertBool+                       ("path " ++ show f ++ " is in tree")+                       (isJust $ find t f)+      check_files = forM_ files . check_file+      have_files = TestCase $ readPlainTree "." >>= expand >>= check_files+      have_pristine_files = TestCase $+         readDarcsPristine "." >>= expand >>= check_files++      -- NB. If darcs starts using hashed-storage internally, the following+      -- tests become useless, since they check our code against darcs.+      darcs_manifest = TestCase $ do+        f <- lines `fmap` readProcess "darcs" ["show", "files" ] ""+        t <- readDarcsPristine "." >>= expand+        forM_ (f \\ ["."]) (\x -> check_file t (floatPath x))+        forM_ (list t)+              (\x -> assertBool (show (fst x) ++ " is in darcs show files") $+                     anchorPath "." (fst x) `elem` f)+      darcs_contents = TestCase $ do+        t <- readDarcsPristine "." >>= expand+        sequence_ [+          do our <- read b+             darcs <- readProcess "darcs" [ "show", "contents",+                                            anchorPath "." p ] ""+             assertEqual "contents match" (BL.unpack our) darcs+         | (p, File b) <- list t ]++testsTreeIndex :: Test+testsTreeIndex =+    TestList [ TestLabel "check_index" check_index+             , TestLabel "check_index_content" check_index_content ]+    where pristine = readDarcsPristine "." >>= expand+          {-+          working = do+            x <- pristine+            plain <- readPlainTree "."+            expand (restrict x plain)+          -}+          build_index =+            do x <- pristine >>= expand+               idx <- updateIndexFrom "_darcs/index" darcsTreeHash x >>= expand+               return (x, idx)+          check_index = TestCase $+            do (pris, idx) <- build_index+               (sort $ map fst $ list idx) @?= (sort $ map fst $ list pris)+          check_blob_pair p x y =+              do a <- read x+                 b <- read y+                 assertEqual ("content match on " ++ show p) a b+          check_index_content = TestCase $+            do (_, idx) <- build_index+               plain <- readPlainTree "."+               x <- sequence $ zipCommonFiles check_blob_pair plain idx+               assertBool "files match" (length x > 0)++testsGeneric :: Test+testsGeneric = TestList [ TestLabel "check_modify" check_modify+                        , TestLabel "check_modify_complex" check_modify_complex ]+    where blob x = File $ Blob (return (BL.pack x)) (Just $ sha256 $ BL.pack x)+          name = Name . BS.pack+          check_modify = TestCase $+              let t = makeTree [(name "foo", blob "bar")]+                  modify = modifyTree t (floatPath "foo") (Just $ blob "bla")+               in do x <- read $ fromJust $ findFile t (floatPath "foo")+                     y <- read $ fromJust $ findFile modify (floatPath "foo")+                     assertEqual "old version" x (BL.pack "bar")+                     assertEqual "new version" y (BL.pack "bla")+          check_modify_complex = TestCase $+              let t = makeTree [ (name "foo", blob "bar")+                               , (name "bar", SubTree t1) ]+                  t1 = makeTree [ (name "foo", blob "bar") ]+                  modify = modifyTree t (floatPath "bar/foo") (Just $ blob "bla")+               in do foo <- read $ fromJust $ findFile t (floatPath "foo")+                     foo' <- read $ fromJust $ findFile modify (floatPath "foo")+                     bar_foo <- read $ fromJust $+                                findFile t (floatPath "bar/foo")+                     bar_foo' <- read $ fromJust $+                                 findFile modify (floatPath "bar/foo")+                     assertEqual "old foo" foo (BL.pack "bar")+                     assertEqual "old bar/foo" bar_foo (BL.pack "bar")+                     assertEqual "new foo" foo' (BL.pack "bar")+                     assertEqual "new bar/foo" bar_foo' (BL.pack "bla")++emptyStub = Stub (return emptyTree) Nothing+testTree = makeTree [ (makeName "foo", emptyStub)+                    , (makeName "subtree", SubTree sub) ]+    where sub = makeTree [ (makeName "stub", emptyStub)+                         , (makeName "x", SubTree emptyTree)]++testsTree :: Test+testsTree = TestList [ TestLabel "check_expand" check_expand ]+    where no_stubs t = null [ () | (_, Stub _ _) <- list t]+          check_expand = TestCase $ do+                           x <- expand testTree+                           assertBool "no stubs in testTree" $+                                    not (no_stubs testTree)+                           assertBool "stubs in expanded tree" $ no_stubs x
Storage/Hashed/Tree.hs view
@@ -2,15 +2,14 @@ -- handle those. module Storage.Hashed.Tree     ( Tree, Blob(..), TreeItem(..), ItemType(..), Hash(..)-    , makeTree, makeTreeWithHash, darcsTreeHash, darcsFormatDir, emptyTree-    , emptyBlob+    , makeTree, makeTreeWithHash, emptyTree, emptyBlob      -- * Unfolding stubbed (lazy) Trees.     --     -- | By default, Tree obtained by a read function is stubbed: it will     -- contain Stub items that need to be executed in order to access the-    -- respective subtrees. 'unfold' will produce an unstubbed Tree.-    , unfold, unfoldPath+    -- respective subtrees. 'expand' will produce an unstubbed Tree.+    , expand, expandPath      -- * Tree access and lookup.     , items, list, listImmediate, treeHash@@ -25,14 +24,13 @@  import Prelude hiding( lookup, filter, read, all ) import Storage.Hashed.AnchoredPath-import Storage.Hashed.Utils( Hash(..), sha256, hashSetSize, darcsFormatHash )+import Storage.Hashed.Utils( Hash(..) ) -import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.Map as M  import Data.Maybe( catMaybes )-import Data.List( sortBy, union, sort )+import Data.List( union, sort )  -------------------------------- -- Tree, Blob and friends@@ -48,11 +46,11 @@ -- | Abstraction of a filesystem tree. -- Please note that the Tree returned by the respective read operations will -- have TreeStub items in it. To obtain a Tree without such stubs, call--- unfold on it, eg.:+-- expand on it, eg.: ----- > tree <- readDarcsPristine "." >>= unfold+-- > tree <- readDarcsPristine "." >>= expand ----- When a Tree is unfolded, it becomes "final". All stubs are forced and the+-- When a Tree is expanded, it becomes "final". All stubs are forced and the -- Tree can be traversed purely. Access to actual file contents stays in IO -- though. --@@ -65,10 +63,10 @@                  -- identify the Tree (including any blob content), as far as                  -- cryptographic hashes are concerned. Sha256 is recommended.                  , treeHash :: !(Maybe Hash)-                 -- | When implementing a Tree that has complex unfolding+                 -- | When implementing a Tree that has complex expanding                  -- semantics, the "finish" IO action lets you do arbitrary IO-                 -- transform on the Tree after it is unfolded but before it is-                 -- given to the user by unfold. (Used to implement Index+                 -- transform on the Tree after it is expanded but before it is+                 -- given to the user by expand. (Used to implement Index                  -- updates, eg.)                  , finish :: Tree -> IO Tree } @@ -104,28 +102,6 @@                             , treeHash = Just h                             , finish = return } -darcsFormatDir :: Tree -> BL.ByteString-darcsFormatDir t = BL.fromChunks $ concatMap string-                     (sortBy cmp $ listImmediate t)-    where cmp (Name a, _) (Name b, _) = compare a b-          string (Name name, item) =-              [ case item of-                  File _ -> BS.pack "file:\n"-                  SubTree _ -> BS.pack "directory:\n"-                  Stub _ _ ->-                      error "Trees with stubs not supported in darcsFormatDir.",-                name, BS.singleton '\n',-                case itemHash item of-                  Nothing -> error $ "darcsFormatDir: missing hash on "-                                 ++ show name-                  Just h -> darcsFormatHash h,-                BS.singleton '\n' ]---- | Compute a darcs-compatible hash value for a tree-like structure.-darcsTreeHash :: Tree -> Hash-darcsTreeHash d = hashSetSize (sha256 bl) $ BL.length bl-    where bl = darcsFormatDir d- ----------------------------------- -- Tree access and lookup --@@ -169,46 +145,37 @@                              | (subn, SubTree subt) <- listImmediate t ]  -- | Unfold a stubbed Tree into a one with no stubs in it. You might want to--- filter the tree before unfolding to save IO.-unfold :: Tree -> IO Tree-unfold t_ = unfold' t_ (AnchoredPath [])-    where unfold' :: Tree -> AnchoredPath -> IO Tree-          unfold' t path = do-            unfolded <- sequence [-                            item n sub path-                            | (n, sub) <- listImmediate t, isSub sub ]-            let orig = M.filter (not . isSub) (items t)-                orig_l = [ i | i <- listImmediate t, not $ isSub $ snd i ]-                m_unfolded = M.fromList unfolded-                tree = t { items = M.union orig m_unfolded-                         , listImmediate = orig_l ++ unfolded }-            finish tree tree-          subtree name sub path =-              do let npath = appendPath path name-                 tree <- unstub sub-                 newsub <- unfold' tree npath-                 return (name, SubTree newsub)+-- filter the tree before expanding to save IO.+expand :: Tree -> IO Tree+expand t = do+  expanded <- mapM subtree [ x | x@(_, item) <- listImmediate t, isSub item ]+  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 }+  finish tree tree+    where subtree (name, sub) = do tree <- expand =<< unstub sub+                                   return (name, SubTree tree)           unstub (Stub s _) = s           unstub (SubTree t) = return t-          item = subtree-          isSub (Stub _ _) = True-          isSub (SubTree _) = True-          isSub _ = False+          isSub (File _) = False+          isSub _ = True  -- | Unfold a path in a (stubbed) Tree, such that the leaf node of the path is -- reachable without crossing any stubs.-unfoldPath :: Tree -> AnchoredPath -> IO Tree-unfoldPath t_ path_ = do unfold' t_ path_-    where unfold' t (AnchoredPath [_]) = return t-          unfold' t (AnchoredPath (n:rest)) = do+expandPath :: Tree -> AnchoredPath -> IO Tree+expandPath t_ path_ = do expand' t_ path_+    where expand' t (AnchoredPath [_]) = return t+          expand' t (AnchoredPath (n:rest)) = do             case lookup t n of               (Just (Stub stub _)) ->                   do unstubbed <- stub                      amend t n rest unstubbed               (Just (SubTree t')) -> amend t n rest t'-              _ -> fail $ "Descent error in unfoldPath: " ++ show path_+              _ -> fail $ "Descent error in expandPath: " ++ show path_           amend t name rest sub = do-            t' <- unfold' sub (AnchoredPath rest)+            t' <- 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 }@@ -230,7 +197,7 @@  -- | Given a predicate of the form AnchoredPath -> TreeItem -> Bool, and a -- Tree, produce a Tree that only has items for which the predicate returned--- True. The tree might contain stubs. When unfolded, these will be subject to+-- True. The tree might contain stubs. When expanded, these will be subject to -- filtering as well. filter :: (AnchoredPath -> TreeItem -> Bool) -> Tree -> Tree filter predicate t_ = filter' t_ (AnchoredPath [])@@ -259,7 +226,7 @@ -- | For every pair of corresponding blobs from the two supplied trees, -- evaluate the supplied function and accumulate the results in a list. Hint: -- to get IO actions through, just use sequence on the resulting list.--- NB. This won't unfold any stubs.+-- NB. This won't expand any stubs. zipCommonFiles :: (AnchoredPath -> Blob -> Blob -> a) -> Tree -> Tree -> [a] zipCommonFiles f a b = catMaybes [ flip (f p) x `fmap` findFile a p                                    | (p, File x) <- list b ]@@ -267,7 +234,7 @@ -- | For each file in each of the two supplied trees, evaluate the supplied -- function (supplying the corresponding file from the other tree, or Nothing) -- and accumulate the results in a list. Hint: to get IO actions through, just--- use sequence on the resulting list.  NB. This won't unfold any stubs.+-- use sequence on the resulting list.  NB. This won't expand any stubs. zipFiles :: (AnchoredPath -> Maybe Blob -> Maybe Blob -> a)          -> Tree -> Tree -> [a] zipFiles f a b = [ f p (findFile a p) (findFile b p)@@ -281,10 +248,10 @@     where paths t = sort [ p | (p, _) <- list t ]  -- | Cautiously extracts differing subtrees from a pair of Trees. It will never--- do any unneccessary unfolding. Tree hashes are used to cut the comparison as+-- do any unneccessary expanding. Tree hashes are used to cut the comparison as -- high up the Tree branches as possible. The result is a pair of trees that do -- not share any identical subtrees. They are derived from the first and second--- parameters respectively and they are always fully unfolded. It might be+-- parameters respectively and they are always fully expanded. It might be -- advantageous to feed the result into 'zipFiles'. diffTrees :: Tree -> Tree -> IO (Tree, Tree) diffTrees left right =@@ -300,8 +267,8 @@         subtree (Stub x _) = x         subtree (SubTree x) = return x         subtree (File _) = error "diffTrees tried to descend a File as a subtree"-        maybeUnfold (Stub x _) = SubTree `fmap` (x >>= unfold)-        maybeUnfold (SubTree x) = SubTree `fmap` unfold x+        maybeUnfold (Stub x _) = SubTree `fmap` (x >>= expand)+        maybeUnfold (SubTree x) = SubTree `fmap` expand x         maybeUnfold i = return i         immediateN t = [ n | (n, _) <- listImmediate t ]         diff left' right' = do
Storage/Hashed/Utils.hs view
@@ -7,12 +7,11 @@ import Prelude hiding ( lookup, catch ) import qualified Bundled.SHA256 as SHA import System.Mem( performGC )-import System.IO.Posix.MMap( unsafeMMapFile )+import System.IO.MMap( mmapFileByteString ) import Bundled.Posix( getFileStatus, fileSize ) import System.Directory( getCurrentDirectory, setCurrentDirectory ) import System.FilePath( (</>), isAbsolute ) import Data.Int( Int64 )-import Data.Char( chr ) import Control.Exception.Extensible( catch, bracket, SomeException(..) ) import Control.Monad( when ) @@ -34,30 +33,9 @@ hashSetSize :: Hash -> Int64 -> Hash hashSetSize (Hash (_,h)) s = Hash (Just s, h) -darcsFormatSize :: (Num a) => a -> BS.ByteString-darcsFormatSize s = BS.pack $ replicate (10 - length n) '0' ++ n-    where n = show s--darcsFormatHash :: Hash -> BS.ByteString-darcsFormatHash (Hash (Just s, h)) =-    BS.concat [ darcsFormatSize s-              , BS.singleton '-'-              , h ]-darcsFormatHash (Hash (Nothing, h)) = h---darcsDecodeWhite :: String -> FilePath-darcsDecodeWhite ('\\':cs) =-    case break (=='\\') cs of-    (theord, '\\':rest) ->-        chr (read theord) : darcsDecodeWhite rest-    _ -> error "malformed filename"-darcsDecodeWhite (c:cs) = c: darcsDecodeWhite cs-darcsDecodeWhite "" = ""- -- | Pointer to a filesystem, possibly with start/end offsets. Supposed to be -- fed to (uncurry mmapFileByteString) or similar.-type FileSegment = (FilePath, Maybe (Int64, Int64))+type FileSegment = (FilePath, Maybe (Int64, Int))  -- | Bad and ugly. Only works well with single-chunk BL's. sha256 :: BL.ByteString -> Hash@@ -65,13 +43,13 @@  -- | Read in a FileSegment into a Lazy ByteString. Implemented using mmap. readSegment :: FileSegment -> IO BL.ByteString-readSegment (f,_) = do- x <- unsafeMMapFile f+readSegment (f,range) = do+ x <- mmapFileByteString f range    `catch` (\(_::SomeException) -> do                      size <- fileSize `fmap` getFileStatus f                      if size == 0                         then return BS.empty-                        else performGC >> unsafeMMapFile f)+                        else performGC >> mmapFileByteString f range)  return $ BL.fromChunks [x] {-# INLINE readSegment #-}
hashed-storage.cabal view
@@ -1,5 +1,5 @@ name:          hashed-storage-version:       0.3.2+version:       0.3.3 synopsis:      Hashed file storage support code.  description:   Support code for reading and manipulating hashed file storage@@ -24,30 +24,36 @@ flag test     default: False +flag diff+    default: False+ library     if impl(ghc >= 6.8)       ghc-options: -fwarn-tabs     ghc-options:   -Wall -O2     ghc-prof-options: -prof -auto-all -O2 +     exposed-modules:         Storage.Hashed         Storage.Hashed.AnchoredPath-        Storage.Hashed.Diff         Storage.Hashed.Index         Storage.Hashed.Monad         Storage.Hashed.Tree+        Storage.Hashed.Darcs +    if flag(diff)+      exposed-modules:+        Storage.Hashed.Diff+      build-depends: lcs+     other-modules:         Bundled.Posix         Bundled.SHA256         Storage.Hashed.Utils -    build-depends: base >= 3 && < 5, directory, filepath,-                   bytestring, bytestring-mmap,-                   zlib, lcs, binary, containers,-                   mtl, extensible-exceptions,-                   mmap+    build-depends: base >= 3 && < 5, directory, filepath, bytestring, zlib,+                   containers, mtl, extensible-exceptions, mmap      c-sources: Bundled/sha2.c @@ -60,6 +66,7 @@      main-is: test.hs     other-modules: Bundled.Posix+                   Storage.Hashed.Test     c-sources: Bundled/sha2.c      if flag(test)