[Pkg-haskell-commits] darcs: tools: Add haskell-pkg-debcheck-exp.hs for experimental binNMUs
Joachim Breitner
mail at joachim-breitner.de
Sat Nov 3 18:19:09 UTC 2012
Sat Nov 3 18:18:59 UTC 2012 Joachim Breitner <mail at joachim-breitner.de>
* Add haskell-pkg-debcheck-exp.hs for experimental binNMUs
Ignore-this: 410990de84e3e0315643cdb695efb951
A ./haskell-pkg-debcheck-exp.hs
M ./make-static-binary.sh +1
Sat Nov 3 18:18:59 UTC 2012 Joachim Breitner <mail at joachim-breitner.de>
* Add haskell-pkg-debcheck-exp.hs for experimental binNMUs
Ignore-this: 410990de84e3e0315643cdb695efb951
diff -rN -u old-tools//haskell-pkg-debcheck-exp.hs new-tools//haskell-pkg-debcheck-exp.hs
--- old-tools//haskell-pkg-debcheck-exp.hs 1970-01-01 00:00:00.000000000 +0000
+++ new-tools//haskell-pkg-debcheck-exp.hs 2012-11-03 18:19:09.779719623 +0000
@@ -0,0 +1,383 @@
+{-# LANGUAGE PatternGuards #-}
+
+import System.Directory
+import System.Process
+import Control.Monad
+import Control.Applicative
+import Data.Functor.Identity
+import Data.Maybe
+import Data.List
+import Data.List.Split
+import Data.Hashable
+import System.IO
+import Text.XML.HaXml hiding ((!),when)
+import Text.XML.HaXml.Posn (noPos)
+import qualified Data.ByteString.Char8 as BS
+import qualified Data.ByteString.Lazy as LB
+--import qualified Codec.Compression.BZip as BZip
+import qualified Codec.Compression.GZip as GZip
+import Debian.Control
+import Debian.Control.ByteString
+import Debian.Relation
+import Debian.Relation.ByteString
+import Debian.Version
+import Debian.Version.ByteString
+import qualified Data.HashMap.Lazy as M
+-- import Data.Map ((!))
+import qualified Data.HashSet as S
+import Debug.Trace
+import Text.Printf
+
+m ! k = case M.lookup k m of
+ Just x -> x
+ Nothing -> error $ "Could not find " ++ show k ++ " in map " ++ take 50 (show m) ++ "..."
+
+type Arch = String
+
+arches :: [Arch]
+arches = ["amd64"] --, "i386"]
+--arches = words "amd64 armel armhf hurd-i386 i386 mips mipsel powerpc s390 s390x sparc kfreebsd-amd64 kfreebsd-i386"
+
+
+-- File locations
+sourcesFile = "data/experimental-main-Sources.gz"
+binariesFiles arch = "data/experimental-main-binary-" ++ arch ++ "-Packages.gz"
+unstableBinariesFiles arch = "data/unstable-main-binary-" ++ arch ++ "-Packages.gz"
+-- wbDump arch = "data/wanna-build-dump-" ++ arch ++ ".gz"
+
+instance Show DebianVersion where show v = render (prettyDebianVersion v)
+instance Show Relation where show v = render (prettyRelation v)
+
+data SourceInfo = SourceInfo
+ { siName :: SrcPkgName
+ , siVersion :: DebianVersion
+ , siBinaries :: [BinPkgName]
+ , siBuildDepends :: Relations
+ }
+ deriving Show
+
+main = do
+ checkFiles
+
+ hPutStr stderr "# Reading sources..."
+ sourcesMap <-
+ toSourcesMap <$>
+ (either (error.show) id) <$>
+ parseControl "Sources" <$>
+ BS.concat <$>
+ LB.toChunks <$>
+ GZip.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 unions $
+ forM arches $ \arch ->
+ toBinaryMap arch bToS <$>
+ (either (error.show) id) <$>
+ parseControl "Binary" <$>
+ BS.concat <$>
+ LB.toChunks <$>
+ GZip.decompress <$>
+ LB.readFile (binariesFiles arch)
+ hPutStrLn stderr $ show (M.size binaryMap) ++ " binary/arch tuples selected."
+
+ {-
+ hPutStr stderr "# Reading Wanna-Build-State..."
+ wbMap <-
+ fmap unions $
+ forM arches $ \arch ->
+ toWBMap arch sourcesMap <$>
+ (either (error.show) id) <$>
+ parseControl "Wanna-Build" <$>
+ BS.concat <$>
+ LB.toChunks <$>
+ GZip.decompress <$>
+ LB.readFile (wbDump arch)
+ hPutStrLn stderr $ show (M.size wbMap) ++ " source/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
+ ((s,a),(st,dw)) <- M.toList wbMap
+ guard $ st /= "Installed"
+ let sv = siVersion (sourcesMap ! s)
+ return (s,(S.singleton a, sv, "dummy"))
+ -}
+
+ let nmus = M.fromListWith mergeArches $ do
+ (p,a,_,x) <- problems
+ guard $ (p,a) `member` binaryMap
+ let s = bToS ! p
+ si = sourcesMap ! s
+ (_,bsv) = binaryMap ! (p,a)
+ sv = siVersion si
+ -- Do not schedule binNMUs for outdated sources
+ guard (bsv == sv)
+ --guard (not (s `member` outdatedSources))
+
+ -- Do not scheulde binNMUs if not in Installed state
+ -- guard (fst (wbMap ! (s,a)) == "Installed")
+ return (s,(S.singleton a, sv, formatReason x))
+
+ forM (M.toList nmus) $ \(s,(as,sv,exp)) -> putStrLn $ "nmu " ++ unPkgName (unSrcPkgName s) ++ "_" ++ show sv ++ " . " ++ unwords (S.toList as) ++ " . -m '" ++ exp ++ "' -D experimental"
+
+ {-
+ let buildingSources = unionWith mergeArches outdatedSources nmus
+
+ let depwaits = filterExistingDepWaits wbMap $
+ M.fromListWith (unionWith mergeRelations) $ do
+ (s,(as,sv,_)) <- M.toList buildingSources
+ a <- S.toList as
+ bdep <- flattenRelations (siBuildDepends (sourcesMap ! s))
+ guard (isNotIgnored bdep)
+ guard (bdep `member` bToS)
+ let dsi = sourcesMap ! (bToS ! bdep)
+ dw <-
+ (do
+ -- DepWait upon packages that are yet to be built
+ guard $ siName dsi `member` outdatedSources
+ -- on this architecute
+ guard $ a `S.member` (let (as,_,_) = outdatedSources ! siName dsi in as)
+ -- unless this package is non-existant on this architecture
+ guard $ (bdep,a) `member` binaryMap
+ let dwv = siVersion dsi
+ return $ [[(Rel bdep (Just (GRE dwv)) Nothing )]]
+ ) ++
+ (do
+ guard $ siName dsi `member` nmus
+ guard $ a `S.member` (let (as,_,_) = nmus ! siName dsi in as)
+ guard $ (bdep,a) `member` binaryMap
+ let dwv = fst (binaryMap ! (bdep,a))
+ return $ [[(Rel bdep (Just (SGR dwv)) Nothing)]]
+ )
+ return ((s,sv),M.singleton a dw)
+
+ 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,fdws) <- M.toList m
+ return (fdws, S.singleton a)
+ forM (M.toList m2) $ \((f,dws),as) -> do
+ {-
+ forM (S.toList as) $ \a ->
+ do case (s, a) `M.lookup` wbMap of
+ Just (_,cdw@(_:_)) -> putStrLn $ "# Current Dep-Wait on " ++ a ++ ": " ++ showRelations cdw
+ _ -> return ()
+ when (not f) $ putStr "# "
+ -}
+ when f $ putStrLn $ "dw " ++ s ++ "_" ++ show sv ++ " . " ++ unwords (S.toList as) ++ " . -m '" ++ showRelations dws ++ "'"
+ -}
+
+interestingSource si = BinPkgName (PkgName "haskell-devscripts") `elem` (flattenRelations (siBuildDepends si)) &&
+ BinPkgName (PkgName "ghc6") `notElem` (flattenRelations (siBuildDepends si))
+
+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.fromListWith higherSourceVersion .
+ mapMaybe (\para -> do -- Maybe monad
+ p <- SrcPkgName . PkgName . BS.unpack <$> fieldValue "Package" para
+ a <- BS.unpack <$> fieldValue "Architecture" para
+ guard (a /= "all")
+ 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 bToS =
+ M.fromList .
+ mapMaybe (\para -> do -- Maybe monad
+ p <- BinPkgName . PkgName . BS.unpack <$>
+ fieldValue "Package" para
+ guard (p `member` bToS)
+ guard (isNotIgnored p)
+ v <- parseDebianVersion <$>
+ fieldValue "Version" para
+ sf <- BS.unpack <$>
+ fieldValue "Source" para
+ -- extract the source name and version if both are given
+ let (s,sv) = case words sf of
+ [s,('(':sv)] -> (s, parseDebianVersion (init sv))
+ [s] -> (s,v)
+ guard (SrcPkgName (PkgName s) == bToS ! p)
+ return ((p,arch), (v,sv))
+ ) .
+ unControl
+
+toWBMap arch sourcesMap =
+ M.fromList .
+ mapMaybe (\para -> do -- Maybe monad
+ s <- BS.unpack <$>
+ fieldValue "package" para
+ guard (s `member` sourcesMap)
+ v <- parseDebianVersion <$>
+ fieldValue "version" para
+ st <- BS.unpack <$>
+ fieldValue "state" para
+ -- Consider all the posibilities here: What if wanna-build is newer,
+ -- what if it is older?
+ when (v /= siVersion (sourcesMap ! s)) $
+ unless (st `elem` ["Failed-Removed", "Not-For-Us"]) $
+ trace (printf "Version difference for %s on %s in state %s: \
+ \wb knows %s and Sources knows %s"
+ s
+ arch
+ st
+ (show v)
+ (show (siVersion (sourcesMap ! s)))) $
+ return ()
+ guard (v == siVersion (sourcesMap ! s))
+ dw <- (
+ (either (error.show) id) <$>
+ parseRelations <$>
+ fieldValue "depends" para
+ ) `mplus` Just []
+ return ((s,arch), (st,dw))
+ ) .
+ unControl
+
+flattenRelations :: Relations -> [BinPkgName]
+flattenRelations = map (\(Rel p _ _) -> p) . concat
+
+higherSourceVersion si1 si2 = if siVersion si1 > siVersion si2 then si1 else si2
+
+checkFiles :: IO ()
+checkFiles =
+ forM_ (sourcesFile : map binariesFiles arches ++ map unstableBinariesFiles arches {- ++ map wbDump arches -}) $ \file -> do
+ ex <- doesFileExist file
+ unless ex $ do
+ hPutStrLn stderr $ "# Missing expected file: " ++ file
+
+collectEdosOutput :: [BinPkgName] -> IO [(BinPkgName, Arch, DebianVersion, String)]
+collectEdosOutput pkgs = fmap concat $ forM arches $ \arch -> do
+ --(_, Just zcatOut, _, _) <- createProcess $ (proc "zcat" [binariesFiles arch]) { std_out = CreatePipe }
+ (Just edosIn, Just edosOut, _, _) <- createProcess $ (proc "edos-debcheck" ["-xml","-failures","-explain","-checkonly", intercalate "," (map (unPkgName.unBinPkgName) pkgs)]) { std_in = CreatePipe, std_out = CreatePipe }
+ LB.readFile (unstableBinariesFiles arch) >>= LB.hPutStr edosIn . GZip.decompress
+ LB.readFile (binariesFiles arch) >>= LB.hPutStr edosIn . GZip.decompress
+ hClose edosIn
+ 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),_) -> (BinPkgName (PkgName p), a, parseDebianVersion v, s)) (filter (CElem root noPos))
+
+removeArchAll :: [(BinPkgName, Arch, DebianVersion, String)] -> [(BinPkgName, Arch, DebianVersion, String)]
+removeArchAll = filter (\(_,a,_,_) -> a /= "all")
+
+isNotIgnored :: BinPkgName -> Bool
+isNotIgnored pkg = not ("-doc" `isSuffixOf` (unPkgName.unBinPkgName) pkg || "-prof" `isSuffixOf` (unPkgName.unBinPkgName) pkg)
+
+formatReason :: String -> String
+formatReason s = "Dependency " ++ packageName ++ " not available any more"
+ where lastLine = last (lines s)
+ packageName = drop 4 lastLine
+
+filterExistingDepWaits wbMap = mapWithKey $ \(s,v) -> mapWithKey $ \a dw ->
+ case (s,a) `M.lookup` wbMap of
+ Just (_,cdw@(_:_)) -> if cdw `impliesRelations` dw
+ then (False, dw)
+ else (True, dw)
+ _ -> (True, dw)
+
+-- This needs to be improved:
+mergeRelations :: AndRelation -> AndRelation -> AndRelation
+mergeRelations r1 r2 = sort (go r1 r2)
+ where go rel1 [] = rel1
+ go rel1 ([r]:rs) = go (sortIn rel1 r) rs
+ go rel1 (r:rs) = r : go rel1 rs -- Do not merge OrRelations
+
+ sortIn :: AndRelation -> Relation -> AndRelation
+ sortIn [] r2 = [[r2]]
+ sortIn (r1s:rs) r2
+ | length r1s > 1
+ = r1s : sortIn rs r2
+ sortIn ([r1]:rs) r2
+ | not (samePkg r1 r2)
+ = [r1] : sortIn rs r2
+ | Rel _ _ (Just _) <- r1
+ = [r1] : sortIn rs r2
+ | Rel _ _ (Just _) <- r2
+ = [r1] : sortIn rs r2
+ | Rel _ Nothing Nothing <- r1
+ = [ r2 ] : rs
+ | Rel _ Nothing Nothing <- r2
+ = [ r1 ] : rs
+ | Rel p1 (Just v1) Nothing <- r1,
+ Rel p2 (Just v2) Nothing <- r2
+ = [ Rel p1 (Just v) Nothing | v <- mergeVersion v1 v2 ] : rs
+
+ mergeVersion (SLT v1) (SLT v2) = [SLT (min v1 v2)]
+ mergeVersion (LTE v1) (LTE v2) = [LTE (min v1 v2)]
+ mergeVersion (LTE v1) (SLT v2) | v1 < v2 = [LTE v1]
+ | otherwise = [SLT v2]
+ mergeVersion (SLT v2) (LTE v1) | v1 < v2 = [LTE v1]
+ | otherwise = [SLT v2]
+ mergeVersion (SGR v1) (SGR v2) = [SGR (max v1 v2)]
+ mergeVersion (GRE v1) (GRE v2) = [GRE (max v1 v2)]
+ mergeVersion (GRE v1) (SGR v2) | v1 > v2 = [GRE v1]
+ | otherwise = [SGR v2]
+ mergeVersion (SGR v2) (GRE v1) | v1 > v2 = [GRE v1]
+ | otherwise = [SGR v2]
+ mergeVersion (EEQ v1) (EEQ v2) | v1 == v2 = [EEQ v1]
+ mergeVersion v1 v2 = [v1,v2]
+
+-- This is a bit shaky, I hope it wokrs.:
+impliesRelations rs1 rs2 = mergeRelations rs1 rs2 == sort rs1
+
+samePkg (Rel p1 _ _) (Rel p2 _ _) = p1 == p2
+
+showRelations :: [[Relation]] -> [Char]
+showRelations = intercalate ", " . map (intercalate " | " . map show)
+
+-- Functions from Data.Map missing in Data.HashMap
+unions = foldl M.union M.empty
+member k = isJust . M.lookup k
+unionWith f m1 m2 = M.foldrWithKey (M.insertWith f) m1 m2
+mapWithKey f = runIdentity . M.traverseWithKey (\k v -> Identity (f k v))
+
+instance Hashable DebianVersion where
+ hashWithSalt s = hashWithSalt s . evr
+instance Hashable Relation where
+ hashWithSalt s (Rel n r a) = hashWithSalt s (n,r,a)
+instance Hashable ArchitectureReq where
+ hashWithSalt s (ArchOnly as) = hashWithSalt s (1::Int,as)
+ hashWithSalt s (ArchExcept as) = hashWithSalt s (2::Int,as)
+instance Hashable VersionReq where
+ hashWithSalt s (SLT v) = hashWithSalt s (1::Int,v)
+ hashWithSalt s (LTE v) = hashWithSalt s (2::Int,v)
+ hashWithSalt s (EEQ v) = hashWithSalt s (3::Int,v)
+ hashWithSalt s (GRE v) = hashWithSalt s (4::Int,v)
+ hashWithSalt s (SGR v) = hashWithSalt s (5::Int,v)
+instance Hashable PkgName where
+ hashWithSalt s = hashWithSalt s . unPkgName
+instance Hashable SrcPkgName where
+ hashWithSalt s = hashWithSalt s . unSrcPkgName
+instance Hashable BinPkgName where
+ hashWithSalt s = hashWithSalt s . unBinPkgName
+
+
+--instance Show a => Show (S.HashSet a) where
+-- show s = "fromList " ++ show (S.toList s)
diff -rN -u old-tools//make-static-binary.sh new-tools//make-static-binary.sh
--- old-tools//make-static-binary.sh 2012-11-03 18:19:09.770926861 +0000
+++ new-tools//make-static-binary.sh 2012-11-03 18:19:09.787720575 +0000
@@ -1 +1,2 @@
ghc -O2 -optl-static -optl-pthread -package transformers --make haskell-pkg-debcheck.hs
+ghc -O2 -optl-static -optl-pthread -package transformers --make haskell-pkg-debcheck-exp.hs
More information about the Pkg-haskell-commits
mailing list