hashed-storage 0.3 → 0.3.1
raw patch · 16 files changed
+195/−144 lines, 16 filessetup-changed
Files
- Bundled/Posix.hsc +3/−2
- Bundled/SHA256.hs +1/−2
- Bundled/sha2.c +0/−1
- Bundled/sha2.h +0/−1
- LICENSE +26/−0
- Setup.hs +2/−1
- Storage/Hashed.hs +14/−15
- Storage/Hashed/AnchoredPath.hs +20/−12
- Storage/Hashed/Diff.hs +19/−19
- Storage/Hashed/Index.hs +14/−14
- Storage/Hashed/Monad.hs +17/−15
- Storage/Hashed/Test.hs +14/−10
- Storage/Hashed/Tree.hs +9/−10
- Storage/Hashed/Utils.hs +7/−8
- hashed-storage.cabal +44/−31
- test.hs +5/−3
Bundled/Posix.hsc view
@@ -1,4 +1,5 @@-{-# OPTIONS_GHC -cpp #-}+{-# LANGUAGE CPP #-}+ module Bundled.Posix( getFdStatus, getSymbolicLinkStatus, getFileStatus , getFileStatusBS , fileExists@@ -70,7 +71,7 @@ #include <sys/stat.h> getSymbolicLinkStatus :: FilePath -> IO FileStatus-getSymbolicLinkStatus fp = +getSymbolicLinkStatus fp = do_stat (\p -> (fp `withCString` (`lstat` p))) getFileStatus :: FilePath -> IO FileStatus
Bundled/SHA256.hs view
@@ -27,7 +27,7 @@ sha256 :: B.ByteString -> String sha256 p = unsafePerformIO $- withCString (take 64 $ repeat 'x') $ \digestCString ->+ withCString (replicate 64 'x') $ \digestCString -> unsafeUseAsCStringLen p $ \(ptr,n) -> do let digest = castPtr digestCString :: Ptr Word8 c_sha256 ptr (fromIntegral n) digest@@ -45,4 +45,3 @@ -- foreign import ccall unsafe "sha2.h sha256" c_sha256 :: Ptr CChar -> CSize -> Ptr Word8 -> IO ()-
Bundled/sha2.c view
@@ -947,4 +947,3 @@ } #endif /* TEST_VECTORS */-
Bundled/sha2.h view
@@ -105,4 +105,3 @@ #endif #endif /* !SHA2_H */-
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright Petr Rockai 2009++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Setup.hs view
@@ -4,8 +4,9 @@ import System( system ) import System.FilePath( (</>) ) +main :: IO () main = defaultMainWithHooks simpleUserHooks {- runTests = \ _ _ pkg lbi -> do+ runTests = \ _ _ _ lbi -> do system $ buildDir lbi </> hst </> hst return () }
Storage/Hashed.hs view
@@ -60,17 +60,17 @@ print' (Just (SubTree t')) = do putStrLn $ "== Listing Tree " ++ p ++ " (immediates only):" putStr $ unlines $ map BS.unpack $ listNames t'- print' (Just (Stub _ _)) = do+ print' (Just (Stub _ _)) = putStrLn $ "== (not listing stub at " ++ p ++ ")" listNames t' = [ n | (Name n, _) <- listImmediate t' ] readPlainDir :: FilePath -> IO [(FilePath, FileStatus)] readPlainDir dir =- do withCurrentDirectory dir $ do- items <- getDirectoryContents "."- sequence [ do st <- getFileStatus s- return (s, st)- | s <- items, not $ s `elem` [ ".", ".." ] ]+ withCurrentDirectory dir $ do+ items <- getDirectoryContents "."+ sequence [ do st <- getFileStatus s+ return (s, st)+ | s <- items, not $ s `elem` [ ".", ".." ] ] -- | Read in a plain directory hierarchy from a filesystem. NB. The 'read' -- function on Blobs with such a Tree is susceptible to file content@@ -107,7 +107,7 @@ parse (t:n:h':r) = (parse' t, Name $ BS.pack $ darcsDecodeWhite (BL.unpack n), makeHash hash) : parse r- where hash = BS.concat $ BL.toChunks $ h'+ where hash = BS.concat $ BL.toChunks h' parse _ = [] parse' x | x == BL.pack "file:" = BlobType@@ -121,16 +121,16 @@ readDarcsHashed dir root = do items <- readDarcsHashedDir dir root subs <- sequence [- do case tp of- BlobType -> return (d, File $- Blob (readBlob h) (Just h))- TreeType ->- do let t = readDarcsHashed dir h- return (d, Stub t (Just h))+ case tp of+ BlobType -> return (d, File $+ Blob (readBlob h) (Just h))+ TreeType ->+ do let t = readDarcsHashed dir h+ return (d, Stub t (Just h)) | (tp, d, h) <- items ] return $ makeTreeWithHash subs root where location h = (dir </> BS.unpack (darcsFormatHash h), Nothing)- readBlob name = fmap decompress $ readSegment $ location name+ readBlob = fmap decompress . readSegment . location -- | Read in a darcs pristine tree. Handles the plain and hashed pristine -- cases. Does not (and will not) handle the no-pristine case, since that@@ -164,4 +164,3 @@ createDirectoryIfMissing True (anchorPath dir p) write _ = return () write' p b = read b >>= BL.writeFile (anchorPath dir p)-
Storage/Hashed/AnchoredPath.hs view
@@ -1,9 +1,11 @@+-- | This module implements relative paths within a Tree. All paths are+-- anchored at a certain root (this is usually the Tree root). They are+-- represented by a list of Names (these are just strict bytestrings). module Storage.Hashed.AnchoredPath ( Name(..), AnchoredPath(..), appendPath, anchorPath- , isPrefix, parent, parents, catPaths+ , isPrefix, parent, parents, catPaths, flatten -- * Unsafe functions.- , nameToFilePath, nameFromFilePath- , floatBS, anchorBS ) where+ , nameToFilePath, nameFromFilePath, floatBS ) where import qualified Data.ByteString.Char8 as BS import Data.List( isPrefixOf, inits )@@ -16,14 +18,15 @@ newtype Name = Name BS.ByteString deriving (Eq, Show, Ord) newtype AnchoredPath = AnchoredPath [Name] deriving (Eq, Show, Ord) --- Both unsafe.-+-- | Unsafe. nameToFilePath :: Name -> FilePath nameToFilePath (Name p) = BS.unpack p +-- | Unsafe. nameFromFilePath :: FilePath -> Name-nameFromFilePath p = Name $ BS.pack p+nameFromFilePath = Name . BS.pack +-- | Check whether a path is a prefix of another path. isPrefix :: AnchoredPath -> AnchoredPath -> Bool (AnchoredPath a) `isPrefix` (AnchoredPath b) = a `isPrefixOf` b @@ -34,12 +37,17 @@ (Name s) | s == BS.empty -> AnchoredPath p | otherwise -> AnchoredPath $ p ++ [n] +-- | Catenate two paths together. Not very safe, but sometimes useful+-- (e.g. when you are representing paths relative to a different point than a+-- Tree root). catPaths :: AnchoredPath -> AnchoredPath -> AnchoredPath catPaths (AnchoredPath p) (AnchoredPath n) = AnchoredPath $ p ++ n +-- | Get parent (path) of a given path. foo/bar/baz -> foo/bar parent :: AnchoredPath -> AnchoredPath parent (AnchoredPath x) = AnchoredPath (init x) +-- | List all parents of a given path. foo/bar/baz -> [foo, foo/bar] parents :: AnchoredPath -> [AnchoredPath] parents (AnchoredPath x) = case x of@@ -47,16 +55,16 @@ [_] -> [AnchoredPath []] _ -> map AnchoredPath $ tail $ inits (init x) --- | Take a "root" directory and an anchored path and produce a full path.+-- | Take a "root" directory and an anchored path and produce a full+-- 'FilePath'. Moreover, you can use anchorPath "" to get a relative+-- 'FilePath'. anchorPath :: FilePath -> AnchoredPath -> FilePath-anchorPath dir (AnchoredPath p) = dir </> path- where path = BS.unpack (flatten p)- flatten = BS.intercalate (BS.singleton '/') . map (\(Name x) -> x)+anchorPath dir p = dir </> BS.unpack (flatten p) {-# INLINE anchorPath #-} floatBS :: BS.ByteString -> AnchoredPath floatBS = AnchoredPath . map Name . takeWhile (not . BS.null) . BS.split '/' -anchorBS :: AnchoredPath -> BS.ByteString-anchorBS (AnchoredPath p) = BS.intercalate (BS.singleton '/')+flatten :: AnchoredPath -> BS.ByteString+flatten (AnchoredPath p) = BS.intercalate (BS.singleton '/') [ n | (Name n) <- p ]
Storage/Hashed/Diff.hs view
@@ -40,7 +40,7 @@ -- | Produce unified diff (in a string form, ie. formatted) from a pair of -- bytestrings. unifiedDiff :: BL.ByteString -> BL.ByteString -> BL.ByteString-unifiedDiff a b = printUnified $ concat $ unifiedHunks+unifiedDiff a b = printUnified $ concat unifiedHunks where unifiedHunks = reduceContext 3 $ map unifyHunk $ hunks $ weave a b -- | Weave two bytestrings. Intermediate data structure for the actual unidiff@@ -54,18 +54,18 @@ common = lcs left right weave' [] [] [] = [] weave' [] c [] = error $ "oops: Left & Right empty, Common: " ++ show c- weave' [] [] (b:bs) = (Add b):weave' [] [] bs- weave' (a:as) [] [] = (Remove a):weave' as [] []- weave' (a:as) [] (b:bs) = (Replace a b):weave' as [] bs+ weave' [] [] (b:bs) = Add b : weave' [] [] bs+ weave' (a:as) [] [] = Remove a : weave' as [] []+ weave' (a:as) [] (b:bs) = Replace a b : weave' as [] bs weave' (a:as) (c:cs) (b:bs)- | a == c && b == c = (Common a):weave' as cs bs- | a == c && b /= c = (Add b):weave' (a:as) (c:cs) bs- | a /= c && b == c = (Remove a):weave' as (c:cs) (b:bs)- | a /= c && b /= c = (Replace a b):weave' as (c:cs) bs+ | a == c && b == c = Common a : weave' as cs bs+ | a == c && b /= c = Add b : weave' (a:as) (c:cs) bs+ | a /= c && b == c = Remove a : weave' as (c:cs) (b:bs)+ | a /= c && b /= c = Replace a b : weave' as (c:cs) bs | otherwise = error "oops!" weave' a c b = error $ "oops: \nLeft: " ++ show a ++ "\nCommon: " ++ show c ++ "\nRight: " ++ show b --- | Break up a Weave into hunks.+-- | Break up a 'Weave' into 'Hunk's. hunks :: Weave -> [Hunk] hunks = groupBy grp where grp (Common _) (Common _) = True@@ -73,10 +73,10 @@ grp _ (Common _) = False grp _ _ = True --- | Reformat a Hunk into a format suitable for unified diff. Replaces are+-- | Reformat a 'Hunk' into a format suitable for unified diff. Replaces are -- turned into add/remove pairs, all removals in a hunk go before all--- adds. Hunks of Common lines are left intact. Produces input suitable for--- reduceContext.+-- adds. 'Hunk's of 'Common' lines are left intact. Produces input suitable for+-- 'reduceContext'. unifyHunk :: Hunk -> Hunk unifyHunk h = case h of (Common _:_) -> h@@ -85,16 +85,16 @@ breakup (Replace f t) = [Remove f, Add t] breakup x = [x] --- | Break up a 'Weave' into unified hunks, leaving @n@ lines of context around--- every hunk. Consecutive Common lines not used as context are replaced with--- Skips.+-- | Break up a 'Weave' into unified 'Hunk's, leaving @n@ lines of context around+-- every hunk. Consecutive 'Common' lines not used as context are replaced with+-- 'Skip's. reduceContext :: Int -> [Hunk] -> [Hunk] reduceContext n hs = case hs of [] -> [] [Common _:_] -> [] [x] -> [x]- [h,t] -> reduce 0 n h : reduce n 0 t : []+ [h,t] -> [reduce 0 n h, reduce n 0 t] (h:rest) -> reduce 0 n h : map (reduce n n) (init rest) ++ [reduce n 0 $ last rest]@@ -106,7 +106,7 @@ drop (length h - e) h reduce _ _ h = h --- | Format a Weave for printing.+-- | Format a 'Weave' for printing. deweave :: Weave -> BL.ByteString deweave = BL.unlines . map disp where disp (Common l) = BL.cons ' ' l@@ -115,8 +115,8 @@ disp (Replace _ t) = BL.cons '!' t disp (Skip n) = BL.pack $ "-- skip " ++ show n ++ " lines --" --- | Print a "hunked" weave in form of an unified diff. Hunk boundaries are--- marked up as "Skip" lines. Cf. "reduceContext".+-- | Print a \"hunked\" weave in form of an unified diff. 'Hunk' boundaries are+-- marked up as 'Skip' lines. Cf. 'reduceContext'. printUnified :: Weave -> BL.ByteString printUnified hunked = printHunks 1 1 $ groupBy splits hunked where splits (Skip _) _ = False
Storage/Hashed/Index.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE PatternSignatures, ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables #-}+ module Storage.Hashed.Index where import Prelude hiding ( lookup, readFile, writeFile, catch )@@ -38,7 +39,7 @@ -- 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).+-- also efficiently implement subtree queries this way (cf. 'readIndex'). data Item = Item { iPath :: BS.ByteString , iName :: BS.ByteString , iHash :: BS.ByteString@@ -57,7 +58,7 @@ createItem :: ItemType -> AnchoredPath -> ForeignPtr () -> Int -> IO Item createItem typ path fp off =- do let name = BS.concat [ anchorBS path,+ do let name = BS.concat [ flatten path, (typ == TreeType) ? (BS.singleton '/', BS.empty), BS.singleton '\0' ] (namefp, nameoff, namel) = toForeignPtr name@@ -107,14 +108,14 @@ let size = fromIntegral $ if req_size > 0 then fromIntegral req_size else act_size case size of- 0 -> return (castForeignPtr $ nullForeignPtr, size)+ 0 -> return (castForeignPtr nullForeignPtr, size) _ -> do (x, _) <- mmapFileForeignPtr "_darcs/index" 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.+-- 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@@ -179,24 +180,24 @@ if fileExists st then return $ Just $ File (Blob readblob $ Just hash) else return Nothing- if (mmap_size > 0) then+ if mmap_size > 0 then do (_, Just (Stub root h)) <- readItem (AnchoredPath []) 0 0 tree <- root 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+-- 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' --- |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).+-- |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'@@ -223,8 +224,7 @@ do i <- createItem TreeType path mmap off case M.lookup path item_map of Nothing -> return ()- Just item -> do hash <- iHash' item- update i Nothing hash+ Just item -> iHash' item >>= update i Nothing let subs [] = return $ off + itemSize i subs ((name,x):xs) = do let path' = path `appendPath` name
Storage/Hashed/Monad.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternSignatures, ScopedTypeVariables, BangPatterns #-}+{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} -- | An experimental monadic interface to Tree mutation. The main idea is to -- simulate IO-ish manipulation of real filesystem (that's the state part of@@ -31,20 +31,22 @@ import Control.Monad.State.Strict import qualified Data.Set as S +-- | 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 = TreeState { cwd :: AnchoredPath , tree :: Tree , changed :: S.Set AnchoredPath , changesize :: Int64 , sync :: TreeIO () } --- | A TreeIO monad. A sort of like IO but it keeps a TreeState around as well,+-- | 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--- TreeIO, the actions in your virtual filesystem get somehow reflected in the--- actual real filesystem. For "virtualTreeIO", nothing happens in real--- filesystem, however with "plainTreeIO", the plain tree will be updated every--- now and then, and with "hashedTreeIO" a darcs-style hashed tree will get+-- 'TreeIO', the actions in your virtual filesystem get somehow reflected in the+-- actual real filesystem. For 'virtualTreeIO', nothing happens in real+-- filesystem, however with 'plainTreeIO', the plain tree will be updated every+-- now and then, and with 'hashedTreeIO' a darcs-style hashed tree will get -- updated.-type TreeIO a = StateT TreeState IO a+type TreeIO = StateT TreeState IO initialState :: Tree -> TreeIO () -> TreeState initialState t s = TreeState { cwd = AnchoredPath []@@ -66,12 +68,12 @@ virtualTreeIO :: TreeIO a -> Tree -> IO (a, Tree) virtualTreeIO action t = runTreeIO action $ initialState t (return ()) --- | Create a hashed file from a filepath and content. In case the file exists+-- | Create a hashed file from a 'FilePath' and content. In case the file exists -- it is kept untouched and is assumed to have the right content. XXX Corrupt -- files should be probably renamed out of the way automatically or something -- (probably when they are being read though).-fs_createHashedFile :: FilePath -> BL.ByteString -> TreeIO ()-fs_createHashedFile fn content =+fsCreateHashedFile :: FilePath -> BL.ByteString -> TreeIO ()+fsCreateHashedFile fn content = liftIO $ do exist <- doesFileExist fn unless exist $ BL.writeFile fn content@@ -90,7 +92,7 @@ t' <- liftIO $ unfoldPath t p modify $ \st -> st { tree = t' } --- | Run a TreeIO @action@ in a hashed setting. The @initial@ tree is assumed+-- | Run a 'TreeIO' @action@ in a hashed setting. The @initial@ tree is assumed -- to be fully available from the @directory@, and any changes will be written -- out to same. Please note that actual filesystem files are never removed. --@@ -115,7 +117,7 @@ let fn = dir </> BS.unpack (darcsFormatHash h) nblob = File $ Blob (decompress `fmap` BL.readFile fn) (Just h) newcontent <- liftIO $ compress `fmap` read b- fs_createHashedFile fn newcontent+ fsCreateHashedFile fn newcontent replaceItemAbs path (Just nblob) updateFile path b@(Blob _ Nothing) = do content <- liftIO $ read b@@ -123,17 +125,17 @@ fn = dir </> BS.unpack (darcsFormatHash h) nblob = File $ Blob (decompress `fmap` BL.readFile fn) (Just h) newcontent = compress content- fs_createHashedFile fn newcontent+ fsCreateHashedFile fn newcontent replaceItemAbs path (Just nblob) updateSub path s = do let !hash = darcsTreeHash s dirdata = darcsFormatDir s fn = dir </> BS.unpack (darcsFormatHash $ hash) ns = SubTree (s { treeHash = Just hash })- fs_createHashedFile fn (compress dirdata)+ fsCreateHashedFile fn (compress dirdata) replaceItemAbs path (Just ns) --- | Run a TreeIO action in a plain tree setting. Writes out changes to the+-- | Run a 'TreeIO' action in a plain tree setting. Writes out changes to the -- plain tree every now and then (after the action is finished, the last tree -- state is always flushed to disk). XXX Modify the tree with filesystem -- reading and put it back into st (ie. replace the in-memory Blobs with normal
Storage/Hashed/Test.hs view
@@ -8,14 +8,14 @@ import Control.Monad( forM_ ) import Data.Maybe import Data.List( (\\), sort )-import System.Directory import Storage.Hashed import Storage.Hashed.AnchoredPath import Storage.Hashed.Tree import Storage.Hashed.Index import Storage.Hashed.Utils -tests_darcs_basic =+testsDarcsBasic :: Test+testsDarcsBasic = TestList [ TestLabel "have_files" have_files , TestLabel "have_pristine_files" have_pristine_files , TestLabel "darcs_manifest" darcs_manifest@@ -27,7 +27,7 @@ check_file t f = assertBool ("path " ++ show f ++ " is in tree") (isJust $ find t f)- check_files t = forM_ files (check_file t)+ check_files = forM_ files . check_file have_files = TestCase $ readPlainTree "." >>= unfold >>= check_files have_pristine_files = TestCase $ readDarcsPristine "." >>= unfold >>= check_files@@ -50,14 +50,17 @@ assertEqual "contents match" (BL.unpack our) darcs | (p, File b) <- list t ] -tests_tree_index =+testsTreeIndex :: Test+testsTreeIndex = TestList [ TestLabel "check_index" check_index , TestLabel "check_index_content" check_index_content ] where pristine = readDarcsPristine "." >>= unfold+ {- working = do x <- pristine plain <- readPlainTree "." unfold (restrict x plain)+ -} build_index = do x <- pristine >>= unfold idx <- updateIndexFrom x >>= unfold@@ -75,29 +78,30 @@ x <- sequence $ zipCommonFiles check_blob_pair plain idx assertBool "files match" (length x > 0) -tests_generic = TestList [ TestLabel "check_modify" check_modify+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")]- mod = modifyTree t (floatPath "foo") (Just $ blob "bla")+ modify = modifyTree t (floatPath "foo") (Just $ blob "bla") in do x <- read $ fromJust $ findFile t (floatPath "foo")- y <- read $ fromJust $ findFile mod (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") ]- mod = modifyTree t (floatPath "bar/foo") (Just $ blob "bla")+ modify = modifyTree t (floatPath "bar/foo") (Just $ blob "bla") in do foo <- read $ fromJust $ findFile t (floatPath "foo")- foo' <- read $ fromJust $ findFile mod (floatPath "foo")+ foo' <- read $ fromJust $ findFile modify (floatPath "foo") bar_foo <- read $ fromJust $ findFile t (floatPath "bar/foo") bar_foo' <- read $ fromJust $- findFile mod (floatPath "bar/foo")+ 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")
Storage/Hashed/Tree.hs view
@@ -144,7 +144,7 @@ -- | Find a 'TreeItem' by its path. Gives 'Nothing' if the path is invalid. find :: Tree -> AnchoredPath -> Maybe TreeItem-find t p = find' (SubTree t) p+find = find' . SubTree -- | Find a 'Blob' by its path. Gives 'Nothing' if the path is invalid, or does -- not point to a Blob.@@ -188,7 +188,7 @@ tree <- stub sub <- unfold' tree npath return (name, SubTree sub)- item n stub p = subtree n stub p+ item = subtree isStub (Stub _ _) = True isStub _ = False @@ -302,7 +302,7 @@ maybeUnfold i = return i immediateN t = [ n | (n, _) <- listImmediate t ] diff left' right' = do- items <- sequence [+ is <- sequence [ case (lookup left' n, lookup right' n) of (Just l, Nothing) -> do l' <- maybeUnfold l@@ -317,18 +317,17 @@ do x <- subtree l y <- subtree r (x', y') <- diffTrees x y- return $ (n,- Just $ SubTree x',- Just $ SubTree y')+ return (n, Just $ SubTree x', Just $ SubTree y') | isFile l && isFile r -> return (n, Just l, Just r) | otherwise -> do l' <- maybeUnfold l r' <- maybeUnfold r- return $ (n, Just l', Just r')+ return (n, Just l', Just r')+ _ -> error "n lookups failed" | n <- immediateN left' `union` immediateN right' ]- let items_l = [ (n, l) | (n, Just l ,_) <- items ]- items_r = [ (n, r) | (n, _, Just r) <- items ]- return (makeTree items_l, makeTree items_r)+ let is_l = [ (n, l) | (n, Just l ,_) <- is ]+ is_r = [ (n, r) | (n, _, Just r) <- is ]+ return (makeTree is_l, makeTree is_r) modifyTree :: Tree -> AnchoredPath -> Maybe TreeItem -> Tree
Storage/Hashed/Utils.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternSignatures, ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | Mostly internal utilities for use by the rest of the library. Subject to -- removal without further notice.@@ -36,7 +36,7 @@ darcsFormatSize :: (Num a) => a -> BS.ByteString darcsFormatSize s = BS.pack $ replicate (10 - length n) '0' ++ n- where n = (show s)+ where n = show s darcsFormatHash :: Hash -> BS.ByteString darcsFormatHash (Hash (Just s, h)) =@@ -78,14 +78,14 @@ -- | Run an IO action with @path@ as a working directory. Does neccessary -- bracketing. withCurrentDirectory :: FilePath -> IO a -> IO a-withCurrentDirectory name m =+withCurrentDirectory name = bracket (do cwd <- getCurrentDirectory when (name /= "") (setCurrentDirectory name) return cwd) (\oldwd -> setCurrentDirectory oldwd `catch` \(_::SomeException) -> return ())- (const m)+ . const -- Ternary kind of operator. Just a concise way to write if. (?) :: Bool -> (a, a) -> a@@ -103,10 +103,9 @@ do let (fp_to, off_to, len_to) = toForeignPtr to (fp_from, off_from, len_from) = toForeignPtr from when (len_to /= len_from) $ fail $ "Length mismatch in pokeBS: from = "- ++ (show len_from) ++ " /= to = " ++ (show len_to)- withForeignPtr fp_from $ \p_from -> do- withForeignPtr fp_to $ \p_to -> do+ ++ show len_from ++ " /= to = " ++ show len_to+ withForeignPtr fp_from $ \p_from ->+ withForeignPtr fp_to $ \p_to -> memcpy (plusPtr p_to off_to) (plusPtr p_from off_from) (fromIntegral len_to)-
hashed-storage.cabal view
@@ -1,55 +1,68 @@-Name: hashed-storage-Version: 0.3-License: BSD3-Copyright: 2009 Petr Rockai <me@mornfall.net>-Author: Petr Rockai <me@mornfall.net>-Maintainer: Petr Rockai <me@mornfall.net>-Synopsis: Hashed file storage support code.-Description:- Support code for reading and manipulating hashed file storage (where each- file and directory is associated with a cryptographic hash, for- corruption-resistant storage and fast comparisons).- .- The supported storage formats include darcs hashed pristine, a plain- filesystem tree and an indexed plain tree (where the index maintains hashes- of the plain files and directories).+name: hashed-storage+version: 0.3.1+synopsis: Hashed file storage support code. -Category: System-Build-Type: Custom-Cabal-Version: >=1.2+description: Support code for reading and manipulating hashed file storage+ (where each file and directory is associated with a+ cryptographic hash, for corruption-resistant storage and fast+ comparisons).+ .+ The supported storage formats include darcs hashed pristine, a+ plain filesystem tree and an indexed plain tree (where the index+ maintains hashes of the plain files and directories). darcs'+ pristine.hashed. +license: BSD3+license-file: LICENSE+copyright: 2009 Petr Rockai <me@mornfall.net>+author: Petr Rockai <me@mornfall.net>+maintainer: Petr Rockai <me@mornfall.net>+category: System+build-type: Custom+cabal-version: >= 1.2 extra-source-files: Bundled/sha2.h -Library- ghc-options: -Wall -O2+flag test+ 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:+ exposed-modules: Storage.Hashed Storage.Hashed.AnchoredPath- Storage.Hashed.Tree- Storage.Hashed.Index Storage.Hashed.Diff+ Storage.Hashed.Index Storage.Hashed.Monad+ Storage.Hashed.Tree - Other-Modules:+ other-modules:+ Bundled.Posix+ Bundled.SHA256 Storage.Hashed.Utils Storage.Hashed.Test - Build-Depends: base, directory, filepath,+ build-depends: base, directory, filepath, bytestring, bytestring-mmap, zlib, lcs, binary, containers, mtl, extensible-exceptions, mmap - other-modules: Bundled.SHA256- Bundled.Posix c-sources: Bundled/sha2.c -Executable hashed-storage-test- ghc-options: -O2+executable hashed-storage-test+ if impl(ghc >= 6.8)+ ghc-options: -fwarn-tabs+ ghc-options: -Wall -O2+ ghc-prof-options: -prof -auto-all -O2++ main-is: test.hs other-modules: Bundled.Posix c-sources: Bundled/sha2.c- Main-Is: test.hs- Build-Depends: HUnit, process >= 1.0.1+ build-depends: HUnit, process >= 1.0.1+ if !flag(test)+ buildable: False
test.hs view
@@ -1,6 +1,8 @@ import Storage.Hashed.Test import Test.HUnit -main = do runTestTT tests_darcs_basic- runTestTT tests_tree_index- runTestTT tests_generic+main :: IO ()+main = do runTestTT testsDarcsBasic+ runTestTT testsTreeIndex+ runTestTT testsGeneric+ return ()