[Pkg-haskell-commits] [tools] 01/02: binNMUs: Support experimental (only in SQL-mode)

Joachim Breitner nomeata at moszumanska.debian.org
Tue Feb 3 12:29:33 UTC 2015


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

nomeata pushed a commit to branch master
in repository tools.

commit fdb95682e8e366e6c28f5e419816930d48fda5f3
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Tue Dec 23 14:44:53 2014 +0100

    binNMUs: Support experimental (only in SQL-mode)
---
 binNMUs.hs | 51 ++++++++++++++++++++++++++++++++++-----------------
 1 file changed, 34 insertions(+), 17 deletions(-)

diff --git a/binNMUs.hs b/binNMUs.hs
index 1a7db60..aaff3d7 100644
--- a/binNMUs.hs
+++ b/binNMUs.hs
@@ -16,6 +16,7 @@ import Debian.Relation.ByteString
 import Control.Monad
 import Text.Regex.PCRE
 import System.IO
+import System.Exit
 import Control.Arrow
 import qualified Data.ByteString.Char8 as B
 import Data.Time
@@ -73,6 +74,11 @@ data Binary = Binary
 run :: Conf -> IO ()
 run conf = do
     printHeader conf
+    when (not (sql conf) && distribution conf /= "unstable") $ do
+        putCLn $ "When reading data via HTTP, only unsable is supported"
+        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)
     -- Parallelization, if required
     --let cBinNMUs = concat (cBinNMUss `using` parList (evalList (evalTuple2 rseq rseq)))
@@ -87,6 +93,7 @@ printHeader conf = do
     putCLn $ "My source is in git+ssh://git.debian.org/git/pkg-haskell/tools"
     t <- getZonedTime
     putCLn $ "It is now " ++ show t
+    putCLn $ "I am looking at " ++ distribution conf
     putCLn $ "I am processing these architectures: " ++ intercalate ", " (arches conf)
     putCLn $ "I am looking for virtual packages matching " ++ regexS conf
     putCLn $ if sql conf then "I read my data from SQL."
@@ -141,7 +148,7 @@ presentBinNMUs conf cBinNMUs = do
         unless (ignoreStatus s) $ do
         putCLn $ statusHeader s
         putStr $ alignAt " . "
