-- largely stolen from darcswatch (http://darcs.nomeata.de/darcswatch)

{-
Copyright (C) 2008 Joachim Breitner

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

{-# LANGUAGE BangPatterns #-}
module DPM.Core.PatchBundleParser
        ( PatchBundle
        , PatchInfo(..)
        , scanBundle
        , readDiffFromString
        ) where

import Control.Arrow
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Char8 (ByteString)
import Data.List
import Data.Either

import DPM.Core.DataTypes ( PatchID(..) )

-- | The defining informtion of a Darcs patch.
data PatchInfo = PatchInfo
        { piDate    :: String
        , piName    :: String
        , piAuthor  :: String
        , piLog     :: [String]
        , piInverted :: Bool
   } deriving (Eq,Ord,Show)

-- | A patch bundle (e.g. a mail)
type PatchBundle = [(PatchInfo, ByteString)]


readPatchInfos :: ByteString -> [PatchInfo]
readPatchInfos inv | B.null inv = []
readPatchInfos inv = case breakOn '[' inv of
                        (_,r) -> case readPatchInfo r of
                             Just (pinfo,r) -> pinfo : readPatchInfos r
                             Nothing -> []

readPatchInfo :: ByteString -> Maybe (PatchInfo, ByteString)
readPatchInfo s =
    if B.null s' || B.head s' /= '[' -- ]
    then Nothing
    else case breakOn '\n' (B.tail s') of
         (!name,s') | B.null s' ->
                        error $ "Broken file (1) " ++ show (B.unpack s)
                    | otherwise ->
             case breakOn '*' $ B.tail s' of
             (!author,s2) | B.null s2 -> error "Broken file (2)"
                          | otherwise ->
                 case B.break (\c->c==']'||c=='\n') $ B.drop 2 s2 of
                 (!ct,!s''') ->
                     do (!log, !s4) <-
                            lines_starting_with_ending_with ' ' ']' $ dn s'''
                        let not_star = B.index s2 1 /= '*'
                        not_star `seq` return
                                ( PatchInfo { piDate = B.unpack ct
                                            , piName = B.unpack name
                                            , piAuthor = B.unpack author
                                            , piLog = map B.unpack log
                                            , piInverted = not_star
                                            }, s4)
    where dn x = if B.null x || B.head x /= '\n' then x else B.tail x
          s' = dropWhite s

lines_starting_with_ending_with :: Char -> Char -> ByteString
                                -> Maybe ([ByteString],ByteString)
lines_starting_with_ending_with st en s = lswew s
    where
  lswew x | B.null x = Nothing
  lswew x =
    if B.head x == en
    then Just ([], B.tail x)
    else if B.head x /= st
         then Nothing
         else case breakOn '\n' $ B.tail x of
              (!l,r) -> case lswew $ B.tail r of
                       Just (!ls,r') -> Just (l:ls,r')
                       Nothing ->
                           case breakLast en l of
                           Just (!l2,_) ->
                                let rest = B.drop (B.length l2+2) x in
                                rest `seq` Just ([l2],  B.drop (B.length l2+2) x)
                           Nothing -> Nothing


dropWhite = B.dropWhile (`elem` " \n\t\r")
breakOn :: Char -> ByteString -> (ByteString, ByteString)
breakOn c = B.break (==c)

breakLast c p = case B.elemIndexEnd c p of
    Nothing -> Nothing
    Just n -> Just (B.take n p, B.drop (n+1) p)

-- This function seems to cause a stack overflow when compiled *without* -O2.
scanBundle :: ByteString -> Either String PatchBundle
scanBundle ps
  | B.null ps = Left "Bad patch bundle!"
  | otherwise =
    case silly_lex ps of
    ("New patches:",rest) ->
        case get_patches rest of
        (submitted, rest') ->
            case silly_lex rest' of
            ("Context:", rest'') ->
                case get_context rest'' of
                (context,maybe_hash) -> -- FIXME verify patch bundle hash
                    returnResult submitted
            (a,r) -> Left $ "Malformed patch bundle: '"++a++"' is not 'Context:'"
                            ++ "\n" ++  B.unpack r
    ("Context:",rest) ->
        case get_context rest of
        (context, rest') ->
            case silly_lex rest' of
            ("New patches:", rest'') ->
                case get_patches rest'' of
                (submitted,_) -> returnResult submitted
            (a,_) -> Left $ "Malformed patch bundle: '" ++ a ++
                            "' is not 'New patches:'"
    ("-----BEGIN PGP SIGNED MESSAGE-----",rest) ->
            scanBundle $ filter_gpg_dashes rest
    (_,rest) -> scanBundle rest
    where
      returnResult list = Right list

get_patches :: ByteString -> ([(PatchInfo,ByteString)], ByteString)
get_patches ps = get_patches' ps []
    where
      get_patches' ps acc =
        case readPatchInfo ps of
          Nothing -> (reverse acc, ps)
          Just (pinfo,ps) ->
            case readDiff ps of
              Nothing -> (reverse acc, ps)
              Just (diff, r) ->
                get_patches' r ((pinfo, diff) : acc)


silly_lex :: ByteString -> (String, ByteString)
silly_lex = first B.unpack . B.span (/='\n') . dropWhite

scan_context :: ByteString -> [PatchInfo]
scan_context = fst . get_context

get_context :: ByteString -> ([PatchInfo],ByteString)
get_context ps =
    case readPatchInfo ps of
    Just (pinfo,r') -> pinfo -:- get_context r'
    Nothing -> ([],ps)

filter_gpg_dashes :: ByteString -> ByteString
filter_gpg_dashes ps =
    B.unlines $ map drop_dashes $
    takeWhile (/= litEndPGPSignedMessages) $
    dropWhile not_context_or_newpatches $ B.lines ps
    where drop_dashes x = if B.length x < 2 then x
                          else if B.take 2 x == litDashSpace
                               then B.drop 2 x
                               else x
          not_context_or_newpatches s = (s /= litContext) &&
                                        (s /= litNewPatches)

readDiffFromString :: String -> Maybe (ByteString, ByteString)
readDiffFromString = readDiff . B.pack

readDiff :: ByteString -> Maybe (ByteString, ByteString)
readDiff s =
        if B.null s' then Nothing
        else do n <- findSplitPoint s' initMode 0
                return $ B.splitAt n s'
  where s' = dropWhite s
        initMode = litOpenAngle `B.isPrefixOf` s'
        findSplitPoint :: ByteString -> Bool -- whether inside <...> or not
                       -> Int -> Maybe Int
        findSplitPoint s _ _ | B.null s = Nothing
        findSplitPoint s True acc =
            case drop litNewlineCloseAngle s of
              Just (rest, n) -> findSplitPoint rest False (acc + n)
              Nothing -> findSplitPoint (B.tail s) True (acc + 1)
        findSplitPoint s False acc =
            case drop litNewlineOpenAngle s of
              Just (rest, n) -> findSplitPoint rest True (acc + n)
              Nothing ->
                  if litNewlineNewlineContext `B.isPrefixOf` s ||
                     litNewlineBracket `B.isPrefixOf` s
                     then Just acc
                     else findSplitPoint (B.tail s) False (acc + 1)
        drop init s =
            if init `B.isPrefixOf` s
               then let n = B.length init
                        in Just (B.drop n s, n)
               else Nothing

(-:-) :: a -> ([a],b)  -> ([a],b)
a -:- (as,r) = (a:as,r)

addSlash filename | last filename == '/' = filename
                  | otherwise            = filename ++ "/"

-- Packed bytestring literators, to avoid re-packing them constantly (ghc is
-- probably not smart enough to do it by itself

litHashedDarcs2 = B.pack "hashed\ndarcs-2\n"
litDarcs10 = B.pack "darcs-1.0\n"
litHashed = B.pack "hashed\n"
litStartingWithTag = B.pack "Starting with tag:"
litPristine = B.pack "pristine"
litStartingWithInventory = B.pack "Starting with inventory:"
litEndPGPSignedMessages = B.pack "-----END PGP SIGNED MESSAGE-----"
litDashSpace = B.pack "- "
litContext = B.pack "Context:"
litNewPatches = B.pack "New patches:"
litNewlineNewlineContext = B.pack "\n\nContext:"
litNewlineBracket = B.pack "\n["
litNewlineOpenAngle = B.pack "\n<"
litOpenAngle = B.pack "<"
litNewlineCloseAngle = B.pack "\n>"
litT = B.pack "t"
litF = B.pack "f"