-- Copyright (C) 2002-2004 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 #-}#include "gadts.h"moduleDarcs.Repository(Repository,($-),maybeIdentifyRepository,identifyRepositoryFor,withRepoLock,withRepoReadLock,withRepository,withRepositoryDirectory,withGutsOf,makePatchLazy,writePatchSet,findRepository,amInRepository,amNotInRepository,slurp_pending,replacePristine,replacePristineFromSlurpy,slurp_recorded,slurp_recorded_and_unrecorded,withRecorded,get_unrecorded,get_unrecorded_unsorted,get_unrecorded_no_look_for_adds,get_unrecorded_in_files,read_repo,sync_repo,prefsUrl,add_to_pending,tentativelyAddPatch,tentativelyRemovePatches,tentativelyAddToPending,tentativelyReplacePatches,tentativelyMergePatches,considerMergeToWorking,revertRepositoryChanges,finalizeRepositoryChanges,createRepository,copyRepository,copy_oldrepo_patches,patchSetToRepository,unrevertUrl,applyToWorking,patchSetToPatches,createPristineDirectoryTree,createPartialsPristineDirectoryTree,optimizeInventory,cleanRepository,checkPristineAgainstSlurpy,getMarkedupFile,PatchSet,SealedPatchSet,PatchInfoAnd,setScriptsExecutable,checkUnrelatedRepos,testTentative,testRecorded)whereimportSystem.Exit(ExitCode(..),exitWith)importDarcs.Repository.Internal(Repository(..),RepoType(..),($-),pristineFromWorking,maybeIdentifyRepository,identifyRepositoryFor,findRepository,amInRepository,amNotInRepository,makePatchLazy,slurp_pending,replacePristine,replacePristineFromSlurpy,slurp_recorded,slurp_recorded_and_unrecorded,withRecorded,get_unrecorded,get_unrecorded_unsorted,get_unrecorded_no_look_for_adds,get_unrecorded_in_files,read_repo,sync_repo,prefsUrl,checkPristineAgainstSlurpy,add_to_pending,withRepoLock,withRepoReadLock,withRepository,withRepositoryDirectory,withGutsOf,tentativelyAddPatch,tentativelyRemovePatches,tentativelyAddToPending,tentativelyReplacePatches,tentativelyMergePatches,considerMergeToWorking,revertRepositoryChanges,finalizeRepositoryChanges,unrevertUrl,applyToWorking,patchSetToPatches,createPristineDirectoryTree,createPartialsPristineDirectoryTree,optimizeInventory,cleanRepository,getMarkedupFile,setScriptsExecutable,testTentative,testRecorded)importDarcs.Repository.Cache(unionCaches,fetchFileUsingCache,HashedDir(..))importDarcs.Patch.Set(PatchSet,SealedPatchSet)importControl.Monad(unless,when)importData.Either(Either(..))importSystem.Directory(createDirectory)importSystem.IO.Error(isAlreadyExistsError)importqualifiedDarcs.Repository.DarcsRepoasDarcsRepoimportqualifiedDarcs.Repository.HashedRepoasHashedRepoimportDarcs.Hopefully(PatchInfoAnd,info,extractHash)importDarcs.Repository.Checkpoint(identify_checkpoint,write_checkpoint_patch,get_checkpoint)importDarcs.Repository.ApplyPatches(apply_patches)importDarcs.Repository.HashedRepo(apply_to_tentative_pristine)importDarcs.Patch(RepoPatch,Named,Patch,patch2patchinfo,apply)importDarcs.Ordered(RL(..),bunchFL,mapFL,mapRL,mapRL_RL,concatFL,reverseRL,concatRL,lengthRL,isShorterThanRL)importDarcs.Patch.Info(PatchInfo)importDarcs.Repository.Format(RepoProperty(HashedInventory),create_repo_format,format_has,writeRepoFormat)importDarcs.Repository.Prefs(write_default_prefs)importDarcs.Repository.Pristine(createPristine,flagsToPristine)importDarcs.Patch.Depends(get_patches_beyond_tag)importDarcs.SlurpDirectory(empty_slurpy)importDarcs.Utils(withCurrentDirectory,catchall,promptYorn)importDarcs.External(copyFileOrUrl,Cachable(..))importProgress(debugMessage,tediousSize,beginTedious,endTedious,progress)importDarcs.ProgressPatches(progressRLShowTags,progressFL)importDarcs.Lock(writeBinFile)importDarcs.Sealed(Sealed(..),FlippedSeal(..),flipSeal,mapFlipped)importDarcs.Flags(DarcsFlag(Quiet,Partial,Lazy,Ephemeral,AllowUnrelatedRepos),compression)importDarcs.Global(darcsdir)#include "impossible.h"createRepository::[DarcsFlag]->IO()createRepositoryopts=docreateDirectorydarcsdir`catch`(\e->ifisAlreadyExistsErrorethenfail"Tree has already been initialized!"elsefail$"Error creating directory `"++darcsdir++"'.")letrf=create_repo_formatoptscreatePristine$flagsToPristineoptsrfcreateDirectory$darcsdir++"/patches"createDirectory$darcsdir++"/prefs"write_default_prefswriteRepoFormatrf(darcsdir++"/format")ifformat_hasHashedInventoryrfthenwriteBinFile(darcsdir++"/hashed_inventory")""elseDarcsRepo.write_inventory"."((NilRL:<:NilRL)::PatchSetPatchC(()))-- YUCK!copyRepository::RepoPatchp=>RepositorypC(rut)->IO()copyRepositoryfromrepository@(Repo_optsrf_)|Partial`elem`opts&&not(format_hasHashedInventoryrf)=doisPartial<-copyPartialRepositoryfromrepositoryunless(isPartial==IsPartial)$copyFullRepositoryfromrepository|otherwise=copyFullRepositoryfromrepositorydataPorNP=NotPartial|IsPartialderiving(Eq)dataRepoSort=Hashed|OldcopyInventory::forallpC(rut).RepoPatchp=>RepositorypC(rut)->IO()copyInventoryfromrepo@(Repofromdiroptsrf(DarcsRepository_cremote))=dorepo@(Repotodirxxrf2(DarcsRepositoryyyc))<-identifyRepositoryForfromrepo"."letnewrepo::RepositorypC(rut)newrepo=Repotodirxxrf2(DarcsRepositoryyy(c`unionCaches`cremote))copyHashedHashed=HashedRepo.copy_reponewrepooptsfromdircopyAnythingToOldr=withCurrentDirectorytodir$read_repor>>=DarcsRepo.write_inventory_and_patchesoptsrepoSortrfx|format_hasHashedInventoryrfx=Hashed|otherwise=OldcaserepoSortrf2ofHashed->ifformat_hasHashedInventoryrfthencopyHashedHashedelsewithCurrentDirectorytodir$doHashedRepo.revert_tentative_changespatches<-read_repofromrepoletk="Copying patch"beginTediousktediousSizek(lengthRL$concatRLpatches)letpatches'=mapRL_RL(mapRL_RL(progressk))patchesHashedRepo.write_tentative_inventoryc(compressionopts)patches'endTediouskHashedRepo.finalize_tentative_changesrepo(compressionopts)Old->caserepoSortrfofHashed->copyAnythingToOldfromrepo_->copy_oldrepo_patchesoptsfromrepotodircopy_oldrepo_patches::RepoPatchp=>[DarcsFlag]->RepositorypC(rut)->FilePath->IO()copy_oldrepo_patchesoptsrepository@(Repodir___)out=doSealedpatches<-DarcsRepo.read_repoopts"."::IO(SealedPatchSetPatch)mpi<-ifPartial`elem`opts-- FIXME this should get last pinfo *before*-- desired tag...thenidentify_checkpointrepositoryelsereturnNothingFlippedSealscp<-return$since_checkpointmpi$concatRLpatchesDarcsRepo.copy_patchesoptsdirout$mapRLinfo$scpwheresince_checkpoint::MaybePatchInfo->RL(PatchInfoAndp)C(xy)->FlippedSeal(RL(PatchInfoAndp))C(y)since_checkpointNothingps=flipSealpssince_checkpoint(Justch)(hp:<:ps)|ch==infohp=flipSeal$hp:<:NilRL|otherwise=(hp:<:)`mapFlipped`since_checkpoint(Justch)pssince_checkpoint_NilRL=flipSealNilRLcopyPartialRepository::forallpC(rut).RepoPatchp=>RepositorypC(rut)->IOPorNPcopyPartialRepositoryfromrepository@(Repo_opts__)=domch<-get_checkpointfromrepository::IO(Maybe(Sealed(NamedpC(x))))casemchofNothing->doputStrLn"No checkpoint."returnNotPartialJust(Sealedch)->docopyInventoryfromrepositorywithRepoLockopts$-\torepository->dowrite_checkpoint_patchchlocal_patches<-read_repotorepositoryletpi_ch=patch2patchinfochFlippedSealps<-return$get_patches_beyond_tagpi_chlocal_patchesletneeded_patches=reverseRL$concatRLpsapplyoptsch`catch`\e->fail("Bad checkpoint!\n"++showe)apply_patchesoptsneeded_patchesdebugMessage"Writing the pristine"pristineFromWorkingtorepositoryreturnIsPartialcopyFullRepository::forallpC(rut).RepoPatchp=>RepositorypC(rut)->IO()copyFullRepositoryfromrepository@(Repofromdiroptsrffrom_)=docopyInventoryfromrepositorydebugMessage"Copying prefs"copyFileOrUrlopts(fromdir++"/"++darcsdir++"/prefs/prefs")(darcsdir++"/prefs/prefs")(MaxAge600)`catchall`return()debugMessage"Grabbing lock in new repository..."withRepoLockopts$-\torepository@(Repo__rfto(DarcsRepository_c))->ifformat_hasHashedInventoryrffrom&&format_hasHashedInventoryrftothendodebugMessage"Writing working directory contents..."createPristineDirectoryTreetorepository"."fetch_patches_if_necessaryoptstorepositorywhen(Partial`elem`opts)$putStrLn$"--partial: hashed or darcs-2 repository detected, using --lazy instead"elseifformat_hasHashedInventoryrftothendolocal_patches<-read_repotorepositoryreplacePristineFromSlurpytorepositoryempty_slurpyletpatchesToApply=progressFL"Applying patch"$concatFL$reverseRL$mapRL_RLreverseRLlocal_patchessequence_$mapFL(apply_to_tentative_pristinecopts)$bunchFL100patchesToApplyfinalizeRepositoryChangestorepositorydebugMessage"Writing working directory contents..."createPristineDirectoryTreetorepository"."elsedoread_repotorepository>>=(apply_patchesopts.reverseRL.concatRL)debugMessage"Writing the pristine"pristineFromWorkingtorepository-- | writePatchSet is like patchSetToRepository, except that it doesn't-- touch the working directory or pristine cache.writePatchSet::RepoPatchp=>PatchSetpC(x)->[DarcsFlag]->IO(RepositorypC(rut))writePatchSetpatchsetopts=domaybeRepo<-maybeIdentifyRepositoryopts"."letrepo@(Repo__rf2(DarcsRepository_c))=casemaybeRepoofRightr->rLefte->bug("Current directory not repository in writePatchSet: "++e)debugMessage"Writing inventory"ifformat_hasHashedInventoryrf2thendoHashedRepo.write_tentative_inventoryc(compressionopts)patchsetHashedRepo.finalize_tentative_changesrepo(compressionopts)elseDarcsRepo.write_inventory_and_patchesoptspatchsetreturnrepo-- | patchSetToRepository takes a patch set, and writes a new repository in the current directory-- that contains all the patches in the patch set. This function is used when 'darcs get'ing a-- repository with the --to-match flag and the new repository is not in hashed format.-- This function does not (yet) work for hashed repositories. If the passed @DarcsFlag@s tell -- darcs to create a hashed repository, this function will call @error@.patchSetToRepository::RepoPatchp=>RepositorypC(r1u1r1)->PatchSetpC(x)->[DarcsFlag]->IO(RepositorypC(rut))patchSetToRepository(Repofromrepo_rf_)patchsetopts=dowhen(format_hasHashedInventoryrf)$-- set up sources and all thatdowriteFile"_darcs/tentative_pristine"""-- this is hokeyrepox<-writePatchSetpatchsetoptsHashedRepo.copy_reporepoxoptsfromreporepo<-writePatchSetpatchsetoptsread_reporepo>>=(apply_patchesopts.reverseRL.concatRL)debugMessage"Writing the pristine"pristineFromWorkingreporeturnrepocheckUnrelatedRepos::[DarcsFlag]->[PatchInfo]->PatchSetpC(x)->PatchSetpC(x)->IO()checkUnrelatedReposoptscommonusthem|AllowUnrelatedRepos`elem`opts||not(nullcommon)||concatRLus`isShorterThanRL`5||concatRLthem`isShorterThanRL`5=return()|otherwise=doyorn<-promptYorn("Repositories seem to be unrelated. Proceed?")when(yorn/='y')$doputStrLn"Cancelled."exitWithExitSuccess-- | Unless a flag has been given in the first argument that tells darcs not to do so (--lazy,-- --partial or --ephemeral), this function fetches all patches that the given repository has -- with fetchFileUsingCache. This is used as a helper in copyFullRepository.fetch_patches_if_necessary::RepoPatchp=>[DarcsFlag]->RepositorypC(rut)->IO()fetch_patches_if_necessaryoptstorepository@(Repo___(DarcsRepository_c))=unless(Partial`elem`opts||Lazy`elem`opts||Ephemeral`elem`opts)$doputInfo"Copying patches, to get lazy repository hit ctrl-C..."r<-read_repotorepositoryletpeekaboo::PatchInfoAndpC(xy)->IO()peekaboox=caseextractHashxofLeft_->return()Righth->fetchFileUsingCachecHashedPatchesDirh>>return()sequence_$mapRLpeekaboo$progressRLShowTags"Copying patches"$concatRLrwhereputInfo=when(not$Quiet`elem`opts).putStrLn