module Darcs.Commands.Rollback ( rollback ) where
import Control.Applicative ( (<$>) )
import Control.Monad ( when )
import System.Exit ( exitWith, ExitCode(..) )
import Data.List ( sort )
import Data.Maybe ( isJust )
import System.Directory ( removeFile )
import Darcs.Commands ( DarcsCommand(..), nodefaults )
import Darcs.Arguments ( DarcsFlag(MarkConflicts), fixSubPaths, getAuthor,
setEnvDarcsPatches,
workingRepoDir, nocompress,
author, patchnameOption, askLongComment,
leaveTestDir, notest, listRegisteredFiles,
matchSeveralOrLast, allInteractive, umaskOption,
recordRollback
)
import Darcs.RepoPath ( toFilePath )
import Darcs.Repository ( Repository, amInHashedRepository, withRepoLock, RepoJob(..),
applyToWorking,
readRepo,
tentativelyMergePatches, withGutsOf,
testTentative,
finalizeRepositoryChanges, invalidateIndex,
tentativelyAddToPending, considerMergeToWorking
)
import Darcs.Patch ( RepoPatch, summary, invert, namepatch, effect, fromPrims,
sortCoalesceFL, canonize, anonymous, PrimOf )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Flags ( isInteractive, rollbackInWorkingDir )
import Darcs.Patch.Set ( PatchSet(..), newset2FL )
import Darcs.Patch.Split ( reversePrimSplitter )
import Darcs.Witnesses.Ordered
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia )
import Darcs.Lock ( worldReadableTemp )
import Darcs.Match ( firstMatch )
import Darcs.SelectChanges ( selectChanges,
WhichChanges(..),
selectionContext, selectionContextPrim,
runSelection
)
import Darcs.Commands.Record ( getLog )
import Darcs.Commands.Unrecord ( getLastPatches )
import Darcs.Commands.Util ( announceFiles, filterExistingFiles )
import Darcs.Utils ( clarifyErrors, PromptConfig(..), promptChar )
import Printer ( renderString )
import Progress ( debugMessage )
import Darcs.Witnesses.Sealed ( Sealed(..) )
import IsoDate ( getIsoDateTime )
import Storage.Hashed.Tree( Tree )
#include "impossible.h"
#include "gadts.h"
rollbackDescription :: String
rollbackDescription =
"Record a new patch reversing some recorded changes."
rollbackHelp :: String
rollbackHelp =
"Rollback is used to undo the effects of one or more patches without actually\n"++
"deleting them. Instead, it creates a new patch reversing selected portions.\n"++
"of those changes. Unlike obliterate and unrecord (which accomplish a similar\n"++
"goal) rollback is perfectly safe, since it leaves in the repository a record\n"++
"of its changes.\n"
rollback :: DarcsCommand
rollback = DarcsCommand {commandProgramName = "darcs",
commandName = "rollback",
commandHelp = rollbackHelp,
commandDescription = rollbackDescription,
commandExtraArgs = 1,
commandExtraArgHelp = ["[FILE or DIRECTORY]..."],
commandCommand = rollbackCmd,
commandPrereq = amInHashedRepository,
commandGetArgPossibilities = listRegisteredFiles,
commandArgdefaults = nodefaults,
commandAdvancedOptions = [nocompress,umaskOption],
commandBasicOptions = [matchSeveralOrLast,
allInteractive,
author, patchnameOption, askLongComment,
notest, leaveTestDir,
workingRepoDir, recordRollback]}
rollbackCmd :: [DarcsFlag] -> [String] -> IO ()
rollbackCmd opts args = withRepoLock opts $ RepoJob $ \repository -> do
files <- if null args then return Nothing
else Just . sort <$> fixSubPaths opts args
when (files == Just []) $ fail "No valid arguments were given."
let files_fp = map toFilePath <$> files
announceFiles files "Recording changes in"
existing_files <- maybe (return Nothing)
(fmap Just . filterExistingFiles repository) files
when (existing_files == Just []) $
fail "None of the files you specified exist!"
allpatches <- readRepo repository
(_ :> patches) <- return $ if firstMatch opts
then getLastPatches opts allpatches
else (PatchSet NilRL NilRL):> (newset2FL allpatches)
let patches_context = selectionContext "rollback" opts Nothing files_fp
(_ :> ps) <- runSelection (selectChanges LastReversed patches) patches_context
when (nullFL ps) $ do putStrLn "No patches selected!"
exitWith ExitSuccess
setEnvDarcsPatches ps
let hunks_context = selectionContextPrim "rollback" opts (Just reversePrimSplitter) files_fp Nothing
hunks = (concatFL $ mapFL_FL canonize $ sortCoalesceFL $ effect ps)
runSelection (selectChanges Last hunks) hunks_context >>=
if (rollbackInWorkingDir opts)
then (undoItNow opts repository)
else (rollItBackNow opts repository ps)
rollItBackNow :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) =>
[DarcsFlag] -> Repository p C(r u t) -> FL (PatchInfoAnd p) C(x y)
-> (q :> FL (PrimOf p)) C(a t) -> IO ()
rollItBackNow opts repository ps (_ :> ps'') =
do when (nullFL ps'') $ do putStrLn "No changes selected!"
exitWith ExitSuccess
let make_log = worldReadableTemp "darcs-rollback"
newlog = Just ("", "":"rolling back:":"":lines (renderString $ summary ps ))
(name, my_log, logf) <- getLog opts newlog make_log $ invert ps''
date <- getIsoDateTime
my_author <- getAuthor opts
rbp <- n2pia `fmap` namepatch date name my_author my_log
(fromPrims $ invert ps'')
debugMessage "Adding rollback patch to repository."
Sealed pw <-
tentativelyMergePatches repository "rollback"
(MarkConflicts : opts) NilFL
(rbp :>: NilFL)
debugMessage "Finalizing rollback changes..."
invalidateIndex repository
rc <- testTentative repository
when (rc /= ExitSuccess) $ do
when (not $ isInteractive opts) $ exitWith rc
putStrLn $ "Looks like you have a bad patch: '"++name++"'"
let prompt = "Shall I rollback anyway?"
yn <- promptChar (PromptConfig prompt "yn" [] (Just 'n') [])
case yn of
'y' -> return ()
_ -> exitWith rc
withGutsOf repository $ do
finalizeRepositoryChanges repository
debugMessage "About to apply rolled-back changes to working directory."
_ <- revertable $ applyToWorking repository opts pw
return ()
when (isJust logf) $ removeFile (fromJust logf)
putStrLn "Finished rolling back."
where revertable x = x `clarifyErrors` unlines
["Error applying patch to the working directory.","",
"This may have left your working directory an inconsistent",
"but recoverable state. If you had no un-recorded changes",
"by using 'darcs revert' you should be able to make your",
"working directory consistent again."]
undoItNow :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)
=> [DarcsFlag] -> Repository p C(r u t)
-> (q :> FL (PrimOf p)) C(a t) -> IO ()
undoItNow opts repo (_ :> prims) =
do
rbp <- n2pia `fmap` anonymous (fromPrims $ invert prims)
Sealed pw <- considerMergeToWorking repo "rollback" (MarkConflicts: opts)
NilFL (rbp :>: NilFL)
tentativelyAddToPending repo opts pw
withGutsOf repo $ do
finalizeRepositoryChanges repo
_ <- applyToWorking repo opts pw `catch` \e ->
fail ("error applying rolled back patch to working directory\n"
++ show e)
debugMessage "Finished applying unrecorded rollback patch"