-- Copyright (C) 2002-2004,2007-2008 David Roundy -- Copyright (C) 2005 Juliusz Chroboczek -- -- This program is free software; you can redistribute it and/or modify -- it under the terms of the GNU General Public License as published by -- the Free Software Foundation; either version 2, or (at your option) -- any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -- GNU General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program; see the file COPYING. If not, write to -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. {-# OPTIONS_GHC -cpp -fglasgow-exts #-} {-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types, RankNTypes, PatternGuards #-} #include "gadts.h" module Darcs.Repository.Internal ( Repository(..), RepoType(..), RIO(unsafeUnRIO), ($-), maybeIdentifyRepository, identifyDarcs1Repository, identifyRepositoryFor, IdentifyRepo(..), findRepository, amInRepository, amNotInRepository, revertRepositoryChanges, announceMergeConflicts, setTentativePending, checkUnrecordedConflicts, withRecorded, readRepo, readTentativeRepo, prefsUrl, makePatchLazy, withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory, withGutsOf, tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending, tentativelyAddPatch_, tentativelyReplacePatches, finalizeRepositoryChanges, unrevertUrl, applyToWorking, patchSetToPatches, createPristineDirectoryTree, createPartialsPristineDirectoryTree, optimizeInventory, cleanRepository, getMarkedupFile, PatchSet, SealedPatchSet, setScriptsExecutable, getRepository, rIO, testTentative, testRecorded, UpdatePristine(..), MakeChanges(..), applyToTentativePristine, makeNewPending ) where import Printer ( putDocLn, (<+>), text, ($$) ) import Darcs.Repository.Prefs ( getPrefval ) import Darcs.Repository.State ( readRecorded, readWorking ) import Darcs.Repository.LowLevel ( readPending, pendingName, readPrims, readPendingfile ) import System.Exit ( ExitCode(..), exitWith ) import System.Cmd ( system ) import Darcs.External ( clonePartialsTree ) import Darcs.IO ( runTolerantly, runSilently ) import Darcs.Repository.Pristine ( identifyPristine, nopristine, easyCreatePristineDirectoryTree, easyCreatePartialsPristineDirectoryTree ) import Darcs.SignalHandler ( withSignalsBlocked ) import Darcs.Repository.Format ( RepoFormat, RepoProperty( Darcs2, HashedInventory ), identifyRepoFormat, formatHas, writeProblem, readProblem, readfromAndWritetoProblem ) import System.Directory ( doesDirectoryExist, setCurrentDirectory, createDirectoryIfMissing ) import Control.Monad ( liftM, when, unless ) import Workaround ( getCurrentDirectory, renameFile, setExecutable ) import ByteStringUtils ( gzReadFilePS ) import qualified Data.ByteString as B ( empty, readFile, isPrefixOf ) import qualified Data.ByteString.Char8 as BC (pack) import Darcs.Patch ( Patch, RealPatch, Effect, primIsHunk, primIsBinary, description, tryToShrink, commuteFLorComplain, commute ) import Darcs.Patch.Prim ( tryShrinkingInverse ) import Darcs.Patch.Bundle ( scanBundle, makeBundleN ) import Darcs.Hopefully ( PatchInfoAnd, info, hopefully, hopefullyM ) import Darcs.Repository.ApplyPatches ( applyPatches ) import qualified Darcs.Repository.HashedRepo as HashedRepo ( revertTentativeChanges, finalizeTentativeChanges, removeFromTentativeInventory, copyPristine, copyPartialsPristine, applyToTentativePristine, writeTentativeInventory, writeAndReadPatch, addToTentativeInventory, readRepo, readTentativeRepo, cleanPristine ) import qualified Darcs.Repository.DarcsRepo as DarcsRepo import Darcs.Flags ( DarcsFlag(Verbose, Quiet, MarkConflicts, AllowConflicts, NoUpdateWorking, WorkRepoUrl, WorkRepoDir, UMask, Test, LeaveTestDir, SetScriptsExecutable, DryRun ), wantExternalMerge, compression ) import Darcs.Witnesses.Ordered ( FL(..), RL(..), EqCheck(..), unsafeCoerceP, (:\/:)(..), (:/\:)(..), (:>)(..), (+>+), lengthFL, allFL, filterFLFL, reverseFL, mapFL_FL, concatFL ) import Darcs.Patch ( RepoPatch, Patchy, Prim, merge, joinPatches, listConflictedFiles, listTouchedFiles, Named, patchcontents, commuteRL, fromPrims, readPatch, writePatch, effect, invert, primIsAddfile, primIsAdddir, primIsSetpref, apply, applyToTree, emptyMarkedupFile, MarkedUpFile ) import Darcs.Patch.Permutations ( commuteWhatWeCanFL, removeFL ) import Darcs.Patch.Info ( PatchInfo ) import Darcs.Patch.Set ( PatchSet(..), SealedPatchSet, newset2FL ) #ifdef GADT_WITNESSES import Darcs.Patch.Set ( Origin ) #endif import Darcs.Patch.Apply ( markupFile, LineMark(None) ) import Darcs.Patch.Depends ( deepOptimizePatchset, removeFromPatchSet, mergeThem ) import Darcs.RepoPath ( FilePathLike, AbsolutePath, toFilePath, ioAbsoluteOrRemote, toPath ) import Darcs.Utils ( promptYorn, catchall, withCurrentDirectory, withUMask, nubsort ) import Progress ( debugMessage ) import Darcs.ProgressPatches (progressFL) import Darcs.URL ( isFile ) import Darcs.Repository.Prefs ( getCaches ) import Darcs.Lock ( withLock, writeDocBinFile, removeFileMayNotExist, withTempDir, withPermDir ) import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, FlippedSeal(FlippedSeal), flipSeal ) import Darcs.Repository.InternalTypes( Repository(..), RepoType(..) ) import Darcs.Global ( darcsdir ) import System.Mem( performGC ) import qualified Storage.Hashed.Tree as Tree import Storage.Hashed.AnchoredPath( anchorPath ) #include "impossible.h" -- | Repository IO monad. This monad-like datatype is responsible for -- sequencing IO actions that modify the tentative recorded state of -- the repository. newtype RIO p C(r u t t1) a = RIO { unsafeUnRIO :: Repository p C(r u t) -> IO a -- ^ converts @RIO a@ to @IO a@. } -- | This is just like @>>=@ from the Monad class except that it -- respects type witness safe repository transformations. Even so, it -- only tracks modifications to the tentative recorded state. (>>>=) :: 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 m >>>= k = RIO $ \ (Repo x y z w) -> do a <- unsafeUnRIO m (Repo x y z w) unsafeUnRIO (k a) (Repo x y z w) -- | This corresponds to @>>@ from the Monad class. (>>>) :: RIO p C(r u t t1) a -> RIO p C(r u t1 t2) b -> RIO p C(r u t t2) b a >>> b = a >>>= (const b) -- | This corresponds to @return@ from the Monad class. returnR :: a -> RIO p C(r u t t) a returnR = rIO . return -- | This the @RIO@ equivalent of @liftIO@. rIO :: IO a -> RIO p C(r u t t) a rIO = RIO . const instance Functor (RIO p C(r u t t)) where fmap f m = RIO $ \r -> fmap f (unsafeUnRIO m r) -- | We have an instance of Monad so that IO actions that do not -- change the tentative recorded state are convenient in the IO monad. instance Monad (RIO p C(r u t t)) where (>>=) = (>>>=) (>>) = (>>>) return = returnR fail = rIO . fail -- | Similar to the @ask@ function of the MonadReader class. -- This allows actions in the RIO monad to get the current -- repository. -- FIXME: Don't export this. If we don't export this -- it makes it harder for arbitrary IO actions to access -- the repository and hence our code is easier to audit. getRepository :: RIO p C(r u t t) (Repository p C(r u t)) getRepository = RIO return -- | The status of a given directory: is it a darcs repository? data IdentifyRepo p C(r u t) = BadRepository String -- ^ looks like a repository with some error | NonRepository String -- ^ safest guess | GoodRepository (Repository p C(r u t)) maybeIdentifyRepository :: [DarcsFlag] -> String -> IO (IdentifyRepo p C(r u t)) maybeIdentifyRepository opts "." = do darcs <- doesDirectoryExist darcsdir rf_or_e <- identifyRepoFormat "." here <- toPath `fmap` ioAbsoluteOrRemote "." case rf_or_e of Left err -> return $ NonRepository err Right rf -> case readProblem rf of Just err -> return $ BadRepository err Nothing -> if darcs then do pris <- identifyPristine cs <- getCaches opts here return $ GoodRepository $ Repo here opts rf (DarcsRepository pris cs) else return (NonRepository "Not a repository") maybeIdentifyRepository opts url' = do url <- toPath `fmap` ioAbsoluteOrRemote url' rf_or_e <- identifyRepoFormat url case rf_or_e of Left e -> return $ NonRepository e Right rf -> case readProblem rf of Just err -> return $ BadRepository err Nothing -> do cs <- getCaches opts url return $ GoodRepository $ Repo url opts rf (DarcsRepository nopristine cs) identifyDarcs1Repository :: [DarcsFlag] -> String -> IO (Repository Patch C(r u t)) identifyDarcs1Repository opts url = do er <- maybeIdentifyRepository opts url case er of BadRepository s -> fail s NonRepository s -> fail s GoodRepository r -> return r identifyRepositoryFor :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> String -> IO (Repository p C(r u t)) identifyRepositoryFor (Repo _ opts rf _) url = do Repo absurl _ rf_ t <- identifyDarcs1Repository opts url let t' = case t of DarcsRepository x c -> DarcsRepository x c case readfromAndWritetoProblem rf_ rf of Just e -> fail $ "Incompatibility with repository " ++ url ++ ":\n" ++ e Nothing -> return $ Repo absurl opts rf_ t' amInRepository :: [DarcsFlag] -> IO (Either String ()) amInRepository (WorkRepoDir d:_) = do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d) status <- maybeIdentifyRepository [] "." case status of GoodRepository _ -> return (Right ()) BadRepository e -> return (Left $ "While " ++ d ++ " looks like a repository directory, we have a problem with it:\n" ++ e) NonRepository _ -> return (Left "You need to be in a repository directory to run this command.") amInRepository (_:fs) = amInRepository fs amInRepository [] = seekRepo (Left "You need to be in a repository directory to run this command.") -- | hunt upwards for the darcs repository -- This keeps changing up one parent directory, testing at each -- step if the current directory is a repository or not. $ -- WARNING this changes the current directory for good if matchFn succeeds seekRepo :: Either String () -- ^ what to return if we don't find a repository -> IO (Either String ()) seekRepo onFail = getCurrentDirectory >>= helper where helper startpwd = do status <- maybeIdentifyRepository [] "." case status of GoodRepository _ -> return (Right ()) BadRepository e -> return (Left e) NonRepository _ -> do cd <- toFilePath `fmap` getCurrentDirectory setCurrentDirectory ".." cd' <- toFilePath `fmap` getCurrentDirectory if cd' /= cd then helper startpwd else do setCurrentDirectory startpwd return onFail -- The performGC in this function is a workaround for a library/GHC bug, -- http://hackage.haskell.org/trac/ghc/ticket/2924 -- (doesn't seem to be a -- problem on fast machines, but virtual ones trip this from time to time) amNotInRepository :: [DarcsFlag] -> IO (Either String ()) amNotInRepository (WorkRepoDir d:_) = do createDirectoryIfMissing False d `catchall` (performGC >> createDirectoryIfMissing False d) -- note that the above could always fail setCurrentDirectory d amNotInRepository [] amNotInRepository (_:f) = amNotInRepository f amNotInRepository [] = do status <- maybeIdentifyRepository [] "." case status of GoodRepository _ -> return (Left $ "You may not run this command in a repository.") BadRepository e -> return (Left $ "You may not run this command in a repository.\nBy the way, we have a problem with it:\n" ++ e) NonRepository _ -> return (Right ()) findRepository :: [DarcsFlag] -> IO (Either String ()) findRepository (WorkRepoUrl d:_) | isFile d = do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d) findRepository [] findRepository (WorkRepoDir d:_) = do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d) findRepository [] findRepository (_:fs) = findRepository fs findRepository [] = seekRepo (Right ()) makeNewPending :: forall p C(r u t y). RepoPatch p => Repository p C(r u t) -> FL Prim C(t y) -> IO () makeNewPending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () makeNewPending repo@(Repo r _ _ tp) origp = withCurrentDirectory r $ do let newname = pendingName tp ++ ".new" debugMessage $ "Writing new pending: " ++ newname Sealed sfp <- return $ siftForPending origp writeSealedPatch newname $ seal $ fromPrims $ sfp cur <- readRecorded repo Sealed p <- readPendingfile newname catch (applyToTree p cur) $ \err -> do let buggyname = pendingName tp ++ "_buggy" renameFile newname buggyname bugDoc $ text ("There was an attempt to write an invalid pending! " ++ show err) $$ text "If possible, please send the contents of" <+> text buggyname $$ text "along with a bug report." renameFile newname (pendingName tp) debugMessage $ "Finished writing new pending: " ++ newname where writeSealedPatch :: FilePath -> Sealed (Patch C(x)) -> IO () writeSealedPatch fp (Sealed p) = writePatch fp p siftForPending :: FL Prim C(x y) -> Sealed (FL Prim C(x)) siftForPending simple_ps = let oldps = maybe simple_ps id $ tryShrinkingInverse $ crudeSift simple_ps in if allFL (\p -> primIsAddfile p || primIsAdddir p) $ oldps then seal oldps else fromJust $ do Sealed x <- return $ sfp NilFL $ reverseFL oldps return (case tryToShrink x of ps | lengthFL ps < lengthFL oldps -> siftForPending ps | otherwise -> seal ps) where sfp :: FL Prim C(a b) -> RL Prim C(c a) -> Sealed (FL Prim C(c)) sfp sofar NilRL = seal sofar sfp sofar (p:<:ps) | primIsHunk p || primIsBinary p = case commuteFLorComplain (p :> sofar) of Right (sofar' :> _) -> sfp sofar' ps Left _ -> sfp (p:>:sofar) ps sfp sofar (p:<:ps) = sfp (p:>:sofar) ps -- @todo: we should not have to open the result of HashedRepo and -- seal it. Instead, update this function to work with type witnesses -- by fixing DarcsRepo to match HashedRepo in the handling of -- Repository state. readRepo :: RepoPatch p => Repository p C(r u t) -> IO (PatchSet p C(Origin r)) readRepo repo@(Repo r opts rf _) | formatHas HashedInventory rf = do ps <- HashedRepo.readRepo repo r return ps | otherwise = do Sealed ps <- DarcsRepo.readRepo opts r return $ unsafeCoerceP ps readTentativeRepo :: RepoPatch p => Repository p C(r u t) -> IO (PatchSet p C(Origin t)) readTentativeRepo repo@(Repo r opts rf _) | formatHas HashedInventory rf = do ps <- HashedRepo.readTentativeRepo repo r return ps | otherwise = do Sealed ps <- DarcsRepo.readTentativeRepo opts r return $ unsafeCoerceP ps makePatchLazy :: RepoPatch p => Repository p C(r u t) -> PatchInfoAnd p C(x y) -> IO (PatchInfoAnd p C(x y)) makePatchLazy (Repo r opts rf (DarcsRepository _ c)) p | formatHas HashedInventory rf = withCurrentDirectory r $ HashedRepo.writeAndReadPatch c (compression opts) p | otherwise = withCurrentDirectory r $ DarcsRepo.writeAndReadPatch opts p prefsUrl :: Repository p C(r u t) -> String prefsUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/"++darcsdir++"/prefs" unrevertUrl :: Repository p C(r u t) -> String unrevertUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/"++darcsdir++"/patches/unrevert" applyToWorking :: Patchy p => Repository p1 C(r u t) -> [DarcsFlag] -> p C(u y) -> IO (Repository p1 C(r y t)) applyToWorking (Repo r ropts rf (DarcsRepository t c)) opts patch = do withCurrentDirectory r $ if Quiet `elem` opts then runSilently $ apply opts patch else runTolerantly $ apply opts patch return (Repo r ropts rf (DarcsRepository t c)) handlePendForAdd :: forall p q C(r u t x y). (RepoPatch p, Effect q) => Repository p C(r u t) -> q C(x y) -> IO () handlePendForAdd (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () handlePendForAdd (Repo _ _ _ rt) p = do let pn = pendingName rt ++ ".tentative" Sealed pend <- (readPrims `fmap` gzReadFilePS pn) `catchall` (return $ Sealed NilFL) let effectp = if allFL isSimple pend then crudeSift $ effect p else effect p Sealed newpend <- return $ rmpend (progressFL "Removing from pending:" effectp) pend writePatch pn $ fromPrims_ newpend where rmpend :: FL Prim C(a b) -> FL Prim C(a c) -> Sealed (FL Prim C(b)) rmpend NilFL x = Sealed x rmpend _ NilFL = Sealed NilFL rmpend (x:>:xs) xys | Just ys <- removeFL x xys = rmpend xs ys rmpend (x:>:xs) ys = case commuteWhatWeCanFL (x:>xs) of a:>x':>b -> case rmpend a ys of Sealed ys' -> case commute (invert (x':>:b) :> ys') of Just (ys'' :> _) -> seal ys'' Nothing -> seal $ invert (x':>:b)+>+ys' -- DJR: I don't think this -- last case should be -- reached, but it also -- shouldn't lead to -- corruption. fromPrims_ :: FL Prim C(a b) -> Patch C(a b) fromPrims_ = fromPrims isSimple :: Prim C(x y) -> Bool isSimple x = primIsHunk x || primIsBinary x || primIsSetpref x crudeSift :: FL Prim C(x y) -> FL Prim C(x y) crudeSift xs = if allFL isSimple xs then filterFLFL ishunkbinary xs else xs where ishunkbinary :: Prim C(x y) -> EqCheck C(x y) ishunkbinary x | primIsHunk x || primIsBinary x = unsafeCoerceP IsEq | otherwise = NotEq data HashedVsOld a = HvsO { old, hashed :: a } decideHashedOrNormal :: Monad m => RepoFormat -> HashedVsOld (m a) -> m a decideHashedOrNormal rf (HvsO { hashed = h, old = o }) | formatHas HashedInventory rf = h | otherwise = o data MakeChanges = MakeChanges | DontMakeChanges deriving ( Eq ) announceMergeConflicts :: String -> [DarcsFlag] -> FL Prim C(x y) -> IO Bool announceMergeConflicts cmd opts resolved_pw = case nubsort $ listTouchedFiles $ resolved_pw of [] -> return False cfs -> if MarkConflicts `elem` opts || AllowConflicts `elem` opts || wantExternalMerge opts /= Nothing then do putStrLn "We have conflicts in the following files:" putStrLn $ unwords cfs return True else do putStrLn "There are conflicts in the following files:" putStrLn $ unwords cfs fail $ "Refusing to "++cmd++" patches leading to conflicts.\n"++ "If you would rather apply the patch and mark the conflicts,\n"++ "use the --mark-conflicts or --allow-conflicts options to "++cmd++"\n"++ "These can set as defaults by adding\n"++ " "++cmd++" mark-conflicts\n"++ "to "++darcsdir++"/prefs/defaults in the target repo. " checkUnrecordedConflicts :: forall p C(t y). RepoPatch p => [DarcsFlag] -> FL (Named p) C(t y) -> IO Bool checkUnrecordedConflicts opts _ | NoUpdateWorking `elem` opts = return False checkUnrecordedConflicts opts pc = do repository <- identifyDarcs1Repository opts "." cuc repository where cuc :: Repository Patch C(r u t) -> IO Bool cuc r = do Sealed mpend <- readPending r :: IO (Sealed (FL Prim C(t))) case mpend of NilFL -> return False pend -> case merge (fromPrims_ pend :\/: fromPrims_ (concatFL $ mapFL_FL effect pc)) of _ :/\: pend' -> case listConflictedFiles pend' of [] -> return False fs -> do putStrLn ("You have conflicting local changes to:\n" ++ unwords fs) yorn <- promptYorn "Proceed?" when (yorn /= 'y') $ do putStrLn "Cancelled." exitWith ExitSuccess return True fromPrims_ :: FL Prim C(a b) -> p C(a b) fromPrims_ = fromPrims tentativelyAddPatch :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> PatchInfoAnd p C(t y) -> IO (Repository p C(r u y)) tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine data UpdatePristine = UpdatePristine | DontUpdatePristine deriving Eq tentativelyAddPatch_ :: RepoPatch p => UpdatePristine -> Repository p C(r u t) -> [DarcsFlag] -> PatchInfoAnd p C(t y) -> IO (Repository p C(r u y)) tentativelyAddPatch_ _ _ opts _ | DryRun `elem` opts = bug "tentativelyAddPatch_ called when --dry-run is specified" tentativelyAddPatch_ up r@(Repo dir ropts rf (DarcsRepository t c)) opts p = withCurrentDirectory dir $ do decideHashedOrNormal rf $ HvsO { hashed = HashedRepo.addToTentativeInventory c (compression opts) p, old = DarcsRepo.addToTentativeInventory opts (hopefully p) } when (up == UpdatePristine) $ do debugMessage "Applying to pristine cache..." applyToTentativePristine r p debugMessage "Updating pending..." handlePendForAdd r p return (Repo dir ropts rf (DarcsRepository t c)) applyToTentativePristine :: (Effect q, Patchy q) => Repository p C(r u t) -> q C(t y) -> IO () applyToTentativePristine (Repo dir opts rf (DarcsRepository _ c)) p = withCurrentDirectory dir $ do when (Verbose `elem` opts) $ putDocLn $ text "Applying to pristine..." <+> description p decideHashedOrNormal rf $ HvsO {hashed = HashedRepo.applyToTentativePristine opts p, old = DarcsRepo.addToTentativePristine p} -- | This fuction is unsafe because it accepts a patch that works on the tentative -- pending and we don't currently track the state of the tentative pending. tentativelyAddToPending :: forall p C(r u t x y). RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> FL Prim C(x y) -> IO () tentativelyAddToPending (Repo _ opts _ _) _ _ | NoUpdateWorking `elem` opts = return () | DryRun `elem` opts = bug "tentativelyAddToPending called when --dry-run is specified" tentativelyAddToPending (Repo dir _ _ rt) _ patch = withCurrentDirectory dir $ do let pn = pendingName rt tpn = pn ++ ".tentative" Sealed pend <- readPrims `liftM` (gzReadFilePS tpn `catchall` (return B.empty)) FlippedSeal newpend_ <- return $ newpend (unsafeCoerceP pend :: FL Prim C(a x)) patch writePatch tpn $ fromPrims_ newpend_ where newpend :: FL Prim C(a b) -> FL Prim C(b c) -> FlippedSeal (FL Prim) C(c) newpend NilFL patch_ = flipSeal patch_ newpend p patch_ = flipSeal $ p +>+ patch_ fromPrims_ :: FL Prim C(a b) -> Patch C(a b) fromPrims_ = fromPrims -- | setTentativePending is basically unsafe. It overwrites the pending state with a new one, not related to -- the repository state. setTentativePending :: forall p C(r u t x y). RepoPatch p => Repository p C(r u t) -> FL Prim C(x y) -> IO () setTentativePending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () setTentativePending (Repo dir _ _ rt) patch = do Sealed prims <- return $ siftForPending patch withCurrentDirectory dir $ writePatch (pendingName rt ++ ".tentative") $ fromPrims_ prims where fromPrims_ :: FL Prim C(a b) -> Patch C(a b) fromPrims_ = fromPrims -- | prepend is basically unsafe. It overwrites the pending state -- with a new one, not related to the repository state. prepend :: forall p C(r u t x y). RepoPatch p => Repository p C(r u t) -> FL Prim C(x y) -> IO () prepend (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return () prepend (Repo _ _ _ rt) patch = do let pn = pendingName rt ++ ".tentative" Sealed pend <- readPrims `liftM` (gzReadFilePS pn `catchall` (return B.empty)) Sealed newpend_ <- return $ newpend pend patch writePatch pn $ fromPrims_ (crudeSift newpend_) where newpend :: FL Prim C(b c) -> FL Prim C(a b) -> Sealed (FL Prim C(a)) newpend NilFL patch_ = seal patch_ newpend p patch_ = seal $ patch_ +>+ p fromPrims_ :: FL Prim C(a b) -> Patch C(a b) fromPrims_ = fromPrims tentativelyRemovePatches :: RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> FL (PatchInfoAnd p) C(x t) -> IO (Repository p C(r u x)) tentativelyRemovePatches = tentativelyRemovePatches_ UpdatePristine tentativelyRemovePatches_ :: forall p C(r u t x). RepoPatch p => UpdatePristine -> Repository p C(r u t) -> [DarcsFlag] -> FL (PatchInfoAnd p) C(x t) -> IO (Repository p C(r u x)) tentativelyRemovePatches_ up repository@(Repo dir ropts rf (DarcsRepository t c)) opts ps = withCurrentDirectory dir $ do when (up == UpdatePristine) $ do debugMessage "Adding changes to pending..." prepend repository $ effect ps removeFromUnrevertContext repository ps debugMessage "Removing changes from tentative inventory..." if formatHas HashedInventory rf then do HashedRepo.removeFromTentativeInventory repository (compression opts) ps when (up == UpdatePristine) $ HashedRepo.applyToTentativePristine opts $ progressFL "Applying inverse to pristine" $ invert ps else DarcsRepo.removeFromTentativeInventory (up==UpdatePristine) opts ps return (Repo dir ropts rf (DarcsRepository t c)) tentativelyReplacePatches :: forall p C(r u t x). RepoPatch p => Repository p C(r u t) -> [DarcsFlag] -> FL (PatchInfoAnd p) C(x t) -> IO (Repository p C(r u t)) tentativelyReplacePatches repository opts ps = do repository' <- tentativelyRemovePatches_ DontUpdatePristine repository opts ps mapAdd repository' ps where mapAdd :: Repository p C(m l i) -> FL (PatchInfoAnd p) C(i j) -> IO (Repository p C(m l j)) mapAdd r NilFL = return r mapAdd r (a:>:as) = do r' <- tentativelyAddPatch_ DontUpdatePristine r opts a mapAdd r' as finalizePending :: RepoPatch p => Repository p C(r u t) -> IO () finalizePending (Repo dir opts _ rt) | NoUpdateWorking `elem` opts = withCurrentDirectory dir $ removeFileMayNotExist $ (pendingName rt) finalizePending repository@(Repo dir _ _ rt) = do withCurrentDirectory dir $ do let pn = pendingName rt tpn = pn ++ ".tentative" tpfile <- gzReadFilePS tpn `catchall` (return B.empty) Sealed tpend <- return $ readPrims tpfile Sealed new_pending <- return $ siftForPending tpend makeNewPending repository new_pending finalizeRepositoryChanges :: RepoPatch p => Repository p C(r u t) -> IO () finalizeRepositoryChanges (Repo _ opts _ _) | DryRun `elem` opts = bug "finalizeRepositoryChanges called when --dry-run specified" finalizeRepositoryChanges repository@(Repo dir opts rf _) | formatHas HashedInventory rf = withCurrentDirectory dir $ do debugMessage "Considering whether to test..." testTentative repository debugMessage "Finalizing changes..." withSignalsBlocked $ do HashedRepo.finalizeTentativeChanges repository (compression opts) finalizePending repository debugMessage "Done finalizing changes..." finalizeRepositoryChanges repository@(Repo dir _ _ (DarcsRepository _ _)) = withCurrentDirectory dir $ do debugMessage "Considering whether to test..." testTentative repository debugMessage "Finalizing changes..." withSignalsBlocked $ do DarcsRepo.finalizePristineChanges DarcsRepo.finalizeTentativeChanges finalizePending repository testTentative :: RepoPatch p => Repository p C(r u t) -> IO () testTentative = testAny withTentative testRecorded :: RepoPatch p => Repository p C(r u t) -> IO () testRecorded = testAny withRecorded testAny :: RepoPatch p => (Repository p C(r u t) -> ((AbsolutePath -> IO ()) -> IO ()) -> (AbsolutePath -> IO ()) -> IO ()) -> Repository p C(r u t) -> IO () testAny withD repository@(Repo dir opts _ _) = when (Test `elem` opts) $ withCurrentDirectory dir $ do let putInfo = if not $ Quiet `elem` opts then putStrLn else const (return ()) debugMessage "About to run test if it exists." testline <- getPrefval "test" case testline of Nothing -> return () Just testcode -> withD repository (wd "testing") $ \_ -> do putInfo "Running test...\n" when (SetScriptsExecutable `elem` opts) setScriptsExecutable ec <- system testcode if ec == ExitSuccess then putInfo "Test ran successfully.\n" else do putInfo "Test failed!\n" exitWith ec where wd = if LeaveTestDir `elem` opts then withPermDir else withTempDir revertRepositoryChanges :: RepoPatch p => Repository p C(r u t) -> IO () revertRepositoryChanges (Repo _ opts _ _) | DryRun `elem` opts = bug "revertRepositoryChanges called when --dry-run is specified" revertRepositoryChanges r@(Repo dir opts rf dr@(DarcsRepository _ _)) = withCurrentDirectory dir $ do removeFileMayNotExist (pendingName dr ++ ".tentative") Sealed x <- readPending r setTentativePending r $ effect x when (NoUpdateWorking `elem` opts) $ removeFileMayNotExist $ pendingName dr decideHashedOrNormal rf $ HvsO { hashed = HashedRepo.revertTentativeChanges, old = DarcsRepo.revertTentativeChanges } patchSetToPatches :: RepoPatch p => PatchSet p C(x y) -> FL (Named p) C(x y) patchSetToPatches patchSet = mapFL_FL hopefully $ newset2FL patchSet getUMask :: [DarcsFlag] -> Maybe String getUMask [] = Nothing getUMask ((UMask u):_) = Just u getUMask (_:l) = getUMask l withGutsOf :: Repository p C(r u t) -> IO () -> IO () withGutsOf (Repo _ _ rf _) | formatHas HashedInventory rf = id | otherwise = withSignalsBlocked withRepository :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a withRepository opts1 = withRepositoryDirectory opts1 "." withRepositoryDirectory :: forall a. [DarcsFlag] -> String -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a withRepositoryDirectory opts1 url job = do Repo dir opts rf rt <- identifyDarcs1Repository opts1 url let rt' = case rt of DarcsRepository t c -> DarcsRepository t c if formatHas Darcs2 rf then do debugMessage $ "Identified darcs-2 repo: " ++ dir job1_ (Repo dir opts rf rt') else do debugMessage $ "Identified darcs-1 repo: " ++ dir job2_ (Repo dir opts rf rt) where job1_ :: Repository (FL RealPatch) C(r u r) -> IO a job1_ = job job2_ :: Repository Patch C(r u r) -> IO a job2_ = job -- RankNTypes -- $- works around the lack of impredicative instantiation in GHC ($-) ::((forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a) -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a x $- y = x y withRepoLock :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a withRepoLock opts job = withRepository opts $- \repository@(Repo _ _ rf _) -> do case writeProblem rf of Nothing -> return () Just err -> fail err let name = "./"++darcsdir++"/lock" wu = case (getUMask opts) of Nothing -> id Just u -> withUMask u wu $ if DryRun `elem` opts then job repository else withLock name (revertRepositoryChanges repository >> job repository) withRepoReadLock :: [DarcsFlag] -> (forall p C(r u). RepoPatch p => Repository p C(r u r) -> IO a) -> IO a withRepoReadLock opts job = withRepository opts $- \repository@(Repo _ _ rf _) -> do case writeProblem rf of Nothing -> return () Just err -> fail err let name = "./"++darcsdir++"/lock" wu = case (getUMask opts) of Nothing -> id Just u -> withUMask u wu $ if formatHas HashedInventory rf || DryRun `elem` opts then job repository else withLock name (revertRepositoryChanges repository >> job repository) removeFromUnrevertContext :: forall p C(r u t x). RepoPatch p => Repository p C(r u t) -> FL (PatchInfoAnd p) C(x t) -> IO () removeFromUnrevertContext repository ps = do Sealed bundle <- unrevert_patch_bundle `catchall` (return $ seal (PatchSet NilRL NilRL)) remove_from_unrevert_context_ bundle where unrevert_impossible = do yorn <- promptYorn "This operation will make unrevert impossible!\nProceed?" case yorn of 'n' -> fail "Cancelled." 'y' -> removeFileMayNotExist (unrevertUrl repository) _ -> impossible unrevert_patch_bundle :: IO (SealedPatchSet p C(Origin)) unrevert_patch_bundle = do pf <- B.readFile (unrevertUrl repository) case scanBundle pf of Right foo -> return foo Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err remove_from_unrevert_context_ :: PatchSet p C(Origin z) -> IO () remove_from_unrevert_context_ (PatchSet NilRL NilRL) = return () remove_from_unrevert_context_ bundle = do debugMessage "Adjusting the context of the unrevert changes..." debugMessage $ "Removing "++ show (lengthFL ps) ++ " patches in removeFromUnrevertContext!" ref <- readTentativeRepo repository let withSinglet :: Sealed (FL ppp C(xxx)) -> (FORALL(yyy) ppp C(xxx yyy) -> IO ()) -> IO () withSinglet (Sealed (x :>: NilFL)) j = j x withSinglet _ _ = return () withSinglet (mergeThem ref bundle) $ \h_us -> case commuteRL (reverseFL ps :> h_us) of Nothing -> unrevert_impossible Just (us' :> _) -> case removeFromPatchSet ps ref of Nothing -> unrevert_impossible Just common -> do debugMessage "Have now found the new context..." s <- readRecorded repository bundle <- makeBundleN [] s common (hopefully us':>:NilFL) writeDocBinFile (unrevertUrl repository) bundle debugMessage "Done adjusting the context of the unrevert changes!" -- | Writes out a fresh copy of the inventory that minimizes the -- amount of inventory that need be downloaded when people pull from -- the repository. -- -- Specifically, it breaks up the inventory on the most recent tag. -- This speeds up most commands when run remotely, both because a -- smaller file needs to be transfered (only the most recent -- inventory). It also gives a guarantee that all the patches prior -- to a given tag are included in that tag, so less commutation and -- history traversal is needed. This latter issue can become very -- important in large repositories. optimizeInventory :: RepoPatch p => Repository p C(r u t) -> IO () optimizeInventory repository@(Repo r opts rf (DarcsRepository _ c)) = do ps <- readRepo repository decideHashedOrNormal rf $ HvsO { hashed = do revertRepositoryChanges repository HashedRepo.writeTentativeInventory c (compression opts) $ deepOptimizePatchset ps finalizeRepositoryChanges repository, old = DarcsRepo.writeInventory r $ deepOptimizePatchset ps } cleanRepository :: RepoPatch p => Repository p C(r u t) -> IO () cleanRepository repository@(Repo _ _ rf _) = decideHashedOrNormal rf $ HvsO { hashed = HashedRepo.cleanPristine repository, old = return () } createPristineDirectoryTree :: RepoPatch p => Repository p C(r u t) -> FilePath -> IO () createPristineDirectoryTree repo@(Repo r opts rf (DarcsRepository pris c)) reldir | formatHas HashedInventory rf = do createDirectoryIfMissing True reldir withCurrentDirectory reldir $ HashedRepo.copyPristine c (compression opts) r (darcsdir++"/hashed_inventory") | otherwise = do dir <- toPath `fmap` ioAbsoluteOrRemote reldir done <- withCurrentDirectory r $ easyCreatePristineDirectoryTree pris dir unless done $ do Sealed patches <- (seal . newset2FL) `liftM` readRepo repo createDirectoryIfMissing True dir withCurrentDirectory dir $ applyPatches [] patches -- fp below really should be FileName createPartialsPristineDirectoryTree :: (FilePathLike fp, RepoPatch p) => Repository p C(r u t) -> [fp] -> FilePath -> IO () createPartialsPristineDirectoryTree (Repo r opts rf (DarcsRepository _ c)) prefs dir | formatHas HashedInventory rf = do createDirectoryIfMissing True dir withCurrentDirectory dir $ HashedRepo.copyPartialsPristine c (compression opts) r (darcsdir++"/hashed_inventory") prefs createPartialsPristineDirectoryTree r@(Repo rdir _ _ (DarcsRepository pris _)) prefs dir = withCurrentDirectory rdir $ do done <- easyCreatePartialsPristineDirectoryTree prefs pris dir unless done $ withRecorded r (withTempDir "recorded") $ \_ -> do clonePartialsTree "." dir (map toFilePath prefs) withRecorded :: RepoPatch p => Repository p C(r u t) -> ((AbsolutePath -> IO a) -> IO a) -> (AbsolutePath -> IO a) -> IO a withRecorded repository mk_dir f = mk_dir $ \d -> do createPristineDirectoryTree repository (toFilePath d) f d withTentative :: forall p a C(r u t). RepoPatch p => Repository p C(r u t) -> ((AbsolutePath -> IO a) -> IO a) -> (AbsolutePath -> IO a) -> IO a withTentative (Repo dir opts rf (DarcsRepository _ c)) mk_dir f | formatHas HashedInventory rf = mk_dir $ \d -> do HashedRepo.copyPristine c (compression opts) dir (darcsdir++"/tentative_pristine") f d withTentative repository@(Repo dir opts _ _) mk_dir f = withRecorded repository mk_dir $ \d -> do Sealed ps <- read_patches (dir ++ "/"++darcsdir++"/tentative_pristine") apply opts $ joinPatches ps f d where read_patches :: FilePath -> IO (Sealed (FL p C(x))) read_patches fil = do ps <- B.readFile fil return $ case readPatch ps of Just (x, _) -> x Nothing -> seal NilFL getMarkedupFile :: RepoPatch p => Repository p C(r u t) -> PatchInfo -> FilePath -> IO MarkedUpFile getMarkedupFile repository pinfo f = do Sealed (FlippedSeal patches) <- (seal . dropWhileFL ((/= pinfo) . info) . newset2FL) `liftM` readRepo repository return $ snd $ doMarkAll patches (f, emptyMarkedupFile) where dropWhileFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(r v) -> FlippedSeal (FL a) C(v) dropWhileFL _ NilFL = flipSeal NilFL dropWhileFL p xs@(x:>:xs') | p x = dropWhileFL p xs' | otherwise = flipSeal xs doMarkAll :: RepoPatch p => FL (PatchInfoAnd p) C(x y) -> (FilePath, MarkedUpFile) -> (FilePath, MarkedUpFile) doMarkAll (hp:>:pps) (f, mk) = case hopefullyM hp of Just p -> doMarkAll pps $ markupFile (info hp) (patchcontents p) (f, mk) Nothing -> (f, [(BC.pack "Error reading a patch!",None)]) doMarkAll NilFL (f, mk) = (f, mk) -- | Sets scripts in or below the current directory executable. A script is any file that starts -- with the bytes '#!'. This is used sometimes for --set-scripts-executable, but at other times -- --set-scripts-executable is handled by the hunk patch case of applyFL. setScriptsExecutable :: IO () setScriptsExecutable = do debugMessage "Making scripts executable" myname <- getCurrentDirectory tree <- readWorking let paths = [ anchorPath "." p | (p, Tree.File _) <- Tree.list tree ] setExecutableIfScript f = do contents <- B.readFile f when (BC.pack "#!" `B.isPrefixOf` contents) $ do debugMessage ("Making executable: " ++ f) setExecutable f True mapM_ setExecutableIfScript paths