module Darcs.Repository.Repair ( replayRepository, checkIndex,
replayRepositoryInTemp,
RepositoryConsistency(..) )
where
import Darcs.Prelude
import Control.Monad ( when, unless )
import Control.Monad.Trans ( liftIO )
import Control.Exception ( catch, finally, IOException )
import Data.Maybe ( catMaybes )
import Data.List ( sort, (\\) )
import System.Directory
( createDirectoryIfMissing
, getCurrentDirectory
, removeDirectoryRecursive
, setCurrentDirectory
)
import System.FilePath ( (</>) )
import Darcs.Util.Path( anchorPath, AbsolutePath, ioAbsolute, toFilePath )
import Darcs.Patch.PatchInfoAnd
( PatchInfoAnd
, WPatchInfo
, compareWPatchInfo
, hopefully
, info
, unWPatchInfo
, winfo
)
import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )
import Darcs.Patch.Witnesses.Ordered
( FL(..), RL(..), lengthFL, reverseFL,
mapRL, nullFL, (:||:)(..) )
import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), Sealed(..), unFreeLeft )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.Repair ( Repair(applyAndTryToFix) )
import Darcs.Patch.Info ( displayPatchInfo )
import Darcs.Patch.Set ( Origin, PatchSet(..), patchSet2FL, patchSet2RL )
import Darcs.Patch ( RepoPatch, IsRepoType, PrimOf, isInconsistent )
import Darcs.Repository.Cache ( HashedDir( HashedPristineDir ) )
import Darcs.Repository.Diff( treeDiff )
import Darcs.Repository.Flags ( Verbosity(..), Compression, DiffAlgorithm )
import Darcs.Repository.Format
( identifyRepoFormat
, RepoProperty ( HashedInventory )
, formatHas
)
import Darcs.Repository.HashedIO ( cleanHashdir )
import Darcs.Repository.Hashed ( readRepo, writeAndReadPatch )
import Darcs.Repository.InternalTypes ( Repository, repoCache, repoLocation )
import Darcs.Repository.Prefs ( filetypeFunction )
import Darcs.Repository.Pristine ( readHashedPristineRoot )
import Darcs.Repository.State
( readRecorded
, readIndex
, readRecordedAndPending
)
import Darcs.Util.Progress
( beginTedious
, debugMessage
, endTedious
, finishedOneIO
, tediousSize
)
import Darcs.Util.File ( withCurrentDirectory )
import Darcs.Util.Exception ( catchall )
import Darcs.Util.Global ( darcsdir )
import Darcs.Util.Lock( withDelayedDir )
import Darcs.Util.Printer ( Doc, putDocLn, text, renderString )
import Darcs.Util.Hash( Hash(NoHash), encodeBase16 )
import Darcs.Util.Tree( Tree, emptyTree, list, restrict, expand, itemHash, zipTrees )
import Darcs.Util.Tree.Monad( TreeIO )
import Darcs.Util.Tree.Hashed( darcsUpdateHashes, hashedTreeIO )
import Darcs.Util.Tree.Plain( readPlainTree )
import Darcs.Util.Index( treeFromIndex )
import qualified Data.ByteString.Char8 as BC
replaceInFL :: FL (PatchInfoAnd rt a) wX wY
-> [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)]
-> FL (PatchInfoAnd rt a) wX wY
replaceInFL :: forall (rt :: RepoType) (a :: * -> * -> *) wX wY.
FL (PatchInfoAnd rt a) wX wY
-> [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)]
-> FL (PatchInfoAnd rt a) wX wY
replaceInFL FL (PatchInfoAnd rt a) wX wY
orig [] = FL (PatchInfoAnd rt a) wX wY
orig
replaceInFL FL (PatchInfoAnd rt a) wX wY
NilFL [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)]
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"impossible case"
replaceInFL (PatchInfoAnd rt a wX wY
o:>:FL (PatchInfoAnd rt a) wY wY
orig) ch :: [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)]
ch@(Sealed2 (WPatchInfo wX wY
o':||:PatchInfoAnd rt a wX wY
c):[Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)]
ch_rest)
| EqCheck (wX, wY) (wX, wY)
IsEq <- forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> WPatchInfo wA wB
winfo PatchInfoAnd rt a wX wY
o forall wA wB wC wD.
WPatchInfo wA wB -> WPatchInfo wC wD -> EqCheck (wA, wB) (wC, wD)
`compareWPatchInfo` WPatchInfo wX wY
o' = PatchInfoAnd rt a wX wY
cforall (a :: * -> * -> *) wX wX wZ.
a wX wX -> FL a wX wZ -> FL a wX wZ
:>:forall (rt :: RepoType) (a :: * -> * -> *) wX wY.
FL (PatchInfoAnd rt a) wX wY
-> [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)]
-> FL (PatchInfoAnd rt a) wX wY
replaceInFL FL (PatchInfoAnd rt a) wY wY
orig [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)]
ch_rest
| Bool
otherwise = PatchInfoAnd rt a wX wY
oforall (a :: * -> * -> *) wX wX wZ.
a wX wX -> FL a wX wZ -> FL a wX wZ
:>:forall (rt :: RepoType) (a :: * -> * -> *) wX wY.
FL (PatchInfoAnd rt a) wX wY
-> [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)]
-> FL (PatchInfoAnd rt a) wX wY
replaceInFL FL (PatchInfoAnd rt a) wY wY
orig [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)]
ch
applyAndFix
:: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wT
-> Compression
-> FL (PatchInfoAnd rt p) Origin wR
-> TreeIO (FL (PatchInfoAnd rt p) Origin wR, Bool)
applyAndFix :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> Compression
-> FL (PatchInfoAnd rt p) Origin wR
-> TreeIO (FL (PatchInfoAnd rt p) Origin wR, Bool)
applyAndFix Repository rt p wR wU wT
_ Compression
_ FL (PatchInfoAnd rt p) Origin wR
NilFL = forall (m :: * -> *) a. Monad m => a -> m a
return (forall (a :: * -> * -> *) wX. FL a wX wX
NilFL, Bool
True)
applyAndFix Repository rt p wR wU wT
r Compression
compr FL (PatchInfoAnd rt p) Origin wR
psin =
do forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
beginTedious [Char]
k
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> Int -> IO ()
tediousSize [Char]
k forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Int
lengthFL FL (PatchInfoAnd rt p) Origin wR
psin
([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)]
repaired, Bool
ok) <- forall wW wZ.
FL (PatchInfoAnd rt p) wW wZ
-> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool)
aaf FL (PatchInfoAnd rt p) Origin wR
psin
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
endTedious [Char]
k
FL (PatchInfoAnd rt p) Origin wR
orig <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> FL (PatchInfoAnd rt p) wStart wX
patchSet2FL forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wT
r
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (rt :: RepoType) (a :: * -> * -> *) wX wY.
FL (PatchInfoAnd rt a) wX wY
-> [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)]
-> FL (PatchInfoAnd rt a) wX wY
replaceInFL FL (PatchInfoAnd rt p) Origin wR
orig [Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)]
repaired, Bool
ok)
where k :: [Char]
k = [Char]
"Replaying patch"
aaf :: FL (PatchInfoAnd rt p) wW wZ
-> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool)
aaf :: forall wW wZ.
FL (PatchInfoAnd rt p) wW wZ
-> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool)
aaf FL (PatchInfoAnd rt p) wW wZ
NilFL = forall (m :: * -> *) a. Monad m => a -> m a
return ([], Bool
True)
aaf (PatchInfoAnd rt p wW wY
p:>:FL (PatchInfoAnd rt p) wY wZ
ps) = do
Maybe ([Char], PatchInfoAnd rt p wW wY)
mp' <- forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(Repair p, ApplyMonad (ApplyState p) m) =>
p wX wY -> m (Maybe ([Char], p wX wY))
applyAndTryToFix PatchInfoAnd rt p wW wY
p
case forall (p :: * -> * -> *) wX wY. Check p => p wX wY -> Maybe Doc
isInconsistent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> p wA wB
hopefully forall a b. (a -> b) -> a -> b
$ PatchInfoAnd rt p wW wY
p of
Just Doc
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Doc -> IO ()
putDocLn Doc
err
Maybe Doc
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
let !winfp :: WPatchInfo wW wY
winfp = forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> WPatchInfo wA wB
winfo PatchInfoAnd rt p wW wY
p
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> IO ()
finishedOneIO [Char]
k forall a b. (a -> b) -> a -> b
$ Doc -> [Char]
renderString forall a b. (a -> b) -> a -> b
$
PatchInfo -> Doc
displayPatchInfo forall a b. (a -> b) -> a -> b
$ forall wA wB. WPatchInfo wA wB -> PatchInfo
unWPatchInfo WPatchInfo wW wY
winfp
([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)]
ps', Bool
restok) <- forall wW wZ.
FL (PatchInfoAnd rt p) wW wZ
-> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool)
aaf FL (PatchInfoAnd rt p) wY wZ
ps
case Maybe ([Char], PatchInfoAnd rt p wW wY)
mp' of
Maybe ([Char], PatchInfoAnd rt p wW wY)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)]
ps', Bool
restok)
Just ([Char]
e,PatchInfoAnd rt p wW wY
pp) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
[Char] -> IO ()
putStrLn [Char]
e
PatchInfoAnd rt p wW wY
p' <- forall p a. FilePathLike p => p -> IO a -> IO a
withCurrentDirectory (forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> [Char]
repoLocation Repository rt p wR wU wT
r) forall a b. (a -> b) -> a -> b
$
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
RepoPatch p =>
Cache
-> Compression
-> PatchInfoAnd rt p wX wY
-> IO (PatchInfoAnd rt p wX wY)
writeAndReadPatch (forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Cache
repoCache Repository rt p wR wU wT
r) Compression
compr PatchInfoAnd rt p wW wY
pp
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (a :: * -> * -> *) wX wY. a wX wY -> Sealed2 a
Sealed2 (WPatchInfo wW wY
winfp forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY.
a1 wX wY -> a2 wX wY -> (:||:) a1 a2 wX wY
:||: PatchInfoAnd rt p wW wY
p')forall a. a -> [a] -> [a]
:[Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)]
ps', Bool
False)
data RepositoryConsistency rt p wX =
RepositoryConsistent
| BrokenPristine (Tree IO)
| BrokenPatches (Tree IO) (PatchSet rt p Origin wX)
checkUniqueness :: (IsRepoType rt, RepoPatch p)
=> (Doc -> IO ()) -> (Doc -> IO ()) -> Repository rt p wR wU wT -> IO ()
checkUniqueness :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
(Doc -> IO ())
-> (Doc -> IO ()) -> Repository rt p wR wU wT -> IO ()
checkUniqueness Doc -> IO ()
putVerbose Doc -> IO ()
putInfo Repository rt p wR wU wT
repository =
do Doc -> IO ()
putVerbose forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"Checking that patch names are unique..."
PatchSet rt p Origin wR
r <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wT
repository
case forall a. Ord a => [a] -> Maybe a
hasDuplicate forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> RL a wX wY -> [b]
mapRL forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info forall a b. (a -> b) -> a -> b
$ forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> RL (PatchInfoAnd rt p) wStart wX
patchSet2RL PatchSet rt p Origin wR
r of
Maybe PatchInfo
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just PatchInfo
pinf -> do Doc -> IO ()
putInfo forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"Error! Duplicate patch name:"
Doc -> IO ()
putInfo forall a b. (a -> b) -> a -> b
$ PatchInfo -> Doc
displayPatchInfo PatchInfo
pinf
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Duplicate patches found."
hasDuplicate :: Ord a => [a] -> Maybe a
hasDuplicate :: forall a. Ord a => [a] -> Maybe a
hasDuplicate [a]
li = forall {a}. Eq a => [a] -> Maybe a
hd forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort [a]
li
where hd :: [a] -> Maybe a
hd [a
_] = forall a. Maybe a
Nothing
hd [] = forall a. Maybe a
Nothing
hd (a
x1:a
x2:[a]
xs) | a
x1 forall a. Eq a => a -> a -> Bool
== a
x2 = forall a. a -> Maybe a
Just a
x1
| Bool
otherwise = [a] -> Maybe a
hd (a
x2forall a. a -> [a] -> [a]
:[a]
xs)
replayRepository'
:: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> DiffAlgorithm
-> AbsolutePath
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> IO (RepositoryConsistency rt p wR)
replayRepository' :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
DiffAlgorithm
-> AbsolutePath
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> IO (RepositoryConsistency rt p wR)
replayRepository' DiffAlgorithm
dflag AbsolutePath
whereToReplay' Repository rt p wR wU wT
repo Compression
compr Verbosity
verbosity = do
let whereToReplay :: [Char]
whereToReplay = forall a. FilePathLike a => a -> [Char]
toFilePath AbsolutePath
whereToReplay'
putVerbose :: Doc -> IO ()
putVerbose Doc
s = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Verbosity
verbosity forall a. Eq a => a -> a -> Bool
== Verbosity
Verbose) forall a b. (a -> b) -> a -> b
$ Doc -> IO ()
putDocLn Doc
s
putInfo :: Doc -> IO ()
putInfo Doc
s = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Verbosity
verbosity forall a. Eq a => a -> a -> Bool
== Verbosity
Quiet) forall a b. (a -> b) -> a -> b
$ Doc -> IO ()
putDocLn Doc
s
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
(Doc -> IO ())
-> (Doc -> IO ()) -> Repository rt p wR wU wT -> IO ()
checkUniqueness Doc -> IO ()
putVerbose Doc -> IO ()
putInfo Repository rt p wR wU wT
repo
Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
False [Char]
whereToReplay
Doc -> IO ()
putVerbose forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"Reading recorded state..."
Tree IO
pris <-
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Tree IO)
readRecorded Repository rt p wR wU wT
repo forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
darcsUpdateHashes)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch`
\(IOException
_ :: IOException) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *). Tree m
emptyTree
Doc -> IO ()
putVerbose forall a b. (a -> b) -> a -> b
$ [Char] -> Doc
text [Char]
"Applying patches..."
PatchSet rt p Origin wR
patches <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wT
repo
[Char] -> IO ()
debugMessage [Char]
"Fixing any broken patches..."
let psin :: FL (PatchInfoAnd rt p) Origin wR
psin = forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> FL (PatchInfoAnd rt p) wStart wX
patchSet2FL PatchSet rt p Origin wR
patches
repair :: TreeIO (FL (PatchInfoAnd rt p) Origin wR, Bool)
repair = forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> Compression
-> FL (PatchInfoAnd rt p) Origin wR
-> TreeIO (FL (PatchInfoAnd rt p) Origin wR, Bool)
applyAndFix Repository rt p wR wU wT
repo Compression
compr FL (PatchInfoAnd rt p) Origin wR
psin
((FL (PatchInfoAnd rt p) Origin wR
ps, Bool
patches_ok), Tree IO
newpris) <- forall a. TreeIO a -> Tree IO -> [Char] -> IO (a, Tree IO)
hashedTreeIO TreeIO (FL (PatchInfoAnd rt p) Origin wR, Bool)
repair forall (m :: * -> *). Tree m
emptyTree [Char]
whereToReplay
[Char] -> IO ()
debugMessage [Char]
"Done fixing broken patches..."
let newpatches :: PatchSet rt p Origin wR
newpatches = forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
RL (Tagged rt p) Origin wX
-> RL (PatchInfoAnd rt p) wX wY -> PatchSet rt p Origin wY
PatchSet forall (a :: * -> * -> *) wX. RL a wX wX
NilRL (forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL (PatchInfoAnd rt p) Origin wR
ps)
[Char] -> IO ()
debugMessage [Char]
"Checking pristine against slurpy"
[Char] -> FileType
ftf <- IO ([Char] -> FileType)
filetypeFunction
Bool
is_same <- do Sealed FL (PrimOf p) wR wX
diff <- forall (p :: * -> * -> *) wX. FreeLeft p -> Sealed (p wX)
unFreeLeft forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (m :: * -> *) (w :: (* -> * -> *) -> *)
(prim :: * -> * -> *).
(Monad m, Gap w, PrimPatch prim) =>
DiffAlgorithm
-> ([Char] -> FileType) -> Tree m -> Tree m -> m (w (FL prim))
treeDiff DiffAlgorithm
dflag [Char] -> FileType
ftf Tree IO
pris Tree IO
newpris
:: IO (Sealed (FL (PrimOf p) wR))
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL FL (PrimOf p) wR wX
diff
forall a. IO a -> IO a -> IO a
`catchall` forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
forall (m :: * -> *) a. Monad m => a -> m a
return (if Bool
is_same Bool -> Bool -> Bool
&& Bool
patches_ok
then forall (rt :: RepoType) (p :: * -> * -> *) wX.
RepositoryConsistency rt p wX
RepositoryConsistent
else if Bool
patches_ok
then forall (rt :: RepoType) (p :: * -> * -> *) wX.
Tree IO -> RepositoryConsistency rt p wX
BrokenPristine Tree IO
newpris
else forall (rt :: RepoType) (p :: * -> * -> *) wX.
Tree IO -> PatchSet rt p Origin wX -> RepositoryConsistency rt p wX
BrokenPatches Tree IO
newpris PatchSet rt p Origin wR
newpatches)
cleanupRepositoryReplay :: Repository rt p wR wU wT -> IO ()
cleanupRepositoryReplay :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO ()
cleanupRepositoryReplay Repository rt p wR wU wT
r = do
let c :: Cache
c = forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> Cache
repoCache Repository rt p wR wU wT
r
RepoFormat
rf <- [Char] -> IO RepoFormat
identifyRepoFormat [Char]
"."
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
HashedInventory RepoFormat
rf) forall a b. (a -> b) -> a -> b
$
[Char] -> IO ()
removeDirectoryRecursive forall a b. (a -> b) -> a -> b
$ [Char]
darcsdir forall a. [a] -> [a] -> [a]
++ [Char]
"/pristine.hashed"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RepoProperty -> RepoFormat -> Bool
formatHas RepoProperty
HashedInventory RepoFormat
rf) forall a b. (a -> b) -> a -> b
$ do
Maybe PristineHash
current <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO (Maybe PristineHash)
readHashedPristineRoot Repository rt p wR wU wT
r
Cache -> HashedDir -> [PristineHash] -> IO ()
cleanHashdir Cache
c HashedDir
HashedPristineDir forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe PristineHash
current]
replayRepositoryInTemp
:: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> DiffAlgorithm
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> IO (RepositoryConsistency rt p wR)
replayRepositoryInTemp :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
DiffAlgorithm
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> IO (RepositoryConsistency rt p wR)
replayRepositoryInTemp DiffAlgorithm
dflag Repository rt p wR wU wT
r Compression
compr Verbosity
verb = do
[Char]
repodir <- IO [Char]
getCurrentDirectory
forall a. [Char] -> (AbsolutePath -> IO a) -> IO a
withDelayedDir [Char]
"darcs-check" forall a b. (a -> b) -> a -> b
$ \AbsolutePath
tmpDir -> do
[Char] -> IO ()
setCurrentDirectory [Char]
repodir
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
DiffAlgorithm
-> AbsolutePath
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> IO (RepositoryConsistency rt p wR)
replayRepository' DiffAlgorithm
dflag AbsolutePath
tmpDir Repository rt p wR wU wT
r Compression
compr Verbosity
verb
replayRepository
:: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
=> DiffAlgorithm
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> (RepositoryConsistency rt p wR -> IO a)
-> IO a
replayRepository :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT a.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
DiffAlgorithm
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> (RepositoryConsistency rt p wR -> IO a)
-> IO a
replayRepository DiffAlgorithm
dflag Repository rt p wR wU wT
r Compression
compr Verbosity
verb RepositoryConsistency rt p wR -> IO a
f =
IO a
run forall a b. IO a -> IO b -> IO a
`finally` forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT -> IO ()
cleanupRepositoryReplay Repository rt p wR wU wT
r
where run :: IO a
run = do
Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
False forall a b. (a -> b) -> a -> b
$ [Char]
darcsdir [Char] -> [Char] -> [Char]
</> [Char]
"pristine.hashed"
AbsolutePath
hashedPristine <- [Char] -> IO AbsolutePath
ioAbsolute forall a b. (a -> b) -> a -> b
$ [Char]
darcsdir [Char] -> [Char] -> [Char]
</> [Char]
"pristine.hashed"
RepositoryConsistency rt p wR
st <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
DiffAlgorithm
-> AbsolutePath
-> Repository rt p wR wU wT
-> Compression
-> Verbosity
-> IO (RepositoryConsistency rt p wR)
replayRepository' DiffAlgorithm
dflag AbsolutePath
hashedPristine Repository rt p wR wU wT
r Compression
compr Verbosity
verb
RepositoryConsistency rt p wR -> IO a
f RepositoryConsistency rt p wR
st
checkIndex
:: (RepoPatch p, ApplyState p ~ Tree)
=> Repository rt p wR wU wR
-> Bool
-> IO Bool
checkIndex :: forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> Bool -> IO Bool
checkIndex Repository rt p wR wU wR
repo Bool
quiet = do
Tree IO
index <- Index -> IO (Tree IO)
treeFromIndex forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO Index
readIndex Repository rt p wR wU wR
repo
Tree IO
pristine <- forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (p :: * -> * -> *) (rt :: RepoType) wR wU.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR -> IO (Tree IO)
readRecordedAndPending Repository rt p wR wU wR
repo
Tree IO
working <- forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
expand forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (t :: (* -> *) -> *) (m :: * -> *) (n :: * -> *).
FilterTree t m =>
Tree n -> t m -> t m
restrict Tree IO
pristine forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> IO (Tree IO)
readPlainTree [Char]
"."
Tree IO
working_hashed <- forall (m :: * -> *). Monad m => Tree m -> m (Tree m)
darcsUpdateHashes Tree IO
working
let index_paths :: [AnchoredPath]
index_paths = [ AnchoredPath
p | (AnchoredPath
p, TreeItem IO
_) <- forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
list Tree IO
index ]
working_paths :: [AnchoredPath]
working_paths = [ AnchoredPath
p | (AnchoredPath
p, TreeItem IO
_) <- forall (m :: * -> *). Tree m -> [(AnchoredPath, TreeItem m)]
list Tree IO
working ]
index_extra :: [AnchoredPath]
index_extra = [AnchoredPath]
index_paths forall a. Eq a => [a] -> [a] -> [a]
\\ [AnchoredPath]
working_paths
working_extra :: [AnchoredPath]
working_extra = [AnchoredPath]
working_paths forall a. Eq a => [a] -> [a] -> [a]
\\ [AnchoredPath]
index_paths
gethashes :: a -> Maybe (TreeItem m) -> Maybe (TreeItem m) -> (a, Hash, Hash)
gethashes a
p (Just TreeItem m
i1) (Just TreeItem m
i2) = (a
p, forall (m :: * -> *). TreeItem m -> Hash
itemHash TreeItem m
i1, forall (m :: * -> *). TreeItem m -> Hash
itemHash TreeItem m
i2)
gethashes a
p (Just TreeItem m
i1) Maybe (TreeItem m)
Nothing = (a
p, forall (m :: * -> *). TreeItem m -> Hash
itemHash TreeItem m
i1, Hash
NoHash)
gethashes a
p Maybe (TreeItem m)
Nothing (Just TreeItem m
i2) = (a
p, Hash
NoHash, forall (m :: * -> *). TreeItem m -> Hash
itemHash TreeItem m
i2)
gethashes a
p Maybe (TreeItem m)
Nothing Maybe (TreeItem m)
Nothing = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Bad case at " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show a
p
mismatches :: [(AnchoredPath, Hash, Hash)]
mismatches =
[(AnchoredPath, Hash, Hash)
miss | miss :: (AnchoredPath, Hash, Hash)
miss@(AnchoredPath
_, Hash
h1, Hash
h2) <- forall (m :: * -> *) a.
(AnchoredPath -> Maybe (TreeItem m) -> Maybe (TreeItem m) -> a)
-> Tree m -> Tree m -> [a]
zipTrees forall {a} {m :: * -> *} {m :: * -> *}.
Show a =>
a -> Maybe (TreeItem m) -> Maybe (TreeItem m) -> (a, Hash, Hash)
gethashes Tree IO
index Tree IO
working_hashed, Hash
h1 forall a. Eq a => a -> a -> Bool
/= Hash
h2]
format :: [AnchoredPath] -> [Char]
format [AnchoredPath]
paths = [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (([Char]
" " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> AnchoredPath -> [Char]
anchorPath [Char]
"") [AnchoredPath]
paths
mismatches_disp :: [Char]
mismatches_disp = [[Char]] -> [Char]
unlines [ [Char] -> AnchoredPath -> [Char]
anchorPath [Char]
"" AnchoredPath
p forall a. [a] -> [a] -> [a]
++
[Char]
"\n index: " forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BC.unpack (Hash -> ByteString
encodeBase16 Hash
h1) forall a. [a] -> [a] -> [a]
++
[Char]
"\n working: " forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BC.unpack (Hash -> ByteString
encodeBase16 Hash
h2)
| (AnchoredPath
p, Hash
h1, Hash
h2) <- [(AnchoredPath, Hash, Hash)]
mismatches ]
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
quiet Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AnchoredPath]
index_extra) forall a b. (a -> b) -> a -> b
$
[Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"Extra items in index!\n" forall a. [a] -> [a] -> [a]
++ [AnchoredPath] -> [Char]
format [AnchoredPath]
index_extra
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
quiet Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AnchoredPath]
working_extra) forall a b. (a -> b) -> a -> b
$
[Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"Missing items in index!\n" forall a. [a] -> [a] -> [a]
++ [AnchoredPath] -> [Char]
format [AnchoredPath]
working_extra
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
quiet Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(AnchoredPath, Hash, Hash)]
mismatches) forall a b. (a -> b) -> a -> b
$
[Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"Hash mismatch(es)!\n" forall a. [a] -> [a] -> [a]
++ [Char]
mismatches_disp
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AnchoredPath]
index_extra Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AnchoredPath]
working_extra Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(AnchoredPath, Hash, Hash)]
mismatches