[Pkg-haskell-commits] [tools] 01/01: reasons.hs: Only consider "out of date" as interesting if it's not in state BD-Uninstallable. Consider "unsatisfiable Depends:" as interesting, as this usually indicates the need of a binNMU.

[Sven Bartscher]

This is an automated email from the git hooks/post-receive script.

svenb-guest pushed a commit to branch master
in repository tools.

commit ea6ba577c73ec86026929d11f8094f525c9ee843
Author: Sven Bartscher <sven.bartscher at weltraumschlangen.de>
Date:   Mon Aug 18 23:35:25 2014 +0200

    reasons.hs: Only consider "out of date" as interesting if it's not in state
    	      BD-Uninstallable.
    	    Consider "unsatisfiable Depends:" as interesting, as this usually
    	      indicates the need of a binNMU.
---
 reasons.hs | 75 +++++++++++++++++++++++++++++++++++++++++---------------------
 1 file changed, 50 insertions(+), 25 deletions(-)

diff --git a/reasons.hs b/reasons.hs
index 0279674..c2dacb1 100644
--- a/reasons.hs
+++ b/reasons.hs
@@ -10,6 +10,9 @@ import qualified Data.Set as S
 import Control.Exception
 import System.IO.Error
 import System.Directory
+import qualified Data.ByteString.Lazy.Char8 as B
+import Codec.Compression.GZip
+import Control.Monad
 import Debug.Trace
 
 data Excuses = Excuses String [String]
