Bundle.lhs

%  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.

\begin{code}
{-# OPTIONS_GHC -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 )
import Darcs.Patch.Set ( PatchSet, SealedPatchSet )
import Darcs.Patch.Ordered ( RL(..), FL(..), unsafeCoerceP,
                             reverseFL, (+<+), mapFL, mapFL_FL )
import Printer ( Doc, renderPS, newline, text, ($$),
                 (<>), vcat, vsep, renderString )
import Darcs.SlurpDirectory ( Slurpy )
import FastPackedString ( PackedString, unpackPS, packString,
                          lengthPS, takePS, dropPS, linesPS, unlinesPS,
                          dropWhitePS, takeWhilePS, dropWhilePS,
                          nullPS, substrPS,
                        )
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
\end{code}

\begin{code}
scan_bundle :: RepoPatch p => PackedString -> Either String (SealedPatchSet p)
scan_bundle ps
  | nullPS 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 (packString "Patch bundle hash:")
                         maybe_hash of
                    Just n ->
                        if hash_bundle cont (mapFL_FL hopefully patches)
                               == fst (silly_lex $ snd $ silly_lex $
                                       dropPS n maybe_hash)
                        then Right $ Sealed ((reverseFL patches +<+ unavailable_patches cont) :<: NilRL)
                        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 -> Right $ Sealed ((reverseFL patches +<+ unavailable_patches cont) :<: NilRL)
            (a,r) -> Left $ "Malformed patch bundle: '"++a++"' is not 'Context:'"
                     ++ "\n" ++ unpackPS 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'' -> Right $ Sealed ((reverseFL ps'' +<+ unavailable_patches cont) :<: NilRL)
            (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

-- filter_gpg_dashes is needed because clearsigned patches escape dashes:
filter_gpg_dashes :: PackedString -> PackedString
filter_gpg_dashes ps =
    unlinesPS $ map drop_dashes $
    takeWhile (/= packString "-----END PGP SIGNED MESSAGE-----") $
    dropWhile not_context_or_newpatches $ linesPS ps
    where drop_dashes x = if lengthPS x < 2 then x
                          else if takePS 2 x == packString "- "
                               then dropPS 2 x
                               else x
          not_context_or_newpatches s = (s /= packString "Context:") &&
                                        (s /= packString "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 :: PackedString -> ([PatchInfo],PackedString)
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 => PackedString -> (Sealed (FL (PatchInfoAnd p) C(x)), PackedString)
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 => PackedString -> 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 :: PackedString -> (String, PackedString)
silly_lex ps = (unpackPS $ takeWhilePS (/='\n') $ dropWhitePS ps,
                dropWhilePS (/='\n') $ dropWhitePS ps)
\end{code}

\begin{code}
make_context :: [PatchInfo] -> Doc
make_context common =
    text ""
 $$ text "Context:"
 $$ text ""
 $$ (vcat $ map showPatchInfo $ common)
 $$ text ""
\end{code}

\begin{code}
scan_context :: RepoPatch p => PackedString -> PatchSet p C(x)
scan_context ps
  | nullPS 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
\end{code}