diff --git a/darcswatch.cabal b/darcswatch.cabal --- a/darcswatch.cabal +++ b/darcswatch.cabal @@ -1,5 +1,5 @@ Name: darcswatch -version: 0.4.3 +version: 0.4.4 Category: Distribution name: darcswatch author: Joachim Breitner @@ -60,7 +60,7 @@ , Darcs.Watch.UpdateRepoData , Darcs.Watch.Storage , Darcs.Watch.Mail - Build-Depends: base > 3 && < 4 + Build-Depends: base == 4.* , network , HTTP >= 4000 , old-time @@ -82,6 +82,7 @@ , regex-compat , cgi , mtl + , safe if flag(Static) ghc-options: -static -optl-static -optl-pthread diff --git a/src/CGI-Main.hs b/src/CGI-Main.hs --- a/src/CGI-Main.hs +++ b/src/CGI-Main.hs @@ -23,6 +23,7 @@ import System.FilePath import Network.CGI import Control.Applicative +import Safe import Darcs.Watch.Storage import Darcs.Watch.Data @@ -31,8 +32,7 @@ main = do confdir <- getEnv "HTTP_DARCSWATCH_DIR" - config <- read `fmap` readFile (confdir "config") :: IO DarcsWatchConfig - + config <- readNote "reading Configuration" `fmap` readFile (confdir "config") :: IO DarcsWatchConfig runCGI $ handleErrors $ authenticated config $ \openID -> do diff --git a/src/ConvertData-Main.hs b/src/ConvertData-Main.hs --- a/src/ConvertData-Main.hs +++ b/src/ConvertData-Main.hs @@ -25,10 +25,11 @@ import System.Directory import Control.Monad import qualified Data.ByteString.Char8 as B +import Safe +import Data.Maybe import Darcs.Watch.Data import Darcs.Watch.Storage -import Data.Maybe main = do args <- getArgs @@ -36,7 +37,7 @@ [confdir] -> (addSlash confdir) _ -> error "Use convert confdir/" putStrLn "Reading configuration..." - config <- read `fmap` readFile (confdir ++ "config") + config <- readNote "reading Configuration" `fmap` readFile (confdir ++ "config") putStrLn "Reading emails..." mailFiles' <- getDirectoryFiles (cMails config) diff --git a/src/Darcs/Watch/GenerateOutput.hs b/src/Darcs/Watch/GenerateOutput.hs --- a/src/Darcs/Watch/GenerateOutput.hs +++ b/src/Darcs/Watch/GenerateOutput.hs @@ -40,6 +40,7 @@ import Data.Maybe import Data.Monoid import System.FilePath +import Safe import qualified Data.ByteString.Char8 as B import Data.ByteString.Char8 (ByteString) @@ -55,7 +56,7 @@ nowStamp <- getCurrentTime let outputStampFile = cData config "output.stamp" ex <- doesFileExist outputStampFile - lastStamp <- if ex then read . B.unpack <$> B.readFile outputStampFile + lastStamp <- if ex then readNote "output.stamp" . B.unpack <$> B.readFile outputStampFile else return $ UTCTime (ModifiedJulianDay 0) 0 date <- getClockTime >>= toCalendarTime @@ -108,7 +109,7 @@ (bundleHashes,_) <- readBundleList (cData config) (RepositoryBundleList r) bundleInfos <- mapM getBundleInfos bundleHashes inv <- readRepository (cData config) r - return $ strict6 (,,,,,) + return $! strict6 (,,,,,) r (length inv) (length $ bundleInfoFilter Applied bundleInfos) @@ -118,7 +119,7 @@ userData <- forM authors $ \u -> do (bundleHashes,_) <- readBundleList (cData config) (AuthorBundleList u) bundleInfos <- mapM getBundleInfos bundleHashes - return $ strict5 (,,,,) + return $! strict5 (,,,,) u (length bundleInfos) (length (bundleInfoFilter Applicable bundleInfos)) diff --git a/src/Darcs/Watch/PullRepos.hs b/src/Darcs/Watch/PullRepos.hs --- a/src/Darcs/Watch/PullRepos.hs +++ b/src/Darcs/Watch/PullRepos.hs @@ -22,6 +22,8 @@ import Control.Monad import Control.Concurrent import Control.Applicative +import Control.Exception +import Prelude hiding (catch) import System.Environment (getArgs) import System.Directory import System.Posix.Files @@ -58,9 +60,11 @@ putStrLn "Updating repositories..." let updateRepo rep = do writeC $ "Updating " ++ rep ++ ":\n" - thisNew <- updateRepository (cData config) writeC rep - writeC (if thisNew then "Repostory is new.\n" else "Repository is cached.\n") - return thisNew + catch ( do + thisNew <- updateRepository (cData config) writeC rep + writeC (if thisNew then "Repostory is new.\n" else "Repository is cached.\n") + return thisNew + ) (\e -> writeC ("Error Updateing " ++ rep ++ ": " ++ show (e::SomeException) ++ "\n") >> return False) new <- or <$> forkSequence (map updateRepo (cRepositories config)) unless new $ putStrLn "Nothing new found" @@ -74,7 +78,7 @@ mvar <- newEmptyMVar forkIO $ do waitQSem sem - act >>= putMVar mvar + catch (act >>= putMVar mvar) (\e -> putMVar mvar (throw (e::SomeException))) signalQSem sem return mvar mapM takeMVar mvars diff --git a/src/Darcs/Watch/Roundup.hs b/src/Darcs/Watch/Roundup.hs --- a/src/Darcs/Watch/Roundup.hs +++ b/src/Darcs/Watch/Roundup.hs @@ -14,6 +14,7 @@ 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 _ _ repo _ _ status | repo == "http://darcs.net/screened" && status == Applicable = return () -- No applicable mails for the screened repo tellRoundup config url repo bundleHash bundle status = do message <- flatten [mk_header ["From: " ++ from] ,mk_header ["To: " ++ to] @@ -27,7 +28,9 @@ to = "bugs@darcs.net" subject = case status of Applicable -> "This patch is being tracked by DarcsWatch [" ++ roundupId ++ "] [darcswatchurl=" ++ bundleLink ++ "]" - Applied -> "This patch has been applied [" ++ roundupId ++ "] [status=accepted]" + Applied -> "This patch has been applied [" ++ roundupId ++ "] [status=" ++ roundupStatus ++ "]" + roundupStatus | repo == "http://darcs.net/screened" = "needs-review" + | otherwise = "accepted" body = case status of Applicable -> "" -- no messages about this, please Applied -> "This patch bundle (with " ++ show (length (fst bundle)) ++ diff --git a/src/Darcs/Watch/Storage.hs b/src/Darcs/Watch/Storage.hs --- a/src/Darcs/Watch/Storage.hs +++ b/src/Darcs/Watch/Storage.hs @@ -32,6 +32,7 @@ import Control.Applicative import Control.Monad import Data.Char +import Safe -- | Adds a new patch bundle to the stogare @@ -54,7 +55,8 @@ -- | Retrieves the meta information for the handle getBundleHistory :: StorageConf -> BundleHash -> IO [BundleHistory] getBundleHistory path hash = - read <$> B.unpack <$> B.readFile (bundleDir path hash <.> "data") + let filename = bundleDir path hash <.> "data" + in readNote ("Bundle data in " ++ filename) <$> B.unpack <$> B.readFile filename -- | Adds a new entry to the bundle history (stamped with the current time) changeBundleState :: StorageConf -> BundleHash -> Source -> BundleState -> IO () @@ -79,7 +81,7 @@ let infoFile = repoDir path safeName repo <.> "data" let repoFile = repoDir path safeName repo <.> "inventory" ex <- doesFileExist infoFile - info <- if ex then read . B.unpack <$> B.readFile infoFile + info <- if ex then readNote ("Repo data in " ++ infoFile) . B.unpack <$> B.readFile infoFile else return (RepositoryInfo Nothing Nothing) now <- getCurrentTime (ps,changed) <- getInventory write (cacheDir path) repo @@ -101,7 +103,7 @@ getRepositoryInfo path repo = do let infoFile = repoDir path safeName repo <.> "data" ex <- doesFileExist infoFile - if ex then read . B.unpack <$> B.readFile infoFile + if ex then readNote ("Repo data in " ++ infoFile) . B.unpack <$> B.readFile infoFile else return (RepositoryInfo Nothing Nothing) setBundleListList :: StorageConf -> [BundleList] -> IO () @@ -110,7 +112,8 @@ getBundleListList :: StorageConf -> IO [BundleList] getBundleListList path = do - read <$> B.unpack <$> B.readFile (bundleListDir path "index") + let indexFile = bundleListDir path "index" + readNote ("Bundle index in " ++ indexFile) <$> B.unpack <$> B.readFile indexFile writeBundleList :: StorageConf -> BundleList -> [BundleHash] -> IO () writeBundleList path bl blist = do @@ -127,7 +130,7 @@ 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) + return (bhashes, readNote ("Bundle list stamp in " ++ filename) stamp) writeNameMapping :: StorageConf -> M.Map Author String -> IO () writeNameMapping path map = do @@ -138,7 +141,7 @@ let filename = nameMappingFilename path ex <- doesFileExist filename if not ex then return M.empty else - read <$> B.unpack <$> B.readFile filename + readNote ("Name mapping in " ++ filename) <$> B.unpack <$> B.readFile filename bundleListFilename path (RepositoryBundleList repo) = bundleListDir path "repo_" ++ safeName repo diff --git a/src/Darcs/Watch/UpdateRepoData.hs b/src/Darcs/Watch/UpdateRepoData.hs --- a/src/Darcs/Watch/UpdateRepoData.hs +++ b/src/Darcs/Watch/UpdateRepoData.hs @@ -41,7 +41,7 @@ import Data.Digest.OpenSSL.MD5 (md5sum) import Data.Maybe import System.FilePath -import Control.Monad.Writer +import Control.Monad.Writer.Strict -- Darcs stuff import Darcs diff --git a/src/Generate-Main.hs b/src/Generate-Main.hs --- a/src/Generate-Main.hs +++ b/src/Generate-Main.hs @@ -36,7 +36,11 @@ import Data.List import Data.Time import System.FilePath +import Safe +import Data.Digest.OpenSSL.MD5 (md5sum) +import Data.Maybe + import qualified Data.ByteString.Char8 as B import Data.ByteString.Char8 (ByteString) @@ -46,10 +50,7 @@ import Darcs.Watch.Data import LockRestart -import Data.Digest.OpenSSL.MD5 (md5sum) -import Data.Maybe - main = do hSetBuffering stdout NoBuffering args <- getArgs @@ -58,6 +59,6 @@ [confdir, "new"] -> (addSlash confdir, True) _ -> error "Use darcswatch confdir/" putStrLn "Reading configuration..." - config <- read `fmap` readFile (confdir ++ "config") + config <- readNote "reading Configuration" `fmap` readFile (confdir ++ "config") lockRestart (cData config) patchNew or True (generateOutput config) diff --git a/src/HTML.hs b/src/HTML.hs --- a/src/HTML.hs +++ b/src/HTML.hs @@ -118,7 +118,8 @@ count Applied "tracked" tracked +++ count Applicable "applicable" applicable +++ count Obsoleted "obsolete" obsolete +++ - count Rejected "rejected" rejected + count Rejected "rejected" rejected +++ " " +++ + hotlink ("http://handra.rampa.sk/dawb/changes?repoPage=0&repoURL=" ++ r ++ "&repoSummary=on&repoLimit=50&repoElem=&repoRegex=") << "view repo" count s t 0 = noHtml count s t n = inColor (stateColor s) << (show n +++ " " +++ t) +++ " " @@ -179,7 +180,8 @@ ) +++ body << form !!! [ method "GET", action "cgi"] << ( h1 << ("DarcsWatch overview for " +++ r) +++ - p << hotlink "." << "Return to main page" +++ + p << (hotlink "." << "Return to main page" +++ " " +++ + hotlink ("http://handra.rampa.sk/dawb/changes?repoPage=0&repoURL=" ++ r ++ "&repoSummary=on&repoLimit=50&repoElem=&repoRegex=") << "View repository") +++ bundleList nameMapping "Unapplied patch bundles" (bundleInfoFilter Applicable bundleInfos) +++ bundleList nameMapping "Applied patch bundles" (bundleInfoFilter Applied bundleInfos) +++ bundleList nameMapping "Obsoleted patch bundles" (bundleInfoFilter Obsoleted bundleInfos) +++ diff --git a/src/ImportBundle-Main.hs b/src/ImportBundle-Main.hs --- a/src/ImportBundle-Main.hs +++ b/src/ImportBundle-Main.hs @@ -27,6 +27,7 @@ import qualified Data.ByteString.Char8 as B import Data.Maybe import System.FilePath +import Safe import Darcs.Watch.Data import Darcs.Watch.Storage @@ -37,7 +38,7 @@ [confdir, file] -> (confdir, file) _ -> error "Use convert confdir/ patchfile" putStrLn "Reading configuration..." - config <- read `fmap` readFile (confdir "config") + config <- readNote "reading Configuration" `fmap` readFile (confdir "config") putStrLn "Reading patch bundle..." mail <- B.readFile file diff --git a/src/ImportMail-Main.hs b/src/ImportMail-Main.hs --- a/src/ImportMail-Main.hs +++ b/src/ImportMail-Main.hs @@ -23,6 +23,7 @@ import Data.Maybe import System.FilePath import System.Posix.IO +import Safe import Darcs.Watch.Data import Darcs.Watch.ImportMail @@ -35,7 +36,7 @@ let (confdir) = case args of [confdir] -> (confdir) _ -> error "Use import-mail confdir/ and pipe mail to it" - config <- read `fmap` readFile (confdir "config") + config <- readNote "reading Configuration" `fmap` readFile (confdir "config") foundMail <- importMail config when foundMail $ do -- We do not want output here diff --git a/src/LockRestart.hs b/src/LockRestart.hs --- a/src/LockRestart.hs +++ b/src/LockRestart.hs @@ -28,7 +28,9 @@ import System.IO.Error import System.Posix.Temp import Control.Monad +import Control.Exception (finally) import GHC.IOBase +import Safe -- | tries to get the lock. If it fails, notifies the running process -- to re-start itself afterwards, with the given information @@ -63,7 +65,7 @@ mapM (\f -> do c <- readFile f when (c==c) $ removeFile f - return (read c) + return (readNote "in releaseLock" c) ) files where interesting "." = False interesting ".." = False @@ -95,8 +97,7 @@ workAndCheck event else when verbose $ putStrLn "Could not get locked, signaled restart" - where workAndCheck event = do - action event + where workAndCheck event = finally (action event) $ do when verbose $ putStrLn "Trying to release the lock..." msgs <- releaseLock dir if null msgs then do diff --git a/src/PullRepos-Main.hs b/src/PullRepos-Main.hs --- a/src/PullRepos-Main.hs +++ b/src/PullRepos-Main.hs @@ -34,6 +34,7 @@ import MultiMap ((!!!!)) import Data.Char import Data.List +import Safe import qualified Data.ByteString.Char8 as B import Data.ByteString.Char8 (ByteString) @@ -56,7 +57,7 @@ [confdir] -> confdir _ -> error "Use darcswatch confdir/" putStrLn "Reading configuration..." - config <- read `fmap` readFile (confdir "config") + config <- readNote "reading Configuration" `fmap` readFile (confdir "config") new <- pullRepos config when new $ do diff --git a/src/UpdateRepoData-Main.hs b/src/UpdateRepoData-Main.hs --- a/src/UpdateRepoData-Main.hs +++ b/src/UpdateRepoData-Main.hs @@ -27,6 +27,7 @@ import System.Time import System.IO import System.Terminal.Concurrent +import Safe import qualified Data.Map as M import qualified Data.Set as S @@ -55,6 +56,6 @@ [confdir] -> confdir _ -> error "Use darcswatch confdir/" putStrLn "Reading configuration..." - config <- read `fmap` readFile (confdir "config") + config <- readNote "reading Configuration" `fmap` readFile (confdir "config") updateRepoData config