diff --git a/Storage/Hashed/Index.hs b/Storage/Hashed/Index.hs --- a/Storage/Hashed/Index.hs +++ b/Storage/Hashed/Index.hs @@ -1,8 +1,15 @@ {-# LANGUAGE ScopedTypeVariables, NoMonomorphismRestriction #-} --- | This module contains plain tree indexing code. +-- | This module contains plain tree indexing code. The index itself is a +-- CACHE: you should only ever use it as an optimisation and never as a primary +-- storage. In practice, this means that when we change index format, the +-- application is expected to throw the old index away and build a fresh +-- index. Please note that tracking index validity is out of scope for this +-- library: this is responsibility of your application. It is advisable that in +-- your validity tracking code, you also check for format validity (see +-- "indexFormatValid") and scrap and re-create index when needed. -- --- The index is a binary file, that overlays a hashed tree over the working +-- 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 @@ -29,7 +36,8 @@ -- 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, readOrUpgradeIndex ) +module Storage.Hashed.Index( readIndex, updateIndexFrom, readOrUpgradeIndex + , indexFormatValid ) where import Prelude hiding ( lookup, readFile, writeFile, catch ) @@ -308,17 +316,26 @@ create (SubTree reference) (AnchoredPath []) 4 readIndex indexpath hashtree --- | Read index (just like readIndex). However, also check that the index --- version matches our expectations and if not, rebuild it from the reference --- (which is provided in form of un-executed action; we will only execute it --- when needed). -readOrUpgradeIndex :: FilePath -> (Tree -> Hash) -> IO Tree -> IO Tree -readOrUpgradeIndex path hashtree getref = do +-- | Check that a given file is an index file with a format we can handle. You +-- should remove and re-create the index whenever this is not true. +indexFormatValid :: FilePath -> IO Bool +indexFormatValid path = do fd <- openBinaryFile path ReadMode magic <- sequence [ hGetChar fd | _ <- [1..4] :: [Int] ] hClose fd - case magic of - "HSI0" -> readIndex path hashtree - _ -> do ref <- getref >>= expand - removeFile path - updateIndexFrom path hashtree ref + return $ case magic of + "HSI0" -> True + _ -> False + +-- | DEPRECATED! Read index (just like readIndex). However, also check that the +-- index version matches our expectations and if not, rebuild it from the +-- reference (which is provided in form of un-executed action; we will only +-- execute it when needed). +readOrUpgradeIndex :: FilePath -> (Tree -> Hash) -> IO Tree -> IO Tree +readOrUpgradeIndex path hashtree getref = do + valid <- indexFormatValid path + if valid then readIndex path hashtree + else do ref <- getref >>= expand + removeFile path + updateIndexFrom path hashtree ref + diff --git a/Storage/Hashed/Test.hs b/Storage/Hashed/Test.hs --- a/Storage/Hashed/Test.hs +++ b/Storage/Hashed/Test.hs @@ -1,6 +1,6 @@ module Storage.Hashed.Test( tests ) where -import Prelude hiding ( read ) +import Prelude hiding ( read, filter ) import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.ByteString.Char8 as BS import System.Process @@ -16,21 +16,23 @@ import Storage.Hashed.Index import Storage.Hashed.Utils import Storage.Hashed.Darcs +import System.IO.Unsafe( unsafePerformIO ) import Test.HUnit import Test.Framework( testGroup ) import Test.QuickCheck import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck +import Test.Framework.Providers.QuickCheck2 ------------------------ -- Test Data -- -files = [ floatPath "hashed-storage.cabal" - , floatPath "Storage/Hashed.hs" - , floatPath "Storage/Hashed/Index.hs" ] +files = [ floatPath "foo_a" + , floatPath "foo_dir/foo_a" + , floatPath "foo_dir/foo_b" + , floatPath "foo_dir/foo_subdir/foo_a" ] emptyStub = Stub (return emptyTree) Nothing @@ -120,7 +122,11 @@ tree = [ testCase "modifyTree" check_modify , testCase "complex modifyTree" check_modify_complex , testCase "expand" check_expand - , testCase "expandPath" check_expand_path ] + , testCase "expandPath" check_expand_path + , testProperty "treeEq" check_tree_eq + , testProperty "expand is identity" check_expand_id + , testProperty "filter True is identity" check_filter_id + , testProperty "filter False is empty" check_filter_empty ] where blob x = File $ Blob (return (BL.pack x)) (Just $ sha256 $ BL.pack x) name = Name . BS.pack check_modify = @@ -160,6 +166,10 @@ assertBool "path reachable" $ path `elem` (map fst $ list t) assertBool "badpath not reachable" $ badpath `notElem` (map fst $ list t) + check_tree_eq x = x `treeEq` x + check_expand_id x = unsafePerformIO (expand x) `treeEq` x + check_filter_id x = filter (\_ _ -> True) x `treeEq` x + check_filter_empty x = filter (\_ _ -> False) x `treeEq` emptyTree utils = [ testProperty "xlate32" prop_xlate32 , testProperty "xlate64" prop_xlate64 ] @@ -176,3 +186,27 @@ let x' = fromIntegral x y' = fromIntegral y return $ x' .|. (y' `shift` 32) + +instance Arbitrary TreeItem where + arbitrary = sized tree' + where tree' 0 = oneof [ return (File emptyBlob), return (SubTree emptyTree) ] + tree' n = do branches <- choose (1, n) + let subtree name = do t <- tree' ((n - 1) `div` branches) + return (makeName $ show name, t) + sublist <- mapM subtree [0..branches] + oneof [ tree' 0 + , return (SubTree $ makeTree sublist) ] + +instance Arbitrary Tree where + arbitrary = do item <- arbitrary + case item of + File _ -> arbitrary + SubTree t -> return t + +treeItemEq (File _) (File _) = True +treeItemEq (SubTree s) (SubTree p) = s `treeEq` p +treeItemEq _ _ = False + +treeEq t r = and $ zipTrees cmp t r + where cmp _ (Just a) (Just b) = a `treeItemEq` b + cmp _ _ _ = False diff --git a/Storage/Hashed/Tree.hs b/Storage/Hashed/Tree.hs --- a/Storage/Hashed/Tree.hs +++ b/Storage/Hashed/Tree.hs @@ -30,7 +30,7 @@ import qualified Data.Map as M import Data.Maybe( catMaybes ) -import Data.List( union, sort ) +import Data.List( union, sort, intersperse ) -------------------------------- -- Tree, Blob and friends @@ -69,6 +69,19 @@ -- given to the user by expand. (Used to implement Index -- updates, eg.) , finish :: Tree -> IO Tree } + +instance Show Blob where + show (Blob _ h) = "Blob " ++ show h + +instance Show TreeItem where + show (File f) = "File (" ++ show f ++ ")" + show (Stub _ h) = "Stub _ " ++ show h + show (SubTree s) = "SubTree (" ++ show s ++ ")" + +instance Show Tree where + show t = "Tree " ++ show (treeHash t) ++ " { " ++ + (concat . intersperse ", " $ itemstrs) ++ " }" + where itemstrs = map show $ listImmediate t -- | Get a hash of a TreeItem. May be Nothing. itemHash :: TreeItem -> Maybe Hash 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.4 +version: 0.3.5 synopsis: Hashed file storage support code. description: Support code for reading and manipulating hashed file storage @@ -74,8 +74,8 @@ if flag(test) build-depends: test-framework, test-framework-hunit, - test-framework-quickcheck, - QuickCheck, HUnit, process >= 1.0.1 + test-framework-quickcheck2, + QuickCheck >= 2, HUnit, process >= 1.0.1, zip-archive else buildable: False diff --git a/test.hs b/test.hs --- a/test.hs +++ b/test.hs @@ -1,5 +1,14 @@ import Storage.Hashed.Test( tests ) import Test.Framework( defaultMain ) +import System.Directory( createDirectory, removeDirectoryRecursive + , setCurrentDirectory ) +import Codec.Archive.Zip( extractFilesFromArchive, toArchive ) +import qualified Data.ByteString.Lazy as BL main :: IO () -main = defaultMain tests +main = do zip <- toArchive `fmap` BL.readFile "testdata.zip" + removeDirectoryRecursive "_test_playground" `catch` \_ -> return () + createDirectory "_test_playground" + setCurrentDirectory "_test_playground" + extractFilesFromArchive [] zip + defaultMain tests