{-
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.
-}
import Control.Monad
import Control.Concurrent
import System.Environment (getArgs)
import System.Directory
import System.Posix.Files
import System.Time
import System.IO
import System.Terminal.Concurrent
import qualified Data.Map as M
import qualified Data.Set as S
import qualified MultiMap as MM
import MultiMap ((!!!!))
import Data.Char
import Data.List
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Char8 (ByteString)
-- Darcs stuff
import Darcs
-- Web ouput
import HTML
import LockRestart
import Data.Digest.OpenSSL.MD5 (md5sum)
data DarcsWatchConfig = DarcsWatchConfig {
cRepositories :: [String],
cOutput :: String,
cMails :: String
} deriving (Show, Read)
main = do
hSetBuffering stdout NoBuffering
args <- getArgs
let (confdir, patchNew) = case args of
[confdir] -> (addSlash confdir, False)
[confdir, "new"] -> (addSlash confdir, True)
_ -> error "Use darcswatch confdir/"
putStrLn "Reading configuration..."
config <- read `fmap` readFile (confdir ++ "config")
lockRestart (cOutput config) patchNew or True (do_work config)
do_work config patchNew = do
writeC <- getConcurrentOutputter
putStrLn "Reading repositories..."
let loadInv rep = do
writeC $ "Reading " ++ rep ++ ":\n"
(ps,thisNew) <- getInventory writeC (cOutput config ++ "/cache/") rep
writeC (if thisNew then "Repostory is new.\n" else "Repository is cached.\n")
return (rep, ps, thisNew)
readInv (p2r,r2p,new) (rep, ps,thisNew) = do
let p2r' = foldr (\p -> MM.append p rep) p2r ps
r2p' = MM.extend rep ps r2p :: M.Map String (S.Set PatchInfo)
return (p2r', r2p', new || thisNew)
(p2r,r2p, new) <- foldM readInv (MM.empty, MM.empty, patchNew) =<<
forkSequence (map loadInv (cRepositories config))
if not new then putStrLn "Nothing new, exiting" else do
putStrLn "Reading emails..."
mailFiles' <- getDirectoryFiles (cMails config)
let mailFiles = filter ((addSlash (cMails config) ++ "patch") `isPrefixOf`) mailFiles'
let readMail (u2p, u2rn, p2pe, md2p) mailFile = do
putStrLn $ "Reading mail " ++ mailFile ++ " ..."
mail <- B.readFile mailFile
let checksum = md5sum mail
let (new,context) = parseMail mail
let u2p' = foldr (\(p,_) -> MM.append (normalizeAuthor (piAuthor p)) p) u2p new
let u2rn' = foldr (\(p,_) ->
M.insertWith (maxBy B.length) (normalizeAuthor (piAuthor p)) (piAuthor p)
) u2rn new
let p2pe' = foldr (\(p,d) ->
let pe = PatchExtras d context mailFile
-- The patch with the smaller context is the more useful
in M.insertWith (minBy (length.peContext)) p pe
) p2pe new
let md2p' = MM.extend checksum (map fst new) md2p
return (u2p', u2rn', p2pe', md2p')
(u2p, u2rn, p2pe, md2p) <- foldM readMail (MM.empty, M.empty, M.empty, MM.empty) mailFiles
putStrLn "Reading bundle states..."
states <- readFile (addSlash (cMails config) ++ "states")
let readStateLine string =
let (checksum: stateString : _ : rest) = words string
sender = unwords rest
state = case stateString of
"add" -> Unmatched
"obsolete" -> Obsolete
"rejected" -> Rejected
unknown -> error $ "Unknown state " ++ show unknown
in flip (foldr (\p -> M.insert p state)) (md2p !!!! checksum)
p2s = foldl (flip readStateLine) M.empty (lines states)
putStrLn "Reading mid to patch mapping..."
midmappings <- readFile (addSlash (cMails config) ++ "mid-mapping")
let readMidLine string =
let [mid,checksum] = words string
in flip (foldr (\p -> M.insert p mid)) (md2p !!!! checksum)
p2mid = foldl (flip readMidLine) M.empty (lines midmappings)
let patches = M.keys p2pe -- Submitted patches
let repos = M.keys r2p -- Repos with patches
let users = M.keys u2p -- Known users
let addables = do -- List modad
patch <- patches
repo <- repos
pe <- M.lookup patch p2pe
present <- M.lookup repo r2p
guard $ all (`S.member` present) (peContext pe)
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 -> not (M.member p p2pr)) patches
now <- getClockTime >>= toCalendarTime
let resultData = ResultData p2r r2p u2p p2pe p2pr r2mp p2s p2mid unmatched now u2rn
{-
putStrLn "Evalutating data"
putStrLn (show (length (show (resultData))))
-}
putStrLn "Writing output..."
writeFile (cOutput config ++ "/index.html") (mainPage resultData)
forM_ users $ \u ->
writeFile (cOutput config ++ "/" ++ userFile u) (userPage resultData u)
forM_ repos $ \r ->
writeFile (cOutput config ++ "/" ++ repoFile r) (repoPage resultData r)
writeFile (cOutput config ++ "/" ++ "unmatched.html") (unmatchedPage resultData)
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 (peMailFile pe) link
mapM_ patchLink $ M.toList p2pe
return ()
getDirectoryFiles dir' = getDirectoryContents dir >>=
return . (map (dir++)) >>=
return . filter ((/= '.') . head) >>=
filterM doesFileExist >>=
filterM ((readable `fmap`) . getPermissions)
where dir = addSlash dir'
maxBy f v1 v2 = if f v1 >= f v2 then v1 else v2
minBy f v1 v2 = if f v1 <= f v2 then v1 else v2
addSlash filename | last filename == '/' = filename
| otherwise = filename ++ "/"
-- not in ghc6.6
infixl 0 `on`
on :: (b -> b -> c) -> (a -> b) -> a -> a -> c
(*) `on` f = \x y -> f x * f y
{- forkSequence = sequence -}
-- Enable for parallel downloads
forkSequence acts = mapM (\act -> newEmptyMVar >>= \mvar -> forkIO (act >>= putMVar mvar) >> return mvar) acts >>= mapM takeMVar