hashed-storage-0.3.7: Storage/Hashed/Test.hs
{-# 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