src/Darcs/Patch/Bundle.lhs

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