{- 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 System.Console.GetOpt import System.Directory import System.Environment import System.Exit import System.IO import Text.XML.HaXml hiding (when) import Config import Darcs import EmailPatch import PatchData import Version data Opt = HelpOpt | VersionOpt | DarcsPathOpt String | DarcsArgsOpt [String] | SendmailOpt String | 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 [] ["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] 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 packageVersion 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 , 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 msg = do pn <- asks confProgName liftIO $ do hPutStrLn stderr (pn ++ ": " ++ msg) exitFailure type Command m = (String, PatchData -> m Bool) dir = "_darcs/third-party/darcs-monitor/" seenPatchesFileName = dir ++ "seen-patches" type SeenPatches = Map String (Set String) readSeenPatches :: MonadIO m => String -> m SeenPatches readSeenPatches repo = do 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 case ok of True -> return $ Set.insert tag set False -> return set in case Map.lookup hash seenPatches of Just set -> case Set.member tag set of True -> return set False -> f set Nothing -> f (Set.empty) return (hash,res) let seenPatches' :: SeenPatches seenPatches' = Map.fromList spl liftIO $ writeFile (repo ++ seenPatchesFileName) (show seenPatches') 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 str = dropWhile isSpace str trim = reverse . ltrim . reverse . ltrim 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 (CElem (Elem name' _ content) : rest) | name == name' = getContent content "" getElem name (_ : rest) = getElem name rest 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 (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)