1 -- Copyright (C) 2002-2003 David Roundy 2 -- 3 -- This program is free software; you can redistribute it and/or modify 4 -- it under the terms of the GNU General Public License as published by 5 -- the Free Software Foundation; either version 2, or (at your option) 6 -- any later version. 7 -- 8 -- This program is distributed in the hope that it will be useful, 9 -- but WITHOUT ANY WARRANTY; without even the implied warranty of 10 -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 -- GNU General Public License for more details. 12 -- 13 -- You should have received a copy of the GNU General Public License 14 -- along with this program; see the file COPYING. If not, write to 15 -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 16 -- Boston, MA 02110-1301, USA. 17 18 module Darcs.Patch.Info ( PatchInfo, patchinfo, invert_name, is_inverted, 19 idpatchinfo, add_junk, 20 make_filename, make_alt_filename, readPatchInfo, 21 just_name, just_author, repopatchinfo, RepoPatchInfo, 22 human_friendly, to_xml, pi_date, set_pi_date, 23 pi_name, pi_rename, pi_author, pi_tag, pi_log, 24 showPatchInfo, is_tag 25 ) where 26 import Text.Html hiding (name, text) 27 import System.Random ( randomRIO ) 28 import Numeric ( showHex ) 29 import Control.Monad ( when ) 30 31 import ByteStringUtils 32 import qualified Data.ByteString as B (length, splitAt, null, drop 33 ,isPrefixOf, tail, concat, ByteString ) 34 import qualified Data.ByteString.Char8 as BC (index, head, unpack, pack, break) 35 36 import Printer ( renderString, Doc, packedString, 37 empty, ($$), (<>), (<+>), vcat, text, blueText, prefix ) 38 import OldDate ( readUTCDate, showIsoDateTime ) 39 import System.Time ( CalendarTime(ctTZ), calendarTimeToString, toClockTime, 40 toCalendarTime ) 41 import System.IO.Unsafe ( unsafePerformIO ) 42 import SHA1 ( sha1PS ) 43 import Darcs.Utils ( promptYorn ) 44 import Prelude hiding (pi, log) 45 46 data RepoPatchInfo = RPI String PatchInfo 47 48 repopatchinfo :: String -> PatchInfo -> RepoPatchInfo 49 repopatchinfo r pi = RPI r pi 50 51 data PatchInfo = PatchInfo { _pi_date :: !B.ByteString 52 , _pi_name :: !B.ByteString 53 , _pi_author :: !B.ByteString 54 , _pi_log :: ![B.ByteString] 55 , is_inverted :: !Bool 56 } 57 deriving (Eq,Ord) 58 59 idpatchinfo :: PatchInfo 60 idpatchinfo = PatchInfo myid myid myid [] False 61 where myid = BC.pack "identity" 62 63 patchinfo :: String -> String -> String -> [String] -> IO PatchInfo 64 patchinfo date name author log = 65 add_junk $ PatchInfo { _pi_date = BC.pack date 66 , _pi_name = BC.pack name 67 , _pi_author = BC.pack author 68 , _pi_log = map BC.pack log 69 , is_inverted = False } 70 71 add_junk :: PatchInfo -> IO PatchInfo 72 add_junk pinf = 73 do x <- randomRIO (0,2^(128 ::Integer) :: Integer) 74 when (_pi_log pinf /= ignore_junk (_pi_log pinf)) $ 75 do yorn <- promptYorn "Lines beginning with 'Ignore-this: ' will be ignored.\nProceed? " 76 when (yorn == 'n') $ fail "User cancelled because of Ignore-this." 77 return $ pinf { _pi_log = BC.pack (head ignored++showHex x ""): 78 _pi_log pinf } 79 80 ignored :: [String] -- this is a [String] so we can change the junk header. 81 ignored = ["Ignore-this: "] 82 83 ignore_junk :: [B.ByteString] -> [B.ByteString] 84 ignore_junk = filter isnt_ignored 85 where isnt_ignored x = doesnt_start_with x (map BC.pack ignored) -- TODO 86 doesnt_start_with x ys = not $ any (`B.isPrefixOf` x) ys 87 88 89 -- * Patch info formatting 90 invert_name :: PatchInfo -> PatchInfo 91 invert_name pi = pi { is_inverted = not (is_inverted pi) } 92 93 just_name :: PatchInfo -> String 94 just_name pinf = if is_inverted pinf then "UNDO: " ++ BC.unpack (_pi_name pinf) 95 else BC.unpack (_pi_name pinf) 96 97 just_author :: PatchInfo -> String 98 just_author = BC.unpack . _pi_author 99 100 human_friendly :: PatchInfo -> Doc 101 human_friendly pi = 102 text (friendly_d $ _pi_date pi) <> text " " <> packedString (_pi_author pi) 103 $$ hfn (_pi_name pi) 104 $$ vcat (map ((text " " <>) . packedString) (ignore_junk $ _pi_log pi)) 105 where hfn x = case pi_tag pi of 106 Nothing -> inverted <+> packedString x 107 Just t -> text " tagged" <+> text t 108 inverted = if is_inverted pi then text " UNDO:" else text " *" 109 110 -- note the difference with just_name 111 pi_name :: PatchInfo -> String 112 pi_name = BC.unpack . _pi_name 113 114 pi_rename :: PatchInfo -> String -> PatchInfo 115 pi_rename x n = x { _pi_name = BC.pack n } 116 117 pi_author :: PatchInfo -> String 118 pi_author = BC.unpack . _pi_author 119 120 is_tag :: PatchInfo -> Bool 121 is_tag pinfo = take 4 (just_name pinfo) == "TAG " 122 123 124 -- | Note: we ignore timezone information in the date string, 125 -- systematically treating a time as UTC. So if the patch 126 -- tells me it's 17:00 EST, we're actually treating it as 127 -- 17:00 UTC, in other words 11:00 EST. This is for 128 -- backwards compatibility to darcs prior to 2003-11, sometime 129 -- before 1.0. Fortunately, newer patch dates are written in 130 -- UTC, so this timezone truncation is harmless for them. 131 readPatchDate :: B.ByteString -> CalendarTime 132 readPatchDate = ignoreTz . readUTCDate . BC.unpack 133 where ignoreTz ct = ct { ctTZ = 0 } 134 135 pi_date :: PatchInfo -> CalendarTime 136 pi_date = readPatchDate . _pi_date 137 138 set_pi_date :: String -> PatchInfo -> PatchInfo 139 set_pi_date date pi = pi { _pi_date = BC.pack date } 140 141 pi_log :: PatchInfo -> [String] 142 pi_log = map BC.unpack . ignore_junk . _pi_log 143 144 pi_tag :: PatchInfo -> Maybe String 145 pi_tag pinf = 146 if l == t 147 then Just $ BC.unpack r 148 else Nothing 149 where (l, r) = B.splitAt (B.length t) (_pi_name pinf) 150 t = BC.pack "TAG " 151 152 friendly_d :: B.ByteString -> String 153 --friendly_d d = calendarTimeToString . readPatchDate . d 154 friendly_d d = unsafePerformIO $ do 155 ct <- toCalendarTime $ toClockTime $ readPatchDate d 156 return $ calendarTimeToString ct 157 158 to_xml :: PatchInfo -> Doc 159 to_xml pi = 160 text "<patch" 161 <+> text "author='" <> escapeXML (just_author pi) <> text "'" 162 <+> text "date='" <> escapeXML (BC.unpack $ _pi_date pi) <> text "'" 163 <+> text "local_date='" <> escapeXML (friendly_d $ _pi_date pi) <> text "'" 164 <+> text "inverted='" <> text (show $ is_inverted pi) <> text "'" 165 <+> text "hash='" <> text (make_filename pi) <> text "'>" 166 $$ prefix "\t" ( 167 text "<name>" <> escapeXML (pi_name pi) <> text "</name>" 168 $$ comments_as_xml (_pi_log pi)) 169 $$ text "</patch>" 170 171 comments_as_xml :: [B.ByteString] -> Doc 172 comments_as_xml comments 173 | B.length comments' > 0 = text "<comment>" 174 <> escapeXML (BC.unpack comments') 175 <> text "</comment>" 176 | otherwise = empty 177 where comments' = unlinesPS comments 178 179 -- escapeXML is duplicated in Patch.lhs and Annotate.lhs 180 -- It should probably be refactored to exist in one place. 181 escapeXML :: String -> Doc 182 escapeXML = text . strReplace '\'' "'" . strReplace '"' """ . 183 strReplace '>' ">" . strReplace '<' "<" . strReplace '&' "&" 184 185 186 strReplace :: Char -> String -> String -> String 187 strReplace _ _ [] = [] 188 strReplace x y (z:zs) 189 | x == z = y ++ (strReplace x y zs) 190 | otherwise = z : (strReplace x y zs) 191 192 make_alt_filename :: PatchInfo -> String 193 make_alt_filename pi@(PatchInfo { is_inverted = False }) = 194 fix_up_fname (midtrunc (pi_name pi)++"-"++just_author pi++"-"++BC.unpack (_pi_date pi)) 195 make_alt_filename pi@(PatchInfo { is_inverted = True}) = 196 make_alt_filename (pi { is_inverted = False }) ++ "-inverted" 197 198 -- This makes darcs-1 (non-hashed repos) filenames, and is also generally used in both in 199 -- hashed and non-hashed repo code for making patch "hashes" 200 make_filename :: PatchInfo -> String 201 make_filename pi = 202 showIsoDateTime d++"-"++sha1_a++"-"++sha1PS sha1_me++".gz" 203 where b2ps True = BC.pack "t" 204 b2ps False = BC.pack "f" 205 sha1_me = B.concat [_pi_name pi, 206 _pi_author pi, 207 _pi_date pi, 208 B.concat $ _pi_log pi, 209 b2ps $ is_inverted pi] 210 d = readPatchDate $ _pi_date pi 211 sha1_a = take 5 $ sha1PS $ _pi_author pi 212 213 midtrunc :: String -> String 214 midtrunc s 215 | length s < 73 = s 216 | otherwise = (take 40 s)++"..."++(reverse $ take 30 $ reverse s) 217 fix_up_fname :: String -> String 218 fix_up_fname = map munge_char 219 220 munge_char :: Char -> Char 221 munge_char '*' = '+' 222 munge_char '?' = '2' 223 munge_char '>' = '7' 224 munge_char '<' = '2' 225 munge_char ' ' = '_' 226 munge_char '"' = '~' 227 munge_char '`' = '.' 228 munge_char '\'' = '.' 229 munge_char '/' = '1' 230 munge_char '\\' = '1' 231 munge_char '!' = '1' 232 munge_char ':' = '.' 233 munge_char ';' = ',' 234 munge_char '{' = '~' 235 munge_char '}' = '~' 236 munge_char '(' = '~' 237 munge_char ')' = '~' 238 munge_char '[' = '~' 239 munge_char ']' = '~' 240 munge_char '=' = '+' 241 munge_char '#' = '+' 242 munge_char '%' = '8' 243 munge_char '&' = '6' 244 munge_char '@' = '9' 245 munge_char '|' = '1' 246 munge_char c = c 247 248 instance HTML RepoPatchInfo where 249 toHtml = htmlPatchInfo 250 instance Show PatchInfo where 251 show pi = renderString (showPatchInfo pi) 252 253 -- |Patch is stored between square brackets. 254 -- 255 -- > [ <patch name> 256 -- > <patch author>*<patch date> 257 -- > <patch log (may be empty)> (indented one) 258 -- > <can have multiple lines in patch log,> 259 -- > <as long as they're preceded by a space> 260 -- > <and don't end with a square bracket.> 261 -- > ] 262 -- 263 -- note that below I assume the name has no newline in it. 264 showPatchInfo :: PatchInfo -> Doc 265 showPatchInfo pi = 266 blueText "[" <> packedString (_pi_name pi) 267 $$ packedString (_pi_author pi) <> text inverted <> packedString (_pi_date pi) 268 <> myunlines (_pi_log pi) <> blueText "] " 269 where inverted = if is_inverted pi then "*-" else "**" 270 myunlines [] = empty 271 myunlines xs = mul xs 272 where mul [] = text "\n" 273 mul (s:ss) = text "\n " <> packedString s <> mul ss 274 275 -- 276 -- Note, Data.ByteString rewrites break ((==) x) into the memchr-based 277 -- breakByte. For this rule to fire, we keep it in prefix application form 278 -- 279 280 readPatchInfo :: B.ByteString -> Maybe (PatchInfo, B.ByteString) 281 readPatchInfo s | B.null (dropSpace s) = Nothing 282 readPatchInfo s = 283 if BC.head (dropSpace s) /= '[' -- ] 284 then Nothing 285 else case BC.break ((==) '\n') $ B.tail $ dropSpace s of 286 (name,s') -> 287 case BC.break ((==) '*') $ B.tail s' of 288 (author,s2) -> 289 case BC.break (\c->c==']'||c=='\n') $ B.drop 2 s2 of 290 (ct,s''') -> 291 do (log, s4) <- lines_starting_with_ending_with ' ' ']' $ dn s''' 292 return $ (PatchInfo { _pi_date = ct 293 , _pi_name = name 294 , _pi_author = author 295 , _pi_log = log 296 , is_inverted = BC.index s2 1 /= '*' 297 }, s4) 298 where dn x = if B.null x || BC.head x /= '\n' then x else B.tail x 299 300 lines_starting_with_ending_with :: Char -> Char -> B.ByteString 301 -> Maybe ([B.ByteString],B.ByteString) 302 lines_starting_with_ending_with st en s = lswew s 303 where 304 lswew x | B.null x = Nothing 305 lswew x = 306 if BC.head x == en 307 then Just ([], B.tail x) 308 else if BC.head x /= st 309 then Nothing 310 else case BC.break ((==) '\n') $ B.tail x of 311 (l,r) -> case lswew $ B.tail r of 312 Just (ls,r') -> Just (l:ls,r') 313 Nothing -> 314 case breakLastPS en l of 315 Just (l2,_) -> 316 Just ([l2], B.drop (B.length l2+2) x) 317 Nothing -> Nothing 318 319 htmlPatchInfo :: RepoPatchInfo -> Html 320 htmlPatchInfo (RPI r pi) = 321 toHtml $ (td << patch_link r pi) `above` 322 ((td ! [align "right"] << mail_link (just_author pi)) `beside` 323 (td << (friendly_d $ _pi_date pi))) 324 325 patch_link :: String -> PatchInfo -> Html 326 patch_link r pi = 327 toHtml $ hotlink 328 ("darcs?"++r++"**"++make_filename pi) 329 [toHtml $ pi_name pi] 330 mail_link :: String -> Html 331 mail_link email = toHtml $ hotlink ("mailto:"++email) [toHtml email]