-            [ (if actStatus s then "" else "# ") ++ formatNMU nmu
+            [ (if actStatus s then "" else "# ") ++ formatNMU (distribution conf) nmu
             | nmu <- sortBy (compare `on` (^. _1)) $
               groupNMUs conf $
               map snd cBinNMUs
@@ -162,11 +169,12 @@ groupNMUs conf =
   where
     gbp = groupPkgs conf
 
-formatNMU :: ([(SourceName, Version)], [Arch], [Reason]) -> String
-formatNMU (ss, as, d) =
-    printf "nmu %s . %s . -m '%s'"
+formatNMU :: String -> ([(SourceName, Version)], [Arch], [Reason]) -> String
+formatNMU dist (ss, as, d) =
+    printf "nmu %s . %s . %s . -m '%s'"
         (intercalate " " $ map (uncurry (printf "%s_%s")) ss)
         (intercalate " " as)
+        dist
         (intercalate ", " $ map formatReason d)
 
 formatReason :: Reason -> String
@@ -255,7 +263,7 @@ fetchWannaBuildSQL conf arch = do
     unless q $ hFlush stderr
     conn <- connectPostgreSQL (B.pack "service=wanna-build")
     --- conn <- connect (ConnectInfo "localhost" 5436 "guest" "" "wanna-build")
-    rows <- query conn fetchWB [arch]
+    rows <- query conn fetchWB (arch, distribution conf)
     close conn
     unless q $ hPutStrLn stderr " done"
     return $ M.fromList $ map go rows
@@ -276,7 +284,7 @@ fetchWB = Query $ B.pack $ "\
     \    packages_public    \
     \WHERE    \
     \    architecture = ?  \
-    \    AND distribution = 'sid' \
+    \    AND distribution = ? \
     \"
 #else
     error "SQL disabled"
@@ -312,6 +320,8 @@ fetchWannaBuildHTTP conf a = do
 packageURL :: String -> Arch -> String
 packageURL "unstable" a        = printf "http://http.debian.net/debian/dists/sid/main/binary-%s/Packages.gz" a
 packageURL "buildd-unstable" a = printf "http://incoming.debian.org/debian-buildd/dists/buildd-sid/main/binary-%s/Packages.gz" a
+packageURL "experimental" a    = printf "http://http.debian.net/debian/dists/experimental/main/binary-%s/Packages.gz" a
+packageURL "buildd-experimental" a = printf "http://incoming.debian.org/debian-buildd/dists/buildd-experimental/main/binary-%s/Packages.gz" a
 
 acquirePackagesHTTP :: Conf -> String -> Arch -> IO [Binary]
 acquirePackagesHTTP conf suite arch = do
@@ -379,9 +389,9 @@ fetchArchive c | sql c     = fetchArchiveSQL c
 -- | Fetches packages for this arch, overlaying sid with buildd-sid
 fetchArchiveHTTP :: Conf -> Arch -> IO [Binary]
 fetchArchiveHTTP conf a = do
-    pkgs1 <- acquirePackagesHTTP conf "buildd-unstable" a
+    pkgs1 <- acquirePackagesHTTP conf ("buildd-" ++ distribution conf) a
     let pkg1_names = S.fromList (map bPkgName pkgs1)
-    pkgs2 <- acquirePackagesHTTP conf "unstable" a
+    pkgs2 <- acquirePackagesHTTP conf (distribution conf) a
     let pkgs2' = [ p | p <- pkgs2 , bPkgName p `S.notMember` pkg1_names ]
     return $ pkgs1 ++ pkgs2'
 
@@ -404,7 +414,7 @@ fetchArchiveSQL conf arch = do
     unless q $ hFlush stderr
     conn <- connectPostgreSQL (B.pack "service=projectb")
     -- conn <- connect (ConnectInfo "localhost" 5434 "guest" "" "projectb")
-    rows <- query conn fetchBins [arch, r, r]
+    rows <- query conn fetchBins (distribution conf, "buildd-" ++ distribution conf, arch, r, r)
     close conn
     let bins = mapMaybe (rowToBinary conf) rows
     unless q $ hPutStrLn  stderr $ " done"
@@ -434,7 +444,7 @@ fetchBins = Query $ B.pack $ "\
     \    JOIN metadata_keys pmk ON pmk.key = 'Provides'    \
     \    LEFT OUTER JOIN binaries_metadata pm ON pm.bin_id = binaries.id AND pmk.key_id = pm.key_id    \
     \WHERE    \
-    \    suite.suite_name IN ('unstable', 'buildd-unstable')   \
+    \    suite.suite_name IN (?,?)  \
     \    AND arch_string = ?    \
     \    AND (dm.value ~ ? OR pm.value ~ ? )    \
     \ORDER BY \
@@ -447,7 +457,8 @@ fetchBins = Query $ B.pack $ "\
 
 -- Option parsing
 data Conf = Conf
-    { arches :: [Arch]
+    { distribution :: String
+    , arches :: [Arch]
     , regex :: Regex
     , roughRegex :: Regex
     , regexS :: String -- A regex is not Show'able, so we need to keep the string
@@ -457,9 +468,9 @@ data Conf = Conf
     , groupPkgs :: Bool
     }
 
-mkConf :: [Arch] -> String -> Bool -> Bool -> Bool -> Bool -> Conf
-mkConf a r =
-    Conf a (makeRegex ("^"++r++"$")) (makeRegex r) r
+mkConf :: String -> [Arch] -> String -> Bool -> Bool -> Bool -> Bool -> Conf
+mkConf d a r =
+    Conf d a (makeRegex ("^"++r++"$")) (makeRegex r) r
 
 parseArches :: String -> ReadM [Arch]
 parseArches s =
@@ -471,13 +482,19 @@ parseArches s =
 
 conf :: Parser Conf
 conf = mkConf
- <$> nullOption (
+ <$> strOption (
+    long "distribution" <>
+    metavar "DIST" <>
+    help "Distribution to produce binNMUs for" <>
+    showDefault <>
+    value "unstable"
+    )
+ <*> option parseArches (
     long "arches" <>
     metavar "ARCH,ARCH,..." <>
     help "comma or space separated list of architectures" <>
     value allArches <>
-    showDefaultWith (intercalate ", ") <>
-    reader parseArches
+    showDefaultWith (intercalate ", ")
     )
  <*> strOption (
     long "regex" <>

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



More information about the Pkg-haskell-commits mailing list