src/Darcs/Patch/Info.lhs

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