-- 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, invert_name, is_inverted, idpatchinfo, add_junk, make_filename, make_alt_filename, readPatchInfo, just_name, just_author, repopatchinfo, RepoPatchInfo, human_friendly, to_xml, pi_date, set_pi_date, pi_name, pi_rename, pi_author, pi_tag, pi_log, showPatchInfo, ) where import Text.Html hiding (name, text) import System.Random ( randomRIO ) import Numeric ( showHex ) import Control.Monad ( when ) import ByteStringUtils import qualified Data.ByteString as B (length, splitAt, null, drop ,isPrefixOf, tail, concat, ByteString ) import qualified Data.ByteString.Char8 as BC (index, head, unpack, pack, break) import Printer ( renderString, Doc, packedString, empty, ($$), (<>), (<+>), vcat, text, blueText, prefix ) import 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 data PatchInfo = PatchInfo { _pi_date :: !B.ByteString , _pi_name :: !B.ByteString , _pi_author :: !B.ByteString , _pi_log :: ![B.ByteString] , is_inverted :: !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 = add_junk $ PatchInfo { _pi_date = BC.pack date , _pi_name = BC.pack name , _pi_author = BC.pack author , _pi_log = map BC.pack log , is_inverted = False } add_junk :: PatchInfo -> IO PatchInfo add_junk pinf = do x <- randomRIO (0,2^(128 ::Integer) :: Integer) when (_pi_log pinf /= ignore_junk (_pi_log pinf)) $ do yorn <- promptYorn "Lines beginning with 'Ignore-this: ' will be ignored.\nProceed? " when (yorn == 'n') $ fail "User cancelled because of Ignore-this." return $ pinf { _pi_log = BC.pack (head ignored++showHex x ""): _pi_log pinf } ignored :: [String] -- this is a [String] so we can change the junk header. ignored = ["Ignore-this: "] ignore_junk :: [B.ByteString] -> [B.ByteString] ignore_junk = 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 invert_name :: PatchInfo -> PatchInfo invert_name pi = pi { is_inverted = not (is_inverted pi) } just_name :: PatchInfo -> String just_name pinf = if is_inverted pinf then "UNDO: " ++ BC.unpack (_pi_name pinf) else BC.unpack (_pi_name pinf) just_author :: PatchInfo -> String just_author = BC.unpack . _pi_author human_friendly :: PatchInfo -> Doc human_friendly pi = text (friendly_d $ _pi_date pi) <> text " " <> packedString (_pi_author pi) $$ hfn (_pi_name pi) $$ vcat (map ((text " " <>) . packedString) (ignore_junk $ _pi_log pi)) where hfn x = case pi_tag pi of Nothing -> inverted <+> packedString x Just t -> text " tagged" <+> text t inverted = if is_inverted pi then text " UNDO:" else text " *" -- note the difference with just_name pi_name :: PatchInfo -> String pi_name = BC.unpack . _pi_name pi_rename :: PatchInfo -> String -> PatchInfo pi_rename x n = x { _pi_name = BC.pack n } pi_author :: PatchInfo -> String pi_author = BC.unpack . _pi_author -- | 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 } pi_date :: PatchInfo -> CalendarTime pi_date = readPatchDate . _pi_date set_pi_date :: String -> PatchInfo -> PatchInfo set_pi_date date pi = pi { _pi_date = BC.pack date } pi_log :: PatchInfo -> [String] pi_log = map BC.unpack . ignore_junk . _pi_log pi_tag :: PatchInfo -> Maybe String pi_tag pinf = if l == t then Just $ BC.unpack r else Nothing where (l, r) = B.splitAt (B.length t) (_pi_name pinf) t = BC.pack "TAG " friendly_d :: B.ByteString -> String --friendly_d d = calendarTimeToString . readPatchDate . d friendly_d d = unsafePerformIO $ do ct <- toCalendarTime $ toClockTime $ readPatchDate d return $ calendarTimeToString ct to_xml :: PatchInfo -> Doc to_xml pi = text " text "author='" <> escapeXML (just_author pi) <> text "'" <+> text "date='" <> escapeXML (BC.unpack $ _pi_date pi) <> text "'" <+> text "local_date='" <> escapeXML (friendly_d $ _pi_date pi) <> text "'" <+> text "inverted='" <> text (show $ is_inverted pi) <> text "'" <+> text "hash='" <> text (make_filename pi) <> text "'>" $$ prefix "\t" ( text "" <> escapeXML (pi_name pi) <> text "" $$ comments_as_xml (_pi_log pi)) $$ text "" comments_as_xml :: [B.ByteString] -> Doc comments_as_xml comments | B.length comments' > 0 = text "" <> escapeXML (BC.unpack 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 '&' "&" strReplace :: Char -> String -> String -> String strReplace _ _ [] = [] strReplace x y (z:zs) | x == z = y ++ (strReplace x y zs) | otherwise = z : (strReplace x y zs) make_alt_filename :: PatchInfo -> String make_alt_filename pi@(PatchInfo { is_inverted = False }) = fix_up_fname (midtrunc (pi_name pi)++"-"++just_author pi++"-"++BC.unpack (_pi_date pi)) make_alt_filename pi@(PatchInfo { is_inverted = True}) = make_alt_filename (pi { is_inverted = 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" make_filename :: PatchInfo -> String make_filename pi = showIsoDateTime d++"-"++sha1_a++"-"++sha1PS sha1_me++".gz" where b2ps True = BC.pack "t" b2ps False = BC.pack "f" sha1_me = B.concat [_pi_name pi, _pi_author pi, _pi_date pi, B.concat $ _pi_log pi, b2ps $ is_inverted pi] d = readPatchDate $ _pi_date pi sha1_a = take 5 $ sha1PS $ _pi_author pi midtrunc :: String -> String midtrunc s | length s < 73 = s | otherwise = (take 40 s)++"..."++(reverse $ take 30 $ reverse s) fix_up_fname :: String -> String fix_up_fname = map munge_char munge_char :: Char -> Char munge_char '*' = '+' munge_char '?' = '2' munge_char '>' = '7' munge_char '<' = '2' munge_char ' ' = '_' munge_char '"' = '~' munge_char '`' = '.' munge_char '\'' = '.' munge_char '/' = '1' munge_char '\\' = '1' munge_char '!' = '1' munge_char ':' = '.' munge_char ';' = ',' munge_char '{' = '~' munge_char '}' = '~' munge_char '(' = '~' munge_char ')' = '~' munge_char '[' = '~' munge_char ']' = '~' munge_char '=' = '+' munge_char '#' = '+' munge_char '%' = '8' munge_char '&' = '6' munge_char '@' = '9' munge_char '|' = '1' munge_char 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 (_pi_name pi) $$ packedString (_pi_author pi) <> text inverted <> packedString (_pi_date pi) <> myunlines (_pi_log pi) <> blueText "] " where inverted = if is_inverted pi then "*-" else "**" myunlines [] = empty myunlines xs = mul xs where mul [] = text "\n" mul (s:ss) = text "\n " <> packedString s <> mul ss -- -- Note, Data.ByteString rewrites break ((==) x) into the memchr-based -- breakByte. For this rule to fire, we keep it in prefix application form -- readPatchInfo :: B.ByteString -> Maybe (PatchInfo, B.ByteString) readPatchInfo s | B.null (dropSpace s) = Nothing readPatchInfo s = if BC.head (dropSpace s) /= '[' -- ] then Nothing else case BC.break ((==) '\n') $ B.tail $ dropSpace s of (name,s') -> case BC.break ((==) '*') $ B.tail s' of (author,s2) -> case BC.break (\c->c==']'||c=='\n') $ B.drop 2 s2 of (ct,s''') -> do (log, s4) <- lines_starting_with_ending_with ' ' ']' $ dn s''' return $ (PatchInfo { _pi_date = ct , _pi_name = name , _pi_author = author , _pi_log = log , is_inverted = BC.index s2 1 /= '*' }, s4) where dn x = if B.null x || BC.head x /= '\n' then x else B.tail x lines_starting_with_ending_with :: Char -> Char -> B.ByteString -> Maybe ([B.ByteString],B.ByteString) lines_starting_with_ending_with st en s = lswew s where lswew x | B.null x = Nothing lswew x = if BC.head x == en then Just ([], B.tail x) else if BC.head x /= st then Nothing else case BC.break ((==) '\n') $ B.tail x of (l,r) -> case lswew $ B.tail r of Just (ls,r') -> Just (l:ls,r') Nothing -> case breakLastPS en l of Just (l2,_) -> Just ([l2], B.drop (B.length l2+2) x) Nothing -> Nothing htmlPatchInfo :: RepoPatchInfo -> Html htmlPatchInfo (RPI r pi) = toHtml $ (td << patch_link r pi) `above` ((td ! [align "right"] << mail_link (just_author pi)) `beside` (td << (friendly_d $ _pi_date pi))) patch_link :: String -> PatchInfo -> Html patch_link r pi = toHtml $ hotlink ("darcs?"++r++"**"++make_filename pi) [toHtml $ pi_name pi] mail_link :: String -> Html mail_link email = toHtml $ hotlink ("mailto:"++email) [toHtml email]