{- darcs-monitor - Darcs repository monitor Copyright © 2007 Antti-Juhani Kaijanaho Copyright © 2007 Benja Fallenstein Copyright © 2007 Benjamin Franksen 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 of the License, 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; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. -} module Main where import Control.Monad import Control.Monad.Trans import Data.Char import Data.Map (Map) import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set import Data.Version import System.Console.GetOpt import System.Directory import System.Environment import System.Exit import System.IO import Text.XML.HaXml hiding (when,version,x,tag,cdata) import Config import Darcs import EmailPatch import PatchData import Paths_darcs_monitor (version) data Opt = HelpOpt | VersionOpt | DarcsPathOpt String | DarcsArgsOpt [String] | SendmailOpt String | MaxDiffOpt Int | EmailTemplateOpt String | CharsetOpt String | DryRunOpt options :: [OptDescr Opt] options = [Option "n" ["dry-run"] (NoArg DryRunOpt) "Do not actually do anything, but do mark it done" ,Option "" ["darcs-path"] (ReqArg DarcsPathOpt "FILE") "Provide location of darcs" ,Option "" ["darcs-args"] (ReqArg (DarcsArgsOpt . splitArgs) "ARGS") "Provide additional arguments to darcs\n\ \(separate arguments with commas)" ,Option "" ["use-sendmail"] (OptArg (\m -> SendmailOpt $ case m of Nothing -> defaultSendmail Just s -> s) "FILE") ("Use sendmail (either " ++ defaultSendmail ++ " or FILE") ,Option "d" ["max-diff"] (ReqArg (MaxDiffOpt . read) "SIZE") "Only include the first SIZE bytes of the diff in the e-mail" ,Option "" ["email-template"] (ReqArg EmailTemplateOpt "FILE") "Provide a template for emails" ,Option "" ["charset"] (ReqArg CharsetOpt "CHARSET") "Specify character set" ,Option "h" ["help"] (NoArg HelpOpt) "Show usage" ,Option "" ["version"] (NoArg VersionOpt) "Show version" ] findOpt :: [a] -> b -> (a -> Maybe b) -> b findOpt [] b _ = b findOpt (x:xs) b f = case f x of Nothing -> findOpt xs b f Just b' -> b' splitArgs :: String -> [String] splitArgs str = let (a,b) = span (/=',') str in case b of ',':r -> a : splitArgs r [] -> [a] _ -> error $ "darcs-monitor: splitArgs called with \ \wrong arguments: b = " ++ b main :: IO () main = do args <- getArgs let (oa, args', errs) = getOpt Permute options args when (errs /= []) $ do mapM_ putStr errs exitFailure pn <- getProgName forM_ oa $ \ opt -> case opt of HelpOpt -> do putStr (usageInfo (usage pn) options) exitWith ExitSuccess where usage pn_ = "Usage: " ++ pn_ ++ " [OPTIONS] email RECIPIENT [REPO ...]" VersionOpt -> do putStrLn $ "darcs-monitor " ++ showVersion version exitWith ExitSuccess _ -> return () let dryRun = findOpt roa False $ \opt -> case opt of DryRunOpt -> Just True _ -> Nothing roa = reverse oa conf = Config { confDarcsPath = findOpt roa "darcs" $ \opt -> case opt of DarcsPathOpt s -> Just s _ -> Nothing , confDarcsArgs = findOpt roa [] $ \opt -> case opt of DarcsArgsOpt s -> Just s _ -> Nothing , confProgName = pn , confSendmailPath = findOpt roa defaultSendmail $ \opt -> case opt of SendmailOpt s -> Just s _ -> Nothing , confMaxDiff = findOpt roa Nothing $ \opt -> case opt of MaxDiffOpt s -> Just $ Just s _ -> Nothing , confEmailTemplate = findOpt roa Nothing $ \opt -> case opt of EmailTemplateOpt s -> Just (Just s) _ -> Nothing , confCharset = findOpt roa Nothing $ \opt -> case opt of CharsetOpt s -> Just (Just s) _ -> Nothing } flip runReaderT conf $ do (cmd,args'') <- case args' of ["email"] -> err "email requires an argument" ("email":addr:rest) -> return (("emailPatch " ++ addr, emailPatch addr), rest) ("print":rest) -> return (("print", \p -> liftIO $ print p >> return True), rest) s:_ -> err ("unknown command " ++ s) _ -> err "missing command" repos <- case args'' of [] -> do wd <- liftIO getCurrentDirectory return [wd] _ -> return args'' mapM_ (processRepo dryRun cmd) repos err :: (MonadConfig m, MonadIO m) => String -> m a err msg = do pn <- asks confProgName liftIO $ do hPutStrLn stderr (pn ++ ": " ++ msg) exitFailure type Command m = (String, PatchData -> m Bool) dir :: String dir = "_darcs/third-party/darcs-monitor/" seenPatchesFileName :: String seenPatchesFileName = dir ++ "seen-patches" type SeenPatches = Map String (Set String) readSeenPatches :: MonadIO m => String -> m SeenPatches readSeenPatches repo = liftIO $ catch (do fc <- readFile (repo ++ seenPatchesFileName) return (read fc) ) $ \_ -> return Map.empty processRepo :: (MonadConfig m, MonadIO m) => Bool -> Command m -> FilePath -> m () processRepo dryRun (tag,cmd) repo' = do let repo = case last repo' of '/' -> repo' _ -> repo' ++ "/" liftIO $ createDirectoryIfMissing True (repo++dir) seenPatches <- readSeenPatches repo xml <- invokeDarcs ["changes", "--reverse", "--repo="++repo,"--xml-output"] let Document _ _ (Elem "changelog" _ content) _ = xmlParse repo xml let patches = filter (\c -> case c of CElem _e -> True ; _ -> False) content spl <- forM patches $ \ (CElem (Elem "patch" attrs content_)) -> do let author = getAttr "author" attrs localDate = getAttr "local_date" attrs hash = getAttr "hash" attrs name = getElem "name" content_ comment = getElem "comment" content_ (authorName, authorEmail) = parseAuthor author dt = PatchData { patchRepo = repo , patchAuthor = authorName , patchAuthorEmail = authorEmail , patchDate = localDate , patchHash = hash , patchTitle = name , patchComment = comment , patchRepoDir = (repo++dir) } res <- let f set | dryRun = return (Set.insert tag set) f set = do ok <- cmd dt return $ if ok then Set.insert tag set else set in case Map.lookup hash seenPatches of Just set -> if Set.member tag set then return set else f set Nothing -> f Set.empty return (hash,res) let seenPatches' :: SeenPatches seenPatches' = Map.fromList spl liftIO $ writeFile (repo ++ seenPatchesFileName) (show seenPatches') parseAuthor :: String -> (String, String) parseAuthor str | '<' `elem` str = let (name, '<':rest) = span (/= '<') str (addr, _) = span (/= '>') rest in (trim name, trim addr) | '(' `elem` str = let (addr, '(':rest) = span (/= '(') str (name, _) = span (/= ')') rest in (trim name, trim addr) | otherwise = ("", trim str) ltrim :: String -> String ltrim = dropWhile isSpace trim :: String -> String trim = reverse . ltrim . reverse . ltrim getAttr :: (Eq a) => a -> [(a, AttValue)] -> String getAttr name attrs = case lookup name attrs of Nothing -> "" Just (AttValue x) -> massage x "" where massage (Left s : ss) = showString s . massage ss massage (Right ref : ss) = getRef ref . massage ss massage [] = id getElem :: Name -> [Content] -> String getElem name (CElem (Elem name' _ content) : _rest) | name == name' = getContent content "" getElem name (_ : rest) = getElem name rest getElem name [] = error $ "darcs-monitor: getElem called with wrong parameter: name = " ++ show name ++ ", contents = []" getContent :: [Content] -> String -> String getContent (CElem (Elem _ _ content) : rest) = getContent content . getContent rest getContent (CString _ cdata : rest) = showString cdata . getContent rest getContent (CRef ref : rest) = getRef ref . getContent rest getContent (CMisc _ : rest) = getContent rest getContent [] = id getRef :: Reference -> String -> String getRef (RefEntity "lt") = showChar '<' getRef (RefEntity "gt") = showChar '>' getRef (RefEntity "amp") = showChar '&' getRef (RefEntity "apos") = showChar '\'' getRef (RefEntity "quot") = showChar '"' getRef (RefEntity s) = error ("unsupported entity reference &" ++ s ++ ";") getRef (RefChar i) = showChar (toEnum i)