-- 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
    , addJunk
    , replaceJunk
    , makePatchname
    , readPatchInfo
    , justName
    , justAuthor
    , justLog
    , displayPatchInfo
    , toXml
    , toXmlShort
    , piDate
    , piDateString
    , piName
    , piRename
    , piAuthor
    , piTag
    , piLog
    , showPatchInfo
    , isTag
    , escapeXML
    , validDate
    , validLog
    , validAuthor
    , validDatePS
    , validLogPS
    , validAuthorPS
    ) where

import Darcs.Prelude

import Data.Char ( isAscii )
import Crypto.Random ( seedNew, seedToInteger )
import Numeric ( showHex )
import Control.Monad ( when, unless, void )

import Darcs.Util.ByteString
    ( decodeLocale
    , packStringToUTF8
    , unlinesPS
    , unpackPSFromUTF8
    )
import qualified Darcs.Util.Parser as RM ( take )
import Darcs.Util.Parser as RM ( skipSpace, char,
                                      takeTill, anyChar, Parser,
                                      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 )

import Darcs.Test.TestOnly ( TestOnly )

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

@_piLegacyIsInverted@:

Historically, the @isInverted@ flag was used to indicate that a Named patch
was inverted.

We no longer support direct inversion of 'Darcs.Patch.Named.Named' patches,
except sometimes via the 'Darcs.Patch.Invertible.Invertible' wrapper which
tracks inversion in the wrapper.

However, going even further back in time, inverted patches could be written
out by @darcs rollback@. This was changed in 2008 so any patches on disk
with this flag set would have been written by a darcs from prior to then.
As they still exist, including in the darcs repository itself, we need
to support them.

As far as current darcs is concerned, the flag should be treated like any
other field in 'PatchInfo' apart from never being set freshly:

 - There is no semantic relationship between a 'PatchInfo' with
   @piLegacyIsInverted = False@ and the same 'PatchInfo' with
   @piLegacyIsInverted = True@. For example they are not inverses of each
   other.

- New or amended patches should never be written out with
  @_piLegacyIsInverted = True@.

 - We do need to maintain backwards compatibility so we take care to
   preserve things like the hash, on-disk format etc.

- A patch with @_piLegacyIsInverted = True@ should work with all the
  normal darcs operations.

The flag is completely separate and orthogonal to the tracking of
explicit inversion in the 'Darcs.Patch.Invertible.Invertible' wrapper.
The 'Darcs.Patch.Invertible.Invertible' wrapper
is only used in memory and never stored to disk so there should be no
confusion when reading a patch from disk. Within the codebase they
serve completely different purposes and should not interact at all.
-}
data PatchInfo =
  PatchInfo { PatchInfo -> ByteString
_piDate    :: !B.ByteString
            , PatchInfo -> ByteString
_piName    :: !B.ByteString
            , PatchInfo -> ByteString
_piAuthor  :: !B.ByteString
            , PatchInfo -> [ByteString]
_piLog     :: ![B.ByteString]
              -- | See the long description of this field in the
              -- docs above.
            , PatchInfo -> Bool
_piLegacyIsInverted :: !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 Int
d (PatchInfo ByteString
date ByteString
name ByteString
author [ByteString]
log 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 String
"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
+ Int
1) ByteString
date ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            String -> ShowS
showString String
" " 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
+ Int
1) ByteString
name ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            String -> ShowS
showString String
" " 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
+ Int
1) ByteString
author ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            String -> ShowS
showString String
" " 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
+ Int
1) [ByteString]
log ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
            String -> ShowS
showString String
" " 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
+ Int
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 Char
c = Char -> Bool
isAscii Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n' Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
']'

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

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

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

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

rawPatchInfo
  :: TestOnly
  => String -> String -> String -> [String] -> Bool -> PatchInfo
rawPatchInfo :: String -> String -> String -> [String] -> Bool -> PatchInfo
rawPatchInfo = String -> String -> String -> [String] -> Bool -> PatchInfo
rawPatchInfoInternal

rawPatchInfoInternal :: String -> String -> String -> [String] -> Bool -> PatchInfo
rawPatchInfoInternal :: String -> String -> String -> [String] -> Bool -> PatchInfo
rawPatchInfoInternal String
date String
name String
author [String]
log Bool
inverted =
    PatchInfo :: 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
              , _piLegacyIsInverted :: Bool
