module Storage.Hashed.Test( tests ) where import Prelude hiding ( read, filter ) import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.ByteString.Char8 as BS import System.Process import System.Directory( doesFileExist, removeFile ) import Control.Monad( forM_, when ) import Data.Maybe import Data.Word import Data.Bits 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 import System.IO.Unsafe( unsafePerformIO ) import Test.HUnit import Test.Framework( testGroup ) import Test.QuickCheck import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 ------------------------ -- Test Data -- 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 testTree = makeTree [ (makeName "foo", emptyStub) , (makeName "subtree", SubTree sub) , (makeName "substub", Stub getsub Nothing) ] where sub = makeTree [ (makeName "stub", emptyStub) , (makeName "substub", Stub getsub2 Nothing) , (makeName "x", SubTree emptyTree) ] getsub = return sub getsub2 = return $ makeTree [ (makeName "file", File emptyBlob) ] --------------------------- -- Test list -- tests = [ testGroup "darcs" darcs , testGroup "Storage.Hashed.Index" index , testGroup "Storage.Hashed.Tree" tree , testGroup "Storage.Hashed.Utils" utils ] -------------------------- -- Tests -- darcs = [ testCase "specific files" have_files , testCase "pristine files" have_pristine_files , testCase "list == darcs show manifest" darcs_manifest , testCase "content == darcs show contents" darcs_contents ] where check_file t f = assertBool ("path " ++ show f ++ " is in tree") (isJust $ find t f) check_files = forM_ files . check_file have_files = readPlainTree "." >>= expand >>= check_files have_pristine_files = readDarcsPristine "." >>= expand >>= check_files -- NB. When hashed-storage replace slurpies in darcs, the following 2 -- tests become useless, since they just check our code against darcs. darcs_manifest = 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 = 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 ] index = [ testCase "index listing" check_index , testCase "index content" check_index_content , testCase "index versioning" check_index_versions ] where pristine = readDarcsPristine "." >>= expand build_index = do x <- pristine exist <- doesFileExist "_darcs/index" when exist $ removeFile "_darcs/index" idx <- updateIndexFrom "_darcs/index" darcsTreeHash x >>= expand return (x, idx) check_index = 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 = do (_, idx) <- build_index plain <- readPlainTree "." x <- sequence $ zipCommonFiles check_blob_pair plain idx assertBool "files match" (length x > 0) check_index_versions = do writeFile "_darcs/index" "nonsense index... do not crash!" pris <- pristine idx <- expand =<< readOrUpgradeIndex "_darcs/index" darcsTreeHash pristine (sort $ map fst $ list idx) @?= (sort $ map fst $ list pris) tree = [ testCase "modifyTree" check_modify , testCase "complex modifyTree" check_modify_complex , testCase "expand" check_expand , 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 = 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 = 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") no_stubs t = null [ () | (_, Stub _ _) <- list t ] path = floatPath "substub/substub/file" badpath = floatPath "substub/substub/foo" check_expand = do x <- expand testTree assertBool "no stubs in testTree" $ not (no_stubs testTree) assertBool "stubs in expanded tree" $ no_stubs x assertBool "path reachable" $ path `elem` (map fst $ list x) assertBool "badpath not reachable" $ badpath `notElem` (map fst $ list x) check_expand_path = do t <- expandPath testTree path 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 ] where prop_xlate32 x = (xlate32 . xlate32) x == x where types = x :: Word32 prop_xlate64 x = (xlate64 . xlate64) x == x where types = x :: Word64 instance Arbitrary Word32 where arbitrary = do x <- arbitrary :: Gen Int return $ fromIntegral x instance Arbitrary Word64 where arbitrary = do x <- arbitrary :: Gen Int y <- arbitrary :: Gen Int 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