[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