-- Copyright (C) 2002-2004 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.{-# LANGUAGE CPP, TypeOperators #-}moduleDarcs.Commands.Push(push)whereimportSystem.Exit(exitWith,ExitCode(ExitSuccess,ExitFailure))importControl.Monad(when)importData.Char(toUpper)importWorkaround(getCurrentDirectory)importDarcs.Commands(DarcsCommand(..),putVerbose,putInfo,abortRun)importDarcs.Arguments(DarcsFlag(DryRun,Sign,SignAs,NoSign,SignSSL),setEnvDarcsPatches,workingRepoDir,summary,printDryRunMessageAndExit,applyas,matchSeveral,fixUrl,depsSel,allInteractive,dryRun,remoteRepo,networkOptions,setDefault,sign,allowUnrelatedRepos,changesReverse)importDarcs.Flags(doReverse)importDarcs.Patch.PatchInfoAnd(PatchInfoAnd,hopefully)importDarcs.Repository(Repository,withRepoReadLock,RepoJob(..),identifyRepositoryFor,readRepo,amInHashedRepository,checkUnrelatedRepos)importDarcs.Patch(RepoPatch,description)importDarcs.Patch.Apply(ApplyState)importDarcs.Witnesses.Ordered((:>)(..),RL,FL,nullRL,nullFL,reverseFL,mapFL_FL,mapRL)importDarcs.Repository.Prefs(defaultrepo,setDefaultrepo,getPreflist)importDarcs.External(maybeURLCmd,signString)importDarcs.URL(isHttpUrl,isFile)importDarcs.SelectChanges(selectChanges,WhichChanges(..),selectionContext,runSelection)importDarcs.Utils(formatPath)importDarcs.Patch.Depends(findCommonWithThem,countUsThem)importDarcs.Patch.Bundle(makeBundleN)importDarcs.Patch.Patchy(ShowPatch)importDarcs.Patch.Set(PatchSet)#ifdef GADT_WITNESSESimportDarcs.Patch.Set(Origin)#endifimportPrinter(Doc,vcat,empty,text,($$))importDarcs.RemoteApply(remoteApply,applyAs)importDarcs.Email(makeEmail)importEnglish(englishNum,Noun(..))importStorage.Hashed.Tree(Tree)#include "impossible.h"#include "gadts.h"pushDescription::StringpushDescription="Copy and apply patches from this repository to another one."pushHelp::StringpushHelp="Push is the opposite of pull. Push allows you to copy changes from the\n"++"current repository into another repository.\n"push::DarcsCommandpush=DarcsCommand{commandProgramName="darcs",commandName="push",commandHelp=pushHelp,commandDescription=pushDescription,commandExtraArgs=1,commandExtraArgHelp=["[REPOSITORY]"],commandCommand=pushCmd,commandPrereq=amInHashedRepository,commandGetArgPossibilities=getPreflist"repos",commandArgdefaults=defaultrepo,commandAdvancedOptions=[applyas,remoteRepo,changesReverse]++networkOptions,commandBasicOptions=[matchSeveral,depsSel,allInteractive,sign]++dryRun++[summary,workingRepoDir,setDefaultFalse,allowUnrelatedRepos]}pushCmd::[DarcsFlag]->[String]->IO()pushCmd_[""]=impossiblepushCmdopts[unfixedrepodir]=dorepodir<-fixUrloptsunfixedrepodir-- Test to make sure we aren't trying to push to the current repohere<-getCurrentDirectorycheckOptionsSanityoptsrepodirwhen(repodir==here)$fail"Cannot push from repository to itself."-- absolute '.' also taken into account by fix_filepath(bundle)<-withRepoReadLockopts$RepoJob$prepareBundleoptsrepodirsbundle<-signStringoptsbundleletbody=ifisFilerepodirthensbundleelsemakeEmailrepodir[]NothingNothingsbundleNothingrval<-remoteApplyoptsrepodirbodycaservalofExitFailureec->doputStrLn$"Apply failed!"exitWith(ExitFailureec)ExitSuccess->putInfoopts$text"Push successful."pushCmd__=impossibleprepareBundle::forallpC(rut).(RepoPatchp,ApplyStatep~Tree)=>[DarcsFlag]->String->RepositorypC(rut)->IO(Doc)prepareBundleoptsrepodirrepository=doold_default<-getPreflist"defaultrepo"when(old_default==[repodir])$letpushing=ifDryRun`elem`optsthen"Would push"else"Pushing"inputInfoopts$text$pushing++" to "++formatPathrepodir++"..."them<-identifyRepositoryForrepositoryrepodir>>=readReposetDefaultreporepodiroptsus<-readReporepositorycommon:>us'<-return$findCommonWithThemusthemprePushChatteroptsus(reverseFLus')themletcontext=selectionContext"push"optsNothingNothingselector=ifdoReverseoptsthenselectChangesFirstReversedelseselectChangesFirstrunSelection(selectorus')context>>=bundlePatchesoptscommonprePushChatter::forallpaC(xyt).(RepoPatchp,ShowPatcha)=>[DarcsFlag]->PatchSetpC(Originx)->RLaC(tx)->PatchSetpC(Originy)->IO()prePushChatteroptsusus'them=docheckUnrelatedReposoptsusthemletnum_to_pull=snd$countUsThemusthempull_reminder=ifnum_to_pull>0thentext$"The remote repository has "++shownum_to_pull++" "++englishNumnum_to_pull(Noun"patch")" to pull."elseemptyputVerboseopts$text"We have the following patches to push:"$$(vcat$mapRLdescriptionus')when(not$nullRLus')$doputInfoopts$pull_reminderwhen(nullRLus')$doputInfoopts$text"No recorded local changes to push!"exitWithExitSuccessbundlePatches::foralltpC(zwa).(RepoPatchp,ApplyStatep~Tree)=>[DarcsFlag]->PatchSetpC(az)->(FL(PatchInfoAndp):>t)C(zw)->IO(Doc)bundlePatchesoptscommon(to_be_pushed:>_)=dosetEnvDarcsPatchesto_be_pushedprintDryRunMessageAndExit"push"optsto_be_pushedwhen(nullFLto_be_pushed)$doputInfoopts$text"You don't want to push any patches, and that's fine with me!"exitWithExitSuccessbundle<-makeBundleNNothingcommon(mapFL_FLhopefullyto_be_pushed)return(bundle)wantSign::[DarcsFlag]->BoolwantSignopts=caseoptsof[]->FalseSign:_->True(SignAs_):_->True(SignSSL_):_->TrueNoSign:_->False_:opts'->wantSignopts'checkOptionsSanity::[DarcsFlag]->String->IO()checkOptionsSanityoptsrepodir=ifisHttpUrlrepodirthendowhen(applyAsopts/=Nothing)$abortRunopts$text"Cannot --apply-as when pushing to URLs"maybeapply<-maybeURLCmd"APPLY"repodirwhen(maybeapply==Nothing)$letlprot=takeWhile(/=':')repodirprot=maptoUpperlprotmsg=text("Pushing to "++lprot++" URLs is not supported.\n"++"You may be able to hack this to work"++" using DARCS_APPLY_"++prot)inabortRunoptsmsgelsedowhen(wantSignopts)$abortRunopts$text"Signing doesn't make sense for local repositories or when pushing over ssh."