darcs-2.1.98.2: src/Darcs/Patch/Bundle.hs
-- 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"
module Darcs.Patch.Bundle ( hash_bundle, make_bundle, make_bundle2, scan_bundle,
make_context, scan_context,
) where
import Darcs.Flags ( DarcsFlag( Unified ) )
import Darcs.Hopefully ( PatchInfoAnd, piap,
patchInfoAndPatch,
unavailable, hopefully )
import Darcs.Patch ( RepoPatch, Named, showPatch, showContextPatch, readPatch )
import Darcs.Patch.Info ( PatchInfo, readPatchInfo, showPatchInfo, human_friendly, is_tag )
import Darcs.Patch.Set ( PatchSet, SealedPatchSet )
import Darcs.Ordered ( RL(..), FL(..), unsafeCoerceP,
reverseFL, (+<+), mapFL, mapFL_FL )
import Printer ( Doc, renderPS, newline, text, ($$),
(<>), vcat, vsep, renderString )
import Darcs.SlurpDirectory ( Slurpy )
import ByteStringUtils ( linesPS, unlinesPS, dropSpace, substrPS)
import qualified Data.ByteString as B (ByteString, length, null, drop, isPrefixOf)
import qualified Data.ByteString.Char8 as BC (unpack, break, pack)
import SHA1( sha1PS )
import Darcs.Sealed ( Sealed(Sealed), mapSeal )
hash_bundle :: RepoPatch p => [PatchInfo] -> FL (Named p) C(x y) -> String
hash_bundle _ to_be_sent = sha1PS $ renderPS
$ vcat (mapFL showPatch to_be_sent) <> newline
make_bundle :: RepoPatch p => [DarcsFlag] -> Slurpy -> [PatchInfo] -> FL (Named p) C(x y) -> Doc
make_bundle opts the_s common to_be_sent = make_bundle2 opts the_s common to_be_sent to_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 :: RepoPatch p => [DarcsFlag] -> Slurpy -> [PatchInfo]
-> FL (Named p) C(x y) -> FL (Named p) C(x y) -> Doc
make_bundle2 opts the_s common to_be_sent to_be_sent2 =
text ""
$$ text "New patches:"
$$ text ""
$$ the_new
$$ text ""
$$ text "Context:"
$$ text ""
$$ (vcat $ map showPatchInfo common)
$$ text "Patch bundle hash:"
$$ text (hash_bundle common to_be_sent2)
$$ text ""
where the_new = if Unified `elem` opts
then showContextPatch the_s to_be_sent
else vsep $ mapFL showPatch to_be_sent
scan_bundle :: RepoPatch p => B.ByteString -> Either String (SealedPatchSet p)
scan_bundle ps
| B.null ps = Left "Bad patch bundle!"
| otherwise =
case silly_lex ps of
("New patches:",rest) ->
case get_patches rest of
(Sealed patches, rest') ->
case silly_lex rest' of
("Context:", rest'') ->
case get_context rest'' of
(cont,maybe_hash) ->
case substrPS (BC.pack "Patch bundle hash:")
maybe_hash of
Just n ->
if hash_bundle cont (mapFL_FL hopefully patches)
== fst (silly_lex $ snd $ silly_lex $
B.drop n maybe_hash)
then seal_up_patches patches cont
else Left $
"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_patches patches cont
(a,r) -> Left $ "Malformed patch bundle: '"++a++"' is not 'Context:'"
++ "\n" ++ BC.unpack r
("Context:",rest) ->
case get_context rest of
(cont, rest') ->
case silly_lex rest' of
("New patches:", rest'') ->
case parse_patches rest'' of
Sealed ps'' -> seal_up_patches ps'' cont
(a,_) -> Left $ "Malformed patch bundle: '" ++ a ++
"' is not 'New patches:'"
("-----BEGIN PGP SIGNED MESSAGE-----",rest) ->
scan_bundle $ filter_gpg_dashes rest
(_,rest) -> scan_bundle rest
where seal_up_patches :: RepoPatch p => FL (PatchInfoAnd p) C(x y) -> [PatchInfo]
-> Either String (SealedPatchSet p)
seal_up_patches xxx yyy =
case reverse yyy of
(x:_) | is_tag x ->
Right $ Sealed ((reverseFL xxx +<+ unavailable_patches yyy)
:<: 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 ((reverseFL xxx +<+ unavailable_patches yyy)
:<: NilRL)
-- filter_gpg_dashes is needed because clearsigned patches escape dashes:
filter_gpg_dashes :: B.ByteString -> B.ByteString
filter_gpg_dashes ps =
unlinesPS $ map drop_dashes $
takeWhile (/= BC.pack "-----END PGP SIGNED MESSAGE-----") $
dropWhile not_context_or_newpatches $ linesPS ps
where drop_dashes x = if B.length x < 2 then x
else if BC.pack "- " `B.isPrefixOf` x
then B.drop 2 x
else x
not_context_or_newpatches s = (s /= BC.pack "Context:") &&
(s /= BC.pack "New patches:")
unavailable_patches :: RepoPatch p => [PatchInfo] -> RL (PatchInfoAnd p) C(x y)
unavailable_patches [] = unsafeCoerceP NilRL
unavailable_patches (x:xs) = pi_unavailable x :<: unavailable_patches xs
pi_unavailable :: RepoPatch p => PatchInfo -> PatchInfoAnd p C(x y)
pi_unavailable i = (i `patchInfoAndPatch`
unavailable ("Patch not stored in patch bundle:\n" ++
renderString (human_friendly i)))
get_context :: B.ByteString -> ([PatchInfo],B.ByteString)
get_context ps =
case readPatchInfo ps of
Just (pinfo,r') ->
case get_context r' of
(pis,r'') -> (pinfo:pis, r'')
Nothing -> ([],ps)
(-:-) :: a C(x y) -> (Sealed (FL a C(y)),b) -> (Sealed (FL a C(x)),b)
p -:- (Sealed ps, r) = (Sealed (p:>:ps), r)
get_patches :: RepoPatch p => B.ByteString -> (Sealed (FL (PatchInfoAnd p) C(x)), B.ByteString)
get_patches ps =
case readPatchInfo ps of
Nothing -> (Sealed NilFL, ps)
Just (pinfo,_) ->
case readPatch ps of
Nothing -> (Sealed NilFL, ps)
Just (Sealed p, r) -> (pinfo `piap` p) -:- get_patches r
parse_patches :: RepoPatch p => B.ByteString -> Sealed (FL (PatchInfoAnd p) C(x))
parse_patches ps =
case readPatchInfo ps of
Nothing -> Sealed NilFL
Just (pinfo,_) ->
case readPatch ps of
Nothing -> Sealed NilFL
Just (Sealed p, r) -> ((pinfo `piap` p) :>:) `mapSeal` parse_patches r
silly_lex :: B.ByteString -> (String, B.ByteString)
silly_lex ps = (BC.unpack a, b)
where
(a, b) = BC.break (== '\n') (dropSpace ps)
{-
silly_lex ps = (BC.unpack $ BC.takeWhile (/='\n') ps', BC.dropWhile (/='\n') ps')
where
ps' = dropSpace ps
-}
make_context :: [PatchInfo] -> Doc
make_context common =
text ""
$$ text "Context:"
$$ text ""
$$ (vcat $ map showPatchInfo $ common)
$$ text ""
scan_context :: RepoPatch p => B.ByteString -> PatchSet p C(x)
scan_context ps
| B.null ps = error "Bad context!"
| otherwise =
case silly_lex ps of
("Context:",rest) ->
case get_context rest of
(cont, _) -> unavailable_patches cont :<: NilRL
("-----BEGIN PGP SIGNED MESSAGE-----",rest) ->
scan_context $ filter_gpg_dashes rest
(_,rest) -> scan_context rest