    -- 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, isUnified )
    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.Witnesses.Ordered ( RL(..), FL(..), unsafeCoerceP,
                                 reverseFL, (+<+), mapFL, mapFL_FL )
    import Printer ( Doc, renderPS, newline, text, ($$),
                     (<>), vcat, vsep, renderString )

    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.Witnesses.Sealed ( Sealed(Sealed), mapSeal )

    import Storage.Hashed.Tree( Tree )
    import Storage.Hashed.Monad( virtualTreeIO )

    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] -> Tree IO -> [PatchInfo] -> FL (Named p) C(x y) -> IO 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] -> Tree IO -> [PatchInfo]
                 -> FL (Named p) C(x y) -> FL (Named p) C(x y) -> IO Doc
    make_bundle2 opts the_s common to_be_sent to_be_sent2 =
        do patches <- case (isUnified opts) of
                        True -> fst `fmap` virtualTreeIO (showContextPatch to_be_sent) the_s
                        False -> return (vsep $ mapFL showPatch to_be_sent)
           return $ format patches
        where format the_new = 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 ""

    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 getContext 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 getContext 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)))
    getContext :: B.ByteString -> ([PatchInfo],B.ByteString)
    getContext ps =
        case readPatchInfo ps of
        Just (pinfo,r') ->
            case getContext 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 getContext rest of
            (cont, _) -> unavailable_patches cont :<: NilRL
        ("-----BEGIN PGP SIGNED MESSAGE-----",rest) ->
                scan_context $ filter_gpg_dashes rest
        (_,rest) -> scan_context rest