diff --git a/Storage/Hashed/AnchoredPath.hs b/Storage/Hashed/AnchoredPath.hs --- a/Storage/Hashed/AnchoredPath.hs +++ b/Storage/Hashed/AnchoredPath.hs @@ -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 + diff --git a/Storage/Hashed/Index.hs b/Storage/Hashed/Index.hs --- a/Storage/Hashed/Index.hs +++ b/Storage/Hashed/Index.hs @@ -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 diff --git a/Storage/Hashed/Monad.hs b/Storage/Hashed/Monad.hs --- a/Storage/Hashed/Monad.hs +++ b/Storage/Hashed/Monad.hs @@ -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 () diff --git a/Storage/Hashed/Test.hs b/Storage/Hashed/Test.hs deleted file mode 100644 --- a/Storage/Hashed/Test.hs +++ /dev/null @@ -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") diff --git a/Storage/Hashed/Tree.hs b/Storage/Hashed/Tree.hs --- a/Storage/Hashed/Tree.hs +++ b/Storage/Hashed/Tree.hs @@ -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. 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.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 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/ diff --git a/test.hs b/test.hs --- a/test.hs +++ b/test.hs @@ -5,4 +5,5 @@ main = do runTestTT testsDarcsBasic runTestTT testsTreeIndex runTestTT testsGeneric + runTestTT testsTree return ()