{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-} 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 Control.Exception( finally ) import System.Process import System.Directory( doesFileExist, removeFile ) import Control.Monad( forM_, when ) import Control.Monad.Identity import Data.Maybe import Data.Word import Data.Bits import Data.List( (\\), sort, intercalate, nub ) import Storage.Hashed import Storage.Hashed.AnchoredPath import Storage.Hashed.Tree import Storage.Hashed.Index import Storage.Hashed.Utils import Storage.Hashed.Darcs import Storage.Hashed.Packed import System.IO.Unsafe( unsafePerformIO ) import System.Mem( performGC ) import qualified Data.Set as S import qualified Data.Map as M import qualified Bundled.Posix as Posix ( getFileStatus, getSymbolicLinkStatus, fileSize, fileExists ) import Test.HUnit import Test.Framework( testGroup ) import Test.QuickCheck import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 ------------------------ -- Test Data -- blobs = [ (floatPath "foo_a", BL.pack "a\n") , (floatPath "foo_dir/foo_a", BL.pack "a\n") , (floatPath "foo_dir/foo_b", BL.pack "b\n") , (floatPath "foo_dir/foo_subdir/foo_a", BL.pack "a\n") , (floatPath "foo space/foo\nnewline", BL.pack "newline\n") , (floatPath "foo space/foo\\backslash", BL.pack "backslash\n") , (floatPath "foo space/foo_a", BL.pack "a\n") ] files = map fst blobs dirs = [ floatPath "foo_dir" , floatPath "foo_dir/foo_subdir" , floatPath "foo space" ] 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) ] equals_testdata t = sequence_ [ do ours <- read b let Just stored = Prelude.lookup p blobs assertEqual "contents match" ours stored | (p, File b) <- list t ] --------------------------- -- Test list -- tests = [ testGroup "Bundled.Posix" posix , testGroup "Storage.Hashed.Utils" utils , testGroup "Storage.Hashed.Tree" tree , testGroup "Storage.Hashed.Index" index , testGroup "Storage.Hashed.Packed" packed , testGroup "Storage.Hashed" hashed ] -------------------------- -- Tests -- hashed = [ testCase "plain has all files" have_files , testCase "pristine has all files" have_pristine_files , testCase "pristine has no extras" pristine_no_extra , testCase "pristine file contents match" pristine_contents , testCase "plain file contents match" plain_contents , testCase "writePlainTree works" write_plain ] where check_file t f = assertBool ("path " ++ show f ++ " is missing in tree") (isJust $ find t f) check_files = forM_ files . check_file pristine_no_extra = do t <- readDarcsPristine "." >>= expand forM_ (list t) $ \(path,_) -> assertBool (show path ++ " is extraneous in tree") (path `elem` (dirs ++ files)) have_files = readPlainTree "." >>= expand >>= check_files have_pristine_files = readDarcsPristine "." >>= expand >>= check_files pristine_contents = do t <- readDarcsPristine "." >>= expand equals_testdata t plain_contents = do t <- expand =<< filter nondarcs `fmap` readPlainTree "." equals_testdata t write_plain = do orig <- readDarcsPristine "." >>= expand writePlainTree orig "_darcs/plain" t <- readPlainTree "_darcs/plain" equals_testdata 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" performGC -- required in win32 to trigger file close 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 performGC -- required in win32 to trigger file close 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 "modifyTree removal" check_modify_remove , testCase "expand" check_expand , testCase "expandPath" check_expand_path , testCase "diffTrees" check_diffTrees , testCase "diffTrees identical" check_diffTrees_ident , testProperty "treeEq" prop_tree_eq , testProperty "expand is identity" prop_expand_id , testProperty "filter True is identity" prop_filter_id , testProperty "filter False is empty" prop_filter_empty , testProperty "restrict both ways keeps shape" prop_restrict_shape_commutative , testProperty "restrict is a subtree of both" prop_restrict_subtree ] 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") assertBool "list has foo" $ isJust (Prelude.lookup (floatPath "foo") $ list modify) length (list modify) @?= 1 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") assertBool "list has bar/foo" $ isJust (Prelude.lookup (floatPath "bar/foo") $ list modify) assertBool "list has foo" $ isJust (Prelude.lookup (floatPath "foo") $ list modify) length (list modify) @?= length (list t) check_modify_remove = let t1 = makeTree [(name "foo", blob "bar")] t2 = makeTree [ (name "foo", blob "bar") , (name "bar", SubTree t1) ] modify1 = modifyTree t1 (floatPath "foo") Nothing modify2 = modifyTree t2 (floatPath "bar") Nothing file = findFile modify1 (floatPath "foo") subtree = findTree modify2 (floatPath "bar") in do assertBool "file is gone" (isNothing file) assertBool "subtree is gone" (isNothing subtree) 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 test_exp <- expand testTree t <- expandPath testTree path t' <- expandPath test_exp path t'' <- expandPath testTree $ floatPath "substub/x" assertBool "path not reachable in testTree" $ path `notElem` (map fst $ list testTree) assertBool "path reachable in t" $ path `elem` (map fst $ list t) assertBool "path reachable in t'" $ path `elem` (map fst $ list t') assertBool "path reachable in t (with findFile)" $ isJust $ findFile t path assertBool "path reachable in t' (with findFile)" $ isJust $ findFile t' path assertBool "path not reachable in t''" $ path `notElem` (map fst $ list t'') assertBool "badpath not reachable in t" $ badpath `notElem` (map fst $ list t) assertBool "badpath not reachable in t'" $ badpath `notElem` (map fst $ list t') check_diffTrees = flip finally (writeFile "foo_dir/foo_a" "a\n") $ do writeFile "foo_dir/foo_a" "b\n" working_plain <- filter nondarcs `fmap` readPlainTree "." working <- expand =<< updateIndexFrom "_darcs/index" darcsTreeHash working_plain pristine <- readDarcsPristine "." (working', pristine') <- diffTrees working pristine let foo_work = findFile working' (floatPath "foo_dir/foo_a") foo_pris = findFile pristine' (floatPath "foo_dir/foo_a") assertBool "trees have equal shapes" (working' `treeEq` pristine') assertBool "foo_dir/foo_a is in working'" $ isJust foo_work assertBool "foo_dir/foo_a is in pristine'" $ isJust foo_pris foo_work_c <- read (fromJust foo_work) foo_pris_c <- read (fromJust foo_pris) BL.unpack foo_work_c @?= "b\n" BL.unpack foo_pris_c @?= "a\n" assertEqual "working' tree is minimal" 2 (length $ list working') assertEqual "pristine' tree is minimal" 2 (length $ list pristine') check_diffTrees_ident = do pristine <- readDarcsPristine "." (t1, t2) <- diffTrees pristine pristine assertBool "t1 is empty" $ null (list t1) assertBool "t2 is empty" $ null (list t2) prop_tree_eq x = x `treeEq` x prop_expand_id x = unsafePerformIO (expand x) `treeEq` x prop_filter_id x = filter (\_ _ -> True) x `treeEq` x prop_filter_empty x = filter (\_ _ -> False) x `treeEq` emptyTree prop_restrict_shape_commutative (t1, t2) = not (restrict t1 t2 `treeEq` emptyTree) ==> restrict t1 t2 `treeEq` restrict t2 t1 prop_restrict_subtree (t1, t2) = not (restrict t1 t2 `treeEq` emptyTree) ==> let restricted = S.fromList (map fst $ list $ restrict t1 t2) orig1 = S.fromList (map fst $ list t1) orig2 = S.fromList (map fst $ list t2) in and [restricted `S.isSubsetOf` orig1, restricted `S.isSubsetOf` orig2] packed = [ testCase "loose pristine tree" check_loose , testCase "readOS" check_readOS , testCase "live" check_live , testCase "compact" check_compact ] where check_loose = do x <- readDarcsPristine "." os <- create "_darcs/loose" Loose (os', root) <- writePackedDarcsPristine x os y <- readPackedDarcsPristine os' root equals_testdata y check_readOS = do os <- readOS "_darcs/loose" format (hatchery os) @?= Loose x <- readDarcsPristine "." y <- readPackedDarcsPristine os (fromJust $ treeHash x) equals_testdata y check_live = do os <- readOS "_darcs/loose" x <- readDarcsPristine "." alive <- live (os { roots = [ fromJust $ treeHash x ] , references = darcsPristineRefs } ) [hatchery os] sequence_ [ assertBool "" $ (fromJust hash) `S.member` M.keysSet alive | hash <- map (itemHash . snd) $ list x ] length (M.toList alive) @?= 1 + length (nub $ map snd blobs) + length dirs check_compact = do os <- readOS "_darcs/loose" x <- darcsUpdateHashes `fmap` (expand =<< readDarcsPristine ".") (os', root) <- storePackedDarcsPristine x os hatch_root_old <- blockLookup (hatchery os') root assertBool "bits in the old hatchery" $ isJust hatch_root_old os'' <- compact os' length (mature os'') @?= 1 hatch_root <- blockLookup (hatchery os'') root assertBool "bits no longer in hatchery" $ isNothing hatch_root -- TODO: -- y <- readPackedDarcsPristine os'' (fromJust $ treeHash x) -- equals_testdata y utils = [ testProperty "xlate32" prop_xlate32 , testProperty "xlate64" prop_xlate64 , testProperty "reachable is a subset" prop_reach_subset , testProperty "roots are reachable" prop_reach_roots , testProperty "nonexistent roots are not reachable" prop_reach_nonroots , testCase "an example for reachable" check_reachable , testCase "fixFrom" check_fixFrom , testCase "mmap empty file" check_mmapEmpty ] where prop_xlate32 x = (xlate32 . xlate32) x == x where types = x :: Word32 prop_xlate64 x = (xlate64 . xlate64) x == x where types = x :: Word64 check_fixFrom = let f 0 = 0 f n = f (n - 1) in fixFrom f 5 @?= 0 check_mmapEmpty = flip finally (removeFile "test_empty") $ do Prelude.writeFile "test_empty" "" x <- readSegment ("test_empty", Nothing) x @?= BL.empty reachable' ref look roots = runIdentity $ reachable ref look roots check_reachable = let refs 0 = [1, 2] refs 1 = [2] refs 2 = [0, 4] refs 3 = [4, 6, 7] refs 4 = [0, 1] set = S.fromList [1, 2] map = M.fromList [ (n, refs n) | n <- [0..10] ] reach = reachable' return (lookup map) set in do M.keysSet reach @?= S.fromList [0, 1, 2, 4] prop_reach_subset (set :: S.Set Int, map :: M.Map Int [Int]) = M.keysSet (reachable' return (lookup map) set) `S.isSubsetOf` M.keysSet map prop_reach_roots (set :: S.Set Int, map :: M.Map Int [Int]) = set `S.isSubsetOf` M.keysSet map ==> set `S.isSubsetOf` M.keysSet (reachable' return (lookup map) set) prop_reach_nonroots (set :: S.Set Int, map :: M.Map Int [Int]) = set `S.intersection` M.keysSet map == M.keysSet (reachable' (return . const []) (lookup map) set) lookup :: (Ord a) => M.Map a [a] -> a -> Identity (Maybe (a, [a])) lookup m k = return $ case M.lookupIndex k m of Nothing -> Nothing Just i -> Just $ M.elemAt i m posix = [ testCase "getFileStatus" $ check_stat Posix.getFileStatus , testCase "getSymbolicLinkStatus" $ check_stat Posix.getSymbolicLinkStatus ] where check_stat fun = flip finally (removeFile "test_empty") $ do x <- Posix.fileSize `fmap` fun "foo_a" Prelude.writeFile "test_empty" "" y <- Posix.fileSize `fmap` fun "test_empty" exist_nonexistent <- Posix.fileExists `fmap` fun "test_does_not_exist" exist_existent <- Posix.fileExists `fmap` fun "test_empty" assertEqual "file size" x 2 assertEqual "file size" y 0 assertBool "existence check" $ not exist_nonexistent assertBool "existence check" exist_existent ---------------------------------- -- Arbitrary instances -- instance (Arbitrary a, Ord a) => Arbitrary (S.Set a) where arbitrary = S.fromList `fmap` arbitrary instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (M.Map k v) where arbitrary = M.fromList `fmap` arbitrary 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 --------------------------- -- Other instances -- instance Show (Int -> Int) where show f = "[" ++ intercalate ", " (map val [1..20]) ++ " ...]" where val x = show x ++ " -> " ++ show (f x) ----------------------- -- Test utilities -- 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 nondarcs (AnchoredPath (Name x:_)) _ | x == BS.pack "_darcs" = False | otherwise = True