1 -- Copyright (C) 2002-2004,2007-2008 David Roundy 2 -- Copyright (C) 2005 Juliusz Chroboczek 3 -- 4 -- This program is free software; you can redistribute it and/or modify 5 -- it under the terms of the GNU General Public License as published by 6 -- the Free Software Foundation; either version 2, or (at your option) 7 -- any later version. 8 -- 9 -- This program is distributed in the hope that it will be useful, 10 -- but WITHOUT ANY WARRANTY; without even the implied warranty of 11 -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 12 -- GNU General Public License for more details. 13 -- 14 -- You should have received a copy of the GNU General Public License 15 -- along with this program; see the file COPYING. If not, write to 16 -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 17 -- Boston, MA 02110-1301, USA. 18 19 {-# OPTIONS_GHC -cpp -fglasgow-exts #-} 20 {-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types, RankNTypes, PatternGuards #-} 21 22 #include "gadts.h" 23 24 module Darcs.Repository.Internal ( Repository(..), RepoType(..), RIO(unsafeUnRIO), ($-), 25 maybeIdentifyRepository, identifyDarcs1Repository, identifyRepositoryFor, 26 findRepository, amInRepository, amNotInRepository, 27 slurp_pending, pristineFromWorking, revertRepositoryChanges, 28 slurp_recorded, slurp_recorded_and_unrecorded, 29 read_pending, announce_merge_conflicts, setTentativePending, 30 check_unrecorded_conflicts, 31 withRecorded, 32 checkPristineAgainstSlurpy, 33 get_unrecorded, get_unrecorded_unsorted, get_unrecorded_no_look_for_adds, 34 get_unrecorded_in_files, get_unrecorded_in_files_unsorted, 35 read_repo, sync_repo, 36 prefsUrl, makePatchLazy, 37 add_to_pending, 38 withRepoLock, withRepoReadLock, 39 withRepository, withRepositoryDirectory, withGutsOf, 40 tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending, 41 tentativelyReplacePatches, 42 tentativelyMergePatches, considerMergeToWorking, 43 finalizeRepositoryChanges, 44 unrevertUrl, 45 applyToWorking, patchSetToPatches, 46 createPristineDirectoryTree, createPartialsPristineDirectoryTree, 47 replacePristineFromSlurpy, 48 optimizeInventory, cleanRepository, 49 getMarkedupFile, 50 PatchSet, SealedPatchSet, 51 setScriptsExecutable, 52 getRepository, rIO, 53 testTentative, testRecorded 54 ) where 55 56 import Printer ( putDocLn, (<+>), text, ($$) ) 57 58 import Data.Maybe ( isJust, isNothing ) 59 import Darcs.Repository.Prefs ( get_prefval ) 60 import Darcs.Resolution ( standard_resolution, external_resolution ) 61 import System.Exit ( ExitCode(..), exitWith ) 62 import System.Cmd ( system ) 63 import Darcs.External ( backupByCopying, clonePartialsTree ) 64 import Darcs.IO ( runTolerantly, runSilently ) 65 import Darcs.Repository.Pristine ( identifyPristine, nopristine, 66 easyCreatePristineDirectoryTree, slurpPristine, syncPristine, 67 easyCreatePartialsPristineDirectoryTree, 68 createPristineFromWorking ) 69 import qualified Darcs.Repository.Pristine as Pristine ( replacePristineFromSlurpy ) 70 71 import Data.List ( (\\) ) 72 import Darcs.SignalHandler ( withSignalsBlocked ) 73 import Darcs.Repository.Format ( RepoFormat, RepoProperty( Darcs2, HashedInventory ), 74 identifyRepoFormat, format_has, 75 write_problem, read_problem, readfrom_and_writeto_problem ) 76 import System.Directory ( doesDirectoryExist, setCurrentDirectory, removeFile, 77 createDirectoryIfMissing ) 78 import Control.Monad ( liftM, when, unless ) 79 import Workaround ( getCurrentDirectory, renameFile, setExecutable ) 80 81 import ByteStringUtils ( gzReadFilePS ) 82 import qualified Data.ByteString as B (ByteString, empty, readFile, isPrefixOf) 83 import qualified Data.ByteString.Char8 as BC (pack) 84 85 import Darcs.Patch ( Patch, RealPatch, Effect, is_hunk, is_binary, description, 86 87 try_to_shrink, commuteFL, commute, apply_to_filepaths ) 88 import Darcs.Patch.Prim ( try_shrinking_inverse, Conflict ) 89 import Darcs.Patch.Bundle ( scan_bundle, make_bundle ) 90 import Darcs.Patch.FileName ( FileName, fn2fp ) 91 import Darcs.Patch.TouchesFiles ( choose_touching ) 92 import Darcs.SlurpDirectory ( Slurpy, slurp_unboring, mmap_slurp, co_slurp, 93 slurp_has, list_slurpy_files ) 94 import Darcs.Hopefully ( PatchInfoAnd, info, n2pia, 95 hopefully, hopefullyM ) 96 import Darcs.Repository.ApplyPatches ( apply_patches ) 97 import qualified Darcs.Repository.HashedRepo as HashedRepo 98 ( revert_tentative_changes, finalize_tentative_changes, 99 remove_from_tentative_inventory, sync_repo, 100 copy_pristine, copy_partials_pristine, slurp_pristine, 101 apply_to_tentative_pristine, pristine_from_working, 102 write_tentative_inventory, write_and_read_patch, 103 add_to_tentative_inventory, 104 read_repo, read_tentative_repo, clean_pristine, 105 replacePristineFromSlurpy, 106 slurp_all_but_darcs ) 107 import qualified Darcs.Repository.DarcsRepo as DarcsRepo 108 import Darcs.Flags ( DarcsFlag(AnyOrder, Boring, LookForAdds, Verbose, Quiet, 109 MarkConflicts, AllowConflicts, NoUpdateWorking, 110 WorkRepoUrl, WorkRepoDir, UMask, Test, LeaveTestDir, 111 SetScriptsExecutable, DryRun, IgnoreTimes, 112 Summary, NoSummary), 113 want_external_merge, compression ) 114 import Darcs.Ordered ( FL(..), RL(..), EqCheck(..), unsafeCoerceP, 115 (:\/:)(..), (:/\:)(..), (:>)(..), 116 (+>+), lengthFL, nullFL, 117 allFL, filterFL, 118 reverseRL, reverseFL, concatRL, mapFL, 119 mapFL_FL, concatFL ) 120 import Darcs.Patch ( RepoPatch, Patchy, Prim, merge, 121 joinPatches, sort_coalesceFL, 122 list_conflicted_files, list_touched_files, 123 Named, patchcontents, anonymous, 124 commuteRL, fromPrims, 125 patch2patchinfo, readPatch, 126 writePatch, effect, invert, 127 is_addfile, is_adddir, 128 is_setpref, 129 apply, apply_to_slurpy, 130 empty_markedup_file, MarkedUpFile 131 ) 132 import Darcs.Patch.Patchy ( Invert(..) ) 133 import Darcs.Patch.Permutations ( commuteWhatWeCanFL, removeFL ) 134 import Darcs.Patch.Info ( PatchInfo ) 135 import Darcs.Patch.Set ( PatchSet, SealedPatchSet ) 136 import Darcs.Patch.Apply ( markup_file, LineMark(None) ) 137 import Darcs.Patch.Depends ( get_common_and_uncommon, deep_optimize_patchset ) 138 import Darcs.Diff ( unsafeDiffAtPaths, unsafeDiff ) 139 import Darcs.RepoPath ( FilePathLike, AbsolutePath, toFilePath, 140 ioAbsoluteOrRemote, toPath ) 141 import Darcs.Utils ( promptYorn, catchall, withCurrentDirectory, withUMask, nubsort ) 142 import Progress ( debugMessage ) 143 import Darcs.ProgressPatches (progressFL) 144 import Darcs.URL ( is_file ) 145 import Darcs.Repository.Prefs ( darcsdir_filter, boring_file_filter, filetype_function, 146 getCaches ) 147 import Darcs.Lock ( withLock, writeDocBinFile, withDelayedDir, removeFileMayNotExist, 148 withTempDir, withPermDir ) 149 import Darcs.Sealed ( Sealed(Sealed), seal, FlippedSeal(FlippedSeal), flipSeal ) 150 import Darcs.Repository.InternalTypes( Repository(..), RepoType(..) ) 151 import Darcs.Global ( darcsdir ) 152 #include "impossible.h" 153 154 -- | Repository IO monad. This monad-like datatype is responsible for 155 -- sequencing IO actions that modify the tentative recorded state of 156 -- the repository. 157 newtype RIO p C(r u t t1) a = RIO { 158 unsafeUnRIO :: Repository p C(r u t) -> IO a -- ^ converts @RIO a@ to @IO a@. 159 } 160 161 -- | This is just like @>>=@ from the Monad class except that it 162 -- respects type witness safe repository transformations. Even so, it 163 -- only tracks modifications to the tentative recorded state. 164 (>>>=) :: RIO p C(r u t t1) a -> (a -> RIO p C(r u t1 t2) b) -> RIO p C(r u t t2) b 165 m >>>= k = RIO $ \ (Repo x y z w) -> 166 do a <- unsafeUnRIO m (Repo x y z w) 167 unsafeUnRIO (k a) (Repo x y z w) 168 169 -- | This corresponds to @>>@ from the Monad class. 170 (>>>) :: RIO p C(r u t t1) a -> RIO p C(r u t1 t2) b -> RIO p C(r u t t2) b 171 a >>> b = a >>>= (const b) 172 173 -- | This corresponds to @return@ from the Monad class. 174 returnR :: a -> RIO p C(r u t t) a 175 returnR = rIO . return 176 177 -- | This the @RIO@ equivalent of @liftIO@. 178 rIO :: IO a -> RIO p C(r u t t) a 179 rIO = RIO . const 180 181 instance Functor (RIO p C(r u t t)) where 182 fmap f m = RIO $ \r -> fmap f (unsafeUnRIO m r) 183 184 -- | We have an instance of Monad so that IO actions that do not 185 -- change the tentative recorded state are convenient in the IO monad. 186 instance Monad (RIO p C(r u t t)) where 187 (>>=) = (>>>=) 188 (>>) = (>>>) 189 return = returnR 190 fail = rIO . fail 191 192 -- | Similar to the @ask@ function of the MonadReader class. 193 -- This allows actions in the RIO monad to get the current 194 -- repository. 195 -- FIXME: Don't export this. If we don't export this 196 -- it makes it harder for arbitrary IO actions to access 197 -- the repository and hence our code is easier to audit. 198 getRepository :: RIO p C(r u t t) (Repository p C(r u t)) 199 getRepository = RIO return 200 201 maybeIdentifyRepository :: [DarcsFlag] -> String -> IO (Either String (Repository p C(r u t))) 202 maybeIdentifyRepository opts "." = 203 do darcs <- doesDirectoryExist darcsdir 204 rf_or_e <- identifyRepoFormat "." 205 here <- toPath `fmap` ioAbsoluteOrRemote "." 206 case rf_or_e of 207 Left err -> return $ Left err 208 Right rf -> 209 case read_problem rf of 210 Just err -> return $ Left err 211 Nothing -> if darcs then do pris <- identifyPristine 212 cs <- getCaches opts here 213 return $ Right $ Repo here opts rf (DarcsRepository pris cs) 214 else return (Left "Not a repository") 215 maybeIdentifyRepository opts url' = 216 do url <- toPath `fmap` ioAbsoluteOrRemote url' 217 rf_or_e <- identifyRepoFormat url 218 case rf_or_e of 219 Left e -> return $ Left e 220 Right rf -> case read_problem rf of 221 Just err -> return $ Left err 222 Nothing -> do cs <- getCaches opts url 223 return $ Right $ Repo url opts rf (DarcsRepository nopristine cs) 224 225 identifyDarcs1Repository :: [DarcsFlag] -> String -> IO (Repository Patch C(r u t)) 226 identifyDarcs1Repository opts url = 227 do er <- maybeIdentifyRepository opts url 228 case er of 229 Left s -> fail s 230 Right r -> return r 231 232 identifyRepositoryFor :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> String -> IO (Repository p C(r u t)) 233 identifyRepositoryFor (Repo _ opts rf _) url = 234 do Repo absurl _ rf_ t <- identifyDarcs1Repository opts url 235 let t' = case t of DarcsRepository x c -> DarcsRepository x c 236 case readfrom_and_writeto_problem rf_ rf of 237 Just e -> fail $ "Incompatibility with repository " ++ url ++ ":\n" ++ e 238 Nothing -> return $ Repo absurl opts rf_ t' 239 240 isRight :: Either a b -> Bool 241 isRight (Right _) = True 242 isRight _ = False 243 244 currentDirIsRepository :: IO Bool 245 currentDirIsRepository = isRight `liftM` maybeIdentifyRepository [] "." 246 247 amInRepository :: [DarcsFlag] -> IO (Either String ()) 248 amInRepository (WorkRepoDir d:_) = 249 do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d) 250 air <- currentDirIsRepository 251 if air 252 then return (Right ()) 253 else return (Left "You need to be in a repository directory to run this command.") 254 amInRepository (_:fs) = amInRepository fs 255 amInRepository [] = 256 seekRepo (Left "You need to be in a repository directory to run this command.") 257 258 -- | hunt upwards for the darcs repository 259 -- This keeps changing up one parent directory, testing at each 260 -- step if the current directory is a repository or not. $ 261 -- WARNING this changes the current directory for good if matchFn succeeds 262 seekRepo :: Either String () 263 -- ^ what to return if we don't find a repository 264 -> IO (Either String ()) 265 seekRepo onFail = getCurrentDirectory >>= helper where 266 helper startpwd = do 267 air <- currentDirIsRepository 268 if air 269 then return (Right ()) 270 else do cd <- toFilePath `fmap` getCurrentDirectory 271 setCurrentDirectory ".." 272 cd' <- toFilePath `fmap` getCurrentDirectory 273 if cd' /= cd 274 then helper startpwd 275 else do setCurrentDirectory startpwd 276 return onFail 277 278 amNotInRepository :: [DarcsFlag] -> IO (Either String ()) 279 amNotInRepository (WorkRepoDir d:_) = do createDirectoryIfMissing False d 280 -- note that the above could always fail 281 setCurrentDirectory d 282 amNotInRepository [] 283 amNotInRepository (_:f) = amNotInRepository f 284 amNotInRepository [] = 285 do air <- currentDirIsRepository 286 if air then return (Left $ "You may not run this command in a repository.") 287 else return $ Right () 288 289 findRepository :: [DarcsFlag] -> IO (Either String ()) 290 findRepository (WorkRepoUrl d:_) | is_file d = 291 do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d) 292 findRepository [] 293 findRepository (WorkRepoDir d:_) = 294 do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d) 295 findRepository [] 296 findRepository (_:fs) = findRepository fs 297 findRepository [] = seekRepo (Right ()) 298 299 slurp_pending :: RepoPatch p => Repository p C(r u t) -> IO Slurpy 300 slurp_pending repo@(Repo _ _ _ rt) = do 301 cur <- slurp_recorded repo 302 Sealed pend <- read_pending repo 303 case apply_to_slurpy pend cur of 304 Just pendcur -> return pendcur 305 Nothing -> do putStrLn "Yikes, pending has conflicts. Renaming file as_darcs/patches/pending_buggy" 306 renameFile (pendingName rt) (pendingName rt++"_buggy") 307 return cur 308 309 slurp_recorded :: RepoPatch p => Repository p C(r u t) -> IO Slurpy 310 slurp_recorded (Repo dir opts rf (DarcsRepository _ c)) 311 | format_has HashedInventory rf = 312 HashedRepo.slurp_pristine c (compression opts) dir $ darcsdir++"/hashed_inventory" 313 slurp_recorded repository@(Repo dir _ _ (DarcsRepository p _)) = do 314 mc <- withCurrentDirectory dir $ slurpPristine p 315 case mc of (Just slurpy) -> return slurpy 316 Nothing -> withDelayedDir "pristine.temp" $ \abscd -> 317 do let cd = toFilePath abscd 318 createPristineDirectoryTree repository cd 319 mmap_slurp cd 320 321 slurp_recorded_and_unrecorded :: RepoPatch p => Repository p C(r u t) -> IO (Slurpy, Slurpy) 322 slurp_recorded_and_unrecorded repo@(Repo r _ _ _) = do 323 cur <- slurp_recorded repo 324 Sealed pend <- read_pending repo 325 withCurrentDirectory r $ 326 case apply_to_slurpy pend cur of 327 Nothing -> fail "Yikes, pending has conflicts!" 328 Just pendslurp -> do unrec <- co_slurp pendslurp "." 329 return (cur, unrec) 330 331 pendingName :: RepoType p -> String 332 pendingName (DarcsRepository _ _) = darcsdir++"/patches/pending" 333 334 read_pending :: RepoPatch p => Repository p C(r u t) -> IO (Sealed (FL Prim C(r))) 335 read_pending (Repo r _ _ tp) = 336 withCurrentDirectory r (read_pendingfile (pendingName tp)) 337 338 add_to_pending :: RepoPatch p => Repository p C(r u t) -> FL Prim C(u y) -> IO () 339 add_to_pending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () 340 add_to_pending repo p = 341 do pend <- get_unrecorded repo 342 make_new_pending repo (pend +>+ p) 343 344 readPrims :: B.ByteString -> Sealed (FL Prim C(x)) 345 readPrims s = case readPatch s :: Maybe (Sealed (Patch C(x )), B.ByteString) of 346 Nothing -> Sealed NilFL 347 Just (Sealed p,_) -> Sealed (effect p) 348 349 read_pendingfile :: String -> IO (Sealed (FL Prim C(x))) 350 read_pendingfile name = do 351 pend <- gzReadFilePS name `catchall` return B.empty 352 return $ readPrims pend 353 354 make_new_pending :: forall p C(r u t y). RepoPatch p => Repository p C(r u t) -> FL Prim C(r y) -> IO () 355 make_new_pending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () 356 make_new_pending repo@(Repo r _ _ tp) origp = 357 withCurrentDirectory r $ 358 do let newname = pendingName tp ++ ".new" 359 debugMessage $ "Writing new pending: " ++ newname 360 Sealed sfp <- return $ sift_for_pending origp 361 writeSealedPatch newname $ seal $ fromPrims $ sfp 362 cur <- slurp_recorded repo 363 Sealed p <- read_pendingfile newname 364 when (isNothing $ apply_to_slurpy p cur) $ do 365 let buggyname = pendingName tp ++ "_buggy" 366 renameFile newname buggyname 367 bugDoc $ text "There was an attempt to write an invalid pending!" 368 $$ text "If possible, please send the contents of" 369 <+> text buggyname 370 $$ text "along with a bug report." 371 renameFile newname (pendingName tp) 372 debugMessage $ "Finished writing new pending: " ++ newname 373 where writeSealedPatch :: FilePath -> Sealed (Patch C(x)) -> IO () 374 writeSealedPatch fp (Sealed p) = writePatch fp p 375 376 sift_for_pending :: FL Prim C(x y) -> Sealed (FL Prim C(x)) 377 sift_for_pending simple_ps = 378 let oldps = maybe simple_ps id $ try_shrinking_inverse $ crude_sift simple_ps 379 in if allFL (\p -> is_addfile p || is_adddir p) $ oldps 380 then seal oldps 381 else fromJust $ do 382 Sealed x <- return $ sfp NilFL $ reverseFL oldps 383 return (case try_to_shrink x of 384 ps | lengthFL ps < lengthFL oldps -> sift_for_pending ps 385 | otherwise -> seal ps) 386 where sfp :: FL Prim C(a b) -> RL Prim C(c a) -> Sealed (FL Prim C(c)) 387 sfp sofar NilRL = seal sofar 388 sfp sofar (p:<:ps) 389 | is_hunk p || is_binary p 390 = case commuteFL (p :> sofar) of 391 Right (sofar' :> _) -> sfp sofar' ps 392 Left _ -> sfp (p:>:sofar) ps 393 sfp sofar (p:<:ps) = sfp (p:>:sofar) ps 394 395 get_unrecorded_no_look_for_adds :: RepoPatch p => Repository p C(r u t) -> [FileName] -> IO (FL Prim C(r y)) 396 get_unrecorded_no_look_for_adds r paths = get_unrecorded_private (filter (/= LookForAdds)) r paths 397 398 get_unrecorded_unsorted :: RepoPatch p => Repository p C(r u t) -> IO (FL Prim C(r u)) 399 get_unrecorded_unsorted r = get_unrecorded_in_files_unsorted r [] 400 401 get_unrecorded :: RepoPatch p => Repository p C(r u t) -> IO (FL Prim C(r u)) 402 get_unrecorded r = get_unrecorded_private id r [] 403 404 -- | Gets the unrecorded changes in the given paths in the current repository, 405 -- without sorting them for presentation to the user 406 get_unrecorded_in_files_unsorted :: RepoPatch p => Repository p C(r u t) -> [FileName] -> IO (FL Prim C(r u)) 407 get_unrecorded_in_files_unsorted = get_unrecorded_private (AnyOrder:) 408 409 -- | Gets the unrecorded changes in the given paths in the current repository. 410 get_unrecorded_in_files :: RepoPatch p => Repository p C(r u t) -> [FileName] -> IO (FL Prim C(r u)) 411 get_unrecorded_in_files = get_unrecorded_private id 412 413 -- | The /unrecorded/ includes the pending and the working directory changes. 414 -- The third argument is a list of paths: if this list is [], it will diff 415 -- the whole repo, but if there are elements in it, the function will return 416 -- only changes to files under those paths. The paths must be fixed paths 417 -- starting with ".", but need not yet be unique. 418 get_unrecorded_private :: RepoPatch p => ([DarcsFlag]->[DarcsFlag]) -> Repository p C(r u t) -> [FileName] -> IO (FL Prim C(r y)) 419 get_unrecorded_private _ (Repo _ opts _ _) _ 420 | NoUpdateWorking `elem` opts = return $ unsafeCoerceP NilFL 421 get_unrecorded_private modopts repository@(Repo r oldopts _ _) files = 422 withCurrentDirectory r (do 423 debugMessage "Looking for unrecorded changes..." 424 cur <- slurp_pending repository 425 work <- if LookForAdds `elem` opts 426 then do nboring <- if Boring `elem` opts 427 then return $ darcsdir_filter 428 else boring_file_filter 429 slurp_unboring (myfilt cur nboring) "." 430 else co_slurp cur "." 431 ftf <- filetype_function 432 Sealed pend <- read_pending repository 433 let changed_files = apply_to_filepaths pend filesFP 434 pre_changed_files = apply_to_filepaths (invert pend) filesFP 435 Sealed relevantPend <- return $ if null files 436 then seal pend 437 else choose_touching pre_changed_files pend 438 debugMessage "diffing dir..." 439 let diffs = if null files 440 then unsafeDiff opts ftf cur work 441 else unsafeDiffAtPaths (ignoreTimes, lookForAdds, summary) ftf cur work changed_files 442 dif = if AnyOrder `elem` opts 443 then relevantPend +>+ diffs 444 else sort_coalesceFL $ relevantPend +>+ diffs 445 seq dif $ debugMessage "Found unrecorded changes." 446 return dif) 447 where myfilt s nboring f = slurp_has f s || nboring [f] /= [] 448 opts = modopts oldopts 449 -- NoSummary/Summary both present gives False 450 -- Just Summary gives True 451 -- Just NoSummary gives False 452 -- Neither gives False 453 summary = Summary `elem` opts && NoSummary `notElem` opts 454 lookForAdds = LookForAdds `elem` opts 455 ignoreTimes = IgnoreTimes `elem` opts 456 filesFP = map fn2fp files 457 458 -- @todo: we should not have to open the result of HashedRepo and 459 -- seal it. Instead, update this function to work with type witnesses 460 -- by fixing DarcsRepo to match HashedRepo in the handling of 461 -- Repository state. 462 read_repo :: RepoPatch p => Repository p C(r u t) -> IO (PatchSet p C(r)) 463 read_repo repo@(Repo r opts rf _) 464 | format_has HashedInventory rf = do ps <- HashedRepo.read_repo repo r 465 return ps 466 | otherwise = do Sealed ps <- DarcsRepo.read_repo opts r 467 return $ unsafeCoerceP ps 468 469 readTentativeRepo :: RepoPatch p => Repository p C(r u t) -> IO (PatchSet p C(t)) 470 readTentativeRepo repo@(Repo r opts rf _) 471 | format_has HashedInventory rf = do ps <- HashedRepo.read_tentative_repo repo r 472 return ps 473 | otherwise = do Sealed ps <- DarcsRepo.read_tentative_repo opts r 474 return $ unsafeCoerceP ps 475 476 makePatchLazy :: RepoPatch p => Repository p C(r u t) -> PatchInfoAnd p C(x y) -> IO (PatchInfoAnd p C(x y)) 477 makePatchLazy (Repo r opts rf (DarcsRepository _ c)) p 478 | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.write_and_read_patch c (compression opts) p 479 | otherwise = withCurrentDirectory r $ DarcsRepo.write_and_read_patch opts p 480 481 sync_repo :: Repository p C(r u t) -> IO () 482 sync_repo (Repo r _ rf (DarcsRepository _ c)) 483 | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.sync_repo c 484 sync_repo (Repo r _ _ (DarcsRepository p _)) = withCurrentDirectory r $ syncPristine p 485 486 prefsUrl :: Repository p C(r u t) -> String 487 prefsUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/"++darcsdir++"/prefs" 488 489 unrevertUrl :: Repository p C(r u t) -> String 490 unrevertUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/"++darcsdir++"/patches/unrevert" 491 492 applyToWorking :: Patchy p => Repository p1 C(r u t) -> [DarcsFlag] -> p C(u y) -> IO () 493 applyToWorking (Repo r _ _ (DarcsRepository _ _)) opts patch = 494 withCurrentDirectory r $ if Quiet `elem` opts 495 then runSilently $ apply opts patch 496 else runTolerantly $ apply opts patch 497 498 handle_pend_for_add :: forall p q C(r u t x y). (RepoPatch p, Effect q) 499 => Repository p C(r u t) -> q C(x y) -> IO () 500 handle_pend_for_add (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () 501 handle_pend_for_add (Repo _ _ _ rt) p = 502 do let pn = pendingName rt ++ ".tentative" 503 Sealed pend <- (readPrims `fmap` gzReadFilePS pn) `catchall` (return $ Sealed NilFL) 504 let effectp = if allFL is_simple pend then crude_sift $ effect p 505 else effect p 506 Sealed newpend <- return $ rmpend (progressFL "Removing from pending:" effectp) pend 507 writePatch pn $ fromPrims_ newpend 508 where rmpend :: FL Prim C(a b) -> FL Prim C(a c) -> Sealed (FL Prim C(b)) 509 rmpend NilFL x = Sealed x 510 rmpend _ NilFL = Sealed NilFL 511 rmpend (x:>:xs) xys | Just ys <- removeFL x xys = rmpend xs ys 512 rmpend (x:>:xs) ys = 513 case commuteWhatWeCanFL (x:>xs) of 514 a:>x':>b -> case rmpend a ys of 515 Sealed ys' -> case commute (invert (x':>:b) :> ys') of 516 Just (ys'' :> _) -> seal ys'' 517 Nothing -> seal $ invert (x':>:b)+>+ys' 518 -- DJR: I don't think this 519 -- last case should be 520 -- reached, but it also 521 -- shouldn't lead to 522 -- corruption. 523 fromPrims_ :: FL Prim C(a b) -> Patch C(a b) 524 fromPrims_ = fromPrims 525 526 is_simple :: Prim C(x y) -> Bool 527 is_simple x = is_hunk x || is_binary x || is_setpref x 528 529 crude_sift :: FL Prim C(x y) -> FL Prim C(x y) 530 crude_sift xs = if allFL is_simple xs then filterFL ishunkbinary xs else xs 531 where ishunkbinary :: Prim C(x y) -> EqCheck C(x y) 532 ishunkbinary x | is_hunk x || is_binary x = unsafeCoerceP IsEq 533 | otherwise = NotEq 534 535 data HashedVsOld a = HvsO { old, hashed :: a } 536 537 decideHashedOrNormal :: Monad m => RepoFormat -> HashedVsOld (m a) -> m a 538 decideHashedOrNormal rf (HvsO { hashed = h, old = o }) 539 | format_has HashedInventory rf = h 540 | otherwise = o 541 542 543 tentativelyMergePatches :: RepoPatch p 544 => Repository p C(r u t) -> String -> [DarcsFlag] 545 -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y) 546 -> IO (Sealed (FL Prim C(u))) 547 tentativelyMergePatches = tentativelyMergePatches_ MakeChanges 548 549 considerMergeToWorking :: RepoPatch p 550 => Repository p C(r u t) -> String -> [DarcsFlag] 551 -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y) 552 -> IO (Sealed (FL Prim C(u))) 553 considerMergeToWorking = tentativelyMergePatches_ DontMakeChanges 554 555 data MakeChanges = MakeChanges | DontMakeChanges deriving ( Eq ) 556 557 tentativelyMergePatches_ :: forall p C(r u t y x). RepoPatch p 558 => MakeChanges 559 -> Repository p C(r u t) -> String -> [DarcsFlag] 560 -> FL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x y) 561 -> IO (Sealed (FL Prim C(u))) 562 tentativelyMergePatches_ mc r cmd opts usi themi = 563 do let us = mapFL_FL hopefully usi 564 them = mapFL_FL hopefully themi 565 _ :/\: pc <- return $ merge (progressFL "Merging them" them :\/: progressFL "Merging us" us) 566 pend <- get_unrecorded_unsorted r -- we don't care if it looks pretty... 567 anonpend <- anonymous (fromPrims pend) 568 pend' :/\: pw <- return $ merge (pc :\/: anonpend :>: NilFL) 569 let pwprim = joinPatches $ progressFL "Examining patches for conflicts" $ mapFL_FL patchcontents pw 570 Sealed standard_resolved_pw <- return $ standard_resolution pwprim 571 debugMessage "Checking for conflicts..." 572 mapM_ backupByCopying $ list_touched_files standard_resolved_pw 573 debugMessage "Announcing conflicts..." 574 have_conflicts <- announce_merge_conflicts cmd opts standard_resolved_pw 575 debugMessage "Checking for unrecorded conflicts..." 576 have_unrecorded_conflicts <- check_unrecorded_conflicts opts pc 577 debugMessage "Reading working directory..." 578 (_, working) <- slurp_recorded_and_unrecorded r 579 debugMessage "Working out conflicts in actual working directory..." 580 Sealed pw_resolution <- 581 case (want_external_merge opts, have_conflicts || have_unrecorded_conflicts) of 582 (Nothing,_) -> return $ if AllowConflicts `elem` opts 583 then seal NilFL 584 else seal standard_resolved_pw 585 (_,False) -> return $ seal standard_resolved_pw 586 (Just c, True) -> external_resolution working c 587 (effect us +>+ pend) 588 (effect them) pwprim 589 debugMessage "Applying patches to the local directories..." 590 when (mc == MakeChanges) $ 591 do let doChanges :: FL (PatchInfoAnd p) C(x r) -> IO () 592 doChanges NilFL = applyps r themi 593 doChanges _ = applyps r (mapFL_FL n2pia pc) 594 doChanges usi 595 setTentativePending r (effect pend' +>+ pw_resolution) 596 return $ seal (effect pwprim +>+ pw_resolution) 597 where mapAdd :: Repository p C(i l m) -> FL (PatchInfoAnd p) C(i j) -> [IO ()] 598 mapAdd _ NilFL = [] 599 mapAdd r'@(Repo dir df rf dr) (a:>:as) = 600 -- we construct a new Repository object on the recursive case so that the 601 -- recordedstate of the repository can match the fact that we just wrote a patch 602 tentativelyAddPatch_ DontUpdatePristine r' opts a : mapAdd (Repo dir df rf dr) as 603 applyps :: Repository p C(i l m) -> FL (PatchInfoAnd p) C(i j) -> IO () 604 applyps repo ps = do debugMessage "Adding patches to inventory..." 605 sequence_ $ mapAdd repo ps 606 debugMessage "Applying patches to pristine..." 607 applyToTentativePristine repo ps 608 609 announce_merge_conflicts :: String -> [DarcsFlag] -> FL Prim C(x y) -> IO Bool 610 announce_merge_conflicts cmd opts resolved_pw = 611 case nubsort $ list_touched_files $ resolved_pw of 612 [] -> return False 613 cfs -> if MarkConflicts `elem` opts || AllowConflicts `elem` opts 614 || want_external_merge opts /= Nothing 615 then do putStrLn "We have conflicts in the following files:" 616 putStrLn $ unwords cfs 617 return True 618 else do putStrLn "There are conflicts in the following files:" 619 putStrLn $ unwords cfs 620 fail $ "Refusing to "++cmd++" patches leading to conflicts.\n"++ 621 "If you would rather apply the patch and mark the conflicts,\n"++ 622 "use the --mark-conflicts or --allow-conflicts options to "++cmd++"\n"++ 623 "These can set as defaults by adding\n"++ 624 " "++cmd++" mark-conflicts\n"++ 625 "to "++darcsdir++"/prefs/defaults in the target repo. " 626 627 check_unrecorded_conflicts :: forall p C(r y). RepoPatch p => [DarcsFlag] -> FL (Named p) C(r y) -> IO Bool 628 check_unrecorded_conflicts opts _ | NoUpdateWorking `elem` opts = return False 629 check_unrecorded_conflicts opts pc = 630 do repository <- identifyDarcs1Repository opts "." 631 cuc repository 632 where cuc :: Repository Patch C(r u t) -> IO Bool 633 cuc r = do Sealed mpend <- read_pending r :: IO (Sealed (FL Prim C(r))) 634 case mpend of 635 NilFL -> return False 636 pend -> 637 case merge (fromPrims_ pend :\/: fromPrims_ (concatFL $ mapFL_FL effect pc)) of 638 _ :/\: pend' -> 639 case list_conflicted_files pend' of 640 [] -> return False 641 fs -> do yorn <- promptYorn 642 ("You have conflicting local changes to:\n" 643 ++ unwords fs++"\nProceed?") 644 when (yorn /= 'y') $ 645 do putStrLn "Cancelled." 646 exitWith ExitSuccess 647 return True 648 fromPrims_ :: FL Prim C(a b) -> p C(a b) 649 fromPrims_ = fromPrims 650 651 tentativelyAddPatch :: RepoPatch p 652 => Repository p C(r u t) -> [DarcsFlag] -> PatchInfoAnd p C(r y) -> IO () 653 tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine 654 655 data UpdatePristine = UpdatePristine | DontUpdatePristine deriving Eq 656 657 tentativelyAddPatch_ :: RepoPatch p 658 => UpdatePristine -> Repository p C(r u t) -> [DarcsFlag] 659 -> PatchInfoAnd p C(r y) -> IO () 660 tentativelyAddPatch_ _ _ opts _ 661 | DryRun `elem` opts = bug "tentativelyAddPatch_ called when --dry-run is specified" 662 tentativelyAddPatch_ up r@(Repo dir _ rf (DarcsRepository _ c)) opts p = 663 withCurrentDirectory dir $ 664 do decideHashedOrNormal rf $ HvsO { 665 hashed = HashedRepo.add_to_tentative_inventory c (compression opts) p, 666 old = DarcsRepo.add_to_tentative_inventory opts (hopefully p) } 667 when (up == UpdatePristine) $ do debugMessage "Applying to pristine cache..." 668 applyToTentativePristine r p 669 debugMessage "Updating pending..." 670 handle_pend_for_add r p 671 672 applyToTentativePristine :: (Effect q, Patchy q) => Repository p C(r u t) -> q C(r y) -> IO () 673 applyToTentativePristine (Repo dir opts rf (DarcsRepository _ c)) p = 674 withCurrentDirectory dir $ 675 do when (Verbose `elem` opts) $ putDocLn $ text "Applying to pristine..." <+> description p 676 decideHashedOrNormal rf $ HvsO {hashed = HashedRepo.apply_to_tentative_pristine c opts p, 677 old = DarcsRepo.add_to_tentative_pristine p} 678 679 -- | This fuction is unsafe because it accepts a patch that works on the tentative 680 -- pending and we don't currently track the state of the tentative pending. 681 tentativelyAddToPending :: forall p C(r u t x y). RepoPatch p 682 => Repository p C(r u t) -> [DarcsFlag] -> FL Prim C(x y) -> IO () 683 tentativelyAddToPending (Repo _ opts _ _) _ _ 684 | NoUpdateWorking `elem` opts = return () 685 | DryRun `elem` opts = bug "tentativelyAddToPending called when --dry-run is specified" 686 tentativelyAddToPending (Repo dir _ _ rt) _ patch = 687 withCurrentDirectory dir $ do 688 let pn = pendingName rt 689 tpn = pn ++ ".tentative" 690 Sealed pend <- readPrims `liftM` (gzReadFilePS tpn `catchall` (return B.empty)) 691 FlippedSeal newpend_ <- return $ newpend (unsafeCoerceP pend :: FL Prim C(a x)) patch 692 writePatch tpn $ fromPrims_ newpend_ 693 where newpend :: FL Prim C(a b) -> FL Prim C(b c) -> FlippedSeal (FL Prim) C(c) 694 newpend NilFL patch_ = flipSeal patch_ 695 newpend p patch_ = flipSeal $ p +>+ patch_ 696 fromPrims_ :: FL Prim C(a b) -> Patch C(a b) 697 fromPrims_ = fromPrims 698 699 -- | setTentativePending is basically unsafe. It overwrites the pending state with a new one, not related to 700 -- the repository state. 701 setTentativePending :: forall p C(r u t x y). RepoPatch p => Repository p C(r u t) -> FL Prim C(x y) -> IO () 702 setTentativePending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () 703 setTentativePending (Repo dir _ _ rt) patch = do 704 Sealed prims <- return $ sift_for_pending patch 705 withCurrentDirectory dir $ 706 writePatch (pendingName rt ++ ".tentative") $ fromPrims_ prims 707 where fromPrims_ :: FL Prim C(a b) -> Patch C(a b) 708 fromPrims_ = fromPrims 709 710 -- | prepend is basically unsafe. It overwrites the pending state 711 -- with a new one, not related to the repository state. 712 prepend :: forall p C(r u t x y). RepoPatch p => 713 Repository p C(r u t) -> FL Prim C(x y) -> IO () 714 prepend (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () 715 prepend (Repo _ _ _ rt) patch = 716 do let pn = pendingName rt ++ ".tentative" 717 Sealed pend <- readPrims `liftM` (gzReadFilePS pn `catchall` (return B.empty)) 718 Sealed newpend_ <- return $ newpend pend patch 719 writePatch pn $ fromPrims_ (crude_sift newpend_) 720 where newpend :: FL Prim C(b c) -> FL Prim C(a b) -> Sealed (FL Prim C(a)) 721 newpend NilFL patch_ = seal patch_ 722 newpend p patch_ = seal $ patch_ +>+ p 723 fromPrims_ :: FL Prim C(a b) -> Patch C(a b) 724 fromPrims_ = fromPrims 725 726 tentativelyRemovePatches :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] 727 -> FL (Named p) C(x t) -> IO () 728 tentativelyRemovePatches = tentativelyRemovePatches_ UpdatePristine 729 730 tentativelyRemovePatches_ :: forall p C(r u t x). RepoPatch p => UpdatePristine 731 -> Repository p C(r u t) -> [DarcsFlag] 732 -> FL (Named p) C(x t) -> IO () 733 tentativelyRemovePatches_ up repository@(Repo dir _ rf (DarcsRepository _ c)) opts ps = 734 withCurrentDirectory dir $ do 735 when (up == UpdatePristine) $ do debugMessage "Adding changes to pending..." 736 prepend repository $ effect ps 737 remove_from_unrevert_context repository ps 738 debugMessage "Removing changes from tentative inventory..." 739 if format_has HashedInventory rf 740 then do HashedRepo.remove_from_tentative_inventory repository (compression opts) ps 741 when (up == UpdatePristine) $ 742 HashedRepo.apply_to_tentative_pristine c opts $ 743 progressFL "Applying inverse to pristine" $ invert ps 744 else DarcsRepo.remove_from_tentative_inventory (up==UpdatePristine) opts ps 745 746 tentativelyReplacePatches :: forall p C(r u t x). RepoPatch p => Repository p C(r u t) -> [DarcsFlag] 747 -> FL (Named p) C(x t) -> IO () 748 tentativelyReplacePatches repository@(Repo x y z w) opts ps = 749 -- tentativelyRemovePatches_ leaves the repository in state C(x u t) 750 do tentativelyRemovePatches_ DontUpdatePristine repository opts ps 751 -- Now we add the patches back so that the repo again has state C(r u t) 752 sequence_ $ mapAdd ((Repo x y z w) :: Repository p C(x u t)) ps 753 where mapAdd :: Repository p C(i l m) -> FL (Named p) C(i j) -> [IO ()] 754 mapAdd _ NilFL = [] 755 mapAdd r@(Repo dir df rf dr) (a:>:as) = 756 -- we construct a new Repository object on the recursive case so that the 757 -- recordedstate of the repository can match the fact that we just wrote a patch 758 tentativelyAddPatch_ DontUpdatePristine r opts (n2pia a) : mapAdd (Repo dir df rf dr) as 759 760 finalize_pending :: RepoPatch p => Repository p C(r u t) -> IO () 761 finalize_pending (Repo dir opts _ rt) 762 | NoUpdateWorking `elem` opts = 763 withCurrentDirectory dir $ removeFileMayNotExist $ (pendingName rt) 764 finalize_pending repository@(Repo dir _ _ rt) = do 765 withCurrentDirectory dir $ do let pn = pendingName rt 766 tpn = pn ++ ".tentative" 767 tpfile <- gzReadFilePS tpn `catchall` (return B.empty) 768 Sealed tpend <- return $ readPrims tpfile 769 Sealed new_pending <- return $ sift_for_pending tpend 770 make_new_pending repository new_pending 771 772 finalizeRepositoryChanges :: RepoPatch p => Repository p C(r u t) -> IO () 773 finalizeRepositoryChanges (Repo _ opts _ _) 774 | DryRun `elem` opts = bug "finalizeRepositoryChanges called when --dry-run specified" 775 finalizeRepositoryChanges repository@(Repo dir opts rf _) 776 | format_has HashedInventory rf = 777 withCurrentDirectory dir $ do debugMessage "Considering whether to test..." 778 testTentative repository 779 debugMessage "Finalizing changes..." 780 withSignalsBlocked $ do HashedRepo.finalize_tentative_changes repository (compression opts) 781 finalize_pending repository 782 debugMessage "Done finalizing changes..." 783 finalizeRepositoryChanges repository@(Repo dir _ _ (DarcsRepository _ _)) = 784 withCurrentDirectory dir $ do debugMessage "Considering whether to test..." 785 testTentative repository 786 debugMessage "Finalizing changes..." 787 withSignalsBlocked $ do DarcsRepo.finalize_pristine_changes 788 DarcsRepo.finalize_tentative_changes 789 finalize_pending repository 790 791 testTentative :: RepoPatch p => Repository p C(r u t) -> IO () 792 testTentative = testAny withTentative 793 794 testRecorded :: RepoPatch p => Repository p C(r u t) -> IO () 795 testRecorded = testAny withRecorded 796 797 testAny :: RepoPatch p => (Repository p C(r u t) 798 -> ((AbsolutePath -> IO ()) -> IO ()) 799 -> (AbsolutePath -> IO ()) -> IO ()) 800 -> Repository p C(r u t) -> IO () 801 testAny withD repository@(Repo dir opts _ _) = 802 when (Test `elem` opts) $ withCurrentDirectory dir $ 803 do let putInfo = if not $ Quiet `elem` opts then putStrLn else const (return ()) 804 debugMessage "About to run test if it exists." 805 testline <- get_prefval "test" 806 case testline of 807 Nothing -> return () 808 Just testcode -> 809 withD repository (wd "testing") $ \_ -> 810 do putInfo "Running test...\n" 811 when (SetScriptsExecutable `elem` opts) setScriptsExecutable 812 ec <- system testcode 813 if ec == ExitSuccess 814 then putInfo "Test ran successfully.\n" 815 else do putInfo "Test failed!\n" 816 exitWith ec 817 where wd = if LeaveTestDir `elem` opts then withPermDir else withTempDir 818 819 revertRepositoryChanges :: RepoPatch p => Repository p C(r u t) -> IO () 820 revertRepositoryChanges (Repo _ opts _ _) 821 | DryRun `elem` opts = bug "revertRepositoryChanges called when --dry-run is specified" 822 revertRepositoryChanges r@(Repo dir opts rf dr@(DarcsRepository _ _)) = 823 withCurrentDirectory dir $ 824 do removeFileMayNotExist (pendingName dr ++ ".tentative") 825 Sealed x <- read_pending r 826 setTentativePending r $ effect x 827 when (NoUpdateWorking `elem` opts) $ removeFileMayNotExist $ pendingName dr 828 decideHashedOrNormal rf $ HvsO { hashed = HashedRepo.revert_tentative_changes, 829 old = DarcsRepo.revert_tentative_changes } 830 831 patchSetToPatches :: RepoPatch p => RL (RL (PatchInfoAnd p)) C(x y) -> FL (Named p) C(x y) 832 patchSetToPatches patchSet = mapFL_FL hopefully $ reverseRL $ concatRL patchSet 833 834 getUMask :: [DarcsFlag] -> Maybe String 835 getUMask [] = Nothing 836 getUMask ((UMask u):_) = Just u 837 getUMask (_:l) = getUMask l 838 839 withGutsOf :: Repository p C(r u t) -> IO () -> IO () 840 withGutsOf (Repo _ _ rf _) | format_has HashedInventory rf = id 841 | otherwise = withSignalsBlocked 842 843 withRepository :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a 844 withRepository opts1 = withRepositoryDirectory opts1 "." 845 846 withRepositoryDirectory :: forall a. [DarcsFlag] -> String 847 -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a 848 withRepositoryDirectory opts1 url job = 849 do Repo dir opts rf rt <- identifyDarcs1Repository opts1 url 850 let rt' = case rt of DarcsRepository t c -> DarcsRepository t c 851 if format_has Darcs2 rf 852 then do debugMessage $ "Identified darcs-2 repo: " ++ dir 853 job1_ (Repo dir opts rf rt') 854 else do debugMessage $ "Identified darcs-1 repo: " ++ dir 855 job2_ (Repo dir opts rf rt) 856 where job1_ :: Repository (FL RealPatch) C(r u r) -> IO a 857 job1_ = job 858 job2_ :: Repository Patch C(r u r) -> IO a 859 job2_ = job 860 861 862 -- RankNTypes 863 -- $- works around the lack of impredicative instantiation in GHC 864 ($-) ::((forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a) 865 -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a 866 x $- y = x y 867 868 withRepoLock :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a 869 withRepoLock opts job = 870 withRepository opts $- \repository@(Repo _ _ rf _) -> 871 do case write_problem rf of 872 Nothing -> return () 873 Just err -> fail err 874 let name = "./"++darcsdir++"/lock" 875 wu = case (getUMask opts) of 876 Nothing -> id 877 Just u -> withUMask u 878 wu $ if DryRun `elem` opts 879 then job repository 880 else withLock name (revertRepositoryChanges repository >> job repository) 881 882 withRepoReadLock :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a 883 withRepoReadLock opts job = 884 withRepository opts $- \repository@(Repo _ _ rf _) -> 885 do case write_problem rf of 886 Nothing -> return () 887 Just err -> fail err 888 let name = "./"++darcsdir++"/lock" 889 wu = case (getUMask opts) of Nothing -> id 890 Just u -> withUMask u 891 wu $ if format_has HashedInventory rf || DryRun `elem` opts 892 then job repository 893 else withLock name (revertRepositoryChanges repository >> job repository) 894 895 remove_from_unrevert_context :: forall p C(r u t x). RepoPatch p 896 => Repository p C(r u t) -> FL (Named p) C(x t) -> IO () 897 remove_from_unrevert_context repository ps = do 898 Sealed bundle <- unrevert_patch_bundle `catchall` (return $ seal (NilRL:<:NilRL)) 899 remove_from_unrevert_context_ bundle 900 where unrevert_impossible unrevert_loc = 901 do yorn <- promptYorn "This operation will make unrevert impossible!\nProceed?" 902 case yorn of 903 'n' -> fail "Cancelled." 904 'y' -> removeFile unrevert_loc `catchall` return () 905 _ -> impossible 906 pis = mapFL patch2patchinfo ps 907 unrevert_patch_bundle :: IO (SealedPatchSet p) 908 unrevert_patch_bundle = do pf <- B.readFile (unrevertUrl repository) 909 case scan_bundle pf of 910 Right foo -> return foo 911 Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err 912 remove_from_unrevert_context_ :: PatchSet p C(z) -> IO () 913 remove_from_unrevert_context_ (NilRL :<: NilRL) = return () 914 remove_from_unrevert_context_ bundle = do 915 let unrevert_loc = unrevertUrl repository 916 debugMessage "Adjusting the context of the unrevert changes..." 917 ref <- readTentativeRepo repository 918 case get_common_and_uncommon (bundle, ref) of 919 (common,(h_us:<:NilRL):<:NilRL :\/: NilRL:<:NilRL) -> 920 case commuteRL (reverseFL ps :> hopefully h_us) of 921 Nothing -> unrevert_impossible unrevert_loc 922 Just (us' :> _) -> do 923 s <- slurp_recorded repository 924 writeDocBinFile unrevert_loc $ 925 make_bundle [] s 926 (common \\ pis) (us':>:NilFL) 927 (common,(x:<:NilRL):<:NilRL:\/:_) 928 | isr && any (`elem` common) pis -> unrevert_impossible unrevert_loc 929 | isr -> return () 930 where isr = isJust $ hopefullyM x 931 _ -> unrevert_impossible unrevert_loc 932 933 -- | Writes out a fresh copy of the inventory that minimizes the 934 -- amount of inventory that need be downloaded when people pull from 935 -- the repository. 936 -- 937 -- Specifically, it breaks up the inventory on the most recent tag. 938 -- This speeds up most commands when run remotely, both because a 939 -- smaller file needs to be transfered (only the most recent 940 -- inventory). It also gives a guarantee that all the patches prior 941 -- to a given tag are included in that tag, so less commutation and 942 -- history traversal is needed. This latter issue can become very 943 -- important in large repositories. 944 optimizeInventory :: RepoPatch p => Repository p C(r u t) -> IO () 945 optimizeInventory repository@(Repo r opts rf (DarcsRepository _ c)) = 946 do ps <- read_repo repository 947 decideHashedOrNormal rf $ 948 HvsO { hashed = do revertRepositoryChanges repository 949 HashedRepo.write_tentative_inventory c (compression opts) $ deep_optimize_patchset ps 950 finalizeRepositoryChanges repository, 951 old = DarcsRepo.write_inventory r $ deep_optimize_patchset ps 952 } 953 954 cleanRepository :: RepoPatch p => Repository p C(r u t) -> IO () 955 cleanRepository repository@(Repo _ _ rf _) = 956 decideHashedOrNormal rf $ 957 HvsO { hashed = HashedRepo.clean_pristine repository, 958 old = return () } 959 960 replacePristineFromSlurpy :: Repository p C(r u t) -> Slurpy -> IO () 961 replacePristineFromSlurpy (Repo r opts rf (DarcsRepository pris c)) s 962 | format_has HashedInventory rf = withCurrentDirectory r $ HashedRepo.replacePristineFromSlurpy c (compression opts) s 963 | otherwise = withCurrentDirectory r $ Pristine.replacePristineFromSlurpy s pris 964 965 createPristineDirectoryTree :: RepoPatch p => Repository p C(r u t) -> FilePath -> IO () 966 createPristineDirectoryTree repo@(Repo r opts rf (DarcsRepository pris c)) reldir 967 | format_has HashedInventory rf = 968 do createDirectoryIfMissing True reldir 969 withCurrentDirectory reldir $ HashedRepo.copy_pristine c (compression opts) r (darcsdir++"/hashed_inventory") 970 | otherwise = 971 do dir <- toPath `fmap` ioAbsoluteOrRemote reldir 972 done <- withCurrentDirectory r $ easyCreatePristineDirectoryTree pris dir 973 unless done $ do Sealed patches <- (seal . reverseRL . concatRL) `liftM` read_repo repo 974 createDirectoryIfMissing True dir 975 withCurrentDirectory dir $ apply_patches [] patches 976 977 -- fp below really should be FileName 978 createPartialsPristineDirectoryTree :: (FilePathLike fp, RepoPatch p) => Repository p C(r u t) -> [fp] -> FilePath -> IO () 979 createPartialsPristineDirectoryTree (Repo r opts rf (DarcsRepository _ c)) prefs dir 980 | format_has HashedInventory rf = 981 do createDirectoryIfMissing True dir 982 withCurrentDirectory dir $ 983 HashedRepo.copy_partials_pristine c (compression opts) r (darcsdir++"/hashed_inventory") prefs 984 createPartialsPristineDirectoryTree r@(Repo rdir _ _ (DarcsRepository pris _)) prefs dir 985 = withCurrentDirectory rdir $ 986 do done <- easyCreatePartialsPristineDirectoryTree prefs pris dir 987 unless done $ withRecorded r (withTempDir "recorded") $ \_ -> do 988 clonePartialsTree "." dir (map toFilePath prefs) 989 990 pristineFromWorking :: RepoPatch p => Repository p C(r u t) -> IO () 991 pristineFromWorking (Repo dir opts rf (DarcsRepository _ c)) 992 | format_has HashedInventory rf = 993 withCurrentDirectory dir $ HashedRepo.pristine_from_working c (compression opts) 994 pristineFromWorking (Repo dir _ _ (DarcsRepository p _)) = 995 withCurrentDirectory dir $ createPristineFromWorking p 996 997 withRecorded :: RepoPatch p => Repository p C(r u t) 998 -> ((AbsolutePath -> IO a) -> IO a) -> (AbsolutePath -> IO a) -> IO a 999 withRecorded repository mk_dir f 1000 = mk_dir $ \d -> do createPristineDirectoryTree repository (toFilePath d) 1001 f d 1002 1003 checkPristineAgainstSlurpy :: RepoPatch p => Repository p C(r u t) -> Slurpy -> IO Bool 1004 checkPristineAgainstSlurpy repository@(Repo _ opts _ _) s2 = 1005 do s1 <- slurp_recorded repository 1006 ftf <- filetype_function 1007 -- The @$!@ is necessary because some code called from this function uses 1008 -- unsafeInterleaveIO around functions that throw exceptions. If one used 1009 -- @$@ instead of @$!@ here, those exceptions might not be caught by code 1010 -- that runs this function inside a @catch@. 1011 return $! nullFL $ unsafeDiff (LookForAdds:IgnoreTimes:opts) ftf s1 s2 1012 1013 withTentative :: forall p a C(r u t). RepoPatch p => 1014 Repository p C(r u t) -> ((AbsolutePath -> IO a) -> IO a) 1015 -> (AbsolutePath -> IO a) -> IO a 1016 withTentative (Repo dir opts rf (DarcsRepository _ c)) mk_dir f 1017 | format_has HashedInventory rf = 1018 mk_dir $ \d -> do HashedRepo.copy_pristine c (compression opts) dir (darcsdir++"/tentative_pristine") 1019 f d 1020 withTentative repository@(Repo dir opts _ _) mk_dir f = 1021 withRecorded repository mk_dir $ \d -> 1022 do Sealed ps <- read_patches (dir ++ "/"++darcsdir++"/tentative_pristine") 1023 apply opts $ joinPatches ps 1024 f d 1025 where read_patches :: FilePath -> IO (Sealed (FL p C(x))) 1026 read_patches fil = do ps <- B.readFile fil 1027 return $ case readPatch ps of 1028 Just (x, _) -> x 1029 Nothing -> seal NilFL 1030 1031 getMarkedupFile :: RepoPatch p => Repository p C(r u t) -> PatchInfo -> FilePath -> IO MarkedUpFile 1032 getMarkedupFile repository pinfo f = do 1033 Sealed (FlippedSeal patches) <- (seal . dropWhileFL ((/= pinfo) . info) 1034 . reverseRL . concatRL) `liftM` read_repo repository 1035 return $ snd $ do_mark_all patches (f, empty_markedup_file) 1036 where dropWhileFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(r v) -> FlippedSeal (FL a) C(v) 1037 dropWhileFL _ NilFL = flipSeal NilFL 1038 dropWhileFL p xs@(x:>:xs') 1039 | p x = dropWhileFL p xs' 1040 | otherwise = flipSeal xs 1041 do_mark_all :: RepoPatch p => FL (PatchInfoAnd p) C(x y) 1042 -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile) 1043 do_mark_all (hp:>:pps) (f, mk) = 1044 case hopefullyM hp of 1045 Just p -> do_mark_all pps $ markup_file (info hp) (patchcontents p) (f, mk) 1046 Nothing -> (f, [(BC.pack "Error reading a patch!",None)]) 1047 do_mark_all NilFL (f, mk) = (f, mk) 1048 1049 -- | Sets scripts in or below the current directory executable. A script is any file that starts 1050 -- with the bytes '#!'. This is used sometimes for --set-scripts-executable, but at other times 1051 -- --set-scripts-executable is handled by the hunk patch case of applyFL. 1052 setScriptsExecutable :: IO () 1053 setScriptsExecutable = do 1054 debugMessage "Making scripts executable" 1055 myname <- getCurrentDirectory 1056 c <- list_slurpy_files `fmap` (HashedRepo.slurp_all_but_darcs myname) 1057 let setExecutableIfScript f = 1058 do contents <- B.readFile f 1059 when (BC.pack "#!" `B.isPrefixOf` contents) $ do 1060 debugMessage ("Making executable: " ++ f) 1061 setExecutable f True 1062 mapM_ setExecutableIfScript c