-- 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(..), patchinfo, invertName, idpatchinfo, addJunk, makePatchname, makeFilename, makeAltFilename, readPatchInfo, justName, justAuthor, justLog, repopatchinfo, RepoPatchInfo, humanFriendly, toXml, piDate, setPiDate, piDateString, piDateBytestring, piName, piRename, piAuthor, piTag, piLog, showPatchInfo, isTag, readPatchInfos, escapeXML ) where import Text.Html hiding (name, text, option) import System.Random ( randomRIO ) import Numeric ( showHex ) import Control.Monad ( when, unless ) import ByteStringUtils ( unlinesPS, packStringToUTF8, unpackPSFromUTF8, decodeLocale) import qualified Darcs.Patch.ReadMonads as RM ( take ) import Darcs.Patch.ReadMonads as RM ( skipSpace, char, takeTill, anyChar, ParserM, option, parseStrictly, takeTillChar, linesStartingWithEndingWith) 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, unpack, pack) import Data.List( isPrefixOf ) import Printer ( renderString, Doc, packedString, empty, ($$), (<>), (<+>), vcat, text, blueText, prefix ) import Darcs.Patch.OldDate ( readUTCDate, showIsoDateTime ) import System.Time ( CalendarTime(ctTZ), calendarTimeToString, toClockTime, toCalendarTime ) import System.IO.Unsafe ( unsafePerformIO ) import SHA1 ( sha1PS ) import Darcs.Utils ( promptYorn ) import Prelude hiding (pi, log) data RepoPatchInfo = RPI String PatchInfo repopatchinfo :: String -> PatchInfo -> RepoPatchInfo repopatchinfo r pi = RPI r pi -- | 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 { _piDate :: !B.ByteString , _piName :: !B.ByteString , _piAuthor :: !B.ByteString , _piLog :: ![B.ByteString] , isInverted :: !Bool } deriving (Eq,Ord) idpatchinfo :: PatchInfo idpatchinfo = PatchInfo myid myid myid [] False where myid = BC.pack "identity" patchinfo :: String -> String -> String -> [String] -> IO PatchInfo patchinfo date name author log = addJunk $ PatchInfo { _piDate = BC.pack date , _piName = packStringToUTF8 name , _piAuthor = packStringToUTF8 author , _piLog = map packStringToUTF8 log , isInverted = False } -- | addJunk adds a line that contains a random number to make the patch -- unique. addJunk :: PatchInfo -> IO PatchInfo addJunk pinf = do x <- randomRIO (0,2^(128 ::Integer) :: Integer) when (_piLog pinf /= ignoreJunk (_piLog pinf)) $ do putStrLn "Lines beginning with 'Ignore-this: ' will be ignored." confirmed <- promptYorn "Proceed? " unless confirmed $ fail "User cancelled because of Ignore-this." return $ pinf { _piLog = BC.pack (head ignored++showHex x ""): _piLog pinf } ignored :: [String] -- this is a [String] so we can change the junk header. ignored = ["Ignore-this: "] ignoreJunk :: [B.ByteString] -> [B.ByteString] ignoreJunk = filter isnt_ignored where isnt_ignored x = doesnt_start_with x (map BC.pack ignored) -- TODO doesnt_start_with x ys = not $ any (`B.isPrefixOf` x) ys -- * Patch info formatting invertName :: PatchInfo -> PatchInfo invertName pi = pi { isInverted = not (isInverted pi) } -- | Get the name, including an "UNDO: " prefix if the patch is inverted. justName :: PatchInfo -> String justName pinf = if isInverted pinf then "UNDO: " ++ nameString else nameString where nameString = metadataToString (_piName pinf) -- | Returns the author of a patch. justAuthor :: PatchInfo -> String justAuthor = metadataToString . _piAuthor justLog :: PatchInfo -> String justLog = unlines . map BC.unpack . _piLog humanFriendly :: PatchInfo -> Doc humanFriendly pi = text (friendlyD $ _piDate pi) <> text " " <> text (piAuthor pi) $$ hfn (piName pi) $$ vcat (map ((text " " <>) . text) (piLog pi)) where hfn x = case piTag pi of Nothing -> inverted <+> text x Just t -> text " tagged" <+> text t inverted = if isInverted pi then text " UNDO:" else 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 = metadataToString . _piName piRename :: PatchInfo -> String -> PatchInfo piRename x n = x { _piName = packStringToUTF8 n } -- | Returns the author of a patch. piAuthor :: PatchInfo -> String piAuthor = metadataToString . _piAuthor isTag :: PatchInfo -> Bool isTag pinfo = "TAG " `isPrefixOf` justName pinfo -- | Note: we ignore timezone information in the date string, -- systematically treating a time as UTC. So if the patch -- tells me it's 17:00 EST, we're actually treating it as -- 17:00 UTC, in other words 11:00 EST. This is for -- backwards compatibility to darcs prior to 2003-11, sometime -- before 1.0. Fortunately, newer patch dates are written in -- UTC, so this timezone truncation is harmless for them. readPatchDate :: B.ByteString -> CalendarTime readPatchDate = ignoreTz . readUTCDate . BC.unpack where ignoreTz ct = ct { ctTZ = 0 } piDate :: PatchInfo -> CalendarTime piDate = readPatchDate . _piDate piDateString :: PatchInfo -> String piDateString = BC.unpack . _piDate piDateBytestring :: PatchInfo -> B.ByteString piDateBytestring = _piDate setPiDate :: String -> PatchInfo -> PatchInfo setPiDate date pi = pi { _piDate = BC.pack date } -- | Get the log message of a patch. piLog :: PatchInfo -> [String] piLog = map metadataToString . ignoreJunk . _piLog -- | Get the tag name, if the patch is a tag patch. piTag :: PatchInfo -> Maybe String piTag pinf = if l == t then Just $ metadataToString r else Nothing where (l, r) = B.splitAt (B.length t) (_piName pinf) t = 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 bs | not ('\xfffd' `elem` bsUtf8) = bsUtf8 | otherwise = decodeLocale bs where bsUtf8 = unpackPSFromUTF8 bs friendlyD :: B.ByteString -> String --friendlyD d = calendarTimeToString . readPatchDate . d friendlyD d = unsafePerformIO $ do ct <- toCalendarTime $ toClockTime $ readPatchDate d return $ calendarTimeToString ct toXml :: PatchInfo -> Doc toXml pi = text " text "author='" <> escapeXMLByteString (_piAuthor pi) <> text "'" <+> text "date='" <> escapeXMLByteString (_piDate pi) <> text "'" <+> text "local_date='" <> escapeXML (friendlyD $ _piDate pi) <> text "'" <+> text "inverted='" <> text (show $ isInverted pi) <> text "'" <+> text "hash='" <> text (makePatchname pi) <> text "'>" $$ prefix "\t" ( text "" <> escapeXMLByteString (_piName pi) <> text "" $$ commentsAsXml (_piLog pi)) $$ text "" commentsAsXml :: [B.ByteString] -> Doc commentsAsXml comments | B.length comments' > 0 = text "" <> escapeXMLByteString comments' <> text "" | otherwise = empty where comments' = unlinesPS comments -- escapeXML is duplicated in Patch.lhs and Annotate.lhs -- It should probably be refactored to exist in one place. escapeXML :: String -> Doc escapeXML = text . strReplace '\'' "'" . strReplace '"' """ . strReplace '>' ">" . strReplace '<' "<" . strReplace '&' "&" -- 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 = packedString . bstrReplace '\'' "'" . bstrReplace '"' """ . bstrReplace '>' ">" . bstrReplace '<' "<" . bstrReplace '&' "&" strReplace :: Char -> String -> String -> String strReplace _ _ [] = [] strReplace x y (z:zs) | x == z = y ++ (strReplace x y zs) | otherwise = z : (strReplace x y zs) bstrReplace :: Char -> String -> B.ByteString -> B.ByteString bstrReplace c s bs | B.null bs = B.empty | otherwise = if BC.head bs == c then B.append (BC.pack s) (bstrReplace c s (B.tail bs)) else B.cons (B.head bs) (bstrReplace c s (B.tail bs)) makeAltFilename :: PatchInfo -> String makeAltFilename pi@(PatchInfo { isInverted = False }) = fixUpFname (midtrunc (piName pi)++"-"++justAuthor pi++"-"++BC.unpack (_piDate pi)) makeAltFilename pi@(PatchInfo { isInverted = True}) = makeAltFilename (pi { isInverted = False }) ++ "-inverted" -- | This makes darcs-1 (non-hashed repos) filenames, and is also generally -- used in both in hashed and non-hashed repo code for making patch "hashes". -- -- The name consists of three segments: -- -- * timestamp (ISO8601-compatible yyyymmmddHHMMSS, UTC) -- -- * SHA1 hash of the author -- -- * SHA1 hash of the patch name, author, date, log, and \"inverted\" -- flag. makeFilename :: PatchInfo -> String makeFilename pi = makePatchname pi ++ ".gz" makePatchname :: PatchInfo -> String makePatchname pi = showIsoDateTime d++"-"++sha1_a++"-"++sha1PS sha1_me where b2ps True = BC.pack "t" b2ps False = BC.pack "f" sha1_me = B.concat [_piName pi, _piAuthor pi, _piDate pi, B.concat $ _piLog pi, b2ps $ isInverted pi] d = readPatchDate $ _piDate pi sha1_a = take 5 $ sha1PS $ _piAuthor pi midtrunc :: String -> String midtrunc s | length s < 73 = s | otherwise = (take 40 s)++"..."++(reverse $ take 30 $ reverse s) fixUpFname :: String -> String fixUpFname = map mungeChar mungeChar :: Char -> Char mungeChar '*' = '+' mungeChar '?' = '2' mungeChar '>' = '7' mungeChar '<' = '2' mungeChar ' ' = '_' mungeChar '"' = '~' mungeChar '`' = '.' mungeChar '\'' = '.' mungeChar '/' = '1' mungeChar '\\' = '1' mungeChar '!' = '1' mungeChar ':' = '.' mungeChar ';' = ',' mungeChar '{' = '~' mungeChar '}' = '~' mungeChar '(' = '~' mungeChar ')' = '~' mungeChar '[' = '~' mungeChar ']' = '~' mungeChar '=' = '+' mungeChar '#' = '+' mungeChar '%' = '8' mungeChar '&' = '6' mungeChar '@' = '9' mungeChar '|' = '1' mungeChar c = c instance HTML RepoPatchInfo where toHtml = htmlPatchInfo instance Show PatchInfo where show pi = renderString (showPatchInfo pi) -- |Patch is stored between square brackets. -- -- > [ -- > * -- > (indented one) -- > -- > -- > -- > ] -- -- note that below I assume the name has no newline in it. showPatchInfo :: PatchInfo -> Doc showPatchInfo pi = blueText "[" <> packedString (_piName pi) $$ packedString (_piAuthor pi) <> text inverted <> packedString (_piDate pi) <> myunlines (_piLog pi) <> blueText "] " where inverted = if isInverted pi then "*-" else "**" myunlines [] = empty myunlines xs = mul xs where mul [] = text "\n" mul (s:ss) = text "\n " <> packedString s <> mul ss readPatchInfo :: ParserM m => m (PatchInfo) readPatchInfo = do skipSpace char '[' name <- takeTillChar '\n' _ <- anyChar author <- takeTillChar '*' s2 <- RM.take 2 ct <- takeTill (\c->c==']'||c=='\n') option () (char '\n' >> return ()) -- consume newline char, if present log <- linesStartingWithEndingWith ' ' ']' return $ PatchInfo { _piDate = ct , _piName = name , _piAuthor = author , _piLog = log , isInverted = BC.index s2 1 /= '*' } readPatchInfos :: B.ByteString -> [PatchInfo] readPatchInfos inv | B.null inv = [] readPatchInfos inv = case parseStrictly readPatchInfo inv of Just (pinfo,r) -> pinfo : readPatchInfos r _ -> [] htmlPatchInfo :: RepoPatchInfo -> Html htmlPatchInfo (RPI r pi) = toHtml $ (td << patchLink r pi) `above` ((td ! [align "right"] << mailLink (justAuthor pi)) `beside` (td << (friendlyD $ _piDate pi))) patchLink :: String -> PatchInfo -> Html patchLink r pi = toHtml $ hotlink ("darcs?"++r++"**"++makeFilename pi) [toHtml $ piName pi] mailLink :: String -> Html mailLink email = toHtml $ hotlink ("mailto:"++email) [toHtml email]