1 -- Copyright (C) 2002-2004,2007 David Roundy 2 -- 3 -- This program is free software; you can redistribute it and/or modify 4 -- it under the terms of the GNU General Public License as published by 5 -- the Free Software Foundation; either version 2, or (at your option) 6 -- any later version. 7 -- 8 -- This program is distributed in the hope that it will be useful, 9 -- but WITHOUT ANY WARRANTY; without even the implied warranty of 10 -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 -- GNU General Public License for more details. 12 -- 13 -- You should have received a copy of the GNU General Public License 14 -- along with this program; see the file COPYING. If not, write to 15 -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 16 -- Boston, MA 02110-1301, USA. 17 18 {-# OPTIONS_GHC -cpp #-} 19 {-# LANGUAGE CPP #-} 20 21 #include "gadts.h" 22 23 module Darcs.Patch.Bundle ( hash_bundle, make_bundle, make_bundle2, scan_bundle, 24 make_context, scan_context, 25 ) where 26 27 import Darcs.Flags ( DarcsFlag( Unified ) ) 28 import Darcs.Hopefully ( PatchInfoAnd, piap, 29 patchInfoAndPatch, 30 unavailable, hopefully ) 31 import Darcs.Patch ( RepoPatch, Named, showPatch, showContextPatch, readPatch ) 32 import Darcs.Patch.Info ( PatchInfo, readPatchInfo, showPatchInfo, human_friendly, is_tag ) 33 import Darcs.Patch.Set ( PatchSet, SealedPatchSet ) 34 import Darcs.Ordered ( RL(..), FL(..), unsafeCoerceP, 35 reverseFL, (+<+), mapFL, mapFL_FL ) 36 import Printer ( Doc, renderPS, newline, text, ($$), 37 (<>), vcat, vsep, renderString ) 38 import Darcs.SlurpDirectory ( Slurpy ) 39 40 import ByteStringUtils ( linesPS, unlinesPS, dropSpace, substrPS) 41 import qualified Data.ByteString as B (ByteString, length, null, drop, isPrefixOf) 42 import qualified Data.ByteString.Char8 as BC (unpack, break, pack) 43 44 import SHA1( sha1PS ) 45 import Darcs.Sealed ( Sealed(Sealed), mapSeal ) 46 47 hash_bundle :: RepoPatch p => [PatchInfo] -> FL (Named p) C(x y) -> String 48 hash_bundle _ to_be_sent = sha1PS $ renderPS 49 $ vcat (mapFL showPatch to_be_sent) <> newline 50 51 make_bundle :: RepoPatch p => [DarcsFlag] -> Slurpy -> [PatchInfo] -> FL (Named p) C(x y) -> Doc 52 make_bundle opts the_s common to_be_sent = make_bundle2 opts the_s common to_be_sent to_be_sent 53 54 -- | In make_bundle2, it is presumed that the two patch sequences are 55 -- identical, but that they may be lazily generated. If two different 56 -- patch sequences are passed, a bundle with a mismatched hash will be 57 -- generated, which is not the end of the world, but isn't very useful 58 -- either. 59 make_bundle2 :: RepoPatch p => [DarcsFlag] -> Slurpy -> [PatchInfo] 60 -> FL (Named p) C(x y) -> FL (Named p) C(x y) -> Doc 61 make_bundle2 opts the_s common to_be_sent to_be_sent2 = 62 text "" 63 $$ text "New patches:" 64 $$ text "" 65 $$ the_new 66 $$ text "" 67 $$ text "Context:" 68 $$ text "" 69 $$ (vcat $ map showPatchInfo common) 70 $$ text "Patch bundle hash:" 71 $$ text (hash_bundle common to_be_sent2) 72 $$ text "" 73 where the_new = if Unified `elem` opts 74 then showContextPatch the_s to_be_sent 75 else vsep $ mapFL showPatch to_be_sent 76 77 scan_bundle :: RepoPatch p => B.ByteString -> Either String (SealedPatchSet p) 78 scan_bundle ps 79 | B.null ps = Left "Bad patch bundle!" 80 | otherwise = 81 case silly_lex ps of 82 ("New patches:",rest) -> 83 case get_patches rest of 84 (Sealed patches, rest') -> 85 case silly_lex rest' of 86 ("Context:", rest'') -> 87 case get_context rest'' of 88 (cont,maybe_hash) -> 89 case substrPS (BC.pack "Patch bundle hash:") 90 maybe_hash of 91 Just n -> 92 if hash_bundle cont (mapFL_FL hopefully patches) 93 == fst (silly_lex $ snd $ silly_lex $ 94 B.drop n maybe_hash) 95 then seal_up_patches patches cont 96 else Left $ 97 "Patch bundle failed hash!\n" ++ 98 "This probably means that the patch has been "++ 99 "corrupted by a mailer.\n"++ 100 "The most likely culprit is CRLF newlines." 101 Nothing -> seal_up_patches patches cont 102 (a,r) -> Left $ "Malformed patch bundle: '"++a++"' is not 'Context:'" 103 ++ "\n" ++ BC.unpack r 104 ("Context:",rest) -> 105 case get_context rest of 106 (cont, rest') -> 107 case silly_lex rest' of 108 ("New patches:", rest'') -> 109 case parse_patches rest'' of 110 Sealed ps'' -> seal_up_patches ps'' cont 111 (a,_) -> Left $ "Malformed patch bundle: '" ++ a ++ 112 "' is not 'New patches:'" 113 ("-----BEGIN PGP SIGNED MESSAGE-----",rest) -> 114 scan_bundle $ filter_gpg_dashes rest 115 (_,rest) -> scan_bundle rest 116 where seal_up_patches :: RepoPatch p => FL (PatchInfoAnd p) C(x y) -> [PatchInfo] 117 -> Either String (SealedPatchSet p) 118 seal_up_patches xxx yyy = 119 case reverse yyy of 120 (x:_) | is_tag x -> 121 Right $ Sealed ((reverseFL xxx +<+ unavailable_patches yyy) 122 :<: NilRL) 123 -- The above NilRL isn't quite 124 -- right, because ther *are* 125 -- earlier patches, but we 126 -- can't set this to undefined 127 -- because there are 128 -- situations where we look at 129 -- the rest. :{ 130 131 -- bug "No more patches in patch bundle!") 132 _ -> Right $ Sealed ((reverseFL xxx +<+ unavailable_patches yyy) 133 :<: NilRL) 134 135 -- filter_gpg_dashes is needed because clearsigned patches escape dashes: 136 filter_gpg_dashes :: B.ByteString -> B.ByteString 137 filter_gpg_dashes ps = 138 unlinesPS $ map drop_dashes $ 139 takeWhile (/= BC.pack "-----END PGP SIGNED MESSAGE-----") $ 140 dropWhile not_context_or_newpatches $ linesPS ps 141 where drop_dashes x = if B.length x < 2 then x 142 else if BC.pack "- " `B.isPrefixOf` x 143 then B.drop 2 x 144 else x 145 not_context_or_newpatches s = (s /= BC.pack "Context:") && 146 (s /= BC.pack "New patches:") 147 148 unavailable_patches :: RepoPatch p => [PatchInfo] -> RL (PatchInfoAnd p) C(x y) 149 unavailable_patches [] = unsafeCoerceP NilRL 150 unavailable_patches (x:xs) = pi_unavailable x :<: unavailable_patches xs 151 152 pi_unavailable :: RepoPatch p => PatchInfo -> PatchInfoAnd p C(x y) 153 pi_unavailable i = (i `patchInfoAndPatch` 154 unavailable ("Patch not stored in patch bundle:\n" ++ 155 renderString (human_friendly i))) 156 get_context :: B.ByteString -> ([PatchInfo],B.ByteString) 157 get_context ps = 158 case readPatchInfo ps of 159 Just (pinfo,r') -> 160 case get_context r' of 161 (pis,r'') -> (pinfo:pis, r'') 162 Nothing -> ([],ps) 163 (-:-) :: a C(x y) -> (Sealed (FL a C(y)),b) -> (Sealed (FL a C(x)),b) 164 p -:- (Sealed ps, r) = (Sealed (p:>:ps), r) 165 get_patches :: RepoPatch p => B.ByteString -> (Sealed (FL (PatchInfoAnd p) C(x)), B.ByteString) 166 get_patches ps = 167 case readPatchInfo ps of 168 Nothing -> (Sealed NilFL, ps) 169 Just (pinfo,_) -> 170 case readPatch ps of 171 Nothing -> (Sealed NilFL, ps) 172 Just (Sealed p, r) -> (pinfo `piap` p) -:- get_patches r 173 parse_patches :: RepoPatch p => B.ByteString -> Sealed (FL (PatchInfoAnd p) C(x)) 174 parse_patches ps = 175 case readPatchInfo ps of 176 Nothing -> Sealed NilFL 177 Just (pinfo,_) -> 178 case readPatch ps of 179 Nothing -> Sealed NilFL 180 Just (Sealed p, r) -> ((pinfo `piap` p) :>:) `mapSeal` parse_patches r 181 182 silly_lex :: B.ByteString -> (String, B.ByteString) 183 silly_lex ps = (BC.unpack a, b) 184 where 185 (a, b) = BC.break (== '\n') (dropSpace ps) 186 187 {- 188 silly_lex ps = (BC.unpack $ BC.takeWhile (/='\n') ps', BC.dropWhile (/='\n') ps') 189 where 190 ps' = dropSpace ps 191 -} 192 193 make_context :: [PatchInfo] -> Doc 194 make_context common = 195 text "" 196 $$ text "Context:" 197 $$ text "" 198 $$ (vcat $ map showPatchInfo $ common) 199 $$ text "" 200 201 scan_context :: RepoPatch p => B.ByteString -> PatchSet p C(x) 202 scan_context ps 203 | B.null ps = error "Bad context!" 204 | otherwise = 205 case silly_lex ps of 206 ("Context:",rest) -> 207 case get_context rest of 208 (cont, _) -> unavailable_patches cont :<: NilRL 209 ("-----BEGIN PGP SIGNED MESSAGE-----",rest) -> 210 scan_context $ filter_gpg_dashes rest 211 (_,rest) -> scan_context rest