hashed-storage-0.4.1: Storage/Hashed/Test.hs
{-# LANGUAGE ScopedTypeVariables, FlexibleInstances #-}
module Storage.Hashed.Test( tests ) where
import Prelude hiding ( filter, readFile, writeFile )
import qualified Prelude
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, doesDirectoryExist )
import System.FilePath( (</>) )
import Control.Monad( forM_, when )
import Control.Monad.Identity
import Control.Monad.Trans( lift )
import Control.Applicative( (<$>) )
import Data.Maybe
import Data.Word
import Data.Int
import Data.Bits
import Data.List( (\\), sort, intercalate, nub, intersperse )
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 Storage.Hashed.Hash
import Storage.Hashed.Monad hiding ( tree )
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) NoHash
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 $ BL.pack "foo") NoHash) ]
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 = [ testGroup "Bundled.Posix" posix
, testGroup "Storage.Hashed.Utils" utils
, testGroup "Storage.Hashed.Hash" hash
, testGroup "Storage.Hashed.Tree" tree
, testGroup "Storage.Hashed.Index" index
, testGroup "Storage.Hashed.Packed" packed
, testGroup "Storage.Hashed.Monad" monad
, 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 " ++ show t)
(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 <- expand =<< readPlainTree "_darcs/plain"
equals_testdata t
index = [ testCase "index versioning" check_index_versions
, testCase "index listing" check_index
, testCase "index content" check_index_content ]
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 =
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 =
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
Prelude.writeFile "_darcs/index" "nonsense index... do not crash!"
valid <- indexFormatValid "_darcs/index"
assertBool "index format invalid" $ not valid
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 "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 (BL.pack x)) (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 <- readBlob $ fromJust $ findFile t (floatPath "foo")
y <- readBlob $ 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 <- 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 (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 :: 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_diffTrees =
flip finally (Prelude.writeFile "foo_dir/foo_a" "a\n") $
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)
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_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)) ==>
Just EQ == (runIdentity $ restrict t2 (t1 `overlay` t2) `cmpTree` t2)
packed = [ testCase "loose pristine tree" check_loose
, testCase "load" check_load
, testCase "live" check_live
, testCase "compact" check_compact ]
where root_hash = treeHash <$> get_pristine
get_pristine = darcsUpdateDirHashes <$> (expand =<< readDarcsPristine ".")
check_loose = do x <- readDarcsPristine "."
os <- create "_darcs/loose" Loose
(os', root) <- writePackedDarcsPristine x os
y <- expand =<< readPackedDarcsPristine os' root
equals_testdata y
check_load = do os <- load "_darcs/loose"
format (hatchery os) @?= Loose
root <- root_hash
y <- expand =<< readPackedDarcsPristine os root
equals_testdata y
check_live = do os <- load "_darcs/loose"
x <- get_pristine
root <- root_hash
alive <- live (os { roots = [ root ]
, references = darcsPristineRefs }) [hatchery os]
sequence_ [ assertBool (show hash ++ " is alive") $
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 <- load "_darcs/loose"
x <- darcsUpdateDirHashes `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
mature_root <- blockLookup (head $ mature os'') root
assertBool "bits no longer in hatchery" $ isNothing hatch_root
assertBool "bits now in the mature space" $ isJust mature_root
mature_root_con <- readSegment (fromJust mature_root)
Just mature_root_con @?= darcsFormatDir x
y <- expand =<< readPackedDarcsPristine os'' root
equals_testdata y
utils = [ testProperty "xlate32" prop_xlate32
, testProperty "xlate64" prop_xlate64
, testProperty "align bounded" prop_align_bounded
, testProperty "align aligned" prop_align_aligned
, 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
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)
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
hash = [ testProperty "decodeBase16 . encodeBase16 == id" prop_base16
, testProperty "decodeBase64u . encodeBase64u == id" prop_base64u ]
where prop_base16 x = (decodeBase16 . encodeBase16) x == x
prop_base64u x = (decodeBase64u . encodeBase64u) x == x
monad = [ testCase "path expansion" check_virtual ]
where check_virtual = virtualTreeMonad run testTree >> return ()
where run = do file <- readFile (floatPath "substub/substub/file")
file2 <- readFile (floatPath "substub/substub/file2")
lift $ BL.unpack file @?= ""
lift $ BL.unpack file2 @?= "foo"
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 BL.ByteString where
arbitrary = BL.pack `fmap` arbitrary
instance Arbitrary Word32 where
arbitrary = do x <- arbitrary :: Gen Int
return $ fromIntegral x
instance Arbitrary Word8 where
arbitrary = do x <- arbitrary :: Gen Int
return $ fromIntegral x
instance Arbitrary Hash where
arbitrary = sized hash'
where hash' 0 = return NoHash
hash' _ = do
tag <- oneof [return 0, return 1]
case tag of
0 -> SHA256 . BS.pack <$> sequence [ arbitrary | _ <- [1..32] ]
1 -> SHA1 . BS.pack <$> sequence [ arbitrary | _ <- [1..20] ]
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 Int64 where
arbitrary = fromIntegral `fmap` (arbitrary :: Gen Word64)
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
---------------------------
-- 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 a b = Just EQ == cmpShape a b
expandedShapeEq a b = (Just EQ ==) <$> cmpExpandedShape a b
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 a b = do a' <- expand a
b' <- expand b
con <- contentsEq a' b'
return $ cmpcat [cmpShape a' b', 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 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
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 (Name x:_)) _ | x == BS.pack "_darcs" = False
| otherwise = 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
hashed <- doesFileExist h_inventory
if hashed
then do inv <- BS.readFile h_inventory
let lines = BS.split '\n' inv
case lines of
[] -> return emptyTree
(pris_line:_) -> do
let hash = decodeDarcsHash $ BS.drop 9 pris_line
size = decodeDarcsSize $ BS.drop 9 pris_line
when (hash == NoHash) $ fail $ "Bad pristine root: " ++ show pris_line
readDarcsHashed (darcs </> "pristine.hashed") (size, hash)
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!"