hashed-storage 0.3.1 → 0.3.2
raw patch · 7 files changed
+36/−133 lines, 7 filesdep ~base
Dependency ranges changed: base
Files
- Storage/Hashed/AnchoredPath.hs +5/−1
- Storage/Hashed/Index.hs +2/−2
- Storage/Hashed/Monad.hs +3/−4
- Storage/Hashed/Test.hs +0/−108
- Storage/Hashed/Tree.hs +13/−10
- hashed-storage.cabal +12/−8
- test.hs +1/−0
Storage/Hashed/AnchoredPath.hs view
@@ -3,7 +3,7 @@ -- represented by a list of Names (these are just strict bytestrings). module Storage.Hashed.AnchoredPath ( Name(..), AnchoredPath(..), appendPath, anchorPath- , isPrefix, parent, parents, catPaths, flatten+ , isPrefix, parent, parents, catPaths, flatten, makeName -- * Unsafe functions. , nameToFilePath, nameFromFilePath, floatBS ) where @@ -68,3 +68,7 @@ flatten :: AnchoredPath -> BS.ByteString flatten (AnchoredPath p) = BS.intercalate (BS.singleton '/') [ n | (Name n) <- p ]++makeName :: String -> Name+makeName = Name . BS.pack+
Storage/Hashed/Index.hs view
@@ -233,7 +233,7 @@ lastOff <- subs (listImmediate s) poke (iAux i) (fromIntegral lastOff) return lastOff- create (Stub _ _) _ _ =- fail "Cannot create index from stubbed Tree."+ create (Stub _ _) path _ =+ fail $ "Cannot create index from stubbed Tree at " ++ show path create (SubTree reference) (AnchoredPath []) 0 readIndex
Storage/Hashed/Monad.hs view
@@ -200,10 +200,9 @@ rename from to = do unfoldTo from tr <- gets tree let item = find tr from- when (isNothing item) $- fail $ "Rename: " ++ show from ++ " does not exist"- replaceItem to item- replaceItem from Nothing+ unless (isNothing item) $ do+ replaceItem to item+ replaceItem from Nothing -- | If buffers are becoming large, sync, otherwise do nothing. maybeSync :: TreeIO ()
− Storage/Hashed/Test.hs
@@ -1,108 +0,0 @@-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--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 "." >>= unfold >>= check_files- have_pristine_files = TestCase $- readDarcsPristine "." >>= unfold >>= 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 "." >>= unfold- 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 "." >>= unfold- 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 "." >>= unfold- {-- working = do- x <- pristine- plain <- readPlainTree "."- unfold (restrict x plain)- -}- build_index =- do x <- pristine >>= unfold- idx <- updateIndexFrom x >>= unfold- 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")
Storage/Hashed/Tree.hs view
@@ -175,22 +175,25 @@ where unfold' :: Tree -> AnchoredPath -> IO Tree unfold' t path = do unfolded <- sequence [- item n t' path- | (n, Stub t' _) <- listImmediate t ]- let orig = M.filter (not . isStub) (items t)- orig_l = [ i | i <- listImmediate t, not $ isStub $ snd i ]+ 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 stub path =+ subtree name sub path = do let npath = appendPath path name- tree <- stub- sub <- unfold' tree npath- return (name, SubTree sub)+ tree <- unstub sub+ newsub <- unfold' tree npath+ return (name, SubTree newsub)+ unstub (Stub s _) = s+ unstub (SubTree t) = return t item = subtree- isStub (Stub _ _) = True- isStub _ = False+ isSub (Stub _ _) = True+ isSub (SubTree _) = True+ isSub _ = False -- | Unfold a path in a (stubbed) Tree, such that the leaf node of the path is -- reachable without crossing any stubs.
hashed-storage.cabal view
@@ -1,5 +1,5 @@ name: hashed-storage-version: 0.3.1+version: 0.3.2 synopsis: Hashed file storage support code. description: Support code for reading and manipulating hashed file storage@@ -9,8 +9,7 @@ . 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.+ maintains hashes of the plain files and directories). license: BSD3 license-file: LICENSE@@ -19,7 +18,7 @@ maintainer: Petr Rockai <me@mornfall.net> category: System build-type: Custom-cabal-version: >= 1.2+cabal-version: >= 1.6 extra-source-files: Bundled/sha2.h flag test@@ -43,9 +42,8 @@ Bundled.Posix Bundled.SHA256 Storage.Hashed.Utils- Storage.Hashed.Test - build-depends: base, directory, filepath,+ build-depends: base >= 3 && < 5, directory, filepath, bytestring, bytestring-mmap, zlib, lcs, binary, containers, mtl, extensible-exceptions,@@ -63,6 +61,12 @@ main-is: test.hs other-modules: Bundled.Posix c-sources: Bundled/sha2.c- build-depends: HUnit, process >= 1.0.1- if !flag(test)++ if flag(test)+ build-depends: HUnit, process >= 1.0.1+ else buildable: False++source-repository head+ type: darcs+ location: http://repos.mornfall.net/hashed-storage/
test.hs view
@@ -5,4 +5,5 @@ main = do runTestTT testsDarcsBasic runTestTT testsTreeIndex runTestTT testsGeneric+ runTestTT testsTree return ()