_piLegacyIsInverted  = Bool
inverted
              }
  where
    validateAuthor :: ShowS
validateAuthor = (String -> Bool) -> String -> ShowS
forall a. Show a => (a -> Bool) -> String -> a -> a
validate String -> Bool
validAuthor String
"author"
    validateName :: ShowS
validateName = (String -> Bool) -> String -> ShowS
forall a. Show a => (a -> Bool) -> String -> a -> a
validate String -> Bool
validLog String
"patch name"
    validateLog :: ShowS
validateLog = (String -> Bool) -> String -> ShowS
forall a. Show a => (a -> Bool) -> String -> a -> a
validate String -> Bool
validLog String
"log line"
    validateDate :: ShowS
validateDate = (String -> Bool) -> String -> ShowS
forall a. Show a => (a -> Bool) -> String -> a -> a
validate String -> Bool
validDate String
"date"
    validate :: (a -> Bool) -> String -> a -> a
validate a -> Bool
test String
meta a
x =
      if a -> Bool
test a
x then a
x else String -> a
forall a. HasCallStack => String -> a
error ([String] -> String
unwords [String
"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 String
date String
name String
author [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
rawPatchInfoInternal 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 PatchInfo
pinf =
    do Integer
x <- Seed -> Integer
seedToInteger (Seed -> Integer) -> IO Seed -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Seed
forall (randomly :: * -> *). MonadRandom randomly => randomly Seed
seedNew
       -- Note: this is now 40 bytes long compare to the 32 we had before
       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
$ String
"Lines beginning with 'Ignore-this: ' " String -> ShowS
forall a. [a] -> [a] -> [a]
++
                          String
"will not be shown when displaying a patch."
               Bool
confirmed <- String -> IO Bool
promptYorn String
"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 String
"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 String
"")ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:
                                 PatchInfo -> [ByteString]
_piLog PatchInfo
pinf }

replaceJunk :: PatchInfo -> IO PatchInfo
replaceJunk :: PatchInfo -> IO PatchInfo
replaceJunk pi :: PatchInfo
pi@(PatchInfo {_piLog :: PatchInfo -> [ByteString]
_piLog=[ByteString]
log}) = PatchInfo -> IO PatchInfo
addJunk (PatchInfo -> IO PatchInfo) -> PatchInfo -> IO PatchInfo
forall a b. (a -> b) -> a -> b
$ PatchInfo
pi{_piLog :: [ByteString]
_piLog = [ByteString] -> [ByteString]
ignoreJunk [ByteString]
log}

ignored :: [String] -- this is a [String] so we can change the junk header.
ignored :: [String]
ignored = [String
"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 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 ByteString
x 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

-- | Get the name, including an "UNDO: " prefix if the patch is
-- a legacy inverted patch.
justName :: PatchInfo -> String
justName :: PatchInfo -> String
justName PatchInfo
pinf =
  if PatchInfo -> Bool
_piLegacyIsInverted PatchInfo
pinf
    then String
"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 PatchInfo
pi =
    String -> Doc
cyanText String
"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 String
"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 String
"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 String
"  " 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 String
x = case PatchInfo -> Maybe String
piTag PatchInfo
pi of
                Maybe String
Nothing -> Doc
inverted Doc -> Doc -> Doc
<+> String -> Doc
text String
x
                Just String
t -> String -> Doc
text String
"  tagged" Doc -> Doc -> Doc
<+> String -> Doc
text String
t
        inverted :: Doc
inverted = if PatchInfo -> Bool
_piLegacyIsInverted PatchInfo
pi then String -> Doc
text String
"  UNDO:" else String -> Doc
text String
"  *"

-- | Returns the name of the patch. Unlike 'justName', it does not preprend
--   "UNDO: " to the name if the patch has the legacy inverted flag set.
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 PatchInfo
x 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 PatchInfo
pinfo = String
"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

-- | 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 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 (ByteString
l, 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 String
"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 ByteString
bs | Char
'\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 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' Bool
includeComments PatchInfo
pi =
        String -> Doc
text String
"<patch"
    Doc -> Doc -> Doc
<+> String -> Doc
text String
"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 String
"'"
    Doc -> Doc -> Doc
<+> String -> Doc
text String
"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 String
"'"
    Doc -> Doc -> Doc
<+> String -> Doc
text String
"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 String
"'"
    Doc -> Doc -> Doc
<+> String -> Doc
text String
"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
_piLegacyIsInverted PatchInfo
pi) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"'"
    Doc -> Doc -> Doc
<+> String -> Doc
text String
"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 String
"'>"
    Doc -> Doc -> Doc
$$  Doc -> Doc
indent Doc
abstract
    Doc -> Doc -> Doc
$$  String -> Doc
text String
"</patch>"
      where
        indent :: Doc -> Doc
indent = String -> Doc -> Doc
prefix String
"    "
        name :: Doc
name = String -> Doc
text String
"<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 String
"</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 [ByteString]
comments
  | ByteString -> Int
B.length ByteString
comments' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = String -> Doc
text String
"<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 String
"</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 Char
'\'' String
"&apos;" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> ShowS
strReplace Char
'"' String
"&quot;" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  Char -> String -> ShowS
strReplace Char
'>' String
"&gt;" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> ShowS
strReplace Char
'<' String
"&lt;" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> ShowS
strReplace Char
'&' String
"&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 Char
'\'' String
"&apos;"
                                   (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> ByteString -> ByteString
bstrReplace Char
'"'  String
"&quot;"
                                   (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> ByteString -> ByteString
bstrReplace Char
'>'  String
"&gt;"
                                   (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> ByteString -> ByteString
bstrReplace Char
'<'  String
"&lt;"
                                   (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> String -> ByteString -> ByteString
bstrReplace Char
'&'  String
"&amp;"

strReplace :: Char -> String -> String -> String
strReplace :: Char -> String -> ShowS
strReplace Char
_ String
_ [] = []
strReplace Char
x String
y (Char
z: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 Char
c String
s 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 the legacy
-- \"inverted\" flag.
-- Robust against context changes but does not guarantee patch contents.
-- Usually used as matcher or patch identifier (see Darcs.Patch.Match).
makePatchname :: PatchInfo -> SHA1
makePatchname :: PatchInfo -> SHA1
makePatchname PatchInfo
pi = ByteString -> SHA1
sha1PS ByteString
sha1_me
        where b2ps :: Bool -> ByteString
b2ps Bool
True = String -> ByteString
BC.pack String
"t"
              b2ps Bool
False = String -> ByteString
BC.pack String
"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
_piLegacyIsInverted PatchInfo
pi]


showPatchInfo :: ShowPatchFor -> PatchInfo -> Doc
showPatchInfo :: ShowPatchFor -> PatchInfo -> Doc
showPatchInfo ShowPatchFor
ForDisplay = PatchInfo -> Doc
displayPatchInfo
showPatchInfo ShowPatchFor
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 PatchInfo
pi =
    String -> Doc
blueText String
"[" 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 String
"] "
    where inverted :: String
inverted = if PatchInfo -> Bool
_piLegacyIsInverted PatchInfo
pi then String
"*-" else String
"**"
          myunlines :: [ByteString] -> Doc
myunlines [] = Doc
empty
          myunlines [ByteString]
xs =
              (ByteString -> Doc -> Doc) -> Doc -> [ByteString] -> Doc
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ByteString
s -> ((String -> Doc
text String
"\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 String
"\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 :: Parser PatchInfo
readPatchInfo :: Parser PatchInfo
readPatchInfo = do
  Parser ()
skipSpace
  Char -> Parser ()
char Char
'['
  ByteString
name <- Char -> Parser ByteString
takeTillChar Char
'\n'
  Char
_ <- Parser Char
anyChar
  ByteString
author <- Char -> Parser ByteString
takeTillChar Char
'*'
  ByteString
s2 <- Int -> Parser ByteString
RM.take Int
2
  ByteString
ct <- (Char -> Bool) -> Parser ByteString
takeTill (\Char
c->Char
cChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
']'Bool -> Bool -> Bool
||Char
cChar -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'\n')
  () -> Parser () -> Parser ()
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option () (Parser () -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> Parser ()
char Char
'\n')) -- consume newline char, if present
  [ByteString]
log <- Char -> Char -> Parser [ByteString]
linesStartingWithEndingWith Char
' ' Char
']'
  PatchInfo -> Parser PatchInfo
forall (m :: * -> *) a. Monad m => a -> m a
return PatchInfo :: 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
                   , _piLegacyIsInverted :: Bool
_piLegacyIsInverted = ByteString -> Int -> Char
BC.index ByteString
s2 Int
1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'*'
                   }