darcswatch 0.3 → 0.4
raw patch · 16 files changed
+570/−285 lines, 16 filesdep +cgidep +mtlnew-component:exe:darcswatch-cgi
Dependencies added: cgi, mtl
Files
- README +5/−1
- darcswatch.cabal +29/−1
- documentation.html +2/−2
- example/config +4/−1
- src/CGI-Main.hs +74/−0
- src/Darcs.hs +65/−33
- src/Darcs/Watch/Data.hs +19/−4
- src/Darcs/Watch/GenerateOutput.hs +73/−97
- src/Darcs/Watch/ImportMail.hs +5/−1
- src/Darcs/Watch/Roundup.hs +9/−13
- src/Darcs/Watch/Storage.hs +58/−6
- src/Darcs/Watch/UpdateRepoData.hs +49/−16
- src/Generate-Main.hs +1/−1
- src/HTML.hs +177/−107
- src/PullRepos-Main.hs +0/−1
- src/UpdateRepoData-Main.hs +0/−1
README view
@@ -16,7 +16,7 @@ the config file therein for configuration. An example configuration is included. -darcsweb uses modules from these non-standard packages:+DarcsWatch uses modules from these non-standard packages: * xhtml * network * HTTP@@ -24,6 +24,10 @@ * parsec * nano-md5 * zlib+ * concurrentoutput+ * time+ * mime-string+ * regex-compat There are a lot of open issues, and help is very appreciated. A non exclusive list of TODO items is:
darcswatch.cabal view
@@ -1,5 +1,5 @@ Name: darcswatch-version: 0.3+version: 0.4 Category: Distribution name: darcswatch author: Joachim Breitner@@ -20,6 +20,10 @@ * Download link for each patch, to apply without searching for the email. . * Knows about inverse and amend-recorded patches and uses them to consider+ .+ * Integrates into http://bugs.darcs.net/+ .+ * Optionally sends out mails to mailing lists when a patch is applied to a repository patches obsolete. Homepage: http://darcswatch.nomeata.de/ Cabal-Version: >= 1.6@@ -30,6 +34,10 @@ example/config Build-Type: Simple +Flag Static+ Description: Build static binaries+ Default: False+ Executable darcswatch-generate Main-Is: Generate-Main.hs hs-source-dirs: src@@ -70,26 +78,46 @@ , process , mime-string , regex-compat+ , cgi+ , mtl+ if flag(Static)+ ghc-options: -static -optl-static -optl-pthread Executable darcswatch-import-mail Main-Is: ImportMail-Main.hs hs-source-dirs: src+ if flag(Static)+ ghc-options: -static -optl-static -optl-pthread Executable darcswatch-import-bundle Main-Is: ImportBundle-Main.hs hs-source-dirs: src+ if flag(Static)+ ghc-options: -static -optl-static -optl-pthread Executable darcswatch-convert-data Main-Is: ConvertData-Main.hs hs-source-dirs: src+ if flag(Static)+ ghc-options: -static -optl-static -optl-pthread Executable darcswatch-pull-repos Main-Is: PullRepos-Main.hs hs-source-dirs: src+ if flag(Static)+ ghc-options: -static -optl-static -optl-pthread Executable darcswatch-update-data Main-Is: UpdateRepoData-Main.hs hs-source-dirs: src+ if flag(Static)+ ghc-options: -static -optl-static -optl-pthread ++Executable darcswatch-cgi+ Main-Is: CGI-Main.hs+ hs-source-dirs: src+ if flag(Static)+ ghc-options: -static -optl-static -optl-pthread source-repository head type: darcs
documentation.html view
@@ -46,7 +46,7 @@ <h2>Other questions.</h2> -<h3>What happens if the same mail reaches darcsweb multiple times, e.g. directly and via a mailing list?</h3>+<h3>What happens if the same mail reaches DarcsWatch multiple times, e.g. directly and via a mailing list?</h3> <p>Not much. Patch bundles are stored by their MD5 sum, so if the same hash bundle arrives again, it will just override the old one.</p> <h3>I submitted a patch but it should not be used. Can I mark it as obsolete or rejected?</h3>@@ -54,7 +54,7 @@ <p> <strong>Via tagged mails</strong> DarcsWatch remembers the message-ids of the mails that submitted a particular patch bundle, so if it sees a direct reply to such a mail, it looks in the subject for the text <tt>[OBSOLETE]</tt> or <tt>[REJECTED]</tt> and marks a patch as such. If the bundle (or parts of it) are later re-submitted, these flags are removed again.</p> -<p>If you don’t have the original message around to reply to it, you can also attach the patch bundle to the mail with the tag in the subject – just download it from the DarcsWatch site. Also, when patch bundles are added to DarcsWatch manually, there might not be a message-id attached and this will be the only way. The probably fastest way of doing that is using the command line <tt>GET http://darcswatch.nomeata.de/....dpatch | mail -s '[REJECTED]' darcswatch@nomeata.de</tt>.+<p>If you don’t have the original message around to reply to it, you can also attach the patch bundle to the mail with the tag in the subject – just download it from the DarcsWatch site. Also, when patch bundles are added to DarcsWatch manually, there might not be a message-id attached and this will be the only way. <!-- The probably fastest way of doing that is using the command line <tt>GET http://darcswatch.nomeata.de/....dpatch | mail -s '[REJECTED]' darcswatch@nomeata.de</tt>. --> </p> <p> <strong>Via inverse patches.</strong> Make sure DarcsWatch has seen the inverse of the patch. You can do so by first running <tt>darcs rollback</tt> and select your patch, and then send it to DarcsWatch using <tt>darcs send --to=darcswatch@nomeata.de</tt>. If the project is using a mailing list that is being tracked by DarcsWatch, you can send this mail to the list, thus notifying your fellow developers that you consider your patch obsolete. Of course you can do this also to patches other than your own.</p>
example/config view
@@ -12,5 +12,8 @@ , cMails = "/home/jojo/projekte/programming/haskell/darcswatch/example/mails" , cDarcsWatchURL = "http://darcswatch.nomeata.de/" , cDarcsWatchAddress = "darcswatch@nomeata.de"- , cSendRoundupMails = False+ , cRepoSubscriptions =+ [ ("http://code.haskell.org/XMonadContrib", "xmonad@haskell.org")+ ]+ , cSendMails = False }
+ src/CGI-Main.hs view
@@ -0,0 +1,74 @@+{-+Copyright (C) 2009 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.+-}++import Data.List+import Data.Maybe+import System.Environment+import System.FilePath+import Network.CGI+import Control.Applicative++import Darcs.Watch.Storage+import Darcs.Watch.Data+import HTML++main = do+ confdir <- getEnv "HTTP_DARCSWATCH_DIR"++ config <- read `fmap` readFile (confdir </> "config") :: IO DarcsWatchConfig++ + runCGI $ handleErrors $ authenticated config $ \openID -> do++ --setHeader "Content-type" "text/html; charset=UTF-8"++ bundleChanges <- getBundleChanges <$> getInputs+ if null bundleChanges+ then output $ cgiMessagePage True "No changed entered"+ else do errors <- catMaybes <$> mapM (applyBundleChange config openID) bundleChanges+ if null errors+ then output $ cgiMessagePage False $ "Sucessfully updated " +++ show (length bundleChanges) ++ " patch bundle state" +++ (if (length bundleChanges) == 1 then "" else "s")++ ". " +++ "The DarcsWatch web pages are generated " +++ "periodically, so it might take a while until your "+++ "changes become visible."+ else output $ cgiMessagePage True $ "There were errors "+++ "applying your updates: "++ show errors++getBundleChanges = mapMaybe $ \(n,v) -> + case ("state-" `stripPrefix` n, v) of+ (Nothing,_) -> Nothing+ (Just hb,"UNCHANGED") -> Nothing+ (Just hb,"OBSOLETE") -> Just (hb, Obsoleted)+ (Just hb,"REJECTED") -> Just (hb, Rejected)+ _ -> Nothing ++applyBundleChange config openID (bhash,newState) = do+ history <- liftIO $ getBundleHistory (cData config) bhash+ if newState <= maxState history then+ return $ Just $+ "Can not set patch bundle state to " ++ show newState+ ++", "++ "already in state " ++ show (maxState history) ++ "!"+ else do+ liftIO $ changeBundleState (cData config) bhash (ViaWeb openID) newState+ return Nothing++authenticated config action = do+ action "unauthenticated"
src/Darcs.hs view
@@ -17,6 +17,7 @@ Boston, MA 02110-1301, USA. -} +{-# LANGUAGE BangPatterns #-} module Darcs ( PatchInfo(..) , PatchBundle@@ -29,6 +30,7 @@ , hash_bundle , make_context , scan_context+ , make_patch ) where import OldDate@@ -41,6 +43,8 @@ import Printer import SHA1 +import Control.Arrow+ import qualified Data.ByteString.Char8 as B import Data.ByteString.Char8 (ByteString) import Data.List@@ -71,11 +75,11 @@ getInventory write cDir repo = do format <- get write False cDir formatUrl case format of- Nothing -> getInventory1 write cDir repo- Just (f,_) | f == B.pack "hashed\ndarcs-2\n" -> getInventory2 write cDir repo- | f == B.pack "darcs-1.0\n" -> getInventory1 write cDir repo- | f == B.pack "hashed\n" -> getInventory2 write cDir repo- | otherwise -> error $ "Unkown repository format: " ++ B.unpack f ++ " in repo " ++ repo+ 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@@ -91,7 +95,7 @@ let unzipped = maybeUnzipB body let patches = readPatchInfos unzipped case breakOn '\n' unzipped of- (l1,r) | l1 == B.pack "Starting with tag:" -> do+ (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@@ -108,11 +112,11 @@ write $ "Repository " ++ repo ++ " not found.\n" return ([],False) skip_pristine s = case breakOn '\n' s of- (l1,r) | B.pack "pristine" `B.isPrefixOf` l1 -> B.tail r+ (l1,r) | litPristine `B.isPrefixOf` l1 -> B.tail r _ -> s parseStart body = do case breakOn '\n' (skip_pristine body) of- (l,r) | l == B.pack "Starting with inventory:" -> do+ (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'')@@ -133,27 +137,28 @@ Nothing -> [] readPatchInfo :: ByteString -> Maybe (PatchInfo, ByteString)-readPatchInfo s | B.null (dropWhite s) = Nothing readPatchInfo s =- if B.head (dropWhite s) /= '[' -- ]+ if B.null s' || B.head s' /= '[' -- ] then Nothing- else case breakOn '\n' $ B.tail $ dropWhite s of- (name,s') | B.null s' -> error $ "Broken file (1) " ++ show (B.unpack s)- (name,s') | otherwise -> + 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)"+ (!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'''+ (!ct,!s''') ->+ do (!log, !s4) <- lines_starting_with_ending_with ' ' ']' $ dn s''' let not_star = B.index s2 1 /= '*'- return $ (PatchInfo { piDate = ct+ 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@@ -165,17 +170,19 @@ 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')+ (!l,r) -> case lswew $ B.tail r of+ Just (!ls,r') -> Just (l:ls,r') Nothing -> case breakLast en l of- Just (l2,_) ->- Just ([l2], B.drop (B.length l2+2) x)+ 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 c = B.break (c ==)+breakOn :: Char -> ByteString -> (ByteString, ByteString)+breakOn c = B.break (==c) breakLast c p = case B.elemIndexEnd c p of Nothing -> Nothing@@ -202,6 +209,10 @@ 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 ""@@ -258,8 +269,7 @@ silly_lex :: ByteString -> (String, ByteString)-silly_lex ps = (B.unpack $ B.takeWhile (/='\n') $ dropWhite ps,- B.dropWhile (/='\n') $ dropWhite ps)+silly_lex = first B.unpack . B.span (/='\n') . dropWhite make_context :: [PatchInfo] -> ByteString make_context = renderPS . vcat . map showPatchInfo@@ -277,20 +287,22 @@ filter_gpg_dashes :: ByteString -> ByteString filter_gpg_dashes ps = B.unlines $ map drop_dashes $- takeWhile (/= B.pack "-----END PGP SIGNED MESSAGE-----") $+ 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 == B.pack "- "+ else if B.take 2 x == litDashSpace then B.drop 2 x else x- not_context_or_newpatches s = (s /= B.pack "Context:") &&- (s /= B.pack "New patches:")+ not_context_or_newpatches s = (s /= litContext) &&+ (s /= litNewPatches) readDiff :: ByteString -> Maybe (ByteString, ByteString)-readDiff s | B.null (dropWhite s) = Nothing-readDiff s = find (\(p,r) -> B.pack "\n\n" `B.isPrefixOf` r || B.pack "\n[" `B.isPrefixOf` r)+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+ where s' = dropWhite s patchFilename :: PatchInfo -> String patchFilename pi = patchBasename pi ++ ".gz"@@ -299,8 +311,8 @@ -- stores it in, without the ".gz" suffix. patchBasename :: PatchInfo -> String patchBasename pi = showIsoDateTime d++"-"++sha1_a++"-"++sha1 (B.unpack sha1_me)- where b2ps True = B.pack "t"- b2ps False = B.pack "f"+ where b2ps True = litT+ b2ps False = litF sha1_me = B.concat [piName pi, piAuthor pi, piDate pi,@@ -319,3 +331,23 @@ 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"++
src/Darcs/Watch/Data.hs view
@@ -20,6 +20,7 @@ module Darcs.Watch.Data where import Data.Time+import Data.Maybe type BundleHash = String @@ -27,7 +28,7 @@ type StorageConf = String -- | A history entry is a state change-type BundleHistory = (UTCTime, Source, BundleState)+type BundleHistory = (ZonedTime, Source, BundleState) data BundleState = New@@ -41,12 +42,20 @@ = ManualImport | ViaEMail String String String (Maybe String) -- ^ From, To, Subject, Message-Id | ViaBugtracker String -- ^ URL--- | ViaWeb String -- ^ OpenID Username+ | ViaWeb String -- ^ OpenID Username | ViaRepository RepositoryURL -- ^ Repository-URL- deriving (Read, Show)+ deriving (Read, Show, Eq, Ord) type RepositoryURL = String+type EMailAddress = String -- ^ not use for patch authors, but subscriptions etc. +type Author = String -- ^ the email-address of an patch author++data BundleList = RepositoryBundleList RepositoryURL+ | AuthorBundleList Author+ | UnmatchedBundleList+ deriving (Read, Show, Eq, Ord)+ data RepositoryInfo = RepositoryInfo { lastCheck :: Maybe UTCTime , lastUpdate :: Maybe UTCTime@@ -60,6 +69,12 @@ cMails :: String, cDarcsWatchURL :: String, cDarcsWatchAddress :: String,- cSendRoundupMails :: Bool+ cRepoSubscriptions :: [(RepositoryURL, EMailAddress)],+ cSendMails :: Bool } deriving (Show, Read) ++stateOfRepo history repo = fromMaybe New (lookup repo (repoStates history))++repoStates history = [ (repo, state)+ | (_,ViaRepository repo, state) <- history ]
src/Darcs/Watch/GenerateOutput.hs view
@@ -36,6 +36,9 @@ import Data.Char import Data.List import Data.Time+import Data.Digest.OpenSSL.MD5 (md5sum)+import Data.Maybe+import Data.Monoid import System.FilePath import qualified Data.ByteString.Char8 as B@@ -48,9 +51,6 @@ -- Web ouput import HTML -import Data.Digest.OpenSSL.MD5 (md5sum)-import Data.Maybe- generateOutput config patchNew = do nowStamp <- getCurrentTime let outputStampFile = cData config </> "output.stamp"@@ -58,110 +58,86 @@ lastStamp <- if ex then read . B.unpack <$> B.readFile outputStampFile else return $ UTCTime (ModifiedJulianDay 0) 0 - putStrLn "Reading repositories..."- let loadInv rep = do- putStr $ "Reading " ++ rep ++ " ...\n"- ps <- readRepository (cData config) rep- repoInfo <- getRepositoryInfo (cData config) rep- let thisNew = maybe True (>= lastStamp) (lastUpdate repoInfo)- putStr (if thisNew then "Repostory is new.\n" else "Repository is cached.\n")- return (rep, ps, repoInfo, thisNew)- readInv (p2r,r2p,r2ri,new) (rep, ps, repoInfo, thisNew) = do- let p2r' = foldr (\p -> MM.append p rep) p2r ps- r2p' = MM.extend rep ps r2p :: M.Map RepositoryURL (S.Set PatchInfo)- r2ri' = M.insert rep repoInfo r2ri- return (p2r', r2p', r2ri', new || thisNew)- (p2r,r2p, r2ri, new) <- foldM readInv (MM.empty, MM.empty, M.empty, patchNew) =<<- sequence (map loadInv (cRepositories config))+ date <- getClockTime >>= toCalendarTime - putStrLn "Reading emails..."- bundleHashes <- listBundles (cData config)+ putStrLn "Reading name mapping list..."+ nameMapping <- readNameMapping (cData config) - let sortInBundle (u2p, u2rn, p2pe, new) bundleHash = do- putStrLn $ "Reading mail " ++ bundleHash ++ " ..."+ putStrLn "Reading bundle list lists.."+ bundleLists <- getBundleListList (cData config)+ -- Split bundle lists by type+ let (repos, authors) = mconcat $ map (\bl -> case bl of+ RepositoryBundleList repo -> ([repo],[])+ AuthorBundleList author -> ([],[author])+ _ -> mempty) bundleLists+ + let getBundleInfos bundleHash = do bundle <- getBundle (cData config) bundleHash- let bundleFileName = getBundleFileName (cData config) bundleHash history <- getBundleHistory (cData config) bundleHash+ let bundleFileName = "bundles" </> bundleBaseName bundleHash - let thisNew = any (\(d,_,_) -> d >= lastStamp) history-- let (patches,context) = bundle- let u2p' = foldr (\(p,_) -> MM.append (normalizeAuthor (piAuthor p)) p) u2p patches- let u2rn' = foldr (\(p,_) ->- M.insertWith (maxBy B.length) (normalizeAuthor (piAuthor p)) (piAuthor p)- ) u2rn patches- let p2pe' = foldr (\(p,d) ->- let pe = PatchExtras d context bundleFileName history- -- The patch with the smaller context is the more useful- in M.insertWith (minBy (length.peContext)) p pe- ) p2pe patches- return (u2p', u2rn', p2pe', new || thisNew)- (u2p, u2rn, p2pe, new') <- foldM sortInBundle (MM.empty, M.empty, M.empty, new) bundleHashes- let patches = M.keys p2pe -- Submitted patches- let repos = M.keys r2p -- Repos with patches- let users = M.keys u2p -- Known users- - if not new' then putStrLn "Nothing new, exiting" else do--- -- Clonsider patches as belonging to a repository when either- -- * it is already applied- -- * all its context is in the repository- -- * at least 10 patches of the context are in the repository- let addables = do -- List monad- patch <- patches- repo <- repos- present <- maybeToList $ M.lookup repo r2p- if patch `S.member` present- then return (patch,repo)- else do- pe <- maybeToList $ M.lookup patch p2pe- case partition (`S.member` present) (peContext pe) of- (_,[]) -> return (patch,repo) - (m,_) | length m >= 10 -> return (patch,repo) - _ -> []-- -- Patch to possible repos- -- Repo to possible patch- let p2pr = foldr (\(p,r) -> MM.append p r) MM.empty addables- let r2mp = foldr (\(p,r) -> MM.append r p) MM.empty addables-- -- Unmatched patches- let unmatched = S.fromList $- -- filter (\p -> M.findWithDefault Unmatched p p2s == Unmatched) $- filter (\p -> not (M.member p p2pr)) patches-- now <- getClockTime >>= toCalendarTime- let resultData = ResultData p2r r2p u2p p2pe p2pr r2mp r2ri unmatched now u2rn- - {-- putStrLn "Evalutating data"- putStrLn (show (length (show (resultData))))- -}-- putStrLn "Writing output..."- writeFile (cOutput config ++ "/index.html") (mainPage resultData)+ return (BundleInfo bundleHash bundle bundleFileName history) - forM_ users $ \u ->- writeFile (cOutput config ++ "/" ++ userFile u) (userPage resultData u)+ putStrLn "Writing output (repo pages)..."+ forM_ repos $ \r -> do+ (bundleHashes,_) <- readBundleList (cData config) (RepositoryBundleList r)+ bundleInfos <- mapM getBundleInfos bundleHashes+ repoInfo <- getRepositoryInfo (cData config) r+ writeFile (cOutput config ++ "/" ++ repoFile r) $+ repoPage date nameMapping r repoInfo bundleInfos - forM_ repos $ \r ->- writeFile (cOutput config ++ "/" ++ repoFile r) (repoPage resultData r)+ putStrLn "Writing output (user pages)..."+ forM_ authors $ \u -> do+ (bundleHashes,_) <- readBundleList (cData config) (AuthorBundleList u)+ bundleInfos <- mapM getBundleInfos bundleHashes+ writeFile (cOutput config ++ "/" ++ userFile u) $+ userPage date nameMapping u bundleInfos+ + putStrLn "Writing output (main page)..."+ bundleHashes <- listBundles (cData config) - forM_ patches $ \p ->- B.writeFile (cOutput config ++ "/" ++ patchDiffFile p) (peDiff (p2pe M.! p))+ patches <- mconcat <$> forM bundleHashes (\bundleHash -> do+ (ps,_) <- getBundle (cData config) bundleHash+ return (M.fromList ps)+ )+ let patchCount = M.size patches+ let bundleCount = length bundleHashes+ let strict5 f a b c d e = ((((f $! a) $! b) $! c) $! d ) $! e+ let strict6 f a b c d e g = (((((f $! a) $! b) $! c) $! d ) $! e) $! g+ repoData <- forM repos $ \r -> do+ (bundleHashes,_) <- readBundleList (cData config) (RepositoryBundleList r)+ bundleInfos <- mapM getBundleInfos bundleHashes+ inv <- readRepository (cData config) r+ return $ strict6 (,,,,,) + r+ (length inv)+ (length $ bundleInfoFilter Applied bundleInfos)+ (length $ bundleInfoFilter Applicable bundleInfos)+ (length $ bundleInfoFilter Obsoleted bundleInfos)+ (length $ bundleInfoFilter Rejected bundleInfos)+ userData <- forM authors $ \u -> do+ (bundleHashes,_) <- readBundleList (cData config) (AuthorBundleList u)+ bundleInfos <- mapM getBundleInfos bundleHashes+ return $ strict5 (,,,,) + u+ (length bundleInfos)+ (length (bundleInfoFilter Applicable bundleInfos))+ (length (bundleInfoFilter Obsoleted bundleInfos))+ (length (bundleInfoFilter Rejected bundleInfos))+ writeFile (cOutput config ++ "/index.html") $+ mainPage date nameMapping patchCount bundleCount repoData userData - writeFile (cOutput config ++ "/" ++ "unmatched.html") (unmatchedPage resultData)+ putStrLn "Writing output (diffs)..."+ forM_ (M.toList patches) $ \(p,d) -> do+ let filename = cOutput config ++ "/" ++ patchDiffFile p + ex <- doesFileExist filename+ unless ex $ do+ putStrLn $ "Writing new patch file " ++ filename+ B.writeFile filename d - putStrLn "Linking patches"- let patchLink (p,pe) = do- let link = cOutput config ++ "/" ++ patchBasename p ++ ".dpatch"- ex <- fileExist link- unless ex $ do- -- There might be a broken symlink here:- catch (removeFile link) (const (return ()))- createSymbolicLink (peBundleFile pe) link- mapM_ patchLink $ M.toList p2pe+ ex <- doesDirectoryExist (cOutput config </> "bundles")+ unless ex $ + createSymbolicLink (bundleDir (cData config)) (cOutput config </> "bundles") B.writeFile outputStampFile (B.pack (show nowStamp))
src/Darcs/Watch/ImportMail.hs view
@@ -37,6 +37,7 @@ import Darcs.Watch.Data import Darcs.Watch.Storage+import Darcs.Watch.Roundup importMail :: DarcsWatchConfig -> IO Bool importMail config = do@@ -60,6 +61,9 @@ case roundupURL of Nothing -> return () Just url -> do+ history <- getBundleHistory (cData config) bhash+ forM_ (repoStates history) $ \(repo,state) -> + tellRoundup config url repo bhash bundle state changeBundleState (cData config) bhash (ViaBugtracker url) New changeBundleState (cData config) bhash emailSource state@@ -79,7 +83,6 @@ return (or changes) findSubmittingMail = mapMaybe isSubmittingMail- isSubmittingMail (_,ViaEMail _ _ _ (Just mid), New) = Just mid isSubmittingMail _ = Nothing @@ -121,6 +124,7 @@ findDarcsBundle (Message _ _ (Body (ContentType "text" "x-darcs-patch" _) _ msg)) = Just msg findDarcsBundle (Message _ _ (Data _ _ filename msg)) | ".dpatch" `isSuffixOf` filename = Just msg+ | "darcs" `isPrefixOf` filename = Just msg findDarcsBundle (Message _ _ (Mixed (Multipart _ msgs _ ))) = msum (map findDarcsBundle msgs) findDarcsBundle (Message _ _ (Alternative (Multipart _ msgs _ ))) = msum (map findDarcsBundle msgs) findDarcsBundle (Message _ _ (Parallel (Multipart _ msgs _ ))) = msum (map findDarcsBundle msgs)
src/Darcs/Watch/Roundup.hs view
@@ -11,36 +11,32 @@ import Darcs import HTML -tellRoundup :: DarcsWatchConfig -> String -> RepositoryURL -> PatchBundle -> BundleState -> IO ()-tellRoundup _ _ _ _ status | status `notElem` [Applied, Applicable] = return ()-tellRoundup _ url _ _ _ | not $ "http://bugs.darcs.net/" `isPrefixOf` url = return ()-tellRoundup config url repo bundle status = do+tellRoundup :: DarcsWatchConfig -> String -> RepositoryURL -> BundleHash -> PatchBundle -> BundleState -> IO ()+tellRoundup _ _ _ _ _ status | status `notElem` [Applied, Applicable] = return ()+tellRoundup _ url _ _ _ _ | not $ "http://bugs.darcs.net/" `isPrefixOf` url = return ()+tellRoundup config url repo bundleHash bundle status = do message <- flatten [mk_header ["From: " ++ from] ,mk_header ["To: " ++ to] ,mk_header ["Subject: " ++ subject] ] body Nothing []- if cSendRoundupMails config+ if cSendMails config then do sendMail message else do hPutStrLn stderr "Would send this message:" hPutStrLn stderr message where from = cDarcsWatchAddress config to = "bugs@darcs.net" subject = case status of- Applicable -> "This patch is being tracked by DarcsWatch [" ++ roundupId ++ "]"+ Applicable -> "This patch is being tracked by DarcsWatch [" ++ roundupId ++ "] [darcswatchurl=" ++ bundleLink ++ "]" Applied -> "This patch has been applied [" ++ roundupId ++ "] [status=accepted]" body = case status of- Applicable -> "This patch bundle (with " ++ show numPatches ++ " patch" ++- (if numPatches == 1 then "" else "es") ++ "), which can be " ++- " applied to the repository " ++ repo ++ " is now tracked " ++- " on DarcsWatch at " ++- cDarcsWatchURL config ++ repoFile repo+ Applicable -> "" -- no messages about this, please Applied -> "This patch bundle (with " ++ show (length (fst bundle)) ++ " patches) was just applied to the repository " ++ repo ++".\n" ++ "This message was brought to you by " ++ "DarcsWatch\n" ++- cDarcsWatchURL config ++ repoFile repo+ bundleLink+ bundleLink = bundleURL config repo bundleHash numPatches = length (fst bundle)- roundupId = drop (length "http://bugs.darcs.net/") url sendMail :: String -> IO ()
src/Darcs/Watch/Storage.hs view
@@ -24,6 +24,7 @@ import Data.Time import qualified Data.ByteString.Char8 as B+import qualified Data.Map as M import Data.ByteString.Char8 (ByteString) import System.FilePath import System.Directory@@ -41,7 +42,7 @@ let dataFile = bundleDir path </> hash <.> "data" ex <- doesFileExist dataFile unless ex $ B.writeFile dataFile (B.pack "[]")- B.writeFile (bundleDir path </> hash <.> "bundle")+ B.writeFile (bundleFileName path hash) (make_bundle bundle) return hash @@ -49,7 +50,7 @@ -- | Retrieves a new patch bundle from the storage getBundle :: StorageConf -> BundleHash -> IO PatchBundle getBundle path hash = - either error id . scan_bundle <$> B.readFile (bundleDir path </> hash <.> "bundle")+ either error id . scan_bundle <$> B.readFile (bundleFileName path hash) -- | Retrieves the meta information for the handle getBundleHistory :: StorageConf -> BundleHash -> IO [BundleHistory]@@ -60,7 +61,7 @@ changeBundleState :: StorageConf -> BundleHash -> Source -> BundleState -> IO () changeBundleState path hash source state = do history <- getBundleHistory path hash- now <- getCurrentTime+ now <- getZonedTime B.writeFile (bundleDir path </> hash <.> "data") $ B.pack $ show $ (now, source, state) : history @@ -69,7 +70,7 @@ listBundles path = do items <- getDirectoryContents (bundleDir path) return $ map dropExtension- $ filter ( (".bundle" == ) .takeExtension )+ $ filter ( (".dpatch" == ) . takeExtension ) $ items @@ -104,17 +105,68 @@ if ex then read . B.unpack <$> B.readFile infoFile else return (RepositoryInfo Nothing Nothing) +setBundleListList :: StorageConf -> [BundleList] -> IO ()+setBundleListList path bll = do+ writeFile (bundleListDir path </> "index") (show bll)++getBundleListList :: StorageConf -> IO [BundleList]+getBundleListList path = do+ read <$> B.unpack <$> B.readFile (bundleListDir path </> "index")++writeBundleList :: StorageConf -> BundleList -> [BundleHash] -> IO ()+writeBundleList path bl blist = do+ let filename = bundleListFilename path bl+ sorted = sort blist+ (oldList,_) <- readBundleList path bl+ when (oldList /= blist) $ do+ now <- getCurrentTime+ writeFile filename (unlines (show now : blist))++readBundleList :: StorageConf -> BundleList -> IO ([BundleHash], UTCTime)+readBundleList path bl = do+ let filename = bundleListFilename path bl+ ex <- doesFileExist filename + if not ex then return ([],UTCTime (ModifiedJulianDay 0) 0) else do+ (stamp:bhashes) <- lines <$> B.unpack <$> B.readFile filename+ return (bhashes, read stamp)++writeNameMapping :: StorageConf -> M.Map Author String -> IO ()+writeNameMapping path map = do+ B.writeFile (nameMappingFilename path) $ B.pack $ show map++readNameMapping :: StorageConf -> IO (M.Map Author String)+readNameMapping path = do+ let filename = nameMappingFilename path+ ex <- doesFileExist filename + if not ex then return M.empty else + read <$> B.unpack <$> B.readFile filename++bundleListFilename path (RepositoryBundleList repo) =+ bundleListDir path </> "repo_" ++ safeName repo+bundleListFilename path (AuthorBundleList author) =+ bundleListDir path </> "user_" ++ safeName author+bundleListFilename path UnmatchedBundleList =+ bundleListDir path </> "unmatched"++nameMappingFilename path = path </> "nameMapping"+ bundleDir :: StorageConf -> FilePath bundleDir path = path </> "bundles" -getBundleFileName :: StorageConf -> BundleHash -> FilePath-getBundleFileName path hash = bundleDir path </> hash <.> "bundle"+bundleBaseName :: BundleHash -> FilePath+bundleBaseName hash = hash <.> "dpatch" +bundleFileName :: StorageConf -> BundleHash -> FilePath+bundleFileName path hash = bundleDir path </> bundleBaseName hash+ repoDir :: StorageConf -> FilePath repoDir path = path </> "repos" cacheDir :: StorageConf -> FilePath cacheDir path = path </> "cache"++bundleListDir :: StorageConf -> FilePath+bundleListDir path = path </> "bundleLists" safeName n = map s n where s c = if isSafeFileChar c then c else '_'
src/Darcs/Watch/UpdateRepoData.hs view
@@ -41,13 +41,34 @@ import Data.Digest.OpenSSL.MD5 (md5sum) import Data.Maybe import System.FilePath+import Control.Monad.Writer -- Darcs stuff import Darcs import Darcs.Watch.Storage import Darcs.Watch.Data import Darcs.Watch.Roundup+import Darcs.Watch.Mail+import HTML (normalizeAuthor) +newtype BundleListMap = BundleListMap { unBundleListMap :: M.Map BundleList (S.Set BundleHash) }++instance Monoid BundleListMap where+ mempty = BundleListMap M.empty+ mappend (BundleListMap m1) (BundleListMap m2) =+ BundleListMap (M.unionWith (S.union) m1 m2)++addBundleListEntry bl bh =+ tell (mempty,(BundleListMap (M.singleton bl (S.singleton bh))))++addNameOccurence name =+ tell (Endo (M.insertWith (maxBy length) (normalizeAuthor name) name), mempty)++forBundleListMap :: Monad m => BundleListMap -> (BundleList -> [BundleHash] -> m ()) -> m ()+forBundleListMap (BundleListMap m) act = mapM_ (\(bl,bhs) -> act bl (S.toList bhs)) $ M.toList m++bundleListMapKeys (BundleListMap m) = M.keys m+ updateRepoData config = do let readRepo rep = do inv <- readRepository (cData config) rep@@ -55,27 +76,27 @@ repos <- mapM readRepo (cRepositories config) bundleHashes <- listBundles (cData config)- forM_ bundleHashes $ \bundleHash -> do- bundle <- getBundle (cData config) bundleHash- history <- getBundleHistory (cData config) bundleHash+ putStrLn "Detecing bundle state changes..."+ (nameSetters, bundleHashLists) <- execWriterT $ forM_ bundleHashes $ \bundleHash -> do+ bundle <- liftIO $ getBundle (cData config) bundleHash+ history <- liftIO $ getBundleHistory (cData config) bundleHash let context = snd bundle let patches = map fst (fst bundle)- ++ forM patches $ \pi -> do+ let email = normalizeAuthor (B.unpack (piAuthor pi))+ addBundleListEntry (AuthorBundleList email) bundleHash+ addNameOccurence (B.unpack (piAuthor pi))+ forM repos $ \(repo, inv) -> do- let statusQuoAnte =- fromMaybe New $- listToMaybe $- map (\(_,_,s) -> s) $- filter (aboutRepo repo) $- history- - let statusQuo = + let statusQuoAnte = stateOfRepo history repo+ statusQuo = if all (`S.member` inv) patches then Applied else if applicable inv context then Applicable else New - when (statusQuo /= statusQuoAnte) $ do+ when (statusQuo /= statusQuoAnte) $ liftIO $ do putStrLn $ "Marking bundle " ++ bundleHash ++ " as " ++ show statusQuo ++ " with regard to " ++ repo@@ -87,9 +108,22 @@ case haveRoundupURL history of Nothing -> return () Just url -> - tellRoundup config url repo bundle statusQuo+ tellRoundup config url repo bundleHash bundle statusQuo+ + mailSubscriptions config repo bundleHash bundle history statusQuo + when (statusQuo /= New) $+ addBundleListEntry (RepositoryBundleList repo) bundleHash + + putStrLn $ "Writing bundle lists..."+ forBundleListMap bundleHashLists $ \bl bh -> do+ writeBundleList (cData config) bl bh + setBundleListList (cData config) (bundleListMapKeys bundleHashLists)++ putStrLn $ "Writing name mapping list..."+ writeNameMapping (cData config) (appEndo nameSetters M.empty)+ -- Clonsider patches as applicable to a repository when either -- * all its context is in the repository -- * at least 10 patches of the context are in the repository@@ -99,5 +133,4 @@ (m,_) | length m >= 10 -> True _ -> False -aboutRepo repo (_,ViaRepository r,_) = repo == r-aboutRepo _ _ = False+maxBy f v1 v2 = if f v1 >= f v2 then v1 else v2
src/Generate-Main.hs view
@@ -60,4 +60,4 @@ putStrLn "Reading configuration..." config <- read `fmap` readFile (confdir ++ "config") - lockRestart (cOutput config) patchNew or True (generateOutput config)+ lockRestart (cData config) patchNew or True (generateOutput config)
src/HTML.hs view
@@ -18,16 +18,19 @@ -} module HTML - ( ResultData(ResultData)- , PatchExtras(..)+ ( BundleInfo(..) , mainPage , userPage , repoPage- , unmatchedPage+ , cgiMessagePage , userFile , repoFile , patchDiffFile , normalizeAuthor+ , bundleInfoFilter+ , maxState+ , bundleURL+ , stripIgnorethis ) where import Text.XHtml hiding ((!))@@ -58,32 +61,30 @@ on :: (b -> b -> c) -> (a -> b) -> a -> a -> c (*) `on` f = \x y -> f x * f y -data ResultData = ResultData- { p2r :: M.Map PatchInfo (S.Set RepositoryURL)- , r2p :: M.Map RepositoryURL (S.Set PatchInfo)- , u2p :: M.Map ByteString (S.Set PatchInfo)- , p2pe:: M.Map PatchInfo (PatchExtras)- , p2pr :: M.Map PatchInfo (S.Set String)- , r2mp :: M.Map RepositoryURL (S.Set PatchInfo)- , r2ri :: M.Map RepositoryURL (RepositoryInfo)- , unmatched :: (S.Set PatchInfo)- , date :: CalendarTime- , u2rn :: M.Map ByteString ByteString- } deriving (Show)--data PatchExtras = PatchExtras- { peDiff :: ByteString- , peContext :: [PatchInfo]- , peBundleFile :: FilePath- , peStateHistory :: [BundleHistory]- } deriving (Show)+data BundleInfo = BundleInfo+ { biBundleHash :: BundleHash+ , biBundle :: PatchBundle+ , biFileName :: FilePath+ , biHistory :: [BundleHistory]+ } +instance Eq BundleInfo where+ (==) = (==) `on` biBundleHash -users d = M.keys (u2p d)-repos d = M.keys (r2p d)+instance Ord BundleInfo where+ compare = compare `on` (map (piDate.fst) . fst . biBundle) -mainPage d = showHtml $- header << thetitle << "DarcsWatch overview" ++++mainPage date+ nameMapping+ patchCount+ bundleCount+ repoData+ authorData+ = showHtml $+ header << (+ thetitle << "DarcsWatch overview" ++++ myHeader + ) +++ body << ( h1 << "DarcsWatch overview" +++ p << ( "Welcome to DarcsWatch. If you want to know more, please read the " +++@@ -92,31 +93,45 @@ ) +++ h2 << "Statistics" +++ p << stringToHtml (- printf "Tracking %d repositories and %d patches submitted by %d users"- (M.size (r2p d)) (M.size (p2pe d)) (M.size (u2p d))+ printf "Tracking %d repositories and %d patches in %d bundles submitted by %d users."+ (length repoData) (patchCount :: Int) (bundleCount :: Int) (length authorData) ) +++ h2 << "Listing by user" +++ - unordList (map (\u -> hotlink (userFile u) << u2rn d ! u +++ userStats u d) (users d)) ++++ unordList (map userLine authorData) +++ h2 << "Listing by repository" +++ - unordList ( map (\r -> hotlink (repoFile r) << r +++ repoStats r d) (repos d)- ++ [hotlink "unmatched.html" << "Unmatched patches"- +++ " "+++ show (S.size (unmatched d)) +++ " patches" ]- ) +++- footer d+ unordList (map repoLine repoData) ++++ footer (Just date) )+ where userLine (u, tracked, unapplied, obsolete, rejected) =+ hotlink (userFile u) << M.findWithDefault u u nameMapping ++++ " " +++ show tracked +++ + " tracked patches, "++++ count Applicable "unapplied" unapplied ++++ count Obsoleted "obsolete" obsolete ++++ count Rejected "rejected" rejected+ repoLine (r, inventory, tracked, applicable, obsolete, rejected) =+ hotlink (repoFile r) << r ++++ " " +++ show tracked +++ + " patches in inventory, "++++ count Applied "tracked" tracked ++++ count Applicable "applicable" applicable ++++ count Obsoleted "obsolete" obsolete ++++ count Rejected "rejected" rejected+ count s t 0 = noHtml+ count s t n = inColor (stateColor s) << (show n +++ " " +++ t) +++ " " -footer d = +footer mDate = p !!! [thestyle "font-size:80%"] << ( "darcswatch © Joachim Breitner <" +++ hotlink "mailto:mail@joachim-breitner.de" << "mail@joachim-breitner.de" +++ ">. Source code at " +++ hotlink "http://darcs.nomeata.de/darcswatch/" << "http://darcs.nomeata.de/darcswatch/"+++- ". Last update " +++- calendarTimeToString (date d) +++- "."+ "." +++ maybe noHtml (\d -> " Last update " +++ calendarTimeToString d +++ ".") mDate ) -myHeader d = script !!! [thetype "text/javascript", src "/javascript/jquery/jquery.js"] << noHtml+myHeader = script !!! [thetype "text/javascript", src "/javascript/jquery/jquery.js"] << noHtml +++ script !!! [thetype "text/javascript"] << "\ \$(document).ready(function () { \@@ -140,68 +155,88 @@ \span[title] { border-bottom: dotted 1px black; } \ \" --userPage d u = showHtml $+userPage date nameMapping u bundleInfos = showHtml $ header << (- thetitle << ("DarcsWatch overview for " +++ u2rn d ! u) +++- myHeader d+ thetitle << ("DarcsWatch overview for " +++ u) ++++ myHeader ) +++- body << (- h1 << ("DarcsWatch overview for " +++ u2rn d ! u) ++++ body << form !!! [ method "GET", action "cgi"] << (+ h1 << ("DarcsWatch overview for " +++ M.findWithDefault u u nameMapping) +++ p << hotlink "." << "Return to main page" +++- patchList d (sps !!!! Applicable) "Unapplied patches" True +++- patchList d (sps !!!! New) "Unmatched patches" True +++- patchList d (sps !!!! Rejected) "Rejected patches" True +++- patchList d (sps !!!! Obsoleted) "Obsoleted patches" True +++- patchList d (sps !!!! Applied) "Applied patches" True +++- footer d+ bundleList nameMapping "Unapplied patch bundles" (bundleInfoFilter Applicable bundleInfos) +++ + bundleList nameMapping "Unmatched patch bundles" (bundleInfoFilter New bundleInfos) +++ + bundleList nameMapping "Applied patch bundles" (bundleInfoFilter Applied bundleInfos) +++ + bundleList nameMapping "Obsoleted patch bundles" (bundleInfoFilter Obsoleted bundleInfos) +++ + bundleList nameMapping "Rejected patch bundles" (bundleInfoFilter Rejected bundleInfos) +++ + footer (Just date) )- where (ps, sps) = userData u d -repoPage d r = showHtml $++repoPage date nameMapping r repoInfo bundleInfos = showHtml $ header << ( thetitle << ("DarcsWatch overview for " +++ r) +++- myHeader d+ myHeader ) +++- body << (+ body << form !!! [ method "GET", action "cgi"] << ( h1 << ("DarcsWatch overview for " +++ r) +++ p << hotlink "." << "Return to main page" +++- patchList d (sps !!!! Applicable) "Unapplied patches" False +++- patchList d (sps !!!! Applied) "Applied patches" False +++- patchList d (sps !!!! Obsoleted) "Obsoleted patches" False +++- patchList d (sps !!!! Rejected) "Rejected patches" True ++++ bundleList nameMapping "Unapplied patch bundles" (bundleInfoFilter Applicable bundleInfos) +++ + bundleList nameMapping "Applied patch bundles" (bundleInfoFilter Applied bundleInfos) +++ + bundleList nameMapping "Obsoleted patch bundles" (bundleInfoFilter Obsoleted bundleInfos) +++ + bundleList nameMapping "Rejected patch bundles" (bundleInfoFilter Rejected bundleInfos) +++ thediv << ( "Last change in repository at " +++- maybe (toHtml "No idea when") toHtml (lastUpdate (r2ri d ! r)) ++++ maybe (toHtml "No idea when") toHtml (lastUpdate repoInfo) +++ ", last check of repository at " +++- maybe (toHtml "No idea when") toHtml (lastCheck (r2ri d ! r)) +++ "."+ maybe (toHtml "No idea when") toHtml (lastCheck repoInfo) +++ "." ) +++- footer d+ footer (Just date) )- where (ps, sps) = repoData r d- ++bundleList nameMapping title [] = noHtml+bundleList nameMapping title list = + h2 << title ++++ unordList (map (bundleView nameMapping) list)++bundleInfoFilter state = sort . filter (\bi -> state == maxState (biHistory bi))++{- unmatchedPage d = showHtml $ header << ( thetitle << ("DarcsWatch overview, unmatched patches") +++- myHeader d+ myHeader ) +++- body << (+ body << form !!! [ method "GET", action "cgi"] << ( h1 << ("DarcsWatch overview, unmatched Patches") +++ p << hotlink "." << "Return to main page" +++ patchList d (S.toList (unmatched d)) "Unmatched patches" False +++- footer d+ footer (Just (date d)) )+-} -patchList d [] title userCentric = h5 << ("No "++title)-patchList d ps title userCentric = - h2 << title +++ (unordList $ map (patchView d userCentric) ps)+cgiMessagePage isError msg = showHtml $+ header << (+ thetitle << "DarcsWatch" ++++ myHeader+ ) ++++ body << (+ h1 << "DarcsWatch" ++++ p << (+ (if isError then inColor "red" << "Error: " else noHtml)+ ++++ msg+ ) ++++ footer Nothing+ ) -patchHistoryView d p = - unordList $ flip map (reverse $ peStateHistory $ p2pe d ! p) $ \(date,source,state) ->- date +++ ": " +++ showState state +++ " " +++ showSource source+patchHistoryView history = unordList $+ map (\(date,source,state) ->+ date +++ ": " +++ showState state +++ " " +++ showSource source)+ (reverse history) showSource (ViaRepository repo) = " in repo " +++ hotlink (repoFile repo) << repo showSource (ViaBugtracker url) = " in bug tracker ticket " +++ hotlink url << url+showSource (ViaWeb openid) = " via web interface by user " +++ hotlink openid << openid showSource (ViaEMail from to subject mmid) = " via " +++ thespan !!! [ title $ "From: " ++ from ++ "\n" ++@@ -219,44 +254,72 @@ showSource ManualImport = toHtml "via a manual import" -patchView d userCentric p =+bundleView nameMapping (BundleInfo bundleHash (ps,ctx) bundleFileName history) = + p << (anchor !!! [name ("bundle-" ++ bundleHash)] << noHtml ++++ strong << "Contents:" ++++ " (" ++++ (if length ps == 1+ then "1 patch"+ else show (length ps) ++ " patches" ) ++++ ")"+ ) ++++ unordList (map (patchView nameMapping) (map fst ps)) ++++ p << (strong << "History:") ++++ patchHistoryView history ++++ actions+ where+ actions = paragraph << (+ strong << "Actions: " ++++ hotlink bundleFileName << "Download .dpatch" ++++ " "+++ + if maxState history <= Applicable+ then " "++++ select !!! [ name ("state-" ++ bundleHash), size "1"] << (+ option !!! [ value "UNCHANGED" ] << "Mark patch as..." ++++ option !!! [ value "OBSOLETE" ] << "Obsolete" ++++ option !!! [ value "REJECTED" ] << "Rejected"+ ) ++++ submit "submit" "Submit"+ else noHtml+ )++patchView nameMapping p = piDate p +++ ": " +++ strong << ( (if piInverted p then stringToHtml "UNDO: " else noHtml) +++ piName p ) +++- (if userCentric- then noHtml- else ( " " +++ small << (- " by " +++ hotlink (userFile (piAuthor p)) << piAuthor p- )- )+ " " ++++ small << (+ " by " ++++ let u = B.unpack (piAuthor p) in+ hotlink (userFile u) <<+ M.findWithDefault u u nameMapping ++++ " " ++++ diffShower ) +++- pre << B.unlines (piLog p) +++- patchHistoryView d p +++- actions ++++ (if null log then noHtml else pre << B.unlines log) +++ thediv !!! [identifier diffId, thestyle "display:none"] << pre noHtml where pid = patchBasename p diffShowerId = "diffshower_"++pid diffId = "diff_"++pid- actions = paragraph << (- strong << "Actions: " +++- hotlink (pid ++ ".dpatch") << "Download .dpatch" +++- " "+++ - anchor !!! [identifier diffShowerId, theclass "diffshower", href "javascript:"]- << "Show/Hide diff"- )- + diffShower = anchor+ !!! [identifier diffShowerId, theclass "diffshower", href "javascript:"]+ << "Show/Hide diff"+ log = stripIgnorethis (piLog p)++maxState history = maximum $ New : map (\(_,_,s) -> s) history++{- state d p r | p `S.member` ps = Applied- | ip `S.member` ps = explicit_state+ | ip `S.member` ps = maxState history | amend_obsoleted = Obsoleted | ip `S.member` subs && not (piInverted p) = Obsoleted- | otherwise = explicit_state+ | otherwise = maxState history where context = peContext (p2pe d ! p) history = peStateHistory (p2pe d ! p) ps = r2p d ! r ip = inversePatch p subs = M.keysSet (p2pe d)- explicit_state = maximum $ New : map (\(_,_,s) -> s) history amend_obsoleted = any (`laterThan` p) $ S.toList (u2p d ! (normalizeAuthor (piAuthor p))) p1 `laterThan` p2 = piAuthor p1 == piAuthor p2@@ -264,6 +327,7 @@ && piLog p1 == piLog p2 && piInverted p1 == piInverted p2 && piDate p1 > piDate p2+-} showState New = "Seen bundle" showState Applicable = "Not yet fully applied bundle"@@ -279,13 +343,10 @@ inColor c = thespan !!! [thestyle ("color:"++c)] -viewState d p r = inColor (stateColor s) << (showState s)- where s = state d p r- (!!!) :: ADDATTRS a => a -> [HtmlAttr] -> a (!!!) = (Text.XHtml.!) -+{- userStats u d = " " +++ show (length ps) +++ " tracked patches, "+++@@ -321,19 +382,17 @@ state' p | S.null repos = New | otherwise = S.findMax (S.map (state d p) repos) where repos = p2pr d !!!! p+-} -userFile u = "user_" ++ B.unpack (normalizeAuthor u) ++ ".html"+userFile u = "user_" ++ normalizeAuthor u ++ ".html" repoFile r = "repo_" ++ safeName r ++ ".html" patchDiffFile p = "diff_" ++ patchBasename p ++ ".txt" -normalizeAuthor name | not (B.null r') && valid = email- | otherwise = safeNameB name- where r' = B.dropWhile (/='<') name- (email,r'') = B.span (/='>') (B.tail r')- valid = not (B.null email) && not (B.null r'') && B.all (isSafeFileChar) email--safeNameB n = B.map s n- where s c = if isSafeFileChar c then c else '_'+normalizeAuthor name | not (null r') && valid = email+ | otherwise = safeName name+ where r' = dropWhile (/='<') name+ (email,r'') = span (/='>') (tail r')+ valid = not (null email) && not (null r'') && all (isSafeFileChar) email safeName n = map s n where s c = if isSafeFileChar c then c else '_'@@ -344,8 +403,19 @@ s2List = patchSort . S.toList patchSort = sortBy (flip (compare `on` piDate)) +bundleURL :: DarcsWatchConfig -> RepositoryURL -> BundleHash -> String+bundleURL config repo hash = cDarcsWatchURL config ++ repoFile repo ++ "#bundle-" ++ hash++stripIgnorethis [] = []+stripIgnorethis (x:xs) | B.pack "Ignore-this:" `B.isPrefixOf` x = stripIgnorethis xs+ | B.null x = stripIgnorethis xs+ | otherwise = x:xs+ instance HTML ByteString where toHtml = toHtml . B.unpack instance HTML UTCTime where+ toHtml = toHtml . formatTime defaultTimeLocale "%c" ++instance HTML ZonedTime where toHtml = toHtml . formatTime defaultTimeLocale "%c"
src/PullRepos-Main.hs view
@@ -58,7 +58,6 @@ putStrLn "Reading configuration..." config <- read `fmap` readFile (confdir </> "config") - --lockRestart (cOutput config) patchNew or True (do_work config) new <- pullRepos config when new $ do lockRestart (cData config) False or True $ \new -> do
src/UpdateRepoData-Main.hs view
@@ -57,5 +57,4 @@ putStrLn "Reading configuration..." config <- read `fmap` readFile (confdir </> "config") - --lockRestart (cOutput config) patchNew or True (do_work config) updateRepoData config