{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-} module Darcs.Test.HashedStorage( tests ) where import Prelude hiding ( filter, readFile, writeFile, lookup, (<$>) ) import qualified Prelude import qualified Data.ByteString.Lazy.Char8 as BLC import qualified Data.ByteString.Char8 as BC import System.Directory( doesFileExist, removeFile, doesDirectoryExist ) import System.FilePath( () ) import Control.Monad.Identity import Control.Monad.Trans( lift ) import Control.Applicative( (<$>) ) import Codec.Archive.Zip( extractFilesFromArchive, toArchive ) import Data.Maybe import Data.Word import Data.List( sort, intercalate, intersperse ) import Darcs.Util.Path hiding ( setCurrentDirectory ) import Darcs.Util.Lock ( withTempDir ) import Darcs.Util.Tree hiding ( lookup ) import Darcs.Util.Index import Darcs.Util.Tree.Hashed import Darcs.Util.Hash import Darcs.Util.Tree.Monad hiding ( tree, createDirectory ) import Darcs.Util.Tree.Plain import System.Mem( performGC ) import qualified Data.Set as S import Test.HUnit hiding ( path ) import Test.Framework( testGroup ) import qualified Test.Framework as TF ( Test ) import Test.QuickCheck import Test.Framework.Providers.HUnit import Test.Framework.Providers.QuickCheck2 ------------------------ -- Test Data -- blobs :: [(AnchoredPath, BLC.ByteString)] blobs = [ (floatPath "foo_a", BLC.pack "a\n") , (floatPath "foo_dir/foo_a", BLC.pack "a\n") , (floatPath "foo_dir/foo_b", BLC.pack "b\n") , (floatPath "foo_dir/foo_subdir/foo_a", BLC.pack "a\n") , (floatPath "foo space/foo\nnewline", BLC.pack "newline\n") , (floatPath "foo space/foo\\backslash", BLC.pack "backslash\n") , (floatPath "foo space/foo_a", BLC.pack "a\n") ] files :: [AnchoredPath] files = map fst blobs dirs :: [AnchoredPath] dirs = [ floatPath "foo_dir" , floatPath "foo_dir/foo_subdir" , floatPath "foo space" ] emptyStub :: TreeItem IO emptyStub = Stub (return emptyTree) NoHash testTree :: Tree IO testTree = makeTree [ (makeName "foo", emptyStub) , (makeName "subtree", SubTree sub) , (makeName "substub", Stub getsub NoHash) ] where sub = makeTree [ (makeName "stub", emptyStub) , (makeName "substub", Stub getsub2 NoHash) , (makeName "x", SubTree emptyTree) ] getsub = return sub getsub2 = return $ makeTree [ (makeName "file", File emptyBlob) , (makeName "file2", File $ Blob (return $ BLC.pack "foo") NoHash) ] equals_testdata :: Tree IO -> IO () equals_testdata t = sequence_ [ do isJust (findFile t p) @? show p ++ " in tree" ours <- readBlob (fromJust $ findFile t p) ours @?= stored | (p, stored) <- blobs ] >> sequence_ [ isJust (Prelude.lookup p blobs) @? show p ++ " extra in tree" | (p, File _) <- list t ] --------------------------- -- Test list -- tests :: [TF.Test] tests = [ testGroup "Darcs.Util.Hash" hash , testGroup "Darcs.Util.Tree" tree , testGroup "Darcs.Util.Index" index , testGroup "Darcs.Util.Tree.Monad" monad , testGroup "Hashed Storage" hashed ] -------------------------- -- Tests -- hashed :: [TF.Test] 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 " ++ show t) (isJust $ find t f) check_files = forM_ files . check_file pristine_no_extra = extractRepoAndRun $ do t <- readDarcsPristine "." >>= expand forM_ (list t) $ \(path,_) -> assertBool (show path ++ " is extraneous in tree") (path `elem` (dirs ++ files)) have_files = extractRepoAndRun ( readPlainTree "." >>= expand >>= check_files ) have_pristine_files = extractRepoAndRun ( readDarcsPristine "." >>= expand >>= check_files ) pristine_contents = extractRepoAndRun $ do t <- readDarcsPristine "." >>= expand equals_testdata t plain_contents = extractRepoAndRun $ do t <- expand =<< filter nondarcs `fmap` readPlainTree "." equals_testdata t write_plain = extractRepoAndRun $ do orig <- readDarcsPristine "." >>= expand writePlainTree orig "_darcs/plain" t <- expand =<< readPlainTree "_darcs/plain" equals_testdata t index :: [TF.Test] index = [ testCase "index versioning" check_index_versions , testCase "index listing" check_index , testCase "index content" check_index_content , testProperty "xlate32" prop_xlate32 , testProperty "xlate64" prop_xlate64 , testProperty "align bounded" prop_align_bounded , testProperty "align aligned" prop_align_aligned ] 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 <- updateIndex =<< updateIndexFrom "_darcs/index" darcsTreeHash x return (x, idx) check_index = extractRepoAndRun $ do (pris, idx) <- build_index (sort $ map fst $ list idx) @?= (sort $ map fst $ list pris) check_blob_pair p x y = do a <- readBlob x b <- readBlob y assertEqual ("content match on " ++ show p) a b check_index_content = extractRepoAndRun $ do (_, idx) <- build_index plain <- readPlainTree "." x <- sequence $ zipCommonFiles check_blob_pair plain idx assertBool "files match" (length x > 0) check_index_versions = extractRepoAndRun $ do performGC -- required in win32 to trigger file close Prelude.writeFile "_darcs/index" "nonsense index... do not crash!" valid <- indexFormatValid "_darcs/index" assertBool "index format invalid" $ not valid prop_xlate32 x = (xlate32 . xlate32) x == x where _types = x :: Word32 prop_xlate64 x = (xlate64 . xlate64) x == x where _types = x :: Word64 prop_align_bounded (bound, x) = bound > 0 && bound < 1024 && x >= 0 ==> align bound x >= x && align bound x < x + bound where _types = (bound, x) :: (Int, Int) prop_align_aligned (bound, x) = bound > 0 && bound < 1024 && x >= 0 ==> align bound x `rem` bound == 0 where _types = (bound, x) :: (Int, Int) tree :: [TF.Test] 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 "expandPath of sub" check_expand_path_sub , testCase "diffTrees" check_diffTrees , testCase "diffTrees identical" check_diffTrees_ident , testProperty "expandPath" prop_expandPath , testProperty "shapeEq" prop_shape_eq , testProperty "expandedShapeEq" prop_expanded_shape_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 , testProperty "overlay keeps shape" prop_overlay_shape , testProperty "overlay is superset of over" prop_overlay_super ] where blob x = File $ Blob (return (BLC.pack x)) (sha256 $ BLC.pack x) name = makeName check_modify = let t = makeTree [(name "foo", blob "bar")] modify = modifyTree t (floatPath "foo") (Just $ blob "bla") in do x <- readBlob $ fromJust $ findFile t (floatPath "foo") y <- readBlob $ fromJust $ findFile modify (floatPath "foo") assertEqual "old version" x (BLC.pack "bar") assertEqual "new version" y (BLC.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 <- readBlob $ fromJust $ findFile t (floatPath "foo") foo' <- readBlob $ fromJust $ findFile modify (floatPath "foo") bar_foo <- readBlob $ fromJust $ findFile t (floatPath "bar/foo") bar_foo' <- readBlob $ fromJust $ findFile modify (floatPath "bar/foo") assertEqual "old foo" foo (BLC.pack "bar") assertEqual "old bar/foo" bar_foo (BLC.pack "bar") assertEqual "new foo" foo' (BLC.pack "bar") assertEqual "new bar/foo" bar_foo' (BLC.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 :: Tree Identity = 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_expand_path_sub = do t <- expandPath testTree $ floatPath "substub" t' <- expandPath testTree $ floatPath "substub/stub" t'' <- expandPath testTree $ floatPath "subtree/stub" assertBool "leaf is not a Stub" $ isNothing (findTree testTree $ floatPath "substub") assertBool "leaf is not a Stub" $ isJust (findTree t $ floatPath "substub") assertBool "leaf is not a Stub (2)" $ isJust (findTree t' $ floatPath "substub/stub") assertBool "leaf is not a Stub (3)" $ isJust (findTree t'' $ floatPath "subtree/stub") check_diffTrees = extractRepoAndRun $ do Prelude.writeFile "foo_dir/foo_a" "b\n" working_plain <- filter nondarcs `fmap` readPlainTree "." working <- updateIndex =<< 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") working' `shapeEq` pristine' @? show working' ++ " `shapeEq` " ++ show 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 <- readBlob (fromJust foo_work) foo_pris_c <- readBlob (fromJust foo_pris) BLC.unpack foo_work_c @?= "b\n" BLC.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_shape_eq x = no_stubs x ==> x `shapeEq` x where _types = x :: Tree Identity prop_expanded_shape_eq x = runIdentity $ expandedShapeEq x x where _types = x :: Tree Identity prop_expand_id x = no_stubs x ==> runIdentity (expand x) `shapeEq` x where _types = x :: Tree Identity prop_filter_id x = runIdentity $ expandedShapeEq x $ filter (\_ _ -> True) x where _types = x :: Tree Identity prop_filter_empty x = runIdentity $ expandedShapeEq emptyTree $ filter (\_ _ -> False) x where _types = x :: Tree Identity prop_restrict_shape_commutative (t1, t2) = no_stubs t1 && no_stubs t2 && not (restrict t1 t2 `shapeEq` emptyTree) ==> restrict t1 t2 `shapeEq` restrict t2 t1 where _types = (t1 :: Tree Identity, t2 :: Tree Identity) prop_restrict_subtree (t1, t2) = no_stubs t1 && not (restrict t1 t2 `shapeEq` 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] where _types = (t1 :: Tree Identity, t2 :: Tree Identity) prop_overlay_shape (t1 :: Tree Identity, t2) = (Just LT == runIdentity (t2 `cmpExpandedShape` t1)) ==> runIdentity $ (t1 `overlay` t2) `expandedShapeEq` t1 prop_overlay_super (t1 :: Tree Identity, t2) = (Just LT == runIdentity (t2 `cmpExpandedShape` t1)) && no_stubs t2 ==> Just EQ == (runIdentity $ restrict t2 (t1 `overlay` t2) `cmpTree` t2) prop_expandPath (TreeWithPath t p) = notStub $ find (runIdentity $ expandPath t p) p where notStub (Just (Stub _ _)) = False notStub Nothing = error "Did not exist." notStub _ = True hash :: [TF.Test] hash = [ testProperty "decodeBase16 . encodeBase16 == id" prop_base16 ] where prop_base16 x = (decodeBase16 . encodeBase16) x == x monad :: [TF.Test] monad = [ testCase "path expansion" check_virtual , testCase "rename" check_rename ] where check_virtual = virtualTreeMonad run testTree >> return () where run = do file <- readFile (floatPath "substub/substub/file") file2 <- readFile (floatPath "substub/substub/file2") lift $ BLC.unpack file @?= "" lift $ BLC.unpack file2 @?= "foo" check_rename = do (_, t) <- virtualTreeMonad run testTree t' <- darcsAddMissingHashes =<< expand t forM_ [ (p, i) | (p, i) <- list t' ] $ \(p,i) -> assertBool ("have hash: " ++ show p) $ itemHash i /= NoHash where run = do rename (floatPath "substub/substub/file") (floatPath "substub/file2") ---------------------------------- -- Arbitrary instances -- instance Arbitrary BLC.ByteString where arbitrary = BLC.pack `fmap` arbitrary instance Arbitrary Hash where arbitrary = sized hash' where hash' 0 = return NoHash hash' _ = SHA256 . BC.pack <$> sequence [ arbitrary | _ <- [1..32] :: [Int] ] instance (Monad m) => Arbitrary (TreeItem m) where arbitrary = sized tree' where tree' 0 = oneof [ return (File emptyBlob), return (SubTree emptyTree) ] tree' n = oneof [ file n, subtree n ] file 0 = return (File emptyBlob) file _ = do content <- arbitrary return (File $ Blob (return content) NoHash) subtree n = do branches <- choose (1, n) let sub name = do t <- tree' ((n - 1) `div` branches) return (makeName $ show name, t) sublist <- mapM sub [0..branches] oneof [ tree' 0 , return (SubTree $ makeTree sublist) , return $ (Stub $ return (makeTree sublist)) NoHash ] instance (Monad m) => Arbitrary (Tree m) where arbitrary = do item <- arbitrary case item of File _ -> arbitrary Stub _ _ -> arbitrary SubTree t -> return t data TreeWithPath = TreeWithPath (Tree Identity) AnchoredPath deriving (Show) instance Arbitrary TreeWithPath where arbitrary = do t <- arbitrary p <- oneof $ return (AnchoredPath []) : (map (return . fst) $ list (runIdentity $ expand t)) return $ TreeWithPath t p --------------------------- -- Other instances -- instance Show (Blob m) where show (Blob _ h) = "Blob " ++ show h instance Show (TreeItem m) where show (File f) = "File (" ++ show f ++ ")" show (Stub _ h) = "Stub _ " ++ show h show (SubTree s) = "SubTree (" ++ show s ++ ")" instance Show (Tree m) where show t = "Tree " ++ show (treeHash t) ++ " { " ++ (concat . intersperse ", " $ itemstrs) ++ " }" where itemstrs = map show $ listImmediate t instance Show (Int -> Int) where show f = "[" ++ intercalate ", " (map val [1..20]) ++ " ...]" where val x = show x ++ " -> " ++ show (f x) ----------------------- -- Test utilities -- shapeEq :: Tree m -> Tree m -> Bool shapeEq a b = Just EQ == cmpShape a b expandedShapeEq :: (Monad m, Functor m) => Tree m -> Tree m -> m Bool expandedShapeEq a b = (Just EQ ==) <$> cmpExpandedShape a b cmpcat :: [Maybe Ordering] -> Maybe Ordering cmpcat (x:y:rest) | x == y = cmpcat (x:rest) | x == Just EQ = cmpcat (y:rest) | y == Just EQ = cmpcat (x:rest) | otherwise = Nothing cmpcat [x] = x cmpcat [] = Just EQ -- empty things are equal cmpTree :: (Monad m, Functor m) => Tree m -> Tree m -> m (Maybe Ordering) cmpTree x y = do x' <- expand x y' <- expand y con <- contentsEq x' y' return $ cmpcat [cmpShape x' y', con] where contentsEq a b = cmpcat <$> sequence (zipTrees cmp a b) cmp _ (Just (File a)) (Just (File b)) = do a' <- readBlob a b' <- readBlob b return $ Just (compare a' b') cmp _ _ _ = return (Just EQ) -- neutral cmpShape :: Tree m -> Tree m -> Maybe Ordering cmpShape t r = cmpcat $ zipTrees cmp t r where cmp _ (Just a) (Just b) = a `item` b cmp _ Nothing (Just _) = Just LT cmp _ (Just _) Nothing = Just GT cmp _ Nothing Nothing = Just EQ item (File _) (File _) = Just EQ item (SubTree s) (SubTree p) = s `cmpShape` p item _ _ = Nothing cmpExpandedShape :: (Monad m) => Tree m -> Tree m -> m (Maybe Ordering) cmpExpandedShape a b = do x <- expand a y <- expand b return $ x `cmpShape` y nondarcs :: AnchoredPath -> TreeItem m -> Bool nondarcs (AnchoredPath (x:_)) _ | x == makeName "_darcs" = False | otherwise = True nondarcs (AnchoredPath []) _ = True readDarcsPristine :: FilePath -> IO (Tree IO) readDarcsPristine dir = do let darcs = dir "_darcs" h_inventory = darcs "hashed_inventory" repo <- doesDirectoryExist darcs unless repo $ fail $ "Not a darcs repository: " ++ dir isHashed <- doesFileExist h_inventory if isHashed then do inv <- BC.readFile h_inventory let thelines = BC.split '\n' inv case thelines of [] -> return emptyTree (pris_line:_) -> do let thehash = decodeDarcsHash $ BC.drop 9 pris_line thesize = decodeDarcsSize $ BC.drop 9 pris_line when (thehash == NoHash) $ fail $ "Bad pristine root: " ++ show pris_line readDarcsHashed (darcs "pristine.hashed") (thesize, thehash) else do have_pristine <- doesDirectoryExist $ darcs "pristine" have_current <- doesDirectoryExist $ darcs "current" case (have_pristine, have_current) of (True, _) -> readPlainTree $ darcs "pristine" (False, True) -> readPlainTree $ darcs "current" (_, _) -> fail "No pristine tree is available!" extractRepoAndRun :: IO a -> IO a extractRepoAndRun action = do zipFile <- toArchive . BLC.fromStrict <$> BC.readFile "harness/hstestdata.zip" withTempDir "_test_playground" $ \_ -> do extractFilesFromArchive [] zipFile action