[Pkg-haskell-commits] [tools] 01/01: reasons: Added flag "--show-aging" to include packages that are too young to go into haskell and BD-Uninstallable packages.

[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 9ffbc3022e2197d380d15fe065d9d15290c769b5
Author: Sven Bartscher <sven.bartscher at weltraumschlangen.de>
Date:   Sat Aug 23 14:01:10 2014 +0200

    reasons: Added flag "--show-aging" to include packages that are too young to go
    into haskell and BD-Uninstallable packages.
---
 reasons.hs | 60 ++++++++++++++++++++++++++++++++++++------------------------
 1 file changed, 36 insertions(+), 24 deletions(-)

diff --git a/reasons.hs b/reasons.hs
index 6d9991c..173c477 100644
--- a/reasons.hs
+++ b/reasons.hs
@@ -35,29 +35,33 @@ packageNotFoundMsg
 -- Main
 
 main = withCurlDo $ do
-         package <- getArgs >>= parse
+         (package, showAging) <- getArgs >>= parse
          output <- fmap lines
-                   $ acquireFile outputURL "update_output.txt" fileSuffix False
+                    $ acquireFile outputURL "update_output.txt" fileSuffix False
          let bins = getBinBlockers output package
          result <- try (fmap nub $ mapM getSrcPackage bins) :: IO (Either ErrorCall [String])
          srcBlockers <- case result of
                           Left e -> putStrLn packageNotFoundMsg >> exitFailure
                           Right pkgs -> return pkgs
          excuses <- mapM getExcuse srcBlockers
-         additionalExcuses <- getAdditionalExcuses srcBlockers excuses
-         filteredExcuses <- filterExcuses (isInteresting fileSuffix) $ excuses ++ additionalExcuses
+         additionalExcuses <- getAdditionalExcuses fileSuffix srcBlockers excuses
+         filteredExcuses <- filterExcuses
+                            (isInteresting fileSuffix showAging)
+                            $ excuses ++ additionalExcuses
          mapM_ putStrLn $ map excuses2String filteredExcuses
 
 -- Command line parsing
 
-parse :: [String] -> IO String
-parse [package] = return package
+parse :: [String] -> IO (String, Bool)
+parse [package] = return (package, False)
+parse ["--show-aging", package] = return (package, True)
+parse [package, "--show-aging"] = return (package, True)
 parse _ = printUsage >> exitFailure
 
 printUsage :: IO ()
 printUsage = do
   progName <- getProgName
-  putStrLn $ "Usage: " ++ progName ++ " package-name"
+  putStrLn $ "Usage: " ++ progName ++ " [--show-aging] package-name"
 
 -- Utility
 
@@ -155,12 +159,12 @@ filterExcuses f excuses = fmap (filter isEmpty) $ mapM filterPkgExcuses excuses
     where filterPkgExcuses (Excuses pkg excuses)
               = fmap (Excuses pkg) $ filterM (f pkg) excuses
 
-isInteresting :: String -> String -> String -> IO Bool
-isInteresting fileSuffix pkg excuse = do
-  interestingOUD <- isInterestingOUD fileSuffix pkg excuse
+isInteresting :: String -> Bool -> String -> String -> IO Bool
+isInteresting fileSuffix showAging pkg excuse = do
+  interestingOUD <- isInterestingOUD showAging fileSuffix pkg excuse
   return $ interestingOUD
              || "introduces new bugs" `isInfixOf` excuse
-             || "Too young" `isPrefixOf` excuse
+             || ("Too young" `isPrefixOf` excuse && showAging)
              || "unsatisfiable Depends" `isInfixOf` excuse
 
 isInterestingDependency :: [String] -> String -> String -> IO Bool
@@ -168,15 +172,23 @@ isInterestingDependency pkgs _ excuse = return
                                         $ "(not considered)" `isSuffixOf` excuse
                                         && (mangleDependency excuse) `notElem` pkgs
 
-isInterestingOUD :: String -> String -> String -> IO Bool
-isInterestingOUD fileSuffix pkg excuse = if "out of date" `isPrefixOf` excuse
-                              then do
-                                let arch = mangleOUD excuse
-                                text <- acquireFile "https://buildd.debian.org/stats/"
-                                        (arch ++ "-dump.txt.gz") fileSuffix True
-                                return $ (status $ B.pack text) /= (B.pack "BD-Uninstallable")
-                              else return False
-    where status = (=~ (B.pack $ "(?<=state:  ).*(?=\n(.+\n)*package:  "
+isInterestingOUD :: Bool -> String -> String -> String -> IO Bool
+isInterestingOUD True _ _ excuse = return $ "out of date" `isPrefixOf` excuse
+isInterestingOUD False fileSuffix pkg excuse
+    = if "out of date" `isPrefixOf` excuse
+      then do
+        let arch = mangleOUD excuse
+        text <- acquireFile
+                "https://buildd.debian.org/stats/"
+                (arch ++ "-dump.txt.gz") 
+                fileSuffix True
+        return $ (status $ B.pack text) /= (B.pack "BD-Uninstallable")
+      else return False
+    where status = builddField pkg "state"
+ 
+
+builddField :: String -> String -> B.ByteString -> B.ByteString
+builddField pkg field = (=~ (B.pack $ "(?<=" ++ field ++ ":  ).*(?=\n(.+\n)*package:  "
                              ++ pkg ++ ")"))
 
 mangleDependency :: String -> String
@@ -191,15 +203,15 @@ mangleOUD = (=~ "(?<=out of date on ).*(?=:)")
 -- Fetching Excuses
 
 -- 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
+getAdditionalExcuses :: String -> [String] -> [Excuses] -> IO [Excuses]
+getAdditionalExcuses _ _ [] = return []
+getAdditionalExcuses fileSuffix pkgs excuses = do
   interestingDepends <- filterExcuses
                         (isInterestingDependency pkgs)
                         excuses
   let dependencies = nub $ map mangleDependency $ flattenExcuses interestingDepends
   excuses <- mapM getExcuse dependencies
-  evenMoreExcuses <- getAdditionalExcuses (pkgs ++ dependencies) excuses
+  evenMoreExcuses <- getAdditionalExcuses fileSuffix (pkgs ++ dependencies) excuses
   return $ excuses ++ evenMoreExcuses
 
 getExcuse :: String -> IO Excuses

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