1 {-# LANGUAGE ScopedTypeVariables, FlexibleInstances, ViewPatterns, OverloadedStrings #-} 2 module Storage.Hashed.Test( tests ) where 3 4 import Prelude hiding ( filter, readFile, writeFile ) 5 import qualified Prelude 6 import qualified Data.ByteString.Lazy.Char8 as BL 7 import qualified Data.ByteString.Char8 as BS 8 import Control.Exception( finally ) 9 import System.Process 10 import System.Directory( doesFileExist, removeFile, doesDirectoryExist ) 11 import Control.Monad( forM_, when ) 12 import Control.Monad.Identity 13 import Control.Monad.Trans( lift ) 14 import Control.Applicative( (<$>) ) 15 16 import Data.Maybe 17 import Data.Word 18 import Data.Int 19 import Data.Bits 20 import Data.List( (\\), sort, intercalate, nub, intersperse ) 21 22 import Storage.Hashed 23 import Storage.Hashed.Path 24 import Data.Path.Unsafe 25 import Storage.Hashed.Tree 26 import Storage.Hashed.Index 27 import Storage.Hashed.Utils 28 import Storage.Hashed.Darcs 29 import Storage.Hashed.Hash 30 import Storage.Hashed.Monad 31 32 import System.IO.Unsafe( unsafePerformIO ) 33 import System.Mem( performGC ) 34 35 import qualified Data.Set as S 36 import qualified Data.Map as M 37 38 import qualified Bundled.Posix as Posix 39 ( getFileStatus, getSymbolicLinkStatus, fileSize, fileExists ) 40 41 import Test.HUnit hiding ( Path ) 42 import Test.Framework( testGroup ) 43 import Test.QuickCheck 44 45 import Test.Framework.Providers.HUnit 46 import Test.Framework.Providers.QuickCheck2 47 48 ------------------------ 49 -- Test Data 50 -- 51 52 blobs = [ (unsafePathFromString "foo_a", BL.pack "a\n") 53 , (unsafePathFromString "foo_dir/foo_a", BL.pack "a\n") 54 , (unsafePathFromString "foo_dir/foo_b", BL.pack "b\n") 55 , (unsafePathFromString "foo_dir/foo_subdir/foo_a", BL.pack "a\n") 56 , (unsafePathFromString "foo space/foo\nnewline", BL.pack "newline\n") 57 , (unsafePathFromString "foo space/foo\\backslash", BL.pack "backslash\n") 58 , (unsafePathFromString "foo space/foo_a", BL.pack "a\n") ] 59 60 files = map fst blobs 61 62 dirs = [ unsafePathFromString "foo_dir" 63 , unsafePathFromString "foo_dir/foo_subdir" 64 , unsafePathFromString "foo space" ] 65 66 emptyStub = Stub (return emptyTree) NoHash 67 68 testTree = 69 makeTree [ ("foo", emptyStub) 70 , ("subtree", SubTree sub) 71 , ("substub", Stub getsub NoHash) ] 72 where sub = makeTree [ ("stub", emptyStub) 73 , ("substub", Stub getsub2 NoHash) 74 , ("x", SubTree emptyTree) ] 75 getsub = return sub 76 getsub2 = return $ makeTree [ ("file", File emptyBlob) 77 , ("file2", 78 File $ Blob (return $ BL.pack "foo") NoHash) ] 79 80 equals_testdata t = sequence_ [ 81 do isJust (findFile t p) @? show p ++ " in tree" 82 ours <- readBlob (fromJust $ findFile t p) 83 ours @?= stored 84 | (p, stored) <- blobs ] >> 85 sequence_ [ isJust (Prelude.lookup p blobs) @? show p ++ " extra in tree" 86 | (p, File _) <- list t ] 87 88 --------------------------- 89 -- Test list 90 -- 91 92 tests = [ testGroup "Bundled.Posix" posix 93 , testGroup "Storage.Hashed.Utils" utils 94 , testGroup "Storage.Hashed.Hash" hash 95 , testGroup "Storage.Hashed.Tree" tree 96 , testGroup "Storage.Hashed.Index" index 97 , testGroup "Storage.Hashed.Monad" monad 98 , testGroup "Storage.Hashed" hashed ] 99 100 -------------------------- 101 -- Tests 102 -- 103 104 hashed = [ testCase "plain has all files" have_files 105 , testCase "pristine has all files" have_pristine_files 106 , testCase "pristine has no extras" pristine_no_extra 107 , testCase "pristine file contents match" pristine_contents 108 , testCase "plain file contents match" plain_contents 109 , testCase "writePlainTree works" write_plain ] 110 where 111 check_file t f = assertBool 112 ("path " ++ show f ++ " is missing in tree " ++ show t) 113 (isJust $ find t f) 114 check_files = forM_ files . check_file 115 116 pristine_no_extra = do 117 t <- readDarcsPristine currentDir >>= expand 118 forM_ (list t) $ \(path,_) -> assertBool (show path ++ " is extraneous in tree") 119 (path `elem` (dirs ++ files)) 120 have_files = readPlainTree currentDir >>= expand >>= check_files 121 have_pristine_files = 122 readDarcsPristine currentDir >>= expand >>= check_files 123 124 pristine_contents = do 125 t <- readDarcsPristine currentDir >>= expand 126 equals_testdata t 127 128 plain_contents = do 129 t <- expand =<< filter nondarcs `fmap` readPlainTree currentDir 130 equals_testdata t 131 132 write_plain = do 133 orig <- readDarcsPristine currentDir >>= expand 134 writePlainTree orig (currentDir </> "_darcs" </> "plain") 135 t <- expand =<< readPlainTree (currentDir </> "_darcs" </> "plain") 136 equals_testdata t 137 138 index = [ testCase "index versioning" check_index_versions 139 , testCase "index listing" check_index 140 , testCase "index content" check_index_content ] 141 where pristine = readDarcsPristine currentDir >>= expand 142 build_index = 143 do x <- pristine 144 exist <- doesFileExist "_darcs/index" 145 performGC -- required in win32 to trigger file close 146 when exist $ removeFile "_darcs/index" 147 idx <- updateIndex =<< updateIndexFrom "_darcs/index" darcsTreeHash x 148 return (x, idx) 149 check_index = 150 do (pris, idx) <- build_index 151 (sort $ map fst $ list idx) @?= (sort $ map fst $ list pris) 152 check_blob_pair p x y = 153 do a <- readBlob x 154 b <- readBlob y 155 assertEqual ("content match on " ++ show p) a b 156 check_index_content = 157 do (_, idx) <- build_index 158 plain <- readPlainTree currentDir 159 x <- sequence $ zipCommonFiles check_blob_pair plain idx 160 assertBool "files match" (length x > 0) 161 check_index_versions = 162 do performGC -- required in win32 to trigger file close 163 Prelude.writeFile "_darcs/index" "nonsense index... do not crash!" 164 valid <- indexFormatValid "_darcs/index" 165 assertBool "index format invalid" $ not valid 166 167 tree = [ testCase "modifyTree" check_modify 168 , testCase "complex modifyTree" check_modify_complex 169 , testCase "modifyTree removal" check_modify_remove 170 , testCase "expand" check_expand 171 , testCase "expandPath" check_expand_path 172 , testCase "expandPath of sub" check_expand_path_sub 173 , testCase "diffTrees" check_diffTrees 174 , testCase "diffTrees identical" check_diffTrees_ident 175 , testProperty "expandPath" prop_expandPath 176 , testProperty "shapeEq" prop_shape_eq 177 , testProperty "expandedShapeEq" prop_expanded_shape_eq 178 , testProperty "expand is identity" prop_expand_id 179 , testProperty "filter True is identity" prop_filter_id 180 , testProperty "filter False is empty" prop_filter_empty 181 , testProperty "restrict both ways keeps shape" prop_restrict_shape_commutative 182 , testProperty "restrict is a subtree of both" prop_restrict_subtree 183 , testProperty "overlay keeps shape" prop_overlay_shape 184 , testProperty "overlay is superset of over" prop_overlay_super ] 185 where blob x = File $ Blob (return (BL.pack x)) (sha256 $ BL.pack x) 186 name = BS.pack 187 check_modify = 188 let t = makeTree [(name "foo", blob "bar")] 189 modify = modifyTree t (unsafePathFromString "foo") (Just $ blob "bla") 190 in do x <- readBlob $ fromJust $ findFile t (unsafePathFromString "foo") 191 y <- readBlob $ fromJust $ findFile modify (unsafePathFromString "foo") 192 assertEqual "old version" x (BL.pack "bar") 193 assertEqual "new version" y (BL.pack "bla") 194 assertBool "list has foo" $ 195 isJust (Prelude.lookup (unsafePathFromString "foo") $ list modify) 196 length (list modify) @?= 1 197 check_modify_complex = 198 let t = makeTree [ (name "foo", blob "bar") 199 , (name "bar", SubTree t1) ] 200 t1 = makeTree [ (name "foo", blob "bar") ] 201 modify = modifyTree t (unsafePathFromString "bar/foo") (Just $ blob "bla") 202 in do foo <- readBlob $ fromJust $ findFile t (unsafePathFromString "foo") 203 foo' <- readBlob $ fromJust $ findFile modify (unsafePathFromString "foo") 204 bar_foo <- readBlob $ fromJust $ 205 findFile t (unsafePathFromString "bar/foo") 206 bar_foo' <- readBlob $ fromJust $ 207 findFile modify (unsafePathFromString "bar/foo") 208 assertEqual "old foo" foo (BL.pack "bar") 209 assertEqual "old bar/foo" bar_foo (BL.pack "bar") 210 assertEqual "new foo" foo' (BL.pack "bar") 211 assertEqual "new bar/foo" bar_foo' (BL.pack "bla") 212 assertBool "list has bar/foo" $ 213 isJust (Prelude.lookup (unsafePathFromString "bar/foo") $ list modify) 214 assertBool "list has foo" $ 215 isJust (Prelude.lookup (unsafePathFromString "foo") $ list modify) 216 length (list modify) @?= length (list t) 217 check_modify_remove = 218 let t1 = makeTree [(name "foo", blob "bar")] 219 t2 :: Tree Identity = makeTree [ (name "foo", blob "bar") 220 , (name "bar", SubTree t1) ] 221 modify1 = modifyTree t1 (unsafePathFromString "foo") Nothing 222 modify2 = modifyTree t2 (unsafePathFromString "bar") Nothing 223 file = findFile modify1 (unsafePathFromString "foo") 224 subtree = findTree modify2 (unsafePathFromString "bar") 225 in do assertBool "file is gone" (isNothing file) 226 assertBool "subtree is gone" (isNothing subtree) 227 228 no_stubs t = null [ () | (_, Stub _ _) <- list t ] 229 path = unsafePathFromString "substub/substub/file" 230 badpath = unsafePathFromString "substub/substub/foo" 231 check_expand = do 232 x <- expand testTree 233 assertBool "no stubs in testTree" $ not (no_stubs testTree) 234 assertBool "stubs in expanded tree" $ no_stubs x 235 assertBool "path reachable" $ path `elem` (map fst $ list x) 236 assertBool "badpath not reachable" $ 237 badpath `notElem` (map fst $ list x) 238 check_expand_path = do 239 test_exp <- expand testTree 240 t <- expandPath testTree path 241 t' <- expandPath test_exp path 242 t'' <- expandPath testTree $ unsafePathFromString "substub/x" 243 assertBool "path not reachable in testTree" $ path `notElem` (map fst $ list testTree) 244 assertBool "path reachable in t" $ path `elem` (map fst $ list t) 245 assertBool "path reachable in t'" $ path `elem` (map fst $ list t') 246 assertBool "path reachable in t (with findFile)" $ 247 isJust $ findFile t path 248 assertBool "path reachable in t' (with findFile)" $ 249 isJust $ findFile t' path 250 assertBool "path not reachable in t''" $ path `notElem` (map fst $ list t'') 251 assertBool "badpath not reachable in t" $ 252 badpath `notElem` (map fst $ list t) 253 assertBool "badpath not reachable in t'" $ 254 badpath `notElem` (map fst $ list t') 255 256 check_expand_path_sub = do 257 t <- expandPath testTree $ unsafePathFromString "substub" 258 t' <- expandPath testTree $ unsafePathFromString "substub/stub" 259 t'' <- expandPath testTree $ unsafePathFromString "subtree/stub" 260 assertBool "leaf is not a Stub" $ 261 isNothing (findTree testTree $ unsafePathFromString "substub") 262 assertBool "leaf is not a Stub" $ isJust (findTree t $ unsafePathFromString "substub") 263 assertBool "leaf is not a Stub (2)" $ isJust (findTree t' $ unsafePathFromString "substub/stub") 264 assertBool "leaf is not a Stub (3)" $ isJust (findTree t'' $ unsafePathFromString "subtree/stub") 265 266 check_diffTrees = 267 flip finally (Prelude.writeFile "foo_dir/foo_a" "a\n") $ 268 do Prelude.writeFile "foo_dir/foo_a" "b\n" 269 working_plain <- filter nondarcs `fmap` readPlainTree currentDir 270 working <- updateIndex =<< 271 updateIndexFrom "_darcs/index" darcsTreeHash working_plain 272 pristine <- readDarcsPristine currentDir 273 (working', pristine') <- diffTrees working pristine 274 let foo_work = findFile working' (unsafePathFromString "foo_dir/foo_a") 275 foo_pris = findFile pristine' (unsafePathFromString "foo_dir/foo_a") 276 working' `shapeEq` pristine' 277 @? show working' ++ " `shapeEq` " ++ show pristine' 278 assertBool "foo_dir/foo_a is in working'" $ isJust foo_work 279 assertBool "foo_dir/foo_a is in pristine'" $ isJust foo_pris 280 foo_work_c <- readBlob (fromJust foo_work) 281 foo_pris_c <- readBlob (fromJust foo_pris) 282 BL.unpack foo_work_c @?= "b\n" 283 BL.unpack foo_pris_c @?= "a\n" 284 assertEqual "working' tree is minimal" 2 (length $ list working') 285 assertEqual "pristine' tree is minimal" 2 (length $ list pristine') 286 287 check_diffTrees_ident = do 288 pristine <- readDarcsPristine currentDir 289 (t1, t2) <- diffTrees pristine pristine 290 assertBool "t1 is empty" $ null (list t1) 291 assertBool "t2 is empty" $ null (list t2) 292 293 prop_shape_eq x = no_stubs x ==> x `shapeEq` x 294 where types = x :: Tree Identity 295 prop_expanded_shape_eq x = runIdentity $ expandedShapeEq x x 296 where types = x :: Tree Identity 297 prop_expand_id x = no_stubs x ==> runIdentity (expand x) `shapeEq` x 298 where types = x :: Tree Identity 299 prop_filter_id x = runIdentity $ expandedShapeEq x $ filter (\_ _ -> True) x 300 where types = x :: Tree Identity 301 prop_filter_empty x = runIdentity $ expandedShapeEq emptyTree $ filter (\_ _ -> False) x 302 where types = x :: Tree Identity 303 prop_restrict_shape_commutative (t1, t2) = 304 no_stubs t1 && no_stubs t2 && not (restrict t1 t2 `shapeEq` emptyTree) ==> 305 restrict t1 t2 `shapeEq` restrict t2 t1 306 where types = (t1 :: Tree Identity, t2 :: Tree Identity) 307 prop_restrict_subtree (t1, t2) = 308 no_stubs t1 && not (restrict t1 t2 `shapeEq` emptyTree) ==> 309 let restricted = S.fromList (map fst $ list $ restrict t1 t2) 310 orig1 = S.fromList (map fst $ list t1) 311 orig2 = S.fromList (map fst $ list t2) 312 in and [restricted `S.isSubsetOf` orig1, restricted `S.isSubsetOf` orig2] 313 where types = (t1 :: Tree Identity, t2 :: Tree Identity) 314 prop_overlay_shape (t1 :: Tree Identity, t2) = 315 (Just LT == runIdentity (t2 `cmpExpandedShape` t1)) ==> 316 runIdentity $ (t1 `overlay` t2) `expandedShapeEq` t1 317 prop_overlay_super (t1 :: Tree Identity, t2) = 318 (Just LT == runIdentity (t2 `cmpExpandedShape` t1)) ==> 319 Just EQ == (runIdentity $ restrict t2 (t1 `overlay` t2) `cmpTree` t2) 320 prop_expandPath (TreeWithPath t p) = 321 notStub $ find (runIdentity $ expandPath t p) p 322 where notStub (Just (Stub _ _)) = False 323 notStub Nothing = error "Did not exist." 324 notStub _ = True 325 326 utils = [ testProperty "xlate32" prop_xlate32 327 , testProperty "xlate64" prop_xlate64 328 , testProperty "align bounded" prop_align_bounded 329 , testProperty "align aligned" prop_align_aligned 330 , testProperty "reachable is a subset" prop_reach_subset 331 , testProperty "roots are reachable" prop_reach_roots 332 , testProperty "nonexistent roots are not reachable" prop_reach_nonroots 333 , testCase "an example for reachable" check_reachable 334 , testCase "fixFrom" check_fixFrom 335 , testCase "mmap empty file" check_mmapEmpty ] 336 where prop_xlate32 x = (xlate32 . xlate32) x == x where types = x :: Word32 337 prop_xlate64 x = (xlate64 . xlate64) x == x where types = x :: Word64 338 prop_align_bounded (bound, x) = 339 bound > 0 && bound < 1024 && x >= 0 ==> 340 align bound x >= x && align bound x < x + bound 341 where types = (bound, x) :: (Int, Int) 342 prop_align_aligned (bound, x) = 343 bound > 0 && bound < 1024 && x >= 0 ==> 344 align bound x `rem` bound == 0 345 where types = (bound, x) :: (Int, Int) 346 347 check_fixFrom = let f 0 = 0 348 f n = f (n - 1) in fixFrom f 5 @?= 0 349 350 check_mmapEmpty = flip finally (removeFile "test_empty") $ do 351 Prelude.writeFile "test_empty" "" 352 abs <- ioAbsolute (currentDir </> "test_empty") 353 x <- readSegment (abs, Nothing) 354 x @?= BL.empty 355 356 reachable' ref look roots = runIdentity $ reachable ref look roots 357 358 check_reachable = let refs 0 = [1, 2] 359 refs 1 = [2] 360 refs 2 = [0, 4] 361 refs 3 = [4, 6, 7] 362 refs 4 = [0, 1] 363 set = S.fromList [1, 2] 364 map = M.fromList [ (n, refs n) | n <- [0..10] ] 365 reach = reachable' return (lookup map) set 366 in do M.keysSet reach @?= S.fromList [0, 1, 2, 4] 367 368 prop_reach_subset (set :: S.Set Int, map :: M.Map Int [Int]) = 369 M.keysSet (reachable' return (lookup map) set) 370 `S.isSubsetOf` M.keysSet map 371 prop_reach_roots (set :: S.Set Int, map :: M.Map Int [Int]) = 372 set `S.isSubsetOf` M.keysSet map 373 ==> set `S.isSubsetOf` 374 M.keysSet (reachable' return (lookup map) set) 375 376 prop_reach_nonroots (set :: S.Set Int, map :: M.Map Int [Int]) = 377 set `S.intersection` M.keysSet map 378 == M.keysSet (reachable' (return . const []) 379 (lookup map) set) 380 381 lookup :: (Ord a) => M.Map a [a] -> a -> Identity (Maybe (a, [a])) 382 lookup m k = return $ case M.lookupIndex k m of 383 Nothing -> Nothing 384 Just i -> Just $ M.elemAt i m 385 386 hash = [ testProperty "decodeBase16 . encodeBase16 == id" prop_base16 387 , testProperty "decodeBase64u . encodeBase64u == id" prop_base64u ] 388 where prop_base16 x = (decodeBase16 . encodeBase16) x == x 389 prop_base64u x = (decodeBase64u . encodeBase64u) x == x 390 391 monad = [ testCase "path expansion" check_virtual 392 , testCase "rename" check_rename ] 393 where check_virtual = virtualTreeMonad run testTree >> return () 394 where run = do file <- readFile (unsafePathFromString "substub/substub/file") 395 file2 <- readFile (unsafePathFromString "substub/substub/file2") 396 lift $ BL.unpack file @?= "" 397 lift $ BL.unpack file2 @?= "foo" 398 check_rename = do (_, t) <- virtualTreeMonad run testTree 399 t' <- darcsAddMissingHashes =<< expand t 400 forM_ [ (p, i) | (p, i) <- list t' ] $ \(p,i) -> 401 assertBool ("have hash: " ++ show p) $ itemHash i /= NoHash 402 where run = do rename (unsafePathFromString "substub/substub/file") (unsafePathFromString "substub/file2") 403 404 posix = [ testCase "getFileStatus" $ check_stat Posix.getFileStatus 405 , testCase "getSymbolicLinkStatus" $ check_stat Posix.getSymbolicLinkStatus ] 406 where check_stat fun = flip finally (removeFile "test_empty") $ do 407 x <- Posix.fileSize `fmap` fun "foo_a" 408 Prelude.writeFile "test_empty" "" 409 y <- Posix.fileSize `fmap` fun "test_empty" 410 exist_nonexistent <- Posix.fileExists `fmap` fun "test_does_not_exist" 411 exist_existent <- Posix.fileExists `fmap` fun "test_empty" 412 assertEqual "file size" x 2 413 assertEqual "file size" y 0 414 assertBool "existence check" $ not exist_nonexistent 415 assertBool "existence check" exist_existent 416 417 ---------------------------------- 418 -- Arbitrary instances 419 -- 420 421 instance (Arbitrary a, Ord a) => Arbitrary (S.Set a) 422 where arbitrary = S.fromList `fmap` arbitrary 423 424 instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (M.Map k v) 425 where arbitrary = M.fromList `fmap` arbitrary 426 427 instance Arbitrary BL.ByteString where 428 arbitrary = BL.pack `fmap` arbitrary 429 430 instance Arbitrary Word32 where 431 arbitrary = do x <- arbitrary :: Gen Int 432 return $ fromIntegral x 433 434 instance Arbitrary Word8 where 435 arbitrary = do x <- arbitrary :: Gen Int 436 return $ fromIntegral x 437 438 instance Arbitrary Hash where 439 arbitrary = sized hash' 440 where hash' 0 = return NoHash 441 hash' _ = do 442 tag <- oneof [return 0, return 1] 443 case tag of 444 0 -> SHA256 . BS.pack <$> sequence [ arbitrary | _ <- [1..32] ] 445 1 -> SHA1 . BS.pack <$> sequence [ arbitrary | _ <- [1..20] ] 446 447 instance Arbitrary Word64 where 448 arbitrary = do x <- arbitrary :: Gen Int 449 y <- arbitrary :: Gen Int 450 let x' = fromIntegral x 451 y' = fromIntegral y 452 return $ x' .|. (y' `shift` 32) 453 454 instance Arbitrary Int64 where 455 arbitrary = fromIntegral `fmap` (arbitrary :: Gen Word64) 456 457 instance (Monad m) => Arbitrary (TreeItem m) where 458 arbitrary = sized tree' 459 where tree' 0 = oneof [ return (File emptyBlob), return (SubTree emptyTree) ] 460 tree' n = oneof [ file n, subtree n ] 461 file 0 = return (File emptyBlob) 462 file _ = do content <- arbitrary 463 return (File $ Blob (return content) NoHash) 464 subtree n = do branches <- choose (1, n) 465 let sub name = do t <- tree' ((n - 1) `div` branches) 466 return (BS.pack $ show name, t) 467 sublist <- mapM sub [0..branches] 468 oneof [ tree' 0 469 , return (SubTree $ makeTree sublist) 470 , return $ (Stub $ return (makeTree sublist)) NoHash ] 471 472 instance (Monad m) => Arbitrary (Tree m) where 473 arbitrary = do item <- arbitrary 474 case item of 475 File _ -> arbitrary 476 Stub _ _ -> arbitrary 477 SubTree t -> return t 478 479 data TreeWithPath = TreeWithPath (Tree Identity) Relative deriving (Show) 480 481 instance Arbitrary TreeWithPath where 482 arbitrary = do t <- arbitrary 483 p <- oneof $ return root : 484 (map (return . fst) $ list (runIdentity $ expand t)) 485 return $ TreeWithPath t p 486 487 --------------------------- 488 -- Other instances 489 -- 490 491 instance Show (Blob m) where 492 show (Blob _ h) = "Blob " ++ show h 493 494 instance Show (TreeItem m) where 495 show (File f) = "File (" ++ show f ++ ")" 496 show (Stub _ h) = "Stub _ " ++ show h 497 show (SubTree s) = "SubTree (" ++ show s ++ ")" 498 499 instance Show (Tree m) where 500 show t = "Tree " ++ show (treeHash t) ++ " { " ++ 501 (concat . intersperse ", " $ itemstrs) ++ " }" 502 where itemstrs = map show $ listImmediate t 503 504 instance Show (Int -> Int) where 505 show f = "[" ++ intercalate ", " (map val [1..20]) ++ " ...]" 506 where val x = show x ++ " -> " ++ show (f x) 507 508 ----------------------- 509 -- Test utilities 510 -- 511 512 shapeEq a b = Just EQ == cmpShape a b 513 expandedShapeEq a b = (Just EQ ==) <$> cmpExpandedShape a b 514 515 cmpcat (x:y:rest) | x == y = cmpcat (x:rest) 516 | x == Just EQ = cmpcat (y:rest) 517 | y == Just EQ = cmpcat (x:rest) 518 | otherwise = Nothing 519 cmpcat [x] = x 520 cmpcat [] = Just EQ -- empty things are equal 521 522 cmpTree a b = do a' <- expand a 523 b' <- expand b 524 con <- contentsEq a' b' 525 return $ cmpcat [cmpShape a' b', con] 526 where contentsEq a b = cmpcat <$> sequence (zipTrees cmp a b) 527 cmp _ (Just (File a)) (Just (File b)) = do a' <- readBlob a 528 b' <- readBlob b 529 return $ Just (compare a' b') 530 cmp _ _ _ = return (Just EQ) -- neutral 531 532 cmpShape t r = cmpcat $ zipTrees cmp t r 533 where cmp _ (Just a) (Just b) = a `item` b 534 cmp _ Nothing (Just _) = Just LT 535 cmp _ (Just _) Nothing = Just GT 536 item (File _) (File _) = Just EQ 537 item (SubTree s) (SubTree p) = s `cmpShape` p 538 item _ _ = Nothing 539 540 cmpExpandedShape :: (Monad m) => Tree m -> Tree m -> m (Maybe Ordering) 541 cmpExpandedShape a b = do x <- expand a 542 y <- expand b 543 return $ x `cmpShape` y 544 545 nondarcs (directory -> x :/: _) _ | x == BS.pack "_darcs" = False 546 | otherwise = True 547 548 readDarcsPristine :: (AbsRel x) => Path x -> IO (Tree IO) 549 readDarcsPristine dir = do 550 let darcs = dir </> "_darcs" 551 h_inventory = pathToString $ darcs </> "hashed_inventory" 552 repo <- doesDirectoryExist $ pathToString darcs 553 unless repo $ fail $ "Not a darcs repository: " ++ pathToString dir 554 hashed <- doesFileExist h_inventory 555 if hashed 556 then do inv <- BS.readFile h_inventory 557 let lines = BS.split '\n' inv 558 case lines of 559 [] -> return emptyTree 560 (pris_line:_) -> do 561 let hash = decodeDarcsHash $ BS.drop 9 pris_line 562 size = decodeDarcsSize $ BS.drop 9 pris_line 563 when (hash == NoHash) $ fail $ "Bad pristine root: " ++ show pris_line 564 readDarcsHashed (darcsGetLocal $ pathToString $ darcs </> "pristine.hashed") 565 (size, hash) 566 else do have_pristine <- doesDirectoryExist $ pathToString $ darcs </> "pristine" 567 have_current <- doesDirectoryExist $ pathToString $ darcs </> "current" 568 case (have_pristine, have_current) of 569 (True, _) -> readPlainTree $ darcs </> "pristine" 570 (False, True) -> readPlainTree $ darcs </> "current" 571 (_, _) -> fail "No pristine tree is available!"