@@ -23,7 +26,9 @@ excuses2String (Excuses pkg excuses) = unlines $ (pkg ++ ":"):(map ("    " ++) e
 
 main = do
   package <- getArgs >>= parse
-  output <- fmap lines acquireBritneyOut
+  output <- fmap lines
+            $ acquireFile outputURL
+                  "update_output.txt" False
   let bins = getBinBlockers output package
   result <- try (fmap nub $ mapM getSrcPackage bins) :: IO (Either ErrorCall [String])
   srcBlockers <- case result of
@@ -31,19 +36,21 @@ main = do
                    Right pkgs -> return pkgs
   excuses <- mapM getExcuse srcBlockers
   additionalExcuses <- getAdditionalExcuses srcBlockers excuses
-  let filteredExcuses = filterExcuses (isInteresting srcBlockers) $ excuses ++ additionalExcuses
+  filteredExcuses <- filterExcuses isInteresting $ excuses ++ additionalExcuses
   mapM_ putStrLn $ map excuses2String filteredExcuses
 
-acquireBritneyOut :: IO String
-acquireBritneyOut = do
+acquireFile :: String -> String -> Bool -> IO String
+acquireFile urldir filename ungz = do
   cachePath <- chooseCachePath
   case cachePath of 
-    Nothing -> readProcess "/usr/bin/wget" ["-q", "-O", "-", outputUrl] ""
+    Nothing -> readProcess "/usr/bin/wget" ["-q", "-O", "-", urldir ++ ('/':filename)] ""
     Just path -> do
       createDirectoryIfMissing False path
       setCurrentDirectory path
-      readProcess "/usr/bin/wget" ["-q", "-N", outputUrl] ""
-      readFile "update_output.txt"
+      readProcess "/usr/bin/wget" ["-q", "-N", urldir ++ ('/':filename)] ""
+      if ungz
+      then fmap (B.unpack . decompress) $ B.readFile filename
+      else readFile filename
 
 chooseCachePath :: IO (Maybe String)
 chooseCachePath = do
@@ -58,8 +65,8 @@ chooseCachePath = do
                             then Just e
                             else Nothing
 
-outputUrl :: String
-outputUrl = "release.debian.org/britney/update_output.txt"
+outputURL :: String
+outputURL = "release.debian.org/britney/"
 
 parse :: [String] -> IO String
 parse [package] = return package
@@ -73,22 +80,26 @@ printUsage = do
 packageNotFoundMsg :: String
 packageNotFoundMsg
     = "The package you requested was not processed by the autohinter.\n\
-       \grep-excuses <pkg> should list all reasons why this package doesn't\
+       \grep-excuses <pkg> should list all reasons why this package doesn't \
        \migrate."
 
-filterExcuses :: (String -> Bool) -> [Excuses] -> [Excuses]
-filterExcuses f excuses = filter isEmpty $ map filterPkgExcuses excuses
-    where filterPkgExcuses (Excuses pkg excuses) = Excuses pkg
-                                                   $ filter f excuses
+filterExcuses :: (String -> String -> IO Bool) -> [Excuses] -> IO [Excuses]
+filterExcuses f excuses = fmap (filter isEmpty) $ mapM filterPkgExcuses excuses
+    where filterPkgExcuses (Excuses pkg excuses)
+              = fmap (Excuses pkg) $ filterM (f pkg) excuses
 
-isInteresting :: [String] -> String -> Bool
-isInteresting blockers excuse = "out of date on" `isPrefixOf` excuse 
-                                || "introduces new bugs" `isInfixOf` excuse
-                                || "Too young" `isPrefixOf` excuse
+isInteresting :: String -> String -> IO Bool
+isInteresting pkg excuse = do
+  interestingOUD <- isInterestingOUD pkg excuse
+  return $ interestingOUD
+             || "introduces new bugs" `isInfixOf` excuse
+             || "Too young" `isPrefixOf` excuse
+             || "unsatisfiable Depends" `isInfixOf` excuse
 
-isInterestingDependency :: [String] -> String -> Bool
-isInterestingDependency pkgs excuse = "(not considered)" `isSuffixOf` excuse 
-                                      && (mangleDependency excuse) `notElem` pkgs
+isInterestingDependency :: [String] -> String -> String -> IO Bool
+isInterestingDependency pkgs _ excuse = return
+                                        $ "(not considered)" `isSuffixOf` excuse
+                                        && (mangleDependency excuse) `notElem` pkgs
 
 mangleDependency :: String -> String
 mangleDependency excuse
@@ -96,14 +107,28 @@ mangleDependency excuse
     | otherwise = tail $ dropWhile (/= ' ') dependency
     where dependency = excuse =~ "(?<=Depends: ).*(?= \\(not considered\\))"
 
+mangleOUD :: String -> String
+mangleOUD = (=~ "(?<=out of date on ).*(?=:)")
+
+isInterestingOUD :: String -> String -> IO Bool
+isInterestingOUD pkg excuse = if "out of date" `isPrefixOf` excuse
+                              then do
+                                let arch = mangleOUD excuse
+                                text <- acquireFile "buildd.debian.org/stats/"
+                                        (arch ++ "-dump.txt.gz") True
+                                return $ (status $ B.pack text) /= (B.pack "BD-Uninstallable")
+                              else return False
+    where status
+              = (=~ (B.pack $ "(?<=state:  ).*(?=\n(.+\n)*package:  " ++ pkg ++ ")"))
+
 -- Takes a list of already fetched excuses and returns the excuses of missing dependencies
 getAdditionalExcuses :: [String] -> [Excuses] -> IO [Excuses]
 getAdditionalExcuses _ [] = return []
 getAdditionalExcuses pkgs excuses = do
-  let interestingDepends = filterExcuses
-                           (isInterestingDependency pkgs)
-                           excuses
-      dependencies = nub $ map mangleDependency $ flattenExcuses interestingDepends
+  interestingDepends <- filterExcuses
+                        (isInterestingDependency pkgs)
+                        excuses
+  let dependencies = nub $ map mangleDependency $ flattenExcuses interestingDepends
   excuses <- mapM getExcuse dependencies
   evenMoreExcuses <- getAdditionalExcuses (pkgs ++ dependencies) excuses
   return $ excuses ++ evenMoreExcuses

-- 
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-haskell/tools.git