-- Copyright (C) 2002-2003 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.

module Darcs.Patch.Info
    ( PatchInfo(..) -- constructor and fields exported *only for tests*
    , rawPatchInfo  -- exported *only for tests*
    , patchinfo
    , invertName
    , addJunk
    , makePatchname
    , readPatchInfo
    , justName
    , justAuthor
    , justLog
    , displayPatchInfo
    , toXml
    , toXmlShort
    , piDate
    , setPiDate
    , piDateString
    , piName
    , piRename
    , piAuthor
    , piTag
    , piLog
    , showPatchInfo
    , isTag
    , escapeXML
    , validDate
    , validLog
    , validAuthor
    , validDatePS
    , validLogPS
    , validAuthorPS
    ) where

import Prelude ( (^) )
import Darcs.Prelude

import Data.Char ( isAscii )
import System.Random ( randomRIO )
import Numeric ( showHex )
import Control.Monad ( when, unless, void )

import Darcs.Util.ByteString
    ( decodeLocale
    , packStringToUTF8
    , unlinesPS
    , unpackPSFromUTF8
    )
import qualified Darcs.Patch.ReadMonads as RM ( take )
import Darcs.Patch.ReadMonads as RM ( skipSpace, char,
                                      takeTill, anyChar, ParserM,
                                      option,
                                      takeTillChar,
                                      linesStartingWithEndingWith)
import Darcs.Patch.Show ( ShowPatchFor(..) )
import qualified Data.ByteString       as B  (length, splitAt, null
                                             ,isPrefixOf, tail, concat
                                             ,empty, head, cons, append
                                             ,ByteString )
import qualified Data.ByteString.Char8 as BC
    ( index, head, notElem, all, unpack, pack )
import Data.List( isPrefixOf )

import Darcs.Util.Printer ( Doc, packedString,
                 empty, ($$), (<+>), vcat, text, cyanText, blueText, prefix )
import Darcs.Util.IsoDate ( readUTCDate )
import System.Time ( CalendarTime, calendarTimeToString, toClockTime,
                     toCalendarTime )
import System.IO.Unsafe ( unsafePerformIO )
import Darcs.Util.Hash ( sha1PS, SHA1 )
import Darcs.Util.Prompt ( promptYorn )
import Darcs.Util.Show ( appPrec )

-- | A PatchInfo value contains the metadata of a patch. The date, name, author
-- and log fields are UTF-8 encoded text in darcs 2.4 and later, and just
-- sequences of bytes (decoded with whatever is the locale when displayed) in
-- earlier darcs.
--
-- The members with names that start with '_' are not supposed to be used
-- directly in code that does not care how the patch info is stored.
data PatchInfo = PatchInfo { PatchInfo -> ByteString
_piDate    :: !B.ByteString
                           , PatchInfo -> ByteString
_piName    :: !B.ByteString
                           , PatchInfo -> ByteString
_piAuthor  :: !B.ByteString
                           , PatchInfo -> [ByteString]
_piLog     :: ![B.ByteString]
                           , PatchInfo -> Bool
isInverted :: !Bool
                           }
                 deriving (PatchInfo -> PatchInfo -> Bool
(PatchInfo -> PatchInfo -> Bool)
-> (PatchInfo -> PatchInfo -> Bool) -> Eq PatchInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PatchInfo -> PatchInfo -> Bool
$c/= :: PatchInfo -> PatchInfo -> Bool
== :: PatchInfo -> PatchInfo -> Bool
$c== :: PatchInfo -> PatchInfo -> Bool
Eq,Eq PatchInfo
Eq PatchInfo =>
(PatchInfo -> PatchInfo -> Ordering)
-> (PatchInfo -> PatchInfo -> Bool)
-> (PatchInfo -> PatchInfo -> Bool)
-> (PatchInfo -> PatchInfo -> Bool)
-> (PatchInfo -> PatchInfo -> Bool)
-> (PatchInfo -> PatchInfo -> PatchInfo)
-> (PatchInfo -> PatchInfo -> PatchInfo)
-> Ord PatchInfo
PatchInfo -> PatchInfo -> Bool
PatchInfo -> PatchInfo -> Ordering
PatchInfo -> PatchInfo -> PatchInfo
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PatchInfo -> PatchInfo -> PatchInfo
$cmin :: PatchInfo -> PatchInfo -> PatchInfo
max :: PatchInfo -> PatchInfo -> PatchInfo
$cmax :: PatchInfo -> PatchInfo -> PatchInfo
>= :: PatchInfo -> PatchInfo -> Bool
$c>= :: PatchInfo -> PatchInfo -> Bool
> :: PatchInfo -> PatchInfo -> Bool
$c> :: PatchInfo -> PatchInfo -> Bool
<= :: PatchInfo -> PatchInfo -> Bool
$c<= :: PatchInfo -> PatchInfo -> Bool
< :: PatchInfo -> PatchInfo -> Bool
$c< :: PatchInfo -> PatchInfo -> Bool
compare :: PatchInfo -> PatchInfo -> Ordering
$ccompare :: PatchInfo -> PatchInfo -> Ordering
$cp1Ord :: Eq PatchInfo
Ord)

instance Show PatchInfo where
    showsPrec :: Int -> PatchInfo -> ShowS
showsPrec d :: Int
d (PatchInfo date :: ByteString
date name :: ByteString
name author :: ByteString
author log :: [ByteString]
log inverted :: Bool
inverted) =
        Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
appPrec) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
            String -> ShowS
showString "rawPatchInfo " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Int
appPrec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) ByteString
date ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            String -> ShowS
showString " " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Int
appPrec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) ByteString
name ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            String -> ShowS
showString " " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Int
appPrec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) ByteString
author ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            String -> ShowS
showString " " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [ByteString] -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Int
appPrec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) [ByteString]
log ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            String -> ShowS
showString " " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Bool -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Int
appPrec Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Bool
inverted

-- Validation

-- We need these functions to ensure that we can parse the
-- result of showPatchInfo.

validDate :: String -> Bool
validDate :: String -> Bool
validDate = (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
validCharForDate

validDatePS :: B.ByteString -> Bool
validDatePS :: ByteString -> Bool
validDatePS = (Char -> Bool) -> ByteString -> Bool
BC.all Char -> Bool
validCharForDate

-- | The isAscii limitation is due to the use of BC.pack below.
validCharForDate :: Char -> Bool
validCharForDate :: Char -> Bool
validCharForDate c :: Char
c = Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '\n' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= ']'

validLog :: String -> Bool
validLog :: String -> Bool
validLog = Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem '\n'

validLogPS :: B.ByteString -> Bool
validLogPS :: ByteString -> Bool
validLogPS = Char -> ByteString -> Bool
BC.notElem '\n'

validAuthor :: String -> Bool
validAuthor :: String -> Bool
validAuthor = Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem '*'

validAuthorPS :: B.ByteString -> Bool
validAuthorPS :: ByteString -> Bool
validAuthorPS = Char -> ByteString -> Bool
BC.notElem '*'

rawPatchInfo :: String -> String -> String -> [String] -> Bool -> PatchInfo
rawPatchInfo :: String -> String -> String -> [String] -> Bool -> PatchInfo
rawPatchInfo date :: String
date name :: String
name author :: String
author log :: [String]
log inverted :: Bool
inverted =
    $WPatchInfo :: ByteString
-> ByteString -> ByteString -> [ByteString] -> Bool -> PatchInfo
PatchInfo { _piDate :: ByteString
_piDate     = String -> ByteString
BC.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ ShowS
validateDate String
date
              , _piName :: ByteString
_piName     = String -> ByteString
packStringToUTF8 (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ ShowS
validateName String
name
              , _piAuthor :: ByteString
_piAuthor   = String -> ByteString
packStringToUTF8 (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ ShowS
validateAuthor String
author
              , _piLog :: [ByteString]
_piLog      = (String -> ByteString) -> [String] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (String -> ByteString
packStringToUTF8 (String -> ByteString) -> ShowS -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
validateLog) [String]
log
              , isInverted :: Bool
isInverted  = Bool
inverted }
  where
    validateAuthor :: ShowS
validateAuthor = (String -> Bool) -> String -> ShowS
forall a. Show a => (a -> Bool) -> String -> a -> a
validate String -> Bool
validAuthor "author"
    validateName :: ShowS
validateName = (String -> Bool) -> String -> ShowS
forall a. Show a => (a -> Bool) -> String -> a -> a
validate String -> Bool
validLog "patch name"
    validateLog :: ShowS
validateLog = (String -> Bool) -> String -> ShowS
forall a. Show a => (a -> Bool) -> String -> a -> a
validate String -> Bool
validLog "log line"
    validateDate :: ShowS
validateDate = (String -> Bool) -> String -> ShowS
forall a. Show a => (a -> Bool) -> String -> a -> a
validate String -> Bool
validDate "date"
    validate :: (a -> Bool) -> String -> a -> a
validate test :: a -> Bool
test meta :: String
meta x :: a
x =
      if a -> Bool
test a
x then a
x else String -> a
forall a. HasCallStack => String -> a
error ([String] -> String
unwords ["invalid",String
meta,a -> String
forall a. Show a => a -> String
show a
x])

-- | @patchinfo date name author log@ constructs a new 'PatchInfo' value
-- with the given details, automatically assigning an Ignore-this header
-- to guarantee the patch is unique.  The function does not verify
-- the date string's sanity.
patchinfo :: String -> String -> String -> [String] -> IO PatchInfo
patchinfo :: String -> String -> String -> [String] -> IO PatchInfo
patchinfo date :: String
date name :: String
name author :: String
author log :: [String]
log =
    PatchInfo -> IO PatchInfo
addJunk (PatchInfo -> IO PatchInfo) -> PatchInfo -> IO PatchInfo
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> [String] -> Bool -> PatchInfo
rawPatchInfo String
date String
name String
author [String]
log Bool
False

-- | addJunk adds a line that contains a random number to make the patch
--   unique.
addJunk :: PatchInfo -> IO PatchInfo
addJunk :: PatchInfo -> IO PatchInfo
addJunk pinf :: PatchInfo
pinf =
    do Integer
x <- (Integer, Integer) -> IO Integer
forall a. Random a => (a, a) -> IO a
randomRIO (0,2Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(128 ::Integer) :: Integer)
       Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PatchInfo -> [ByteString]
_piLog PatchInfo
pinf [ByteString] -> [ByteString] -> Bool
forall a. Eq a => a -> a -> Bool
/= [ByteString] -> [ByteString]
ignoreJunk (PatchInfo -> [ByteString]
_piLog PatchInfo
pinf)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            do String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Lines beginning with 'Ignore-this: ' " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                          "will not be shown when displaying a patch."
               Bool
confirmed <- String -> IO Bool
promptYorn "Proceed? "
               Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
confirmed (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "User cancelled because of Ignore-this."
       PatchInfo -> IO PatchInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (PatchInfo -> IO PatchInfo) -> PatchInfo -> IO PatchInfo
forall a b. (a -> b) -> a -> b
$ PatchInfo
pinf { _piLog :: [ByteString]
_piLog = String -> ByteString
BC.pack ([String] -> String
forall a. [a] -> a
head [String]
ignoredString -> ShowS
forall a. [a] -> [a] -> [a]
++Integer -> ShowS
forall a. (Integral a, Show a) => a -> ShowS
showHex Integer
x "")ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:
                                 PatchInfo -> [ByteString]
_piLog PatchInfo
pinf }

ignored :: [String] -- this is a [String] so we can change the junk header.
ignored :: [String]
ignored = ["Ignore-this: "]

ignoreJunk :: [B.ByteString] -> [B.ByteString]
ignoreJunk :: [ByteString] -> [ByteString]
ignoreJunk = (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter ByteString -> Bool
isnt_ignored
    where isnt_ignored :: ByteString -> Bool
isnt_ignored x :: ByteString
x = ByteString -> [ByteString] -> Bool
forall (t :: * -> *).
Foldable t =>
ByteString -> t ByteString -> Bool
doesnt_start_with ByteString
x ((String -> ByteString) -> [String] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map String -> ByteString
BC.pack [String]
ignored) -- TODO
          doesnt_start_with :: ByteString -> t ByteString -> Bool
doesnt_start_with x :: ByteString
x ys :: t ByteString
ys = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (ByteString -> Bool) -> t ByteString -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
x) t ByteString
ys


-- * Patch info formatting
invertName :: PatchInfo -> PatchInfo
invertName :: PatchInfo -> PatchInfo
invertName pi :: PatchInfo
pi = PatchInfo
pi { isInverted :: Bool
isInverted = Bool -> Bool
not (PatchInfo -> Bool
isInverted PatchInfo
pi) }

-- | Get the name, including an "UNDO: " prefix if the patch is inverted.
justName :: PatchInfo -> String
justName :: PatchInfo -> String
justName pinf :: PatchInfo
pinf = if PatchInfo -> Bool
isInverted PatchInfo
pinf then "UNDO: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
nameString
                                     else String
nameString
  where nameString :: String
nameString = ByteString -> String
metadataToString (PatchInfo -> ByteString
_piName PatchInfo
pinf)

-- | Returns the author of a patch.
justAuthor :: PatchInfo -> String
justAuthor :: PatchInfo -> String
justAuthor =  ByteString -> String
metadataToString (ByteString -> String)
-> (PatchInfo -> ByteString) -> PatchInfo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfo -> ByteString
_piAuthor

justLog :: PatchInfo -> String
justLog :: PatchInfo -> String
justLog = [String] -> String
unlines ([String] -> String)
-> (PatchInfo -> [String]) -> PatchInfo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> String) -> [ByteString] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> String
BC.unpack ([ByteString] -> [String])
-> (PatchInfo -> [ByteString]) -> PatchInfo -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfo -> [ByteString]
_piLog

displayPatchInfo :: PatchInfo -> Doc
displayPatchInfo :: PatchInfo -> Doc
displayPatchInfo pi :: PatchInfo
pi =
    String -> Doc
cyanText "patch " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
cyanText (SHA1 -> String
forall a. Show a => a -> String
show (SHA1 -> String) -> SHA1 -> String
forall a b. (a -> b) -> a -> b
$ PatchInfo -> SHA1
makePatchname PatchInfo
pi)
 Doc -> Doc -> Doc
$$ String -> Doc
text "Author: " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text (PatchInfo -> String
piAuthor PatchInfo
pi)
 Doc -> Doc -> Doc
$$ String -> Doc
text "Date:   " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text (ByteString -> String
friendlyD (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ PatchInfo -> ByteString
_piDate PatchInfo
pi)
 Doc -> Doc -> Doc
$$ String -> Doc
hfn (PatchInfo -> String
piName PatchInfo
pi)
 Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat ((String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> Doc
text "  " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>) (Doc -> Doc) -> (String -> Doc) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text) (PatchInfo -> [String]
piLog PatchInfo
pi))
  where hfn :: String -> Doc
hfn x :: String
x = case PatchInfo -> Maybe String
piTag PatchInfo
pi of
                Nothing -> Doc
inverted Doc -> Doc -> Doc
<+> String -> Doc
text String
x
                Just t :: String
t -> String -> Doc
text "  tagged" Doc -> Doc -> Doc
<+> String -> Doc
text String
t
        inverted :: Doc
inverted = if PatchInfo -> Bool
isInverted PatchInfo
pi then String -> Doc
text "  UNDO:" else String -> Doc
text "  *"

-- | Returns the name of the patch. Unlike 'justName', it does not preprend
--   "UNDO: " to the name if the patch is inverted.
piName :: PatchInfo -> String
piName :: PatchInfo -> String
piName = ByteString -> String
metadataToString (ByteString -> String)
-> (PatchInfo -> ByteString) -> PatchInfo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfo -> ByteString
_piName

piRename :: PatchInfo -> String -> PatchInfo
piRename :: PatchInfo -> String -> PatchInfo
piRename x :: PatchInfo
x n :: String
n = PatchInfo
x { _piName :: ByteString
_piName = String -> ByteString
packStringToUTF8 String
n }

-- | Returns the author of a patch.
piAuthor :: PatchInfo -> String
piAuthor :: PatchInfo -> String
piAuthor = ByteString -> String
metadataToString (ByteString -> String)
-> (PatchInfo -> ByteString) -> PatchInfo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfo -> ByteString
_piAuthor

isTag :: PatchInfo -> Bool
isTag :: PatchInfo -> Bool
isTag pinfo :: PatchInfo
pinfo = "TAG " String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` PatchInfo -> String
justName PatchInfo
pinfo

-- | Read the date from raw patch (meta) data and convert it to UTC.
-- The raw data may contain timezone info. This is for compatibiltity
-- with patches that were created before 2003-11, when darcs still
-- created patches that contained localized date strings.
readPatchDate :: B.ByteString -> CalendarTime
readPatchDate :: ByteString -> CalendarTime
readPatchDate = String -> CalendarTime
readUTCDate (String -> CalendarTime)
-> (ByteString -> String) -> ByteString -> CalendarTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BC.unpack

piDate :: PatchInfo -> CalendarTime
piDate :: PatchInfo -> CalendarTime
piDate = ByteString -> CalendarTime
readPatchDate (ByteString -> CalendarTime)
-> (PatchInfo -> ByteString) -> PatchInfo -> CalendarTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfo -> ByteString
_piDate

piDateString :: PatchInfo -> String
piDateString :: PatchInfo -> String
piDateString = ByteString -> String
BC.unpack (ByteString -> String)
-> (PatchInfo -> ByteString) -> PatchInfo -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfo -> ByteString
_piDate

setPiDate :: String -> PatchInfo -> PatchInfo
setPiDate :: String -> PatchInfo -> PatchInfo
setPiDate date :: String
date pi :: PatchInfo
pi = PatchInfo
pi { _piDate :: ByteString
_piDate = String -> ByteString
BC.pack String
date }

-- | Get the log message of a patch.
piLog :: PatchInfo -> [String]
piLog :: PatchInfo -> [String]
piLog = (ByteString -> String) -> [ByteString] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> String
metadataToString ([ByteString] -> [String])
-> (PatchInfo -> [ByteString]) -> PatchInfo -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> [ByteString]
ignoreJunk ([ByteString] -> [ByteString])
-> (PatchInfo -> [ByteString]) -> PatchInfo -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfo -> [ByteString]
_piLog

-- | Get the tag name, if the patch is a tag patch.
piTag :: PatchInfo -> Maybe String
piTag :: PatchInfo -> Maybe String
piTag pinf :: PatchInfo
pinf =
    if ByteString
l ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
t
      then String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ ByteString -> String
metadataToString ByteString
r
      else Maybe String
forall a. Maybe a
Nothing
    where (l :: ByteString
l, r :: ByteString
r) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt (ByteString -> Int
B.length ByteString
t) (PatchInfo -> ByteString
_piName PatchInfo
pinf)
          t :: ByteString
t = String -> ByteString
BC.pack "TAG "

-- | Convert a metadata ByteString to a string. It first tries to convert
--   using UTF-8, and if that fails, tries the locale encoding.
--   We try UTF-8 first because UTF-8 is clearly recognizable, widely used,
--   and people may have UTF-8 patches even when UTF-8 is not their locale.
metadataToString :: B.ByteString -> String
metadataToString :: ByteString -> String
metadataToString bs :: ByteString
bs | '\xfffd' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
bsUtf8 = String
bsUtf8
                    | Bool
otherwise                 = ByteString -> String
decodeLocale ByteString
bs
  where bsUtf8 :: String
bsUtf8 = ByteString -> String
unpackPSFromUTF8 ByteString
bs

friendlyD :: B.ByteString -> String
friendlyD :: ByteString -> String
friendlyD d :: ByteString
d = IO String -> String
forall a. IO a -> a
unsafePerformIO (IO String -> String) -> IO String -> String
forall a b. (a -> b) -> a -> b
$ do
    CalendarTime
ct <- ClockTime -> IO CalendarTime
toCalendarTime (ClockTime -> IO CalendarTime) -> ClockTime -> IO CalendarTime
forall a b. (a -> b) -> a -> b
$ CalendarTime -> ClockTime
toClockTime (CalendarTime -> ClockTime) -> CalendarTime -> ClockTime
forall a b. (a -> b) -> a -> b
$ ByteString -> CalendarTime
readPatchDate ByteString
d
    String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ CalendarTime -> String
calendarTimeToString CalendarTime
ct

toXml :: PatchInfo -> Doc
toXml :: PatchInfo -> Doc
toXml = Bool -> PatchInfo -> Doc
toXml' Bool
True

toXmlShort :: PatchInfo -> Doc
toXmlShort :: PatchInfo -> Doc
toXmlShort = Bool -> PatchInfo -> Doc
toXml' Bool
False

toXml' :: Bool -> PatchInfo -> Doc
toXml' :: Bool -> PatchInfo -> Doc
toXml' includeComments :: Bool
includeComments pi :: PatchInfo
pi =
        String -> Doc
text "<patch"
    Doc -> Doc -> Doc
<+> String -> Doc
text "author='" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> ByteString -> Doc
escapeXMLByteString (PatchInfo -> ByteString
_piAuthor PatchInfo
pi) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text "'"
    Doc -> Doc -> Doc
<+> String -> Doc
text "date='" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> ByteString -> Doc
escapeXMLByteString (PatchInfo -> ByteString
_piDate PatchInfo
pi) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text "'"
    Doc -> Doc -> Doc
<+> String -> Doc
text "local_date='" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
escapeXML (ByteString -> String
friendlyD (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ PatchInfo -> ByteString
_piDate PatchInfo
pi) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text "'"
    Doc -> Doc -> Doc
<+> String -> Doc
text "inverted='" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text (Bool -> String
forall a. Show a => a -> String
show (Bool -> String) -> Bool -> String
forall a b. (a -> b) -> a -> b
$ PatchInfo -> Bool
isInverted PatchInfo
pi) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text "'"
    Doc -> Doc -> Doc
<+> String -> Doc
text "hash='" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text (SHA1 -> String
forall a. Show a => a -> String
show (SHA1 -> String) -> SHA1 -> String
forall a b. (a -> b) -> a -> b
$ PatchInfo -> SHA1
makePatchname PatchInfo
pi) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text "'>"
    Doc -> Doc -> Doc
$$  Doc -> Doc
indent Doc
abstract
    Doc -> Doc -> Doc
$$  String -> Doc
text "</patch>"
      where
        indent :: Doc -> Doc
indent = String -> Doc -> Doc
prefix "    "
        name :: Doc
name = String -> Doc
text "<name>" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> ByteString -> Doc
escapeXMLByteString (PatchInfo -> ByteString
_piName PatchInfo
pi) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text "</name>"
        abstract :: Doc
abstract | Bool
includeComments = Doc
name Doc -> Doc -> Doc
$$ [ByteString] -> Doc
commentsAsXml (PatchInfo -> [ByteString]
_piLog PatchInfo
pi)
                 | Bool
otherwise = Doc
name

commentsAsXml :: [B.ByteString] -> Doc
commentsAsXml :: [ByteString] -> Doc
commentsAsXml comments :: [ByteString]
comments
  | ByteString -> Int
B.length ByteString
comments' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 = String -> Doc
text "<comment>"
                          Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> ByteString -> Doc
escapeXMLByteString ByteString
comments'
                          Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text "</comment>"
  | Bool
otherwise = Doc
empty
    where comments' :: ByteString
comments' = [ByteString] -> ByteString
unlinesPS [ByteString]
comments

-- escapeXML is duplicated in Patch.lhs and Annotate.lhs
-- It should probably be refactored to exist in one place.
escapeXML :: String -> Doc
escapeXML :: String -> Doc
escapeXML = String -> Doc
text (String -> Doc) -> ShowS -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> ShowS
strReplace '\'' "&apos;" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> ShowS
strReplace '"' "&quot;" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Char -> String -> ShowS
strReplace '>' "&gt;" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> ShowS
strReplace '<' "&lt;" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> ShowS
strReplace '&' "&amp;"

-- Escape XML characters in a UTF-8 encoded ByteString, and turn it into a Doc.
-- The data will be in the Doc as a bytestring.
escapeXMLByteString :: B.ByteString -> Doc
escapeXMLByteString :: ByteString -> Doc
escapeXMLByteString = ByteString -> Doc
packedString (ByteString -> Doc)
-> (ByteString -> ByteString) -> ByteString -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> ByteString -> ByteString
bstrReplace '\'' "&apos;"
                                   (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> ByteString -> ByteString
bstrReplace '"'  "&quot;"
                                   (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> ByteString -> ByteString
bstrReplace '>'  "&gt;"
                                   (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> ByteString -> ByteString
bstrReplace '<'  "&lt;"
                                   (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> ByteString -> ByteString
bstrReplace '&'  "&amp;"

strReplace :: Char -> String -> String -> String
strReplace :: Char -> String -> ShowS
strReplace _ _ [] = []
strReplace x :: Char
x y :: String
y (z :: Char
z:zs :: String
zs)
  | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
z    = String
y String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> String -> ShowS
strReplace Char
x String
y String
zs
  | Bool
otherwise = Char
z Char -> ShowS
forall a. a -> [a] -> [a]
: Char -> String -> ShowS
strReplace Char
x String
y String
zs

bstrReplace :: Char -> String -> B.ByteString -> B.ByteString
bstrReplace :: Char -> String -> ByteString -> ByteString
bstrReplace c :: Char
c s :: String
s bs :: ByteString
bs | ByteString -> Bool
B.null ByteString
bs   = ByteString
B.empty
                   | Bool
otherwise   = if ByteString -> Char
BC.head ByteString
bs Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
c
                                     then ByteString -> ByteString -> ByteString
B.append (String -> ByteString
BC.pack String
s)
                                                   (Char -> String -> ByteString -> ByteString
bstrReplace Char
c String
s (ByteString -> ByteString
B.tail ByteString
bs))
                                     else Word8 -> ByteString -> ByteString
B.cons (ByteString -> Word8
B.head ByteString
bs)
                                                 (Char -> String -> ByteString -> ByteString
bstrReplace Char
c String
s (ByteString -> ByteString
B.tail ByteString
bs))

-- | Hash on patch metadata (patch name, author, date, log, and \"inverted\"
-- flag. Robust against context changes but does not garantee patch contents.
-- Usually used as matcher or patch identifier (see Darcs.Patch.Match).
makePatchname :: PatchInfo -> SHA1
makePatchname :: PatchInfo -> SHA1
makePatchname pi :: PatchInfo
pi = ByteString -> SHA1
sha1PS ByteString
sha1_me
        where b2ps :: Bool -> ByteString
b2ps True = String -> ByteString
BC.pack "t"
              b2ps False = String -> ByteString
BC.pack "f"
              sha1_me :: ByteString
sha1_me = [ByteString] -> ByteString
B.concat [PatchInfo -> ByteString
_piName PatchInfo
pi,
                                  PatchInfo -> ByteString
_piAuthor PatchInfo
pi,
                                  PatchInfo -> ByteString
_piDate PatchInfo
pi,
                                  [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ PatchInfo -> [ByteString]
_piLog PatchInfo
pi,
                                  Bool -> ByteString
b2ps (Bool -> ByteString) -> Bool -> ByteString
forall a b. (a -> b) -> a -> b
$ PatchInfo -> Bool
isInverted PatchInfo
pi]


showPatchInfo :: ShowPatchFor -> PatchInfo -> Doc
showPatchInfo :: ShowPatchFor -> PatchInfo -> Doc
showPatchInfo ForDisplay = PatchInfo -> Doc
displayPatchInfo
showPatchInfo ForStorage = PatchInfo -> Doc
storePatchInfo

-- |Patch is stored between square brackets.
--
-- > [ <patch name>
-- > <patch author>*<patch date>
-- >  <patch log (may be empty)> (indented one)
-- >  <can have multiple lines in patch log,>
-- >  <as long as they're preceded by a space>
-- >  <and don't end with a square bracket.>
-- > ]
--
-- note that below I assume the name has no newline in it.
-- See 'readPatchInfo' for the inverse operation.
-- There are more assumptions, see validation functions above.
storePatchInfo :: PatchInfo -> Doc
storePatchInfo :: PatchInfo -> Doc
storePatchInfo pi :: PatchInfo
pi =
    String -> Doc
blueText "[" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> ByteString -> Doc
packedString (PatchInfo -> ByteString
_piName PatchInfo
pi)
 Doc -> Doc -> Doc
$$ ByteString -> Doc
packedString (PatchInfo -> ByteString
_piAuthor PatchInfo
pi) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
inverted Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> ByteString -> Doc
packedString (PatchInfo -> ByteString
_piDate PatchInfo
pi)
                                 Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> [ByteString] -> Doc
myunlines (PatchInfo -> [ByteString]
_piLog PatchInfo
pi) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
blueText "] "
    where inverted :: String
inverted = if PatchInfo -> Bool
isInverted PatchInfo
pi then "*-" else "**"
          myunlines :: [ByteString] -> Doc
myunlines [] = Doc
empty
          myunlines xs :: [ByteString]
xs =
              (ByteString -> Doc -> Doc) -> Doc -> [ByteString] -> Doc
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\s :: ByteString
s -> ((String -> Doc
text "\n " Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> ByteString -> Doc
packedString ByteString
s) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>)) (String -> Doc
text "\n") [ByteString]
xs

-- |Parser for 'PatchInfo' as stored in patch bundles and inventory files,
-- for example:
--
-- > [Document the foo interface
-- > John Doe <john.doe@example.com>**20110615084241
-- >  Ignore-this: 85b94f67d377c4ab671101266ef9c229
-- >  Nobody knows what a 'foo' is, so describe it.
-- > ]
--
-- See 'showPatchInfo' for the inverse operation.
readPatchInfo :: ParserM m => m PatchInfo
readPatchInfo :: m PatchInfo
readPatchInfo = do
  m ()
forall (m :: * -> *). ParserM m => m ()
skipSpace
  Char -> m ()
forall (m :: * -> *). ParserM m => Char -> m ()
char '['
  ByteString
name <- Char -> m ByteString
forall (m :: * -> *). ParserM m => Char -> m ByteString
takeTillChar '\n'
  Char
_ <- m Char
forall (m :: * -> *). ParserM m => m Char
anyChar
  ByteString
author <- Char -> m ByteString
forall (m :: * -> *). ParserM m => Char -> m ByteString
takeTillChar '*'
  ByteString
s2 <- Int -> m ByteString
forall (m :: * -> *). ParserM m => Int -> m ByteString
RM.take 2
  ByteString
ct <- (Char -> Bool) -> m ByteString
forall (m :: * -> *). ParserM m => (Char -> Bool) -> m ByteString
takeTill (\c :: Char
c->Char
cChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==']'Bool -> Bool -> Bool
||Char
cChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='\n')
  () -> m () -> m ()
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option () (m () -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> m ()
forall (m :: * -> *). ParserM m => Char -> m ()
char '\n')) -- consume newline char, if present
  [ByteString]
log <- Char -> Char -> m [ByteString]
forall (m :: * -> *). ParserM m => Char -> Char -> m [ByteString]
linesStartingWithEndingWith ' ' ']'
  PatchInfo -> m PatchInfo
forall (m :: * -> *) a. Monad m => a -> m a
return $WPatchInfo :: ByteString
-> ByteString -> ByteString -> [ByteString] -> Bool -> PatchInfo
PatchInfo { _piDate :: ByteString
_piDate = ByteString
ct
                   , _piName :: ByteString
_piName = ByteString
name
                   , _piAuthor :: ByteString
_piAuthor = ByteString
author
                   , _piLog :: [ByteString]
_piLog = [ByteString]
log
                   , isInverted :: Bool
isInverted = ByteString -> Int -> Char
BC.index ByteString
s2 1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '*'
                   }