[Pkg-haskell-commits] darcs: tools: Initial shot at haskell-pkg-debcheck.hs
Joachim Breitner
mail at joachim-breitner.de
Sun May 2 21:52:44 UTC 2010
Sun May 2 21:50:55 UTC 2010 Joachim Breitner <mail at joachim-breitner.de>
* Initial shot at haskell-pkg-debcheck.hs
Ignore-this: ba92e595fa2e77cfb94949470340f04b
A ./haskell-pkg-debcheck.hs
Sun May 2 21:50:55 UTC 2010 Joachim Breitner <mail at joachim-breitner.de>
* Initial shot at haskell-pkg-debcheck.hs
Ignore-this: ba92e595fa2e77cfb94949470340f04b
diff -rN -u old-tools/haskell-pkg-debcheck.hs new-tools/haskell-pkg-debcheck.hs
--- old-tools/haskell-pkg-debcheck.hs 1970-01-01 00:00:00.000000000 +0000
+++ new-tools/haskell-pkg-debcheck.hs 2010-05-02 21:52:44.875995402 +0000
@@ -0,0 +1,197 @@
+import System.Directory
+import System.Process
+import Control.Monad
+import Control.Applicative
+import Data.Maybe
+import Data.List
+import Data.List.Split
+import System.IO
+import Text.XML.HaXml hiding ((!))
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString.Lazy as LB
+import qualified Codec.Compression.BZip as BZip
+import Debian.Control
+import Debian.Control.ByteString
+import Debian.Relation
+import Debian.Relation.ByteString
+import Debian.Version
+import Debian.Version.ByteString
+import qualified Data.Map as M
+import Data.Map ((!))
+import qualified Data.Set as S
+
+type Arch = String
+
+arches :: [Arch]
+-- arches = ["amd64","i386"]
+arches = words "amd64 armel hppa i386 ia64 mips mipsel powerpc s390 sparc kfreebsd-amd64 kfreebsd-i386"
+
+
+-- File locations
+sourcesFile = "data/unstable-main-Sources.bz2"
+binariesFiles arch = "data/unstable-main-binary-" ++ arch ++ "-Packages.bz2"
+wbDump arch = "data/wanna-build-dump-" ++ arch ++ ".gz"
+
+data SourceInfo = SourceInfo
+ { siName :: PkgName
+ , siVersion :: DebianVersion
+ , siBinaries :: [PkgName]
+ , siBuildDepends :: Relations
+ }
+ deriving Show
+
+main = do
+ checkFiles
+
+ hPutStr stderr "# Reading sources..."
+ sourcesMap <-
+ toSourcesMap <$>
+ (either (error.show) id) <$>
+ parseControl "Sources" <$>
+ BS.concat <$>
+ LB.toChunks <$>
+ BZip.decompress <$>
+ LB.readFile (sourcesFile)
+ hPutStrLn stderr $ show (M.size sourcesMap) ++ " sources selected."
+
+ -- Invert the map for easy binary → source lookup
+ let bToS = M.fromList $ concat $ map (\(_,si) -> map (\p -> (p,siName si)) (siBinaries si)) $ M.toList sourcesMap
+
+ hPutStr stderr "# Reading binaries..."
+ binaryMap <-
+ fmap M.unions $
+ forM arches $ \arch ->
+ toBinaryMap arch (M.keysSet bToS) <$>
+ (either (error.show) id) <$>
+ parseControl "Sources" <$>
+ BS.concat <$>
+ LB.toChunks <$>
+ BZip.decompress <$>
+ LB.readFile (binariesFiles arch)
+ hPutStrLn stderr $ show (M.size binaryMap) ++ " binary/arch tuples selected."
+
+ hPutStr stderr "# Reading edos-debcheck output..."
+ problems <- removeArchAll <$> collectEdosOutput (filter isNotIgnored (M.keys bToS))
+ hPutStrLn stderr $ show (length problems) ++ " problems detected."
+
+ let outdatedSources = M.fromListWith mergeArches $ do -- list monad
+ ((p,a),(bv,_)) <- M.toList binaryMap
+ let s = bToS ! p
+ si = sourcesMap ! s
+ sv = siVersion si
+ guard $ bv < sv
+ return (s,(S.singleton a, sv, "dummy"))
+
+ let nmus = M.fromListWith mergeArches $ do
+ (p,a,_,x) <- problems
+ guard $ (p,a) `M.member` binaryMap
+ let s = bToS ! p
+ si = sourcesMap ! s
+ (_,bsv) = binaryMap ! (p,a)
+ sv = siVersion si
+ guard (bsv == sv) -- Do not schedule binNMUs for outdated sources
+ return (s,(S.singleton a, sv, "Rebuild against updated dependencies"))
+
+ forM (M.toList nmus) $ \(s,(as,sv,exp)) -> putStrLn $ "nmu " ++ s ++ "_" ++ show sv ++ " . " ++ unwords (S.toList as) ++ " . -m '" ++ exp ++ "'"
+
+ let buildingSources = M.unionWith mergeArches outdatedSources nmus
+
+ let depwaits = M.fromListWith (M.unionWith S.union) $ do
+ (s,(as,sv,_)) <- M.toList buildingSources
+ a <- S.toList as
+ bdep <- flattenRelations (siBuildDepends (sourcesMap ! s))
+ guard (isNotIgnored bdep)
+ guard (bdep `M.member` bToS)
+ let dsi = sourcesMap ! (bToS ! bdep)
+ msg <-
+ (do
+ guard $ siName dsi `M.member` outdatedSources
+ guard $ a `S.member` (let (as,_,_) = outdatedSources ! siName dsi in as)
+ return $ bdep ++ " (>= " ++ show (siVersion dsi) ++ ")"
+ ) ++
+ (do
+ guard $ siName dsi `M.member` nmus
+ guard $ a `S.member` (let (as,_,_) = nmus ! siName dsi in as)
+ return $ bdep ++ " (>> " ++ show (fst (binaryMap ! (bdep,a))) ++ ")"
+ )
+ return ((s,sv),M.singleton a (S.singleton msg))
+
+ forM (M.toList depwaits) $ \((s,sv),m) -> do
+ -- Reorder to collapse dw lines with identical depwait command
+ let m2 = M.fromListWith S.union $ do
+ (a,dws) <- M.toList m
+ return (dws, S.singleton a)
+ forM (M.toList m2) $ \(dws,as) ->
+ putStrLn $ "dw " ++ s ++ "_" ++ show sv ++ " . " ++ unwords (S.toList as) ++ " . -m '" ++ intercalate ", " (S.toList dws) ++ "'"
+
+interestingSource = any (\(Rel p _ _) -> p == "haskell-devscripts") . concat . siBuildDepends
+
+mergeArches n1@(as1, v1, x1) n2@(as2, v2, x2)
+ | v1 == v2 = (as1 `S.union` as2, v1, x1)
+ | v1 > v2 = n1
+ | v1 < v2 = n2
+
+toSourcesMap =
+ M.fromList .
+ mapMaybe (\para -> do -- Maybe monad
+ p <- BS.unpack <$> fieldValue "Package" para
+ v <- parseDebianVersion <$>
+ fieldValue "Version" para
+ bins <-
+ flattenRelations <$>
+ (either (error.show) id) <$>
+ parseRelations <$>
+ fieldValue "Binary" para
+ bd <-
+ (either (error.show) id) <$>
+ parseRelations <$>
+ fieldValue "Build-Depends" para
+ let si = SourceInfo p v bins bd
+ guard (interestingSource si)
+ return (p, si)
+ ) .
+ unControl
+
+toBinaryMap arch interesting =
+ M.fromList .
+ mapMaybe (\para -> do -- Maybe monad
+ p <- BS.unpack <$>
+ fieldValue "Package" para
+ guard (p `S.member` interesting)
+ guard (isNotIgnored p)
+ v <- parseDebianVersion <$>
+ fieldValue "Version" para
+ s <- BS.unpack <$>
+ fieldValue "Source" para
+ -- extract the source version if available
+ let sv = case words s of
+ [_,('(':sv)] -> parseDebianVersion (init sv)
+ _ -> v
+ return ((p,arch), (v,sv))
+ ) .
+ unControl
+
+flattenRelations :: Relations -> [PkgName]
+flattenRelations = map (\(Rel p _ _) -> p) . concat
+
+checkFiles :: IO ()
+checkFiles =
+ forM_ (sourcesFile : map binariesFiles arches ++ map wbDump arches ) $ \file -> do
+ ex <- doesFileExist file
+ unless ex $ do
+ hPutStrLn stderr $ "# Missing expected file: " ++ file
+
+collectEdosOutput :: [PkgName] -> IO [(PkgName, Arch, DebianVersion, String)]
+collectEdosOutput pkgs = fmap concat $ forM arches $ \arch -> do
+ (_, Just bzcatOut, _, _) <- createProcess $ (proc "bzcat" [binariesFiles arch]) { std_out = CreatePipe }
+ (_, Just edosOut, _, _) <- createProcess $ (proc "edos-debcheck" ["-xml","-failures","-explain","-checkonly", intercalate "," pkgs]) { std_in = UseHandle bzcatOut, std_out = CreatePipe }
+ Document _ _ root _ <- xmlParse "edos output" <$> hGetContents edosOut
+ -- How do you actually use this HaXmL? This can not be the correct way:
+ let filter = concatMap ((attributed "package" `x` attributed "architecture" `x` attributed "version" `x` extracted (concat . mapMaybe fst . textlabelled (txt `o` children)) ) keep) . (elm `o` children)
+ return $ map (\((((p,a),v),s),_) -> (p, a, parseDebianVersion v, s)) (filter (CElem root))
+
+removeArchAll :: [(PkgName, Arch, DebianVersion, String)] -> [(PkgName, Arch, DebianVersion, String)]
+removeArchAll = filter (\(_,a,_,_) -> a /= "all")
+
+isNotIgnored :: PkgName -> Bool
+isNotIgnored pkg = not ("-doc" `isSuffixOf` pkg || "-prof" `isSuffixOf` pkg)
More information about the Pkg-haskell-commits
mailing list