[Pkg-haskell-commits] [tools] 01/03: binNMUs: Do not schedule binNMUs for removed packages

[Joachim Breitner]

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

nomeata pushed a commit to branch master
in repository tools.

commit 372ee65c9f2dfe2e28b6e3bdcfc060a2c3c3896d
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue May 5 16:49:59 2015 +0200

    binNMUs: Do not schedule binNMUs for removed packages
---
 binNMUs.hs | 63 +++++++++++++++++++++++++++++++++++++++++++++-----------------
 1 file changed, 46 insertions(+), 17 deletions(-)

diff --git a/binNMUs.hs b/binNMUs.hs
index e4b2f7c..88971e6 100644
--- a/binNMUs.hs
+++ b/binNMUs.hs
@@ -47,6 +47,7 @@ data Status -- ^ Status of a binNMU
     | DepsMissing -- ^ Some dependencies are not present at all (NEW?)
     | WrongSrcVersion -- ^ Different source versions (out-of-date)
     | WrongVersion -- ^ Wrong version in wanna build
+    | PendingRemoval -- ^ Removal pending
     | Missing -- ^ Doesn't exist in wanna build?
   deriving (Eq, Ord, Show)
 
@@ -79,7 +80,9 @@ run conf = do
         putCLn $ "as other distributions do not have dumps of the wanna-build data."
         putCLn $ "Use --sql on wuiet.debian.org!"
         exitFailure
-    cBinNMUss <- mapM (getNMUs conf) (arches conf)
+    rms <- fetchWnppDump conf
+    putCLn $ "Pending removals: " ++ show rms
+    cBinNMUss <- mapM (getNMUs conf rms) (arches conf)
     -- Parallelization, if required
     --let cBinNMUs = concat (cBinNMUss `using` parList (evalList (evalTuple2 rseq rseq)))
     let cBinNMUs = concat cBinNMUss
@@ -122,6 +125,7 @@ statusHeader Waiting = "Already scheduled NMUs"
 statusHeader Failed = "Failed builds"
 statusHeader DepsMissing = "NMU seems pointless. Dependency in NEW?"
 statusHeader WrongSrcVersion = "Package out of date, will be rebuilt anyways"
+statusHeader PendingRemoval = "Package pending removal, don't bother"
 statusHeader WrongVersion = "Packages and Wanna-Build are out of sync"
 statusHeader Missing = "Packages not known to Wanna-Build. Ignoring."
 
@@ -189,32 +193,33 @@ ordGroupBy f = M.toAscList . M.fromListWith (++) . map (f &&& (:[]))
 
 
 -- | Data aquisition and processing
-getNMUs :: Conf -> Arch -> IO [CBinNMU]
-getNMUs conf a = do
+getNMUs :: Conf -> [SourceName] -> Arch -> IO [CBinNMU]
+getNMUs conf rms a = do
     pkgs <- fetchArchive conf a
     wbmap <- fetchWannaBuild conf a
     let available = M.fromListWith (++) [ (vpBase v, [v])
                                         | p <- pkgs, v <- bProvides p
                                         ]
     let binNMUs = mapMaybe (needsRebuild available) pkgs
-    let cBinNMUs = map (categorize available wbmap &&&
+    let cBinNMUs = map (categorize available wbmap rms &&&
          (\(p,r) -> ((bSourceName p, bSrcVersion p), bArchitecture p, r))) binNMUs
     return cBinNMUs
 
 -- Categorizing nmus
 
-categorize :: VirtPackageMap -> WBMap -> BinNMU -> Status
-categorize available wbmap (p,deps) =
+categorize :: VirtPackageMap -> WBMap -> [SourceName] -> BinNMU -> Status
+categorize available wbmap rms (p,deps) =
     case M.lookup (bSourceName p) wbmap of
       Nothing -> Missing
       Just (v,bv,s)
-        | v /= bSrcVersion p      -> WrongSrcVersion
+        | v /= bSrcVersion p       -> WrongSrcVersion
+        | bSourceName p `elem` rms -> PendingRemoval
         | s == "installed" && bv /= bVersion p
-                                  -> WrongVersion
-        | s `elem` waiting        -> Waiting
-        | any (isMissing) deps    -> DepsMissing
-        | s == "installed"        -> Needed
-        | otherwise               -> Failed
+                                   -> WrongVersion
+        | s `elem` waiting         -> Waiting
+        | any (isMissing) deps     -> DepsMissing
+        | s == "installed"         -> Needed
+        | otherwise                -> Failed
   where waiting = words "bd-uninstallable building built uploaded needs-build"
 
 isMissing (MissingDep _) = True
@@ -293,7 +298,7 @@ fetchWB = Query $ B.pack $ "\
 
 fetchWannaBuildHTTP :: Conf -> Arch -> IO WBMap
 fetchWannaBuildHTTP conf a = do
-    s <- acquireFile' conf url
+    s <- acquireFile' conf True url
     case parseControl url s of
         Left pe -> error $ show pe
         Right c -> return $
@@ -325,7 +330,7 @@ packageURL "buildd-experimental" a = printf "http://incoming.debian.org/debian-b
 
 acquirePackagesHTTP :: Conf -> String -> Arch -> IO [Binary]
 acquirePackagesHTTP conf suite arch = do
-    s <- acquireFile' conf url
+    s <- acquireFile' conf True url
     case parseControl url s of
         Left pe -> error $ show pe
         Right c -> return $
@@ -386,6 +391,7 @@ fetchArchive :: Conf -> Arch -> IO [Binary]
 fetchArchive c | sql c     = fetchArchiveSQL c
                | otherwise = fetchArchiveHTTP c
 
+
 -- | Fetches packages for this arch, overlaying sid with buildd-sid
 fetchArchiveHTTP :: Conf -> Arch -> IO [Binary]
 fetchArchiveHTTP conf a = do
@@ -395,11 +401,11 @@ fetchArchiveHTTP conf a = do
     let pkgs2' = [ p | p <- pkgs2 , bPkgName p `S.notMember` pkg1_names ]
     return $ pkgs1 ++ pkgs2'
 
-acquireFile' :: Conf -> String -> IO B.ByteString
-acquireFile' conf url = do
+acquireFile' :: Conf -> Bool -> String -> IO B.ByteString
+acquireFile' conf ungz url = do
     unless q $ hPutStr stderr $ printf "Fetching %s ..." url
     unless q $ hFlush stderr
-    s <- acquireFile url True o
+    s <- acquireFile url ungz o
     unless q $ hPutStrLn stderr $ printf " done."
     return s
   where o = offline conf
@@ -455,6 +461,29 @@ fetchBins = Query $ B.pack $ "\
     error "no SQL"
 #endif
 
+
+
+-- Reading wnpp dumps
+wnppDumpUrl :: String
+wnppDumpUrl = "https://qa.debian.org/data/bts/wnpp_rm"
+
+fetchWnppDump :: Conf -> IO [SourceName]
+fetchWnppDump conf = do
+    s <- acquireFile' conf False url
+    return $ mapMaybe parseLine $ map B.unpack $ B.lines s
+  where
+    url = wnppDumpUrl
+
+    parseLine :: String -> Maybe SourceName
+    parseLine l = case match wnppRegex l of
+        [[_,s]] -> Just s
+        _ -> Nothing
+
+    wnppRegex :: Regex
+    wnppRegex = makeRegex "^(.*): RM"
+
+
+
 -- Option parsing
 data Conf = Conf
     { distribution :: String

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