-- 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,HashedDir(..),Cache(..),CacheLoc(..),WritableOrNot(..),($-),maybeIdentifyRepository,identifyRepositoryFor,withRepoLock,withRepoReadLock,withRepository,withRepositoryDirectory,withGutsOf,makePatchLazy,writePatchSet,findRepository,amInRepository,amNotInRepository,replacePristine,withRecorded,readRepo,prefsUrl,addToPending,tentativelyAddPatch,tentativelyRemovePatches,tentativelyAddToPending,tentativelyReplacePatches,readTentativeRepo,tentativelyMergePatches,considerMergeToWorking,revertRepositoryChanges,finalizeRepositoryChanges,createRepository,copyRepository,copyOldrepoPatches,patchSetToRepository,unrevertUrl,applyToWorking,patchSetToPatches,createPristineDirectoryTree,createPartialsPristineDirectoryTree,optimizeInventory,cleanRepository,getMarkedupFile,PatchSet,SealedPatchSet,PatchInfoAnd,setScriptsExecutable,checkUnrelatedRepos,testTentative,testRecorded,extractOptions,modifyCache-- * Recorded and unrecorded and pending.,readRecorded,readUnrecorded,unrecordedChanges,readPending,readRecordedAndPending-- * Index.,readIndex,invalidateIndex)whereimportSystem.Exit(ExitCode(..),exitWith)importData.List(isSuffixOf)importData.Maybe(catMaybes)importDarcs.Repository.State(readRecorded,readUnrecorded,readWorking,unrecordedChanges,readPending,readIndex,invalidateIndex,readRecordedAndPending)importDarcs.Repository.Internal(Repository(..),RepoType(..),($-),maybeIdentifyRepository,identifyRepositoryFor,IdentifyRepo(..),findRepository,amInRepository,amNotInRepository,makePatchLazy,withRecorded,readRepo,readTentativeRepo,prefsUrl,withRepoLock,withRepoReadLock,withRepository,withRepositoryDirectory,withGutsOf,tentativelyAddPatch,tentativelyRemovePatches,tentativelyAddToPending,tentativelyReplacePatches,revertRepositoryChanges,finalizeRepositoryChanges,unrevertUrl,applyToWorking,patchSetToPatches,createPristineDirectoryTree,createPartialsPristineDirectoryTree,optimizeInventory,cleanRepository,getMarkedupFile,setScriptsExecutable,testTentative,testRecorded,makeNewPending)importDarcs.Repository.Merge(tentativelyMergePatches,considerMergeToWorking)importDarcs.Repository.Cache(unionRemoteCaches,fetchFileUsingCache,speculateFileUsingCache,HashedDir(..),Cache(..),CacheLoc(..),WritableOrNot(..))importDarcs.Patch.Set(PatchSet(..),SealedPatchSet,newset2RL,newset2FL,progressPatchSet)#ifdef GADT_WITNESSESimportDarcs.Patch.Set(Origin)#endifimportURL(maxPipelineLength)importControl.Applicative((<$>))importControl.Monad(unless,when)importSystem.Directory(createDirectory,renameDirectory,createDirectoryIfMissing,renameFile)importSystem.IO.Error(isAlreadyExistsError)importqualifiedDarcs.Repository.DarcsRepoasDarcsRepoimportqualifiedDarcs.Repository.HashedRepoasHashedRepoimportDarcs.Hopefully(PatchInfoAnd,info,extractHash)importDarcs.Repository.Checkpoint(identifyCheckpoint,writeCheckpointPatch,getCheckpoint)importDarcs.Repository.ApplyPatches(applyPatches)importDarcs.Repository.HashedRepo(applyToTentativePristine,pris2inv,revertTentativeChanges,copySources)importDarcs.Repository.InternalTypes(Pristine(..),extractOptions,modifyCache)importDarcs.Patch(RepoPatch,Named,Prim,Patch,patch2patchinfo,apply)importDarcs.Witnesses.Ordered(FL(..),RL(..),bunchFL,mapFL,mapRL,reverseRL,lengthRL,(+>+),(:\/:)(..))importDarcs.Patch.Info(PatchInfo)importDarcs.Repository.Format(RepoProperty(HashedInventory),RepoFormat,createRepoFormat,formatHas,writeRepoFormat)importDarcs.Repository.Prefs(writeDefaultPrefs)importDarcs.Repository.Pristine(createPristine,flagsToPristine,createPristineFromWorking)importDarcs.Patch.Depends(getPatchesBeyondTag,areUnrelatedRepos,findUncommon)importDarcs.Utils(withCurrentDirectory,catchall,promptYorn,prettyError)importDarcs.External(copyFileOrUrl,Cachable(..),fetchFileLazyPS)importProgress(debugMessage,tediousSize,beginTedious,endTedious)importDarcs.ProgressPatches(progressRLShowTags,progressFL)importDarcs.Lock(writeBinFile,writeDocBinFile,rmRecursive,withTemp)importDarcs.Witnesses.Sealed(Sealed(..),FlippedSeal(..),flipSeal,mapFlipped)importDarcs.Flags(DarcsFlag(Quiet,Partial,Lazy,Ephemeral,Complete,AllowUnrelatedRepos,NoUpdateWorking),compression)importDarcs.Global(darcsdir)importDarcs.URL(isFile)importStorage.Hashed.Tree(Tree,emptyTree)importStorage.Hashed.Hash(encodeBase16)importStorage.Hashed.Darcs(writeDarcsHashed,darcsAddMissingHashes)importStorage.Hashed(writePlainTree)importByteStringUtils(gzReadFilePS)importSystem.FilePath((</>))importqualifiedCodec.Archive.TarasTarimportCodec.Compression.GZip(compress,decompress)importqualifiedData.ByteString.Char8asBSimportqualifiedData.ByteString.LazyasBL#include "impossible.h"createRepository::[DarcsFlag]->IO()createRepositoryopts=docreateDirectorydarcsdir`catch`(\e->ifisAlreadyExistsErrorethenfail"Tree has already been initialized!"elsefail$"Error creating directory `"++darcsdir++"'.")letrf=createRepoFormatoptscreatePristine$flagsToPristineoptsrfcreateDirectory$darcsdir++"/patches"createDirectory$darcsdir++"/prefs"writeDefaultPrefswriteRepoFormatrf(darcsdir++"/format")ifformatHasHashedInventoryrfthenwriteBinFile(darcsdir++"/hashed_inventory")""elseDarcsRepo.writeInventory"."(PatchSetNilRLNilRL::PatchSetPatchC(OriginOrigin))-- YUCK!copyRepository::RepoPatchp=>RepositorypC(rut)->IO()copyRepositoryfromrepository@(Repo_optsrf_)|Partial`elem`opts&&not(formatHasHashedInventoryrf)=doisPartial<-copyPartialRepositoryfromrepositoryunless(isPartial==IsPartial)$copyFullRepositoryfromrepository|otherwise=copyFullRepositoryfromrepositorydataPorNP=NotPartial|IsPartialderiving(Eq)dataRepoSort=Hashed|OldrepoSort::RepoFormat->RepoSortrepoSortf|formatHasHashedInventoryf=Hashed|otherwise=OldcopyInventory::forallpC(rut).RepoPatchp=>RepositorypC(rut)->IO()copyInventoryfromRepo@(RepofromDiroptsfromFormat(DarcsRepository_fromCache))=dotoRepo@(RepotoDiropts'toFormat(DarcsRepositorytoPristinetoCache))<-identifyRepositoryForfromRepo"."toCache2<-unionRemoteCachestoCachefromCachefromDirlettoRepo2::RepositorypC(rut)toRepo2=RepotoDiropts'toFormat$DarcsRepositorytoPristinetoCache2copyHashedHashed=HashedRepo.copyRepotoRepo2optsfromDircopyAnyToOldr=withCurrentDirectorytoDir$readRepor>>=DarcsRepo.writeInventoryAndPatchesoptscaserepoSortfromFormatofHashed->caserepoSorttoFormatofHashed->copyHashedHashedOld->copyAnyToOldfromRepoOld->caserepoSorttoFormatofHashed->withCurrentDirectorytoDir$doHashedRepo.revertTentativeChangespatches<-readRepofromRepoletk="Copying patch"beginTediousktediousSizek(lengthRL$newset2RLpatches)letpatches'=progressPatchSetkpatchesHashedRepo.writeTentativeInventorytoCache(compressionopts)patches'endTediouskHashedRepo.finalizeTentativeChangestoRepo$compressionoptsOld->copyOldrepoPatchesoptsfromRepotoDircopyOldrepoPatches::RepoPatchp=>[DarcsFlag]->RepositorypC(rut)->FilePath->IO()copyOldrepoPatchesoptsrepository@(Repodir___)out=doSealedpatches<-DarcsRepo.readRepoopts"."::IO(SealedPatchSetPatchC(Origin))mpi<-ifPartial`elem`opts-- FIXME this should get last pinfo *before*-- desired tag...thenidentifyCheckpointrepositoryelsereturnNothingFlippedSealscp<-return$since_checkpointmpi$newset2RLpatchesDarcsRepo.copyPatchesoptsdirout$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<-getCheckpointfromrepository::IO(Maybe(Sealed(NamedpC(x))))casemchofNothing->doputStrLn"No checkpoint."returnNotPartialJust(Sealedch)->docopyInventoryfromrepositorywithRepoLockopts$-\torepository->dowriteCheckpointPatchchlocal_patches<-readRepotorepositoryletpi_ch=patch2patchinfochFlippedSealps<-return$getPatchesBeyondTagpi_chlocal_patchesletneeded_patches=reverseRLpsapplyoptsch`catch`\e->fail("Bad checkpoint!\n"++prettyErrore)applyPatchesoptsneeded_patchesdebugMessage"Writing the pristine"pristineFromWorkingtorepositoryreturnIsPartialcopyFullRepository::forallpC(rut).RepoPatchp=>RepositorypC(rut)->IO()copyFullRepositoryfromRepo@(RepofromDiropts__)=dodebugMessage"Copying prefs"copyFileOrUrlopts(fromDir++"/"++darcsdir++"/prefs/prefs")(darcsdir++"/prefs/prefs")(MaxAge600)`catchall`return()ifTrue-- isFile fromDir -- packs disabled for darcs 2.5thencopyNotPackedRepositoryfromRepoelsedob<-(Just<$>fetchFileLazyPS(fromDir++"/"++darcsdir++"/packs/basic.tar.gz")Uncachable)`catchall`returnNothingcasebofNothing->copyNotPackedRepositoryfromRepoJustb'->copyPackedRepositoryfromRepob'copyNotPackedRepository::forallpC(rut).RepoPatchp=>RepositorypC(rut)->IO()copyNotPackedRepositoryfromrepository@(Repo_optsrffrom_)=docopyInventoryfromrepositorydebugMessage"Grabbing lock in new repository..."withRepoLockopts$-\torepository@(Repo__rfto_)->ifformatHasHashedInventoryrffrom&&formatHasHashedInventoryrftothendodebugMessage"Writing working directory contents..."createPristineDirectoryTreetorepository"."fetchPatchesIfNecessaryoptstorepositorywhen(Partial`elem`opts)$putStrLn$"--partial: hashed or darcs-2 repository detected, using --lazy instead"elseifformatHasHashedInventoryrftothendolocal_patches<-readRepotorepositoryreplacePristinetorepositoryemptyTreeletpatchesToApply=progressFL"Applying patch"$newset2FLlocal_patchessequence_$mapFL(applyToTentativePristineopts)$bunchFL100patchesToApplyfinalizeRepositoryChangestorepositorydebugMessage"Writing working directory contents..."createPristineDirectoryTreetorepository"."elsedoreadRepotorepository>>=(applyPatchesopts.newset2FL)debugMessage"Writing the pristine"pristineFromWorkingtorepositorycopyPackedRepository::forallpC(rut).RepoPatchp=>RepositorypC(rut)->BL.ByteString->IO()copyPackedRepositoryfromRepo@(RepofromDiropts_(DarcsRepository_fromCache))b=doRepotoDir_toFormat(DarcsRepositorytoPristinetoCache)<-identifyRepositoryForfromRepo"."toCache2<-unionRemoteCachestoCachefromCachefromDirlettoRepo::RepositorypC(rur)-- In empty repo, t(entative) = r(ecorded)toRepo=RepotoDiroptstoFormat$DarcsRepositorytoPristinetoCache2fromPacksDir=fromDir++"/"++darcsdir++"/packs/"createDirectoryIfMissingFalse$toDir</>darcsdir</>"inventories"createDirectoryIfMissingFalse$toDir</>darcsdir</>"pristine.hashed"createDirectoryIfMissingFalse$toDir</>darcsdir</>"patches"copySourcestoRepofromDir-- unpack inventory & pristine cachewriteCompressed.Tar.read$decompressbcreatePristineDirectoryTreetoRepo"."-- pull new patchesus<-readRepotoRepothem<-readRepofromRepous':\/:them'<-return$findUncommonusthemrevertTentativeChangesSealedpw<-tentativelyMergePatchestoRepo"get"optsus'them'invalidateIndextoRepowithGutsOftoRepo$dofinalizeRepositoryChangestoRepoapplyToWorkingtoRepooptspwreturn()-- get old patchesunless(any(`elem`opts)[Partial,Lazy,Ephemeral])$doputInfo"Copying patches, to get lazy repository hit ctrl-C..."writeCompressed.Tar.read.decompress=<<fetchFileLazyPS(fromPacksDir++"patches.tar.gz")UncachablewherewriteCompressedTar.Done=return()writeCompressed(Tar.Nextxxs)=caseTar.entryContentxofTar.NormalFilex'_->doletp=Tar.entryPathxwithTemp$\p'->doBL.writeFilep'$if"hashed_inventory"`isSuffixOf`pthenx'elsecompressx'renameFilep'pwriteCompressedxs_->fail"Unexpected non-file tar entry"writeCompressed(Tar.Faile)=faileputInfo=when(not$Quiet`elem`opts).putStrLn-- | writePatchSet is like patchSetToRepository, except that it doesn't-- touch the working directory or pristine cache.writePatchSet::RepoPatchp=>PatchSetpC(Originx)->[DarcsFlag]->IO(RepositorypC(rut))writePatchSetpatchsetopts=domaybeRepo<-maybeIdentifyRepositoryopts"."letrepo@(Repo__rf2(DarcsRepository_c))=casemaybeRepoofGoodRepositoryr->rBadRepositorye->bug("Current directory is a bad repository in writePatchSet: "++e)NonRepositorye->bug("Current directory not a repository in writePatchSet: "++e)debugMessage"Writing inventory"ifformatHasHashedInventoryrf2thendoHashedRepo.writeTentativeInventoryc(compressionopts)patchsetHashedRepo.finalizeTentativeChangesrepo(compressionopts)elseDarcsRepo.writeInventoryAndPatchesoptspatchsetreturnrepo-- | 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(Originx)->[DarcsFlag]->IO(RepositorypC(rut))patchSetToRepository(Repofromrepo_rf_)patchsetopts=dowhen(formatHasHashedInventoryrf)$-- set up sources and all thatdowriteFile"_darcs/tentative_pristine"""-- this is hokeyrepox<-writePatchSetpatchsetoptsHashedRepo.copyReporepoxoptsfromreporepo<-writePatchSetpatchsetoptsreadReporepo>>=(applyPatchesopts.newset2FL)debugMessage"Writing the pristine"pristineFromWorkingreporeturnrepocheckUnrelatedRepos::RepoPatchp=>[DarcsFlag]->PatchSetpC(startx)->PatchSetpC(starty)->IO()checkUnrelatedReposopts__|AllowUnrelatedRepos`elem`opts=return()checkUnrelatedRepos_usthem=ifareUnrelatedReposusthemthendoyorn<-promptYorn("Repositories seem to be unrelated. Proceed?")when(yorn/='y')$doputStrLn"Cancelled."exitWithExitSuccesselsereturn()-- | 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.fetchPatchesIfNecessary::forallpC(rut).RepoPatchp=>[DarcsFlag]->RepositorypC(rut)->IO()fetchPatchesIfNecessaryoptstorepository@(Repo___(DarcsRepository_c))=unless(Partial`elem`opts||Lazy`elem`opts||Ephemeral`elem`opts)$dounless(Complete`elem`opts)$putInfo"Copying patches, to get lazy repository hit ctrl-C..."r<-readRepotorepositorypipelineLength<-maxPipelineLengthletpatches=newset2RLrppatches=progressRLShowTags"Copying patches"patches(first,other)=splitAt(pipelineLength-1)$tail$hashespatchesspeculate|pipelineLength>1=[]:first:map(:[])other|otherwise=[]mapM_fetchAndSpeculate$zip(hashesppatches)(speculate++repeat[])whereputInfo=when(not$Quiet`elem`opts).putStrLnhashes::FORALL(xy)RL(PatchInfoAndp)C(xy)->[String]hashes=catMaybes.mapRL((either(constNothing)Just).extractHash)fetchAndSpeculate::(String,[String])->IO()fetchAndSpeculate(f,ss)=dofetchFileUsingCachecHashedPatchesDirfmapM_(speculateFileUsingCachecHashedPatchesDir)ssaddToPending::RepoPatchp=>RepositorypC(rut)->FLPrimC(uy)->IO()addToPending(Repo_opts__)_|NoUpdateWorking`elem`opts=return()addToPendingrepo@(Repo_opts__)p=dopend<-unrecordedChangesoptsrepo[]invalidateIndexrepomakeNewPendingrepo(pend+>+p)-- | Replace the existing pristine with a new one (loaded up in a Tree object).replacePristine::RepositorypC(rut)->TreeIO->IO()replacePristine(Repor_opts_rf(DarcsRepositorypris_c))tree=withCurrentDirectoryr$replacepriswherereplaceHashedPristine=dolett=darcsdir</>"hashed_inventory"i<-gzReadFilePSttree'<-darcsAddMissingHashestreeroot<-writeDarcsHashedtree'$darcsdir</>"pristine.hashed"writeDocBinFilet$pris2inv(BS.unpack$encodeBase16root)ireplace(PlainPristinen)=dormRecursivenold`catchall`return()writePlainTreetreentmprenameDirectorynnoldrenameDirectoryntmpnreturn()replace(NoPristine_)=return()nold=darcsdir</>"pristine-old"ntmp=darcsdir</>"pristine-tmp"pristineFromWorking::RepoPatchp=>RepositorypC(rut)->IO()pristineFromWorkingrepo@(Repodir_rf_)|formatHasHashedInventoryrf=withCurrentDirectorydir$readWorking>>=replacePristinerepopristineFromWorking(Repodir__(DarcsRepositoryp_))=withCurrentDirectorydir$createPristineFromWorkingp