-- Copyright (C) 2002-2005 David Roundy---- 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.moduleDarcs.Commands.Check(check,repair)whereimportControl.Monad(when,unless)importControl.Applicative((<$>))importSystem.Exit(ExitCode(..),exitWith)importSystem.Directory(renameFile)importDarcs.Commands(DarcsCommand(..),nodefaults,putInfo)importDarcs.Arguments(DarcsFlag(Quiet),test,umaskOption,leaveTestDir,workingRepoDir,ignoretimes)importDarcs.Flags(willIgnoreTimes)importDarcs.Repository.Repair(replayRepository,checkIndex,replayRepositoryInTemp,RepositoryConsistency(..))importDarcs.Repository(Repository,amInHashedRepository,withRepository,testRecorded,readRecorded,RepoJob(..),withRepoLock,replacePristine,writePatchSet)importDarcs.Patch(RepoPatch,showPatch,PrimOf)importDarcs.Patch.Apply(ApplyState)importDarcs.Witnesses.Ordered(FL(..))importDarcs.Witnesses.Sealed(Sealed(..),unFreeLeft)importDarcs.Repository.Prefs(filetypeFunction)importDarcs.Diff(treeDiff)importPrinter(text,($$),(<+>))importStorage.Hashed.Tree(Tree)#include "gadts.h"checkDescription::StringcheckDescription="Check the repository for consistency."checkHelp::StringcheckHelp="This command verifies that the patches in the repository, when applied\n"++"successively to an empty tree, result in the pristine tree. If not,\n"++"the differences are printed and Darcs exits unsucessfully (with a\n"++"non-zero exit status).\n"++"\n"++"If a regression test is defined (see `darcs setpref') it will be run\n"++"by `darcs check'. Use the --no-test option to disable this.\n"check::DarcsCommandcheck=DarcsCommand{commandProgramName="darcs",commandName="check",commandHelp=checkHelp,commandDescription=checkDescription,commandExtraArgs=0,commandExtraArgHelp=[],commandCommand=checkCmd,commandPrereq=amInHashedRepository,commandGetArgPossibilities=return[],commandArgdefaults=nodefaults,commandAdvancedOptions=[],commandBasicOptions=[test,leaveTestDir,workingRepoDir,ignoretimes]}checkCmd::[DarcsFlag]->[String]->IO()checkCmdopts_=withRepositoryopts(RepoJob(check'opts))check'::forallpC(rut).(RepoPatchp,ApplyStatep~Tree)=>[DarcsFlag]->RepositorypC(rut)->IO()check'optsrepository=dostate<-replayRepositoryInTemprepositoryoptsfailed<-casestateofRepositoryConsistent->doputInfoopts$text"The repository is consistent!"rc<-testRecordedrepositorywhen(rc/=ExitSuccess)$exitWithrcreturnFalseBrokenPristinenewpris->dobrokenPristinenewprisreturnTrueBrokenPatchesnewpris_->dobrokenPristinenewprisputInfoopts$text"Found broken patches."returnTruebad_index<-casewillIgnoreTimesoptsofFalse->not<$>checkIndexrepository(Quiet`elem`opts)True->returnFalsewhenbad_index$putInfoopts$text"Bad index."exitWith$iffailed||bad_indexthenExitFailure1elseExitSuccesswherebrokenPristinenewpris=doputInfoopts$text"Looks like we have a difference..."mc'<-(fmapJust$readRecordedrepository)`catch`(\_->returnNothing)casemc'ofNothing->doputInfoopts$text"cannot compute that difference, try repair"putInfoopts$text""$$text"Inconsistent repository"return()Justmc->doftf<-filetypeFunctionSealed(diff::FL(PrimOfp)C(rr2))<-unFreeLeft`fmap`treeDiffftfnewprismc::IO(Sealed(FL(PrimOfp)C(r)))putInfoopts$casediffofNilFL->text"Nothing"patch->text"Difference: "<+>showPatchpatchputInfoopts$text""$$text"Inconsistent repository!"repairDescription::StringrepairDescription="Repair a corrupted repository."repairHelp::StringrepairHelp="The `darcs repair' command attempts to fix corruption in the current\n"++"repository. Currently it can only repair damage to the pristine tree,\n"++"which is where most corruption occurs.\n"repair::DarcsCommandrepair=DarcsCommand{commandProgramName="darcs",commandName="repair",commandHelp=repairHelp,commandDescription=repairDescription,commandExtraArgs=0,commandExtraArgHelp=[],commandCommand=repairCmd,commandPrereq=amInHashedRepository,commandGetArgPossibilities=return[],commandArgdefaults=nodefaults,commandAdvancedOptions=[umaskOption],commandBasicOptions=[workingRepoDir]}repairCmd::[DarcsFlag]->[String]->IO()repairCmdopts_=withRepoLockopts$RepoJob$\repository->doreplayRepositoryrepositoryopts$\state->casestateofRepositoryConsistent->putStrLn"The repository is already consistent, no changes made."BrokenPristinetree->doputStrLn"Fixing pristine tree..."replacePristinerepositorytreeBrokenPatchestreenewps->doputStrLn"Writing out repaired patches..."_<-writePatchSetnewpsoptsputStrLn"Fixing pristine tree..."replacePristinerepositorytreeindex_ok<-checkIndexrepository(Quiet`elem`opts)unlessindex_ok$dorenameFile"_darcs/index""_darcs/index.bad"putStrLn"Bad index discarded."