1module Darcs.Repository.Repair ( replayRepository, checkIndex, 2 replayRepositoryInTemp, 3 RepositoryConsistency(..) ) 4 where 5 6import Darcs.Prelude 7 8import Control.Monad ( when, unless ) 9import Control.Monad.Trans ( liftIO ) 10import Control.Exception ( catch, finally, IOException ) 11import Data.Maybe ( catMaybes ) 12import Data.List ( sort, (\\) ) 13import System.Directory 14 ( createDirectoryIfMissing 15 , getCurrentDirectory 16 , removeDirectoryRecursive 17 , setCurrentDirectory 18 ) 19import System.FilePath ( (</>) ) 20import Darcs.Util.Path( anchorPath, AbsolutePath, ioAbsolute, toFilePath ) 21import Darcs.Patch.PatchInfoAnd 22 ( PatchInfoAnd 23 , WPatchInfo 24 , compareWPatchInfo 25 , hopefully 26 , info 27 , unWPatchInfo 28 , winfo 29 ) 30 31import Darcs.Patch.Witnesses.Eq ( EqCheck(..) ) 32import Darcs.Patch.Witnesses.Ordered 33 ( FL(..), RL(..), lengthFL, reverseFL, 34 mapRL, nullFL, (:||:)(..) ) 35import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), Sealed(..), unFreeLeft ) 36import Darcs.Patch.Apply( ApplyState ) 37import Darcs.Patch.Repair ( Repair(applyAndTryToFix) ) 38import Darcs.Patch.Info ( displayPatchInfo ) 39import Darcs.Patch.Set ( Origin, PatchSet(..), patchSet2FL, patchSet2RL ) 40import Darcs.Patch ( RepoPatch, IsRepoType, PrimOf, isInconsistent ) 41 42import Darcs.Repository.Cache ( HashedDir( HashedPristineDir ) ) 43import Darcs.Repository.Diff( treeDiff ) 44import Darcs.Repository.Flags ( Verbosity(..), Compression, DiffAlgorithm ) 45import Darcs.Repository.Format 46 ( identifyRepoFormat 47 , RepoProperty ( HashedInventory ) 48 , formatHas 49 ) 50import Darcs.Repository.HashedIO ( cleanHashdir ) 51import Darcs.Repository.Hashed ( readRepo, writeAndReadPatch ) 52import Darcs.Repository.InternalTypes ( Repository, repoCache, repoLocation ) 53import Darcs.Repository.Prefs ( filetypeFunction ) 54import Darcs.Repository.Pristine ( readHashedPristineRoot ) 55import Darcs.Repository.State 56 ( readRecorded 57 , readIndex 58 , readRecordedAndPending 59 ) 60 61import Darcs.Util.Progress 62 ( beginTedious 63 , debugMessage 64 , endTedious 65 , finishedOneIO 66 , tediousSize 67 ) 68import Darcs.Util.File ( withCurrentDirectory ) 69import Darcs.Util.Exception ( catchall ) 70import Darcs.Util.Global ( darcsdir ) 71import Darcs.Util.Lock( withDelayedDir ) 72import Darcs.Util.Printer ( Doc, putDocLn, text, renderString ) 73 74import Darcs.Util.Hash( Hash(NoHash), encodeBase16 ) 75import Darcs.Util.Tree( Tree, emptyTree, list, restrict, expand, itemHash, zipTrees ) 76import Darcs.Util.Tree.Monad( TreeIO ) 77import Darcs.Util.Tree.Hashed( darcsUpdateHashes, hashedTreeIO ) 78import Darcs.Util.Tree.Plain( readPlainTree ) 79import Darcs.Util.Index( treeFromIndex ) 80 81import qualified Data.ByteString.Char8 as BC 82 83replaceInFL :: FL (PatchInfoAnd rt a) wX wY 84 -> [Sealed2 (WPatchInfo :||: PatchInfoAnd rt a)] 85 -> FL (PatchInfoAnd rt a) wX wY 86replaceInFL orig [] = orig 87replaceInFL NilFL _ = error "impossible case" 88replaceInFL (o:>:orig) ch@(Sealed2 (o':||:c):ch_rest) 89 | IsEq <- winfo o `compareWPatchInfo` o' = c:>:replaceInFL orig ch_rest 90 | otherwise = o:>:replaceInFL orig ch 91 92applyAndFix 93 :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) 94 => Repository rt p wR wU wT 95 -> Compression 96 -> FL (PatchInfoAnd rt p) Origin wR 97 -> TreeIO (FL (PatchInfoAnd rt p) Origin wR, Bool) 98applyAndFix _ _ NilFL = return (NilFL, True) 99applyAndFix r compr psin = 100 do liftIO $ beginTedious k 101 liftIO $ tediousSize k $ lengthFL psin 102 (repaired, ok) <- aaf psin 103 liftIO $ endTedious k 104 orig <- liftIO $ patchSet2FL `fmap` readRepo r 105 return (replaceInFL orig repaired, ok) 106 where k = "Replaying patch" 107 aaf :: FL (PatchInfoAnd rt p) wW wZ 108 -> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd rt p)], Bool) 109 aaf NilFL = return ([], True) 110 aaf (p:>:ps) = do 111 mp' <- applyAndTryToFix p 112 case isInconsistent . hopefully $ p of 113 Just err -> liftIO $ putDocLn err 114 Nothing -> return () 115 let !winfp = winfo p -- assure that 'p' can be garbage collected. 116 liftIO $ finishedOneIO k $ renderString $ 117 displayPatchInfo $ unWPatchInfo winfp 118 (ps', restok) <- aaf ps 119 case mp' of 120 Nothing -> return (ps', restok) 121 Just (e,pp) -> liftIO $ do 122 putStrLn e 123 p' <- withCurrentDirectory (repoLocation r) $ 124 writeAndReadPatch (repoCache r) compr pp 125 return (Sealed2 (winfp :||: p'):ps', False) 126 127data RepositoryConsistency rt p wX = 128 RepositoryConsistent 129 | BrokenPristine (Tree IO) 130 | BrokenPatches (Tree IO) (PatchSet rt p Origin wX) 131 132checkUniqueness :: (IsRepoType rt, RepoPatch p) 133 => (Doc -> IO ()) -> (Doc -> IO ()) -> Repository rt p wR wU wT -> IO () 134checkUniqueness putVerbose putInfo repository = 135 do putVerbose $ text "Checking that patch names are unique..." 136 r <- readRepo repository 137 case hasDuplicate $ mapRL info $ patchSet2RL r of 138 Nothing -> return () 139 Just pinf -> do putInfo $ text "Error! Duplicate patch name:" 140 putInfo $ displayPatchInfo pinf 141 fail "Duplicate patches found." 142 143hasDuplicate :: Ord a => [a] -> Maybe a 144hasDuplicate li = hd $ sort li 145 where hd [_] = Nothing 146 hd [] = Nothing 147 hd (x1:x2:xs) | x1 == x2 = Just x1 148 | otherwise = hd (x2:xs) 149 150replayRepository' 151 :: forall rt p wR wU wT. (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) 152 => DiffAlgorithm 153 -> AbsolutePath 154 -> Repository rt p wR wU wT 155 -> Compression 156 -> Verbosity 157 -> IO (RepositoryConsistency rt p wR) 158replayRepository' dflag whereToReplay' repo compr verbosity = do 159 let whereToReplay = toFilePath whereToReplay' 160 putVerbose s = when (verbosity == Verbose) $ putDocLn s 161 putInfo s = unless (verbosity == Quiet) $ putDocLn s 162 checkUniqueness putVerbose putInfo repo 163 createDirectoryIfMissing False whereToReplay 164 putVerbose $ text "Reading recorded state..." 165 pris <- 166 (readRecorded repo >>= expand >>= darcsUpdateHashes) 167 `catch` 168 \(_ :: IOException) -> return emptyTree 169 putVerbose $ text "Applying patches..." 170 patches <- readRepo repo 171 debugMessage "Fixing any broken patches..." 172 let psin = patchSet2FL patches 173 repair = applyAndFix repo compr psin 174 175 ((ps, patches_ok), newpris) <- hashedTreeIO repair emptyTree whereToReplay 176 debugMessage "Done fixing broken patches..." 177 let newpatches = PatchSet NilRL (reverseFL ps) 178 179 debugMessage "Checking pristine against slurpy" 180 ftf <- filetypeFunction 181 is_same <- do Sealed diff <- unFreeLeft `fmap` treeDiff dflag ftf pris newpris 182 :: IO (Sealed (FL (PrimOf p) wR)) 183 return $ nullFL diff 184 `catchall` return False 185 -- TODO is the latter condition needed? Does a broken patch imply pristine 186 -- difference? Why, or why not? 187 return (if is_same && patches_ok 188 then RepositoryConsistent 189 else if patches_ok 190 then BrokenPristine newpris 191 else BrokenPatches newpris newpatches) 192 193cleanupRepositoryReplay :: Repository rt p wR wU wT -> IO () 194cleanupRepositoryReplay r = do 195 let c = repoCache r 196 rf <- identifyRepoFormat "." 197 unless (formatHas HashedInventory rf) $ 198 removeDirectoryRecursive $ darcsdir ++ "/pristine.hashed" 199 when (formatHas HashedInventory rf) $ do 200 current <- readHashedPristineRoot r 201 cleanHashdir c HashedPristineDir $ catMaybes [current] 202 203replayRepositoryInTemp 204 :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) 205 => DiffAlgorithm 206 -> Repository rt p wR wU wT 207 -> Compression 208 -> Verbosity 209 -> IO (RepositoryConsistency rt p wR) 210replayRepositoryInTemp dflag r compr verb = do 211 repodir <- getCurrentDirectory 212 {- The reason we use withDelayedDir here, instead of withTempDir, is that 213 replayRepository' may return a new pristine that is read from the 214 temporary location and reading a Tree is done using lazy ByteStrings (for 215 file contents). Then we check if there is a difference to our stored 216 pristine, but when there are differences the check may terminate early 217 and not all of the new pristine was read/evaluated. This may then cause 218 does-not-exist-failures later on when the tree is evaluated further. 219 -} 220 withDelayedDir "darcs-check" $ \tmpDir -> do 221 setCurrentDirectory repodir 222 replayRepository' dflag tmpDir r compr verb 223 224replayRepository 225 :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) 226 => DiffAlgorithm 227 -> Repository rt p wR wU wT 228 -> Compression 229 -> Verbosity 230 -> (RepositoryConsistency rt p wR -> IO a) 231 -> IO a 232replayRepository dflag r compr verb f = 233 run `finally` cleanupRepositoryReplay r 234 where run = do 235 createDirectoryIfMissing False $ darcsdir </> "pristine.hashed" 236 hashedPristine <- ioAbsolute $ darcsdir </> "pristine.hashed" 237 st <- replayRepository' dflag hashedPristine r compr verb 238 f st 239 240checkIndex 241 :: (RepoPatch p, ApplyState p ~ Tree) 242 => Repository rt p wR wU wR 243 -> Bool 244 -> IO Bool 245checkIndex repo quiet = do 246 index <- treeFromIndex =<< readIndex repo 247 pristine <- expand =<< readRecordedAndPending repo 248 working <- expand =<< restrict pristine <$> readPlainTree "." 249 working_hashed <- darcsUpdateHashes working 250 let index_paths = [ p | (p, _) <- list index ] 251 working_paths = [ p | (p, _) <- list working ] 252 index_extra = index_paths \\ working_paths 253 working_extra = working_paths \\ index_paths 254 gethashes p (Just i1) (Just i2) = (p, itemHash i1, itemHash i2) 255 gethashes p (Just i1) Nothing = (p, itemHash i1, NoHash) 256 gethashes p Nothing (Just i2) = (p, NoHash, itemHash i2) 257 gethashes p Nothing Nothing = error $ "Bad case at " ++ show p 258 mismatches = 259 [miss | miss@(_, h1, h2) <- zipTrees gethashes index working_hashed, h1 /= h2] 260 261 format paths = unlines $ map ((" " ++) . anchorPath "") paths 262 mismatches_disp = unlines [ anchorPath "" p ++ 263 "\n index: " ++ BC.unpack (encodeBase16 h1) ++ 264 "\n working: " ++ BC.unpack (encodeBase16 h2) 265 | (p, h1, h2) <- mismatches ] 266 unless (quiet || null index_extra) $ 267 putStrLn $ "Extra items in index!\n" ++ format index_extra 268 unless (quiet || null working_extra) $ 269 putStrLn $ "Missing items in index!\n" ++ format working_extra 270 unless (quiet || null mismatches) $ 271 putStrLn $ "Hash mismatch(es)!\n" ++ mismatches_disp 272 return $ null index_extra && null working_extra && null mismatches 273 274