[Pkg-haskell-commits] [tools] 03/03: Alternatively fetch data via SQL
Joachim Breitner
nomeata at moszumanska.debian.org
Tue Aug 26 23:56:31 UTC 2014
This is an automated email from the git hooks/post-receive script.
nomeata pushed a commit to branch master
in repository tools.
commit 9dc2b09e3c74162958a6eec6947a1d2b47b4e4aa
Author: Joachim Breitner <mail at joachim-breitner.de>
Date: Tue Aug 26 16:56:27 2014 -0700
Alternatively fetch data via SQL
---
binNMUs.hs | 158 ++++++++++++++++++++++++++++++++++++++++++++++++++-----------
1 file changed, 131 insertions(+), 27 deletions(-)
diff --git a/binNMUs.hs b/binNMUs.hs
index 0be0b3d..02f4809 100644
--- a/binNMUs.hs
+++ b/binNMUs.hs
@@ -20,6 +20,8 @@ import qualified Data.ByteString.Char8 as B
import Data.Time
import Control.Lens
--import Control.Parallel.Strategies
+import Database.PostgreSQL.Simple hiding (Binary)
+import Database.PostgreSQL.Simple.Types (Query(Query))
import AcquireFile
@@ -84,6 +86,8 @@ printHeader conf = do
putCLn $ "It is now " ++ show t
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"
+ else "I read my data via HTTP"
putStrLn ""
-- | Presentation of binNMUs
@@ -228,7 +232,42 @@ type WBMap = M.Map SourceName (Version, Version, WBState)
fetchWannaBuild :: Conf -> Arch -> IO WBMap
-fetchWannaBuild conf a = do
+fetchWannaBuild c | sql c = fetchWannaBuildSQL c
+ | otherwise = fetchWannaBuildHTTP c
+
+fetchWannaBuildSQL :: Conf -> Arch -> IO WBMap
+fetchWannaBuildSQL conf arch = do
+ unless q $ hPutStr stderr $ printf "Querying wanna-build database for arch %s ..." arch
+ unless q $ hFlush stderr
+ -- conn <- connectPostgreSQL (B.pack "service=projectb")
+ conn <- connect (ConnectInfo "localhost" 5436 "guest" "" "wanna-build")
+ rows <- query conn fetchWB [arch]
+ close conn
+ unless q $ hPutStrLn stderr " done"
+ return $ M.fromList $ map go rows
+ where
+ q = quiet conf
+ go :: (String, String, Maybe Int, String) -> (SourceName, (Version, Version, WBState))
+ go (src,sv,b,status) = (src, (sv, bv, status))
+ where bv = case b of Nothing -> sv
+ Just n -> sv ++ "+b" ++ show n
+
+fetchWB = Query $ B.pack $ "\
+ \SELECT \
+ \ package, \
+ \ version::text, \
+ \ binary_nmu_version , \
+ \ state \
+ \FROM \
+ \ packages_public \
+ \WHERE \
+ \ architecture = ? \
+ \ AND distribution = 'sid' \
+ \"
+
+
+fetchWannaBuildHTTP :: Conf -> Arch -> IO WBMap
+fetchWannaBuildHTTP conf a = do
s <- acquireFile' conf url
case parseControl url s of
Left pe -> error $ show pe
@@ -253,14 +292,12 @@ fetchWannaBuild conf a = do
-- Reading archive files
-builddPackageUrl :: Arch -> String
-builddPackageUrl a = printf "http://incoming.debian.org/debian-buildd/dists/buildd-sid/main/binary-%s/Packages.gz" a
+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
-sidPackageUrl :: Arch -> String
-sidPackageUrl a = printf "http://http.debian.net/debian/dists/sid/main/binary-%s/Packages.gz" a
-
-acquirePackages :: Conf -> String -> IO [Binary]
-acquirePackages conf url = do
+acquirePackagesHTTP :: Conf -> String -> Arch -> IO [Binary]
+acquirePackagesHTTP conf suite arch = do
s <- acquireFile' conf url
case parseControl url s of
Left pe -> error $ show pe
@@ -268,8 +305,9 @@ acquirePackages conf url = do
mapMaybe parsePara $
unControl c
where
+ url = packageURL suite arch
parsePara :: Paragraph -> Maybe Binary
- parsePara p = if likelyInteresting && interesting b then Just b else Nothing
+ parsePara p = if likelyInteresting then rowToBinary conf row else Nothing
where
reqField f = maybe (error $ printf "Missing field %s" f) B.unpack (fieldValue f p)
optField f = B.unpack <$> fieldValue f p
@@ -277,26 +315,42 @@ acquirePackages conf url = do
pkg = reqField "Package"
v = reqField "Version"
- relField :: String -> Relations
- relField f = case parseRelations $ fromMaybe B.empty (fieldValue f p) of
+ mbD = fieldValue "Depends" p
+ mbP = fieldValue "Provides" p
+ mbS = optField "Source"
+
+ likelyInteresting =
+ maybe False (matchTest (roughRegex conf)) mbD ||
+ maybe False (matchTest (roughRegex conf)) mbP
+
+ row = ( pkg
+ , v
+ , reqField "Architecture"
+ , maybe pkg (fst.splitSrc) mbS
+ , fromMaybe v (mbS >>= snd . splitSrc)
+ , fromMaybe B.empty mbD
+ , fromMaybe B.empty mbP
+ )
+
+rowToBinary :: Conf -> Row -> Maybe Binary
+rowToBinary conf (pkg,v,a,s,sv,d,p) = if interesting b then Just b else Nothing
+ where
+ parseRels :: B.ByteString -> Relations
+ parseRels s = case parseRelations s of
Left pe -> error $ printf "Failed to parse relations %s" (show pe)
Right rel -> rel
flatRels :: Relations -> [String]
flatRels = map (\(Rel (BinPkgName n) _ _) -> n) . join
- likelyInteresting =
- maybe False (matchTest (roughRegex conf)) (optField "Depends") ||
- maybe False (matchTest (roughRegex conf)) (optField "Provides")
-
b = Binary
pkg
- (maybe pkg (fst.splitSrc) (optField "Source"))
- (reqField "Architecture")
+ s
+ a
v
- (fromMaybe v (optField "Source" >>= snd . splitSrc))
- (mapMaybe (parseVirtPackage conf) $ flatRels $ relField "Depends")
- (mapMaybe (parseVirtPackage conf) $ flatRels $ relField "Provides")
+ sv
+ (mapMaybe (parseVirtPackage conf) $ flatRels $ parseRels d)
+ (mapMaybe (parseVirtPackage conf) $ flatRels $ parseRels p)
interesting :: Binary -> Bool
@@ -309,14 +363,12 @@ splitSrc sf =
[s] -> (s, Nothing)
_ -> error $ printf "Failed to parse source field %s" sf
-
-
-- | Fetches packages for this arch, overlaying sid with buildd-sid
fetchArchive :: Conf -> Arch -> IO [Binary]
fetchArchive conf a = do
- pkgs1 <- acquirePackages conf (builddPackageUrl a)
+ pkgs1 <- acquirePackages conf "buildd-unstable" a
let pkg1_names = S.fromList (map bPkgName pkgs1)
- pkgs2 <- acquirePackages conf (sidPackageUrl a)
+ pkgs2 <- acquirePackages conf "unstable" a
let pkgs2' = [ p | p <- pkgs2 , bPkgName p `S.notMember` pkg1_names ]
return $ pkgs1 ++ pkgs2'
@@ -330,6 +382,53 @@ acquireFile' conf url = do
where o = offline conf
q = o || quiet conf
+
+acquirePackages :: Conf -> String -> Arch -> IO [Binary]
+acquirePackages c | sql c = acquirePackagesSQL c
+ | otherwise = acquirePackagesHTTP c
+
+type Row = (String, String, String, String, String, B.ByteString, B.ByteString)
+
+acquirePackagesSQL :: Conf -> String -> Arch -> IO [Binary]
+acquirePackagesSQL conf suite arch = do
+ unless q $ hPutStr stderr $ printf "Querying projectb database for suite %s arch %s ..." suite arch
+ unless q $ hFlush stderr
+ -- conn <- connectPostgreSQL (B.pack "service=projectb")
+ conn <- connect (ConnectInfo "localhost" 5434 "guest" "" "projectb")
+ rows <- query conn fetchBins [suite, arch, r, r]
+ close conn
+ let bins = mapMaybe (rowToBinary conf) rows
+ unless q $ hPutStrLn stderr $ " done"
+ return bins
+ where
+ q = quiet conf
+ r = ".*" ++ regexS conf ++ ".*"
+
+fetchBins = Query $ B.pack $ "\
+ \SELECT \
+ \ package, \
+ \ binaries.version::text, \
+ \ arch_string , \
+ \ source.source, \
+ \ source.version::text, \
+ \ COALESCE(dm.value,''), \
+ \ COALESCE(pm.value,'') \
+ \FROM \
+ \ binaries \
+ \ JOIN bin_associations ON bin_associations.bin = binaries.id \
+ \ JOIN suite ON bin_associations.suite = suite.id \
+ \ JOIN architecture ON binaries.architecture = architecture.id \
+ \ JOIN source ON binaries.source = source.id \
+ \ JOIN metadata_keys dmk ON dmk.key = 'Depends' \
+ \ LEFT OUTER JOIN binaries_metadata dm ON dm.bin_id = binaries.id AND dmk.key_id = dm.key_id \
+ \ 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 = ? \
+ \ AND arch_string = ? \
+ \ AND (dm.value ~ ? OR pm.value ~ ? ) \
+ \"
+
-- Option parsing
data Conf = Conf
{ arches :: [Arch]
@@ -338,11 +437,12 @@ data Conf = Conf
, regexS :: String -- A regex is not Show'able, so we need to keep the string
, offline :: Bool
, quiet :: Bool
+ , sql :: Bool
}
-mkConf :: [Arch] -> String -> Bool -> Bool -> Conf
-mkConf a r b1 b2 =
- Conf a (mkRegex ("^"++r++"$")) (mkRegex r) r b1 b2
+mkConf :: [Arch] -> String -> Bool -> Bool -> Bool -> Conf
+mkConf a r b1 b2 b3 =
+ Conf a (mkRegex ("^"++r++"$")) (mkRegex r) r b1 b2 b3
parseArches :: String -> ReadM [Arch]
parseArches s =
@@ -378,6 +478,10 @@ conf = mkConf
long "quiet" <>
help "don't be chatty on stderr"
)
+ <*> switch (
+ long "sql" <>
+ help "use sql instead of downloading files. (e.g. on wuiet.debian.org)"
+ )
haskellRegex :: String
haskellRegex = "libghc-(.*)-dev-([0-9.]+-[0-9a-f]{5})"
--
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