diff --git a/Storage/Hashed.hs b/Storage/Hashed.hs --- a/Storage/Hashed.hs +++ b/Storage/Hashed.hs @@ -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 ) diff --git a/Storage/Hashed/AnchoredPath.hs b/Storage/Hashed/AnchoredPath.hs --- a/Storage/Hashed/AnchoredPath.hs +++ b/Storage/Hashed/AnchoredPath.hs @@ -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) diff --git a/Storage/Hashed/Darcs.hs b/Storage/Hashed/Darcs.hs new file mode 100644 --- /dev/null +++ b/Storage/Hashed/Darcs.hs @@ -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 diff --git a/Storage/Hashed/Index.hs b/Storage/Hashed/Index.hs --- a/Storage/Hashed/Index.hs +++ b/Storage/Hashed/Index.hs @@ -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 diff --git a/Storage/Hashed/Monad.hs b/Storage/Hashed/Monad.hs --- a/Storage/Hashed/Monad.hs +++ b/Storage/Hashed/Monad.hs @@ -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 diff --git a/Storage/Hashed/Test.hs b/Storage/Hashed/Test.hs new file mode 100644 --- /dev/null +++ b/Storage/Hashed/Test.hs @@ -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 diff --git a/Storage/Hashed/Tree.hs b/Storage/Hashed/Tree.hs --- a/Storage/Hashed/Tree.hs +++ b/Storage/Hashed/Tree.hs @@ -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 diff --git a/Storage/Hashed/Utils.hs b/Storage/Hashed/Utils.hs --- a/Storage/Hashed/Utils.hs +++ b/Storage/Hashed/Utils.hs @@ -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 #-} 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.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)