{-
Copyright (C) 2008 Joachim Breitner
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.
-}
{-# LANGUAGE BangPatterns #-}
module Darcs
( PatchInfo(..)
, PatchBundle
, getInventory
, parseMail
, patchBasename
, inversePatch
, make_bundle
, scan_bundle
, hash_bundle
, make_context
, scan_context
, make_patch
) where
import OldDate
import StringCrypto
import System.Time
import CachedGet
import Zip
import Printer
import SHA1
import Control.Arrow
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Char8 (ByteString)
import Data.List
import Darcs.Watch.Data
-- | The defining informtion of a Darcs patch.
data PatchInfo = PatchInfo
{ piDate :: ByteString
, piName :: ByteString
, piAuthor :: ByteString
, piLog :: [ByteString]
, piInverted :: Bool
} deriving (Eq,Ord,Show)
-- | A patch bundle (e.g. a mail)
type PatchBundle = ([(PatchInfo,ByteString)],[PatchInfo])
-- | Toggles the 'piInverted' flag of a 'PatchInfo'
inversePatch :: PatchInfo -> PatchInfo
inversePatch p@(PatchInfo {piInverted = i}) = p {piInverted = not i}
-- | Given a directory used for caching, and an URL of a Darcs repository,
-- it will return the list of patches in the repository, and whether the
-- repository as changed since the last run.
getInventory :: (String -> IO ()) -> FilePath -> RepositoryURL -> IO ([PatchInfo], Bool)
getInventory write cDir repo = do
format <- get write False cDir formatUrl
case format of
Nothing -> getInventory1 write cDir repo
Just (f,_) | f == litHashedDarcs2 -> getInventory2 write cDir repo
| f == litDarcs10 -> getInventory1 write cDir repo
| f == litHashed -> getInventory2 write cDir repo
| otherwise -> error $ "Unkown repository format: " ++ B.unpack f ++ " in repo " ++ repo
where formatUrl = addSlash repo ++ "_darcs/format"
-- | Gets called when old style format was detected
getInventory1 :: (String -> IO ()) -> FilePath -> RepositoryURL -> IO ([PatchInfo],Bool)
getInventory1 write cDir repo = getInventoryFile False (addSlash repo ++ "_darcs/inventory")
where maybe' m f d = maybe d f m
getInventoryFile trustCache url = do
inv <- get write trustCache cDir url
maybe' inv parseBody $ do
write $ "Repository " ++ repo ++ " not found.\n"
return ([],False)
parseBody (body, updated) = do
let unzipped = maybeUnzipB body
let patches = readPatchInfos unzipped
case breakOn '\n' unzipped of
(l1,r) | l1 == litStartingWithTag -> do
let p = head patches
let filename = addSlash repo ++ "_darcs/inventories/" ++ patchBasename p ++ ".gz"
(prev_p,prev_u) <- getInventoryFile True filename
return (prev_p ++ patches, prev_u || updated)
_ -> return (patches, updated)
-- | Gets called when new style format was detected
getInventory2 :: (String -> IO ()) -> FilePath -> RepositoryURL -> IO ([PatchInfo],Bool)
getInventory2 write cDir repo = getInventoryFile False (addSlash repo ++ "_darcs/hashed_inventory")
where maybe' m f d = maybe d f m
getInventoryFile trustCache url = do
inv <- get write trustCache cDir url
maybe' inv parseBody $ do
write $ "Repository " ++ repo ++ " not found.\n"
return ([],False)
skip_pristine s = case breakOn '\n' s of
(l1,r) | litPristine `B.isPrefixOf` l1 -> B.tail r
_ -> s
parseStart body = do
case breakOn '\n' (skip_pristine body) of
(l,r) | l == litStartingWithInventory -> do
case breakOn '\n' $ B.tail r of
(h,r'') -> do prev <- getInventoryFile True (addSlash repo ++ "_darcs/inventories/" ++ B.unpack h)
return (prev,B.tail r'')
--_ -> putStrLn "Broken inventory start line" >> return (([],False),body)
_ -> return (([],False),body)
parseBody (body, updated) = do
let unzipped = maybeUnzipB body
((prev_patches, prev_updated),body') <- parseStart unzipped
return (prev_patches ++ readPatchInfos unzipped, prev_updated || updated)
readPatchInfos :: ByteString -> [PatchInfo]
readPatchInfos inv | B.null inv = []
readPatchInfos inv = case breakOn '[' inv of
(_,r) -> case readPatchInfo r of
Just (pinfo,r) -> pinfo : readPatchInfos r
Nothing -> []
readPatchInfo :: ByteString -> Maybe (PatchInfo, ByteString)
readPatchInfo s =
if B.null s' || B.head s' /= '[' -- ]
then Nothing
else case breakOn '\n' (B.tail s') of
(!name,s') | B.null s' -> error $ "Broken file (1) " ++ show (B.unpack s)
| otherwise ->
case breakOn '*' $ B.tail s' of
(!author,s2) | B.null s2 -> error "Broken file (2)"
| otherwise ->
case B.break (\c->c==']'||c=='\n') $ B.drop 2 s2 of
(!ct,!s''') ->
do (!log, !s4) <- lines_starting_with_ending_with ' ' ']' $ dn s'''
let not_star = B.index s2 1 /= '*'
not_star `seq` return
( PatchInfo { piDate = ct
, piName = name
, piAuthor = author
, piLog = log
, piInverted = not_star
}, s4)
where dn x = if B.null x || B.head x /= '\n' then x else B.tail x
s' = dropWhite s
lines_starting_with_ending_with :: Char -> Char -> ByteString -> Maybe ([ByteString],ByteString)
lines_starting_with_ending_with st en s = lswew s
where
lswew x | B.null x = Nothing
lswew x =
if B.head x == en
then Just ([], B.tail x)
else if B.head x /= st
then Nothing
else case breakOn '\n' $ B.tail x of
(!l,r) -> case lswew $ B.tail r of
Just (!ls,r') -> Just (l:ls,r')
Nothing ->
case breakLast en l of
Just (!l2,_) ->
let rest = B.drop (B.length l2+2) x in
rest `seq` Just ([l2], B.drop (B.length l2+2) x)
Nothing -> Nothing
dropWhite = B.dropWhile (`elem` " \n\t\r")
breakOn :: Char -> ByteString -> (ByteString, ByteString)
breakOn c = B.break (==c)
breakLast c p = case B.elemIndexEnd c p of
Nothing -> Nothing
Just n -> Just (B.take n p, B.drop (n+1) p)
showPatchInfo :: PatchInfo -> Doc
showPatchInfo pi =
blueText "[" <> packedString (piName pi)
$$ packedString (piAuthor pi) <> text inverted <> packedString (piDate pi)
<> myunlines (piLog pi) <> blueText "] "
where inverted = if piInverted pi then "*-" else "**"
myunlines [] = empty
myunlines xs = mul xs
where mul [] = text "\n"
mul (s:ss) = text "\n " <> packedString s <> mul ss
-- | Given the content of a patch bundle, it returns a list of submitted patches with
-- their diff, and the list of patches in the context.
parseMail :: ByteString -> PatchBundle
parseMail content = do case scan_bundle content of
Left err -> ([],[]) -- putStrLn $ "Parse error: "++ err
Right res -> if res == res then res else res
showPatch :: (PatchInfo,ByteString) -> Doc
showPatch (pi,d) = showPatchInfo pi <> packedString d
make_patch :: PatchInfo -> ByteString
make_patch = renderPS . showPatchInfo
make_bundle :: PatchBundle -> ByteString
make_bundle bundle@(to_be_sent, common) = renderPS $
text ""
$$ text "New patches:"
$$ text ""
$$ (vsep $ map showPatch to_be_sent)
$$ text ""
$$ text "Context:"
$$ text ""
$$ (vcat $ map showPatchInfo common)
$$ text "Patch bundle hash:"
$$ text (hash_bundle bundle)
$$ text ""
hash_bundle :: PatchBundle -> String
hash_bundle (to_be_sent,_) = sha1PS $ renderPS $ vcat (map showPatch to_be_sent) <> newline
scan_bundle :: ByteString -> Either String PatchBundle
scan_bundle ps
| B.null ps = Left "Bad patch bundle!"
| otherwise =
case silly_lex ps of
("New patches:",rest) ->
case get_patches rest of
(submitted, rest') ->
case silly_lex rest' of
("Context:", rest'') ->
case get_context rest'' of
(context,maybe_hash) -> -- FIXME verify patch bundle hash
Right (submitted, context)
(a,r) -> Left $ "Malformed patch bundle: '"++a++"' is not 'Context:'"
++ "\n" ++ B.unpack r
("Context:",rest) ->
case get_context rest of
(context, rest') ->
case silly_lex rest' of
("New patches:", rest'') ->
case get_patches rest'' of
(submitted,_) -> Right (submitted, context)
(a,_) -> Left $ "Malformed patch bundle: '" ++ a ++ "' is not 'New patches:'"
("-----BEGIN PGP SIGNED MESSAGE-----",rest) ->
scan_bundle $ filter_gpg_dashes rest
(_,rest) -> scan_bundle rest
get_patches :: ByteString -> ([(PatchInfo,ByteString)], ByteString)
get_patches ps =
case readPatchInfo ps of
Nothing -> ([], ps)
Just (pinfo,ps) ->
case readDiff ps of
Nothing -> ([], ps)
Just (diff, r) -> (pinfo, diff) -:- get_patches r
silly_lex :: ByteString -> (String, ByteString)
silly_lex = first B.unpack . B.span (/='\n') . dropWhite
make_context :: [PatchInfo] -> ByteString
make_context = renderPS . vcat . map showPatchInfo
scan_context :: ByteString -> [PatchInfo]
scan_context = fst . get_context
get_context :: ByteString -> ([PatchInfo],ByteString)
get_context ps =
case readPatchInfo ps of
Just (pinfo,r') -> pinfo -:- get_context r'
Nothing -> ([],ps)
filter_gpg_dashes :: ByteString -> ByteString
filter_gpg_dashes ps =
B.unlines $ map drop_dashes $
takeWhile (/= litEndPGPSignedMessages) $
dropWhile not_context_or_newpatches $ B.lines ps
where drop_dashes x = if B.length x < 2 then x
else if B.take 2 x == litDashSpace
then B.drop 2 x
else x
not_context_or_newpatches s = (s /= litContext) &&
(s /= litNewPatches)
readDiff :: ByteString -> Maybe (ByteString, ByteString)
readDiff s =
if B.null s' then Nothing
else find (\(p,r) -> litNewlineNewline `B.isPrefixOf` r
|| litNewlineBracket `B.isPrefixOf` r)
(zip (B.inits s') (B.tails s'))
where s' = dropWhite s
patchFilename :: PatchInfo -> String
patchFilename pi = patchBasename pi ++ ".gz"
-- | Given a patch, it calculates the name of the file that darcs usually
-- stores it in, without the ".gz" suffix.
patchBasename :: PatchInfo -> String
patchBasename pi = showIsoDateTime d++"-"++sha1_a++"-"++sha1 (B.unpack sha1_me)
where b2ps True = litT
b2ps False = litF
sha1_me = B.concat [piName pi,
piAuthor pi,
piDate pi,
B.concat $ piLog pi,
b2ps $ piInverted pi]
d = readPatchDate $ B.unpack $ piDate pi
sha1_a = take 5 $ sha1 $ B.unpack $ piAuthor pi
readPatchDate :: String -> CalendarTime
readPatchDate = ignoreTz . readUTCDate
where ignoreTz ct = ct { ctTZ = 0 }
(-:-) :: a -> ([a],b) -> ([a],b)
a -:- (as,r) = (a:as,r)
addSlash filename | last filename == '/' = filename
| otherwise = filename ++ "/"
-- Packed bytestring literators, to avoid re-packing them constantly (ghc is
-- probably not smart enough to do it by itself
litHashedDarcs2 = B.pack "hashed\ndarcs-2\n"
litDarcs10 = B.pack "darcs-1.0\n"
litHashed = B.pack "hashed\n"
litStartingWithTag = B.pack "Starting with tag:"
litPristine = B.pack "pristine"
litStartingWithInventory = B.pack "Starting with inventory:"
litEndPGPSignedMessages = B.pack "-----END PGP SIGNED MESSAGE-----"
litDashSpace = B.pack "- "
litContext = B.pack "Context:"
litNewPatches = B.pack "New patches:"
litNewlineNewline = B.pack "\n\n"
litNewlineBracket = B.pack "\n["
litT = B.pack "t"
litF = B.pack "f"