1-- Copyright (C) 2006-2007 David Roundy 2-- 3-- This program is free software; you can redistribute it and/or modify 4-- it under the terms of the GNU General Public License as published by 5-- the Free Software Foundation; either version 2, or (at your option) 6-- any later version. 7-- 8-- This program is distributed in the hope that it will be useful, 9-- but WITHOUT ANY WARRANTY; without even the implied warranty of 10-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11-- GNU General Public License for more details. 12-- 13-- You should have received a copy of the GNU General Public License 14-- along with this program; if not, write to the Free Software Foundation, 15-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 16{-# LANGUAGE OverloadedStrings #-} 17module Darcs.Repository.Hashed 18 ( revertTentativeChanges 19 , revertRepositoryChanges 20 , finalizeTentativeChanges 21 , addToTentativeInventory 22 , readRepo 23 , readRepoHashed 24 , readTentativeRepo 25 , writeAndReadPatch 26 , writeTentativeInventory 27 , copyHashedInventory 28 , writePatchIfNecessary 29 , tentativelyAddPatch 30 , tentativelyRemovePatches 31 , tentativelyRemovePatches_ 32 , tentativelyAddPatch_ 33 , tentativelyAddPatches_ 34 , finalizeRepositoryChanges 35 , reorderInventory 36 , UpdatePristine(..) 37 , repoXor 38 , upgradeOldStyleRebase 39 ) where 40 41import Darcs.Prelude 42 43import Control.Exception ( catch ) 44import Darcs.Util.Exception ( catchall ) 45import Control.Monad ( when, unless ) 46import Data.Maybe 47import Data.List( foldl' ) 48 49import qualified Data.ByteString as B ( empty, readFile, append ) 50import qualified Data.ByteString.Char8 as BC ( pack ) 51 52import Darcs.Util.Hash( SHA1, sha1Xor, sha1zero ) 53import Darcs.Util.Prompt ( promptYorn ) 54import Darcs.Util.Tree ( Tree ) 55import Darcs.Util.SignalHandler ( withSignalsBlocked ) 56 57import System.Directory 58 ( copyFile 59 , createDirectoryIfMissing 60 , doesFileExist 61 , removeFile 62 , renameFile 63 ) 64import System.FilePath.Posix( (</>) ) 65import System.IO.Unsafe ( unsafeInterleaveIO ) 66import System.IO ( IOMode(..), hClose, hPutStrLn, openBinaryFile, stderr ) 67import System.IO.Error ( catchIOError, isDoesNotExistError ) 68 69import Darcs.Util.External 70 ( copyFileOrUrl 71 , cloneFile 72 , gzFetchFilePS 73 , Cachable( Uncachable ) 74 ) 75import Darcs.Repository.Flags 76 ( Compression 77 , RemoteDarcs 78 , UpdatePending(..) 79 , Verbosity(..) 80 , remoteDarcs 81 ) 82 83import Darcs.Repository.Format 84 ( RepoProperty( HashedInventory, RebaseInProgress, RebaseInProgress_2_16 ) 85 , formatHas 86 , writeRepoFormat 87 , addToFormat 88 , removeFromFormat 89 ) 90import Darcs.Repository.Pending 91 ( tentativelyRemoveFromPending 92 , revertPending 93 , finalizePending 94 , readTentativePending 95 , writeTentativePending 96 ) 97import Darcs.Repository.PatchIndex 98 ( createOrUpdatePatchIndexDisk 99 , doesPatchIndexExist 100 ) 101import Darcs.Repository.Pristine 102 ( ApplyDir(..) 103 , applyToTentativePristine 104 , applyToTentativePristineCwd 105 ) 106import Darcs.Repository.Paths 107import Darcs.Repository.Rebase 108 ( withTentativeRebase 109 , createTentativeRebase 110 , readTentativeRebase 111 , writeTentativeRebase 112 , commuteOutOldStyleRebase 113 ) 114import Darcs.Repository.State ( readRecorded, updateIndex ) 115 116import Darcs.Util.Global ( darcsdir ) 117import Darcs.Util.Lock 118 ( writeBinFile 119 , writeDocBinFile 120 , writeAtomicFilePS 121 , appendDocBinFile 122 , removeFileMayNotExist 123 ) 124import Darcs.Patch.Set ( PatchSet(..), Tagged(..) 125 , SealedPatchSet, Origin 126 , patchSet2RL 127 ) 128 129import Darcs.Patch.Show ( ShowPatchFor(..) ) 130import qualified Darcs.Patch.Named.Wrapped as W 131import Darcs.Patch.PatchInfoAnd 132 ( PatchInfoAnd, PatchInfoAndG, Hopefully, patchInfoAndPatch, info 133 , extractHash, createHashed, hopefully 134 , fmapPIAP 135 ) 136import Darcs.Patch ( IsRepoType, RepoPatch, showPatch 137 , commuteRL 138 , readPatch 139 , effect 140 , displayPatch 141 ) 142 143import Darcs.Patch.Apply ( Apply(..) ) 144import Darcs.Patch.Format ( PatchListFormat ) 145import Darcs.Patch.Bundle ( Bundle(..), makeBundle, interpretBundle, parseBundle ) 146import Darcs.Patch.Read ( ReadPatch ) 147import Darcs.Patch.Depends ( removeFromPatchSet, slightlyOptimizePatchset 148 , mergeThem, cleanLatestTag ) 149import Darcs.Patch.Info 150 ( PatchInfo, displayPatchInfo, makePatchname ) 151import Darcs.Patch.Rebase.Suspended 152 ( Suspended(..), addFixupsToSuspended, removeFixupsFromSuspended ) 153 154import Darcs.Util.Path ( ioAbsoluteOrRemote, toPath ) 155import Darcs.Repository.Cache 156 ( Cache 157 , HashedDir(..) 158 , fetchFileUsingCache 159 , hashedDir 160 , peekInCache 161 , speculateFilesUsingCache 162 , writeFileUsingCache 163 ) 164import Darcs.Repository.Inventory 165import Darcs.Repository.InternalTypes 166 ( Repository 167 , repoCache 168 , repoFormat 169 , repoLocation 170 , withRepoLocation 171 , unsafeCoerceR 172 , unsafeCoerceT 173 ) 174import qualified Darcs.Repository.Old as Old ( readOldRepo, oldRepoFailMsg ) 175import Darcs.Patch.Witnesses.Ordered 176 ( (+<+), FL(..), RL(..), mapRL, foldFL_M, foldrwFL, mapRL_RL 177 , (:>)(..), lengthFL, (+>+) 178 , reverseFL ) 179import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal, unseal, mapSeal ) 180import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) 181 182import Darcs.Util.ByteString ( gzReadFilePS ) 183import Darcs.Util.Printer.Color ( debugDoc, ePutDocLn ) 184import Darcs.Util.Printer 185 ( Doc 186 , ($$) 187 , (<+>) 188 , hcat 189 , renderPS 190 , renderString 191 , text 192 ) 193import Darcs.Util.Progress ( beginTedious, endTedious, debugMessage, finishedOneIO ) 194import Darcs.Patch.Progress (progressFL) 195 196 197-- |revertTentativeChanges swaps the tentative and "real" hashed inventory 198-- files, and then updates the tentative pristine with the "real" inventory 199-- hash. 200revertTentativeChanges :: IO () 201revertTentativeChanges = do 202 cloneFile hashedInventoryPath tentativeHashedInventoryPath 203 i <- gzReadFilePS hashedInventoryPath 204 writeBinFile tentativePristinePath $ 205 B.append pristineName $ BC.pack $ getValidHash $ peekPristineHash i 206 207-- |finalizeTentativeChanges trys to atomically swap the tentative 208-- inventory/pristine pointers with the "real" pointers; it first re-reads the 209-- inventory to optimize it, presumably to take account of any new tags, and 210-- then writes out the new tentative inventory, and finally does the atomic 211-- swap. In general, we can't clean the pristine cache at the same time, since 212-- a simultaneous get might be in progress. 213finalizeTentativeChanges :: (IsRepoType rt, RepoPatch p) 214 => Repository rt p wR wU wT -> Compression -> IO () 215finalizeTentativeChanges r compr = do 216 debugMessage "Optimizing the inventory..." 217 -- Read the tentative patches 218 ps <- readTentativeRepo r "." 219 writeTentativeInventory (repoCache r) compr ps 220 i <- gzReadFilePS tentativeHashedInventoryPath 221 p <- gzReadFilePS tentativePristinePath 222 -- Write out the "optimised" tentative inventory. 223 writeDocBinFile tentativeHashedInventoryPath $ pokePristineHash (peekPristineHash p) i 224 -- Atomically swap. 225 renameFile tentativeHashedInventoryPath hashedInventoryPath 226 227-- | Add (append) a patch to a specific inventory file. 228-- | Warning: this allows to add any arbitrary patch! 229addToSpecificInventory :: RepoPatch p => String -> Cache -> Compression 230 -> PatchInfoAnd rt p wX wY -> IO () 231addToSpecificInventory invPath c compr p = do 232 let invFile = makeDarcsdirPath invPath 233 hash <- snd <$> writePatchIfNecessary c compr p 234 appendDocBinFile invFile $ showInventoryEntry (info p, hash) 235 236-- | Add (append) a patch to the tentative inventory. 237-- | Warning: this allows to add any arbitrary patch! Used by convert import. 238addToTentativeInventory :: RepoPatch p => Cache -> Compression 239 -> PatchInfoAnd rt p wX wY -> IO () 240addToTentativeInventory = addToSpecificInventory tentativeHashedInventory 241 242-- |writeHashFile takes a Doc and writes it as a hash-named file, returning the 243-- filename that the contents were written to. 244writeHashFile :: Cache -> Compression -> HashedDir -> Doc -> IO String 245writeHashFile c compr subdir d = do 246 debugMessage $ "Writing hash file to " ++ hashedDir subdir 247 writeFileUsingCache c compr subdir $ renderPS d 248 249-- |readRepo returns the "current" repo patchset. 250readRepoHashed :: (IsRepoType rt, RepoPatch p) => Repository rt p wR wU wT 251 -> String -> IO (PatchSet rt p Origin wR) 252readRepoHashed = readRepoUsingSpecificInventory hashedInventory 253 254-- |readRepo returns the tentative repo patchset. 255readTentativeRepo :: (IsRepoType rt, PatchListFormat p, ReadPatch p) 256 => Repository rt p wR wU wT -> String 257 -> IO (PatchSet rt p Origin wT) 258readTentativeRepo = readRepoUsingSpecificInventory tentativeHashedInventory 259 260-- |readRepoUsingSpecificInventory uses the inventory at @invPath@ to read the 261-- repository @repo@. 262readRepoUsingSpecificInventory :: (IsRepoType rt, PatchListFormat p, ReadPatch p) 263 => String -> Repository rt p wR wU wT 264 -> String -> IO (PatchSet rt p Origin wS) 265readRepoUsingSpecificInventory invPath repo dir = do 266 realdir <- toPath <$> ioAbsoluteOrRemote dir 267 Sealed ps <- readRepoPrivate (repoCache repo) realdir invPath 268 `catch` \e -> do 269 hPutStrLn stderr ("Invalid repository: " ++ realdir) 270 ioError e 271 return $ unsafeCoerceP ps 272 where 273 readRepoPrivate :: (IsRepoType rt, PatchListFormat p, ReadPatch p) 274 => Cache -> FilePath 275 -> FilePath -> IO (SealedPatchSet rt p Origin) 276 readRepoPrivate cache d iname = do 277 inventory <- readInventoryPrivate (d </> darcsdir </> iname) 278 readRepoFromInventoryList cache inventory 279 280-- | Read a 'PatchSet' from the repository (assumed to be located at the 281-- current working directory) by following the chain of 'Inventory's, starting 282-- with the given one. The 'Cache' parameter is used to locate patches and parent 283-- inventories, since not all of them need be present inside the current repo. 284readRepoFromInventoryList 285 :: (IsRepoType rt, PatchListFormat p, ReadPatch p) 286 => Cache 287 -> Inventory 288 -> IO (SealedPatchSet rt p Origin) 289readRepoFromInventoryList cache = parseInv 290 where 291 parseInv :: (IsRepoType rt, PatchListFormat p, ReadPatch p) 292 => Inventory 293 -> IO (SealedPatchSet rt p Origin) 294 parseInv (Inventory Nothing ris) = 295 mapSeal (PatchSet NilRL) <$> readPatchesFromInventory cache ris 296 parseInv (Inventory (Just h) []) = 297 -- TODO could be more tolerant and create a larger PatchSet 298 error $ "bad inventory " ++ getValidHash h ++ " (no tag) in parseInv!" 299 parseInv (Inventory (Just h) (t : ris)) = do 300 Sealed ts <- unseal seal <$> unsafeInterleaveIO (read_ts t h) 301 Sealed ps <- unseal seal <$> 302 unsafeInterleaveIO (readPatchesFromInventory cache ris) 303 return $ seal $ PatchSet ts ps 304 305 read_ts :: (IsRepoType rt, PatchListFormat p, ReadPatch p) => InventoryEntry 306 -> InventoryHash -> IO (Sealed (RL (Tagged rt p) Origin)) 307 read_ts tag0 h0 = do 308 contents <- unsafeInterleaveIO $ readTaggedInventory h0 309 let is = case contents of 310 (Inventory (Just _) (_ : ris0)) -> ris0 311 (Inventory Nothing ris0) -> ris0 312 (Inventory (Just _) []) -> error "inventory without tag!" 313 Sealed ts <- unseal seal <$> 314 unsafeInterleaveIO 315 (case contents of 316 (Inventory (Just h') (t' : _)) -> read_ts t' h' 317 (Inventory (Just _) []) -> error "inventory without tag!" 318 (Inventory Nothing _) -> return $ seal NilRL) 319 Sealed ps <- unseal seal <$> 320 unsafeInterleaveIO (readPatchesFromInventory cache is) 321 Sealed tag00 <- read_tag tag0 322 return $ seal $ ts :<: Tagged tag00 (Just (getValidHash h0)) ps 323 324 read_tag :: (PatchListFormat p, ReadPatch p) => InventoryEntry 325 -> IO (Sealed (PatchInfoAnd rt p wX)) 326 read_tag (i, h) = 327 mapSeal (patchInfoAndPatch i) <$> createValidHashed h (readSinglePatch cache i) 328 329 readTaggedInventory :: InventoryHash -> IO Inventory 330 readTaggedInventory invHash = do 331 (fileName, pristineAndInventory) <- 332 fetchFileUsingCache cache HashedInventoriesDir (getValidHash invHash) 333 case parseInventory pristineAndInventory of 334 Right r -> return r 335 Left e -> fail $ unlines [unwords ["parse error in file", fileName],e] 336 337readPatchesFromInventory :: ReadPatch np 338 => Cache 339 -> [InventoryEntry] 340 -> IO (Sealed (RL (PatchInfoAndG rt np) wX)) 341readPatchesFromInventory cache ris = read_patches (reverse ris) 342 where 343 read_patches [] = return $ seal NilRL 344 read_patches allis@((i1, h1) : is1) = 345 lift2Sealed (\p rest -> rest :<: i1 `patchInfoAndPatch` p) (rp is1) 346 (createValidHashed h1 (const $ speculateAndParse h1 allis i1)) 347 where 348 rp [] = return $ seal NilRL 349 rp [(i, h), (il, hl)] = 350 lift2Sealed (\p rest -> rest :<: i `patchInfoAndPatch` p) 351 (rp [(il, hl)]) 352 (createValidHashed h 353 (const $ speculateAndParse h (reverse allis) i)) 354 rp ((i, h) : is) = 355 lift2Sealed (\p rest -> rest :<: i `patchInfoAndPatch` p) 356 (rp is) 357 (createValidHashed h (readSinglePatch cache i)) 358 359 lift2Sealed :: (forall wY wZ . q wY wZ -> p wX wY -> r wX wZ) 360 -> IO (Sealed (p wX)) 361 -> (forall wB . IO (Sealed (q wB))) 362 -> IO (Sealed (r wX)) 363 lift2Sealed f iox ioy = do 364 Sealed x <- unseal seal <$> unsafeInterleaveIO iox 365 Sealed y <- unseal seal <$> unsafeInterleaveIO ioy 366 return $ seal $ f y x 367 368 speculateAndParse h is i = speculate h is >> readSinglePatch cache i h 369 370 speculate :: PatchHash -> [InventoryEntry] -> IO () 371 speculate pHash is = do 372 already_got_one <- peekInCache cache HashedPatchesDir (getValidHash pHash) 373 unless already_got_one $ 374 speculateFilesUsingCache cache HashedPatchesDir (map (getValidHash . snd) is) 375 376readSinglePatch :: ReadPatch p 377 => Cache 378 -> PatchInfo -> PatchHash -> IO (Sealed (p wX)) 379readSinglePatch cache i h = do 380 debugDoc $ text "Reading patch file:" <+> displayPatchInfo i 381 (fn, ps) <- fetchFileUsingCache cache HashedPatchesDir (getValidHash h) 382 case readPatch ps of 383 Right p -> return p 384 Left e -> fail $ unlines 385 [ "Couldn't parse file " ++ fn 386 , "which is patch" 387 , renderString $ displayPatchInfo i 388 , e 389 ] 390 391-- | Read an inventory from a file. Fails with an error message if 392-- file is not there or cannot be parsed. 393readInventoryPrivate :: FilePath -> IO Inventory 394readInventoryPrivate path = do 395 inv <- skipPristineHash <$> gzFetchFilePS path Uncachable 396 case parseInventory inv of 397 Right r -> return r 398 Left e -> fail $ unlines [unwords ["parse error in file", path],e] 399 400-- |Copy the hashed inventory from the given location to the given repository, 401-- possibly using the given remote darcs binary. 402copyHashedInventory :: Repository rt p wR wU wT -> RemoteDarcs -> String -> IO () 403copyHashedInventory outrepo rdarcs inloc | remote <- remoteDarcs rdarcs = do 404 let outloc = repoLocation outrepo 405 createDirectoryIfMissing False (outloc ++ "/" ++ inventoriesDirPath) 406 copyFileOrUrl remote (inloc </> hashedInventoryPath) 407 (outloc </> hashedInventoryPath) 408 Uncachable -- no need to copy anything but hashed_inventory! 409 debugMessage "Done copying hashed inventory." 410 411-- |writeAndReadPatch makes a patch lazy, by writing it out to disk (thus 412-- forcing it), and then re-reads the patch lazily. 413writeAndReadPatch :: RepoPatch p => Cache -> Compression 414 -> PatchInfoAnd rt p wX wY -> IO (PatchInfoAnd rt p wX wY) 415writeAndReadPatch c compr p = do 416 (i, h) <- writePatchIfNecessary c compr p 417 unsafeInterleaveIO $ readp h i 418 where 419 parse i h = do 420 debugDoc $ text "Rereading patch file:" <+> displayPatchInfo i 421 (fn, ps) <- fetchFileUsingCache c HashedPatchesDir (getValidHash h) 422 case readPatch ps of 423 Right x -> return x 424 Left e -> fail $ unlines 425 [ "Couldn't parse patch file " ++ fn 426 , "which is" 427 , renderString $ displayPatchInfo i 428 , e 429 ] 430 431 readp h i = do Sealed x <- createValidHashed h (parse i) 432 return . patchInfoAndPatch i $ unsafeCoerceP x 433 434createValidHashed :: PatchHash 435 -> (PatchHash -> IO (Sealed (a wX))) 436 -> IO (Sealed (Darcs.Patch.PatchInfoAnd.Hopefully a wX)) 437createValidHashed h f = createHashed (getValidHash h) (f . mkValidHash) 438 439-- | writeTentativeInventory writes @patchSet@ as the tentative inventory. 440writeTentativeInventory :: RepoPatch p => Cache -> Compression 441 -> PatchSet rt p Origin wX -> IO () 442writeTentativeInventory cache compr patchSet = do 443 debugMessage "in writeTentativeInventory..." 444 createDirectoryIfMissing False inventoriesDirPath 445 beginTedious tediousName 446 hsh <- writeInventoryPrivate $ slightlyOptimizePatchset patchSet 447 endTedious tediousName 448 debugMessage "still in writeTentativeInventory..." 449 case hsh of 450 Nothing -> writeBinFile (makeDarcsdirPath tentativeHashedInventory) B.empty 451 Just h -> do 452 content <- snd <$> fetchFileUsingCache cache HashedInventoriesDir h 453 writeAtomicFilePS (makeDarcsdirPath tentativeHashedInventory) content 454 where 455 tediousName = "Writing inventory" 456 writeInventoryPrivate :: RepoPatch p => PatchSet rt p Origin wX 457 -> IO (Maybe String) 458 writeInventoryPrivate (PatchSet NilRL NilRL) = return Nothing 459 writeInventoryPrivate (PatchSet NilRL ps) = do 460 inventory <- sequence $ mapRL (writePatchIfNecessary cache compr) ps 461 let inventorylist = showInventoryPatches (reverse inventory) 462 hash <- writeHashFile cache compr HashedInventoriesDir inventorylist 463 return $ Just hash 464 writeInventoryPrivate 465 (PatchSet xs@(_ :<: Tagged t _ _) x) = do 466 resthash <- write_ts xs 467 finishedOneIO tediousName $ fromMaybe "" resthash 468 inventory <- sequence $ mapRL (writePatchIfNecessary cache compr) 469 (NilRL :<: t +<+ x) 470 let inventorylist = hcat (map showInventoryEntry $ reverse inventory) 471 inventorycontents = 472 case resthash of 473 Just h -> text ("Starting with inventory:\n" ++ h) $$ 474 inventorylist 475 Nothing -> inventorylist 476 hash <- writeHashFile cache compr HashedInventoriesDir inventorycontents 477 return $ Just hash 478 where 479 -- | write_ts writes out a tagged patchset. If it has already been 480 -- written, we'll have the hash, so we can immediately return it. 481 write_ts :: RepoPatch p => RL (Tagged rt p) Origin wX 482 -> IO (Maybe String) 483 write_ts (_ :<: Tagged _ (Just h) _) = return (Just h) 484 write_ts (tts :<: Tagged _ Nothing pps) = 485 writeInventoryPrivate $ PatchSet tts pps 486 write_ts NilRL = return Nothing 487 488-- |writeHashIfNecessary writes the patch and returns the resulting info/hash, 489-- if it has not already been written. If it has been written, we have the hash 490-- in the PatchInfoAnd, so we extract and return the info/hash. 491writePatchIfNecessary :: RepoPatch p => Cache -> Compression 492 -> PatchInfoAnd rt p wX wY -> IO InventoryEntry 493writePatchIfNecessary c compr hp = infohp `seq` 494 case extractHash hp of 495 Right h -> return (infohp, mkValidHash h) 496 Left p -> do 497 h <- writeHashFile c compr HashedPatchesDir (showPatch ForStorage p) 498 return (infohp, mkValidHash h) 499 where 500 infohp = info hp 501 502tentativelyAddPatch :: (RepoPatch p, ApplyState p ~ Tree) 503 => Repository rt p wR wU wT 504 -> Compression 505 -> Verbosity 506 -> UpdatePending 507 -> PatchInfoAnd rt p wT wY 508 -> IO (Repository rt p wR wU wY) 509tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine 510 511data UpdatePristine = UpdatePristine 512 | DontUpdatePristine 513 | DontUpdatePristineNorRevert deriving Eq 514 515tentativelyAddPatches_ :: (RepoPatch p, ApplyState p ~ Tree) 516 => UpdatePristine 517 -> Repository rt p wR wU wT 518 -> Compression 519 -> Verbosity 520 -> UpdatePending 521 -> FL (PatchInfoAnd rt p) wT wY 522 -> IO (Repository rt p wR wU wY) 523tentativelyAddPatches_ upr r c v upe ps = 524 foldFL_M (\r' p -> tentativelyAddPatch_ upr r' c v upe p) r ps 525 526tentativelyAddPatch_ :: (RepoPatch p, ApplyState p ~ Tree) 527 => UpdatePristine 528 -> Repository rt p wR wU wT 529 -> Compression 530 -> Verbosity 531 -> UpdatePending 532 -> PatchInfoAnd rt p wT wY 533 -> IO (Repository rt p wR wU wY) 534tentativelyAddPatch_ upr r compr verb upe p = do 535 let r' = unsafeCoerceT r 536 withTentativeRebase r r' (removeFixupsFromSuspended $ hopefully p) 537 withRepoLocation r $ do 538 addToTentativeInventory (repoCache r) compr p 539 when (upr == UpdatePristine) $ do 540 debugMessage "Applying to pristine cache..." 541 applyToTentativePristine r ApplyNormal verb p 542 when (upe == YesUpdatePending) $ do 543 debugMessage "Updating pending..." 544 tentativelyRemoveFromPending r' (effect p) 545 return r' 546 547tentativelyRemovePatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) 548 => Repository rt p wR wU wT 549 -> Compression 550 -> UpdatePending 551 -> FL (PatchInfoAnd rt p) wX wT 552 -> IO (Repository rt p wR wU wX) 553tentativelyRemovePatches = tentativelyRemovePatches_ UpdatePristine 554 555newtype Dup p wX = Dup { unDup :: p wX wX } 556 557foldrwFL' :: (forall wA wB. p wA wB -> s wB wB -> s wA wA) 558 -> FL p wX wY -> s wY wY -> s wX wX 559foldrwFL' f ps = unDup . foldrwFL (\p -> (Dup . f p . unDup)) ps . Dup 560 561tentativelyRemovePatches_ :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) 562 => UpdatePristine 563 -> Repository rt p wR wU wT 564 -> Compression 565 -> UpdatePending 566 -> FL (PatchInfoAnd rt p) wX wT 567 -> IO (Repository rt p wR wU wX) 568tentativelyRemovePatches_ upr r compr upe ps 569 | formatHas HashedInventory (repoFormat r) = do 570 withRepoLocation r $ do 571 unless (upr == DontUpdatePristineNorRevert) $ removeFromUnrevertContext r ps 572 Sealed pend <- readTentativePending r 573 debugMessage "Removing changes from tentative inventory..." 574 r' <- removeFromTentativeInventory r compr ps 575 withTentativeRebase r r' 576 (foldrwFL' (addFixupsToSuspended . hopefully) ps) 577 when (upr == UpdatePristine) $ 578 applyToTentativePristineCwd ApplyInverted $ 579 progressFL "Applying inverse to pristine" ps 580 when (upe == YesUpdatePending) $ do 581 debugMessage "Adding changes to pending..." 582 writeTentativePending r' $ effect ps +>+ pend 583 return r' 584 | otherwise = fail Old.oldRepoFailMsg 585 586-- | Attempt to remove an FL of patches from the tentative inventory. 587-- 588-- Precondition: it must be possible to remove the patches, i.e. 589-- 590-- * the patches are in the repository 591-- 592-- * any necessary commutations will succeed 593removeFromTentativeInventory :: forall rt p wR wU wT wX. (IsRepoType rt, RepoPatch p) 594 => Repository rt p wR wU wT 595 -> Compression 596 -> FL (PatchInfoAnd rt p) wX wT 597 -> IO (Repository rt p wR wU wX) 598removeFromTentativeInventory repo compr to_remove = do 599 debugMessage $ "Start removeFromTentativeInventory" 600 allpatches :: PatchSet rt p Origin wT <- readTentativeRepo repo "." 601 remaining :: PatchSet rt p Origin wX <- 602 case removeFromPatchSet to_remove allpatches of 603 Nothing -> error "Hashed.removeFromTentativeInventory: precondition violated" 604 Just r -> return r 605 writeTentativeInventory (repoCache repo) compr remaining 606 debugMessage $ "Done removeFromTentativeInventory" 607 return (unsafeCoerceT repo) 608 609-- | Atomically copy the tentative state to the recorded state, 610-- thereby committing the tentative changes that were made so far. 611-- This includes inventories, pending, and the index. 612finalizeRepositoryChanges :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) 613 => Repository rt p wR wU wT 614 -> UpdatePending 615 -> Compression 616 -> IO (Repository rt p wT wU wT) 617finalizeRepositoryChanges r updatePending compr 618 | formatHas HashedInventory (repoFormat r) = 619 withRepoLocation r $ do 620 debugMessage "Finalizing changes..." 621 withSignalsBlocked $ do 622 renameFile tentativeRebasePath rebasePath 623 finalizeTentativeChanges r compr 624 recordedState <- readRecorded r 625 finalizePending r updatePending recordedState 626 let r' = unsafeCoerceR r 627 debugMessage "Done finalizing changes..." 628 ps <- readRepo r' 629 pi_exists <- doesPatchIndexExist (repoLocation r') 630 when pi_exists $ 631 createOrUpdatePatchIndexDisk r' ps 632 `catchIOError` \e -> 633 hPutStrLn stderr $ "Cannot create or update patch index: "++ show e 634 updateIndex r' 635 return r' 636 | otherwise = fail Old.oldRepoFailMsg 637 638-- TODO: rename this and document the transaction protocol (revert/finalize) 639-- clearly. 640-- |Slightly confusingly named: as well as throwing away any tentative 641-- changes, revertRepositoryChanges also re-initialises the tentative state. 642-- It's therefore used before makign any changes to the repo. 643revertRepositoryChanges :: RepoPatch p 644 => Repository rt p wR wU wT 645 -> UpdatePending 646 -> IO (Repository rt p wR wU wR) 647revertRepositoryChanges r upe 648 | formatHas HashedInventory (repoFormat r) = 649 withRepoLocation r $ do 650 checkIndexIsWritable 651 `catchIOError` \e -> fail (unlines ["Cannot write index", show e]) 652 revertPending r upe 653 revertTentativeChanges 654 let r' = unsafeCoerceT r 655 revertTentativeRebase r' 656 return r' 657 | otherwise = fail Old.oldRepoFailMsg 658 659revertTentativeRebase :: RepoPatch p => Repository rt p wR wU wR -> IO () 660revertTentativeRebase repo = 661 copyFile rebasePath tentativeRebasePath 662 `catchIOError` \e -> 663 if isDoesNotExistError e then 664 createTentativeRebase repo 665 else 666 fail $ show e 667 668checkIndexIsWritable :: IO () 669checkIndexIsWritable = do 670 checkWritable indexInvalidPath 671 checkWritable indexPath 672 where 673 checkWritable path = do 674 exists <- doesFileExist path 675 touchFile path 676 unless exists $ removeFile path 677 touchFile path = openBinaryFile path AppendMode >>= hClose 678 679removeFromUnrevertContext :: forall rt p wR wU wT wX 680 . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) 681 => Repository rt p wR wU wT 682 -> FL (PatchInfoAnd rt p) wX wT 683 -> IO () 684removeFromUnrevertContext _ NilFL = return () -- nothing to do 685removeFromUnrevertContext r ps = do 686 Sealed bundle <- unrevert_patch_bundle `catchall` return (seal (Bundle (NilFL :> NilFL))) 687 remove_from_unrevert_context_ bundle 688 where unrevert_impossible = 689 do confirmed <- promptYorn "This operation will make unrevert impossible!\nProceed?" 690 if confirmed then removeFileMayNotExist unrevertPath 691 else fail "Cancelled." 692 unrevert_patch_bundle :: IO (Sealed (Bundle rt p wB)) 693 unrevert_patch_bundle = do pf <- B.readFile unrevertPath 694 case parseBundle pf of 695 Right foo -> return foo 696 Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err 697 remove_from_unrevert_context_ :: Bundle rt p wA wB -> IO () 698 remove_from_unrevert_context_ bundle = 699 do debugMessage "Adjusting the context of the unrevert changes..." 700 debugMessage $ "Removing "++ show (lengthFL ps) ++ 701 " patches in removeFromUnrevertContext!" 702 ref <- readTentativeRepo r (repoLocation r) 703 let withSinglet :: Sealed (FL ppp wXxx) 704 -> (forall wYyy . ppp wXxx wYyy -> IO ()) -> IO () 705 withSinglet (Sealed (x :>: NilFL)) j = j x 706 withSinglet _ _ = return () 707 Sealed bundle_ps <- bundle_to_patchset ref bundle 708 withSinglet (mergeThem ref bundle_ps) $ \h_us -> 709 case commuteRL (reverseFL ps :> h_us) of 710 Nothing -> unrevert_impossible 711 Just (us' :> _) -> 712 case removeFromPatchSet ps ref of 713 Nothing -> unrevert_impossible 714 Just common -> 715 do debugMessage "Have now found the new context..." 716 bundle' <- makeBundle Nothing common (hopefully us':>:NilFL) 717 writeDocBinFile unrevertPath bundle' 718 debugMessage "Done adjusting the context of the unrevert changes!" 719 720 bundle_to_patchset :: PatchSet rt p Origin wT 721 -> Bundle rt p wA wB 722 -> IO (SealedPatchSet rt p Origin) 723 bundle_to_patchset ref bundle = 724 either fail (return . Sealed) $ interpretBundle ref bundle 725 726-- | Writes out a fresh copy of the inventory that minimizes the 727-- amount of inventory that need be downloaded when people pull from 728-- the repository. 729-- 730-- Specifically, it breaks up the inventory on the most recent tag. 731-- This speeds up most commands when run remotely, both because a 732-- smaller file needs to be transfered (only the most recent 733-- inventory). It also gives a guarantee that all the patches prior 734-- to a given tag are included in that tag, so less commutation and 735-- history traversal is needed. This latter issue can become very 736-- important in large repositories. 737reorderInventory :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) 738 => Repository rt p wR wU wR 739 -> Compression 740 -> IO () 741reorderInventory r compr 742 | formatHas HashedInventory (repoFormat r) = do 743 cleanLatestTag `fmap` readRepo r >>= 744 writeTentativeInventory (repoCache r) compr 745 withSignalsBlocked $ finalizeTentativeChanges r compr 746 | otherwise = fail Old.oldRepoFailMsg 747 748-- | Read inventories and patches from a repository and return them as a 749-- 'PatchSet'. Note that patches and inventories are read lazily. 750readRepo :: (IsRepoType rt, RepoPatch p) 751 => Repository rt p wR wU wT 752 -> IO (PatchSet rt p Origin wR) 753readRepo r 754 | formatHas HashedInventory (repoFormat r) = readRepoHashed r (repoLocation r) 755 | otherwise = do Sealed ps <- Old.readOldRepo (repoLocation r) 756 return $ unsafeCoerceP ps 757 758-- | XOR of all hashes of the patches' metadata. 759-- It enables to quickly see whether two repositories 760-- have the same patches, independently of their order. 761-- It relies on the assumption that the same patch cannot 762-- be present twice in a repository. 763-- This checksum is not cryptographically secure, 764-- see http://robotics.stanford.edu/~xb/crypto06b/ . 765repoXor :: (IsRepoType rt, RepoPatch p) 766 => Repository rt p wR wU wR -> IO SHA1 767repoXor repo = do 768 hashes <- mapRL (makePatchname . info) . patchSet2RL <$> readRepo repo 769 return $ foldl' sha1Xor sha1zero hashes 770 771-- | Upgrade a possible old-style rebase in progress to the new style. 772upgradeOldStyleRebase :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) 773 => Repository rt p wR wU wT -> Compression -> IO () 774upgradeOldStyleRebase repo compr = do 775 PatchSet ts _ <- readTentativeRepo repo (repoLocation repo) 776 Inventory _ invEntries <- readInventoryPrivate tentativeHashedInventoryPath 777 Sealed wps <- readPatchesFromInventory (repoCache repo) invEntries 778 case commuteOutOldStyleRebase wps of 779 Nothing -> 780 ePutDocLn $ text "Rebase is already in new style, no upgrade needed." 781 Just (wps' :> wr) -> do 782 -- FIXME inlining this action below where it is used 783 -- results in lots of ambiguous type variable errors 784 -- which is rather strange behavior of ghc IMHO 785 let update_repo = 786 -- low-level call, must not try to update an existing rebase patch, 787 -- nor update anything else beside the inventory 788 writeTentativeInventory 789 (repoCache repo) 790 compr 791 (PatchSet ts (mapRL_RL (fmapPIAP W.fromRebasing) wps')) 792 -- double check if we really have a rebase patch 793 case hopefully wr of 794 W.NormalP wtf -> 795 error $ renderString $ 796 "internal error: expected rebase patch but found normal patch:" 797 $$ displayPatch wtf 798 W.RebaseP _ r -> do 799 update_repo 800 Items old_r <- readTentativeRebase (unsafeCoerceT repo) 801 case old_r of 802 NilFL -> do 803 writeTentativeRebase (unsafeCoerceT repo) r 804 _ <- finalizeRepositoryChanges repo NoUpdatePending compr 805 writeRepoFormat 806 ( addToFormat RebaseInProgress_2_16 807 $ removeFromFormat RebaseInProgress 808 $ repoFormat repo) 809 formatPath 810 return () 811 _ -> do 812 ePutDocLn 813 $ "A new-style rebase is already in progress, not overwriting it." 814 $$ "This should not have happened! This is the old-style rebase I found" 815 $$ "and removed from the repository:" 816 $$ displayPatch wr 817