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