-- Copyright (C) 2002-2004,2007 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.{-# OPTIONS_GHC -cpp #-}{-# LANGUAGE CPP #-}#include "gadts.h"moduleDarcs.Patch.Bundle(hash_bundle,make_bundle,make_bundle2,scan_bundle,make_context,scan_context,)whereimportDarcs.Flags(DarcsFlag(Unified))importDarcs.Hopefully(PatchInfoAnd,piap,patchInfoAndPatch,unavailable,hopefully)importDarcs.Patch(RepoPatch,Named,showPatch,showContextPatch,readPatch)importDarcs.Patch.Info(PatchInfo,readPatchInfo,showPatchInfo,human_friendly,is_tag)importDarcs.Patch.Set(PatchSet,SealedPatchSet)importDarcs.Ordered(RL(..),FL(..),unsafeCoerceP,reverseFL,(+<+),mapFL,mapFL_FL)importPrinter(Doc,renderPS,newline,text,($$),(<>),vcat,vsep,renderString)importDarcs.SlurpDirectory(Slurpy)importByteStringUtils(linesPS,unlinesPS,dropSpace,substrPS)importqualifiedData.ByteStringasB(ByteString,length,null,drop,isPrefixOf)importqualifiedData.ByteString.Char8asBC(unpack,break,pack)importSHA1(sha1PS)importDarcs.Sealed(Sealed(Sealed),mapSeal)hash_bundle::RepoPatchp=>[PatchInfo]->FL(Namedp)C(xy)->Stringhash_bundle_to_be_sent=sha1PS$renderPS$vcat(mapFLshowPatchto_be_sent)<>newlinemake_bundle::RepoPatchp=>[DarcsFlag]->Slurpy->[PatchInfo]->FL(Namedp)C(xy)->Docmake_bundleoptsthe_scommonto_be_sent=make_bundle2optsthe_scommonto_be_sentto_be_sent-- | In make_bundle2, it is presumed that the two patch sequences are-- identical, but that they may be lazily generated. If two different-- patch sequences are passed, a bundle with a mismatched hash will be-- generated, which is not the end of the world, but isn't very useful-- either.make_bundle2::RepoPatchp=>[DarcsFlag]->Slurpy->[PatchInfo]->FL(Namedp)C(xy)->FL(Namedp)C(xy)->Docmake_bundle2optsthe_scommonto_be_sentto_be_sent2=text""$$text"New patches:"$$text""$$the_new$$text""$$text"Context:"$$text""$$(vcat$mapshowPatchInfocommon)$$text"Patch bundle hash:"$$text(hash_bundlecommonto_be_sent2)$$text""wherethe_new=ifUnified`elem`optsthenshowContextPatchthe_sto_be_sentelsevsep$mapFLshowPatchto_be_sentscan_bundle::RepoPatchp=>B.ByteString->EitherString(SealedPatchSetp)scan_bundleps|B.nullps=Left"Bad patch bundle!"|otherwise=casesilly_lexpsof("New patches:",rest)->caseget_patchesrestof(Sealedpatches,rest')->casesilly_lexrest'of("Context:",rest'')->caseget_contextrest''of(cont,maybe_hash)->casesubstrPS(BC.pack"Patch bundle hash:")maybe_hashofJustn->ifhash_bundlecont(mapFL_FLhopefullypatches)==fst(silly_lex$snd$silly_lex$B.dropnmaybe_hash)thenseal_up_patchespatchescontelseLeft$"Patch bundle failed hash!\n"++"This probably means that the patch has been "++"corrupted by a mailer.\n"++"The most likely culprit is CRLF newlines."Nothing->seal_up_patchespatchescont(a,r)->Left$"Malformed patch bundle: '"++a++"' is not 'Context:'"++"\n"++BC.unpackr("Context:",rest)->caseget_contextrestof(cont,rest')->casesilly_lexrest'of("New patches:",rest'')->caseparse_patchesrest''ofSealedps''->seal_up_patchesps''cont(a,_)->Left$"Malformed patch bundle: '"++a++"' is not 'New patches:'"("-----BEGIN PGP SIGNED MESSAGE-----",rest)->scan_bundle$filter_gpg_dashesrest(_,rest)->scan_bundlerestwhereseal_up_patches::RepoPatchp=>FL(PatchInfoAndp)C(xy)->[PatchInfo]->EitherString(SealedPatchSetp)seal_up_patchesxxxyyy=casereverseyyyof(x:_)|is_tagx->Right$Sealed((reverseFLxxx+<+unavailable_patchesyyy):<:NilRL)-- The above NilRL isn't quite-- right, because ther *are*-- earlier patches, but we-- can't set this to undefined-- because there are-- situations where we look at-- the rest. :{-- bug "No more patches in patch bundle!")_->Right$Sealed((reverseFLxxx+<+unavailable_patchesyyy):<:NilRL)-- filter_gpg_dashes is needed because clearsigned patches escape dashes:filter_gpg_dashes::B.ByteString->B.ByteStringfilter_gpg_dashesps=unlinesPS$mapdrop_dashes$takeWhile(/=BC.pack"-----END PGP SIGNED MESSAGE-----")$dropWhilenot_context_or_newpatches$linesPSpswheredrop_dashesx=ifB.lengthx<2thenxelseifBC.pack"- "`B.isPrefixOf`xthenB.drop2xelsexnot_context_or_newpatchess=(s/=BC.pack"Context:")&&(s/=BC.pack"New patches:")unavailable_patches::RepoPatchp=>[PatchInfo]->RL(PatchInfoAndp)C(xy)unavailable_patches[]=unsafeCoercePNilRLunavailable_patches(x:xs)=pi_unavailablex:<:unavailable_patchesxspi_unavailable::RepoPatchp=>PatchInfo->PatchInfoAndpC(xy)pi_unavailablei=(i`patchInfoAndPatch`unavailable("Patch not stored in patch bundle:\n"++renderString(human_friendlyi)))get_context::B.ByteString->([PatchInfo],B.ByteString)get_contextps=casereadPatchInfopsofJust(pinfo,r')->caseget_contextr'of(pis,r'')->(pinfo:pis,r'')Nothing->([],ps)(-:-)::aC(xy)->(Sealed(FLaC(y)),b)->(Sealed(FLaC(x)),b)p-:-(Sealedps,r)=(Sealed(p:>:ps),r)get_patches::RepoPatchp=>B.ByteString->(Sealed(FL(PatchInfoAndp)C(x)),B.ByteString)get_patchesps=casereadPatchInfopsofNothing->(SealedNilFL,ps)Just(pinfo,_)->casereadPatchpsofNothing->(SealedNilFL,ps)Just(Sealedp,r)->(pinfo`piap`p)-:-get_patchesrparse_patches::RepoPatchp=>B.ByteString->Sealed(FL(PatchInfoAndp)C(x))parse_patchesps=casereadPatchInfopsofNothing->SealedNilFLJust(pinfo,_)->casereadPatchpsofNothing->SealedNilFLJust(Sealedp,r)->((pinfo`piap`p):>:)`mapSeal`parse_patchesrsilly_lex::B.ByteString->(String,B.ByteString)silly_lexps=(BC.unpacka,b)where(a,b)=BC.break(=='\n')(dropSpaceps){-
silly_lex ps = (BC.unpack $ BC.takeWhile (/='\n') ps', BC.dropWhile (/='\n') ps')
where
ps' = dropSpace ps
-}make_context::[PatchInfo]->Docmake_contextcommon=text""$$text"Context:"$$text""$$(vcat$mapshowPatchInfo$common)$$text""scan_context::RepoPatchp=>B.ByteString->PatchSetpC(x)scan_contextps|B.nullps=error"Bad context!"|otherwise=casesilly_lexpsof("Context:",rest)->caseget_contextrestof(cont,_)->unavailable_patchescont:<:NilRL("-----BEGIN PGP SIGNED MESSAGE-----",rest)->scan_context$filter_gpg_dashesrest(_,rest)->scan_contextrest