hashed-storage-0.3.6: Storage/Hashed/Test.hs
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 System.Mem( performGC )
import Bundled.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") ]
files = map fst blobs
dirs = [ floatPath "foo_dir"
, floatPath "foo_dir/foo_subdir" ]
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 "Bundled.Posix" posix
, testGroup "Storage.Hashed" hashed
, testGroup "Storage.Hashed.Index" index
, testGroup "Storage.Hashed.Tree" tree
, testGroup "Storage.Hashed.Utils" utils ]
--------------------------
-- 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 ]
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
sequence_ [
do ours <- read b
let Just stored = Prelude.lookup p blobs
assertEqual "contents match" ours stored
| (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"
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 "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
posix = [ testCase "getFileStatus" $ check_stat getFileStatus
, testCase "getSymbolicLinkStatus" $ check_stat getSymbolicLinkStatus ]
where check_stat fun = do
x <- fileSize `fmap` fun "foo_a"
writeFile "test_empty" ""
y <- fileSize `fmap` fun "test_empty"
exist_nonexistent <- fileExists `fmap` fun "test_does_not_exist"
exist_existent <- 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
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