{-# 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/unstable-main-Sources.gz" binariesFiles 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 :: 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 <$> 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 " ++ s ++ "_" ++ show sv ++ " . " ++ unwords (S.toList as) ++ " . -m '" ++ exp ++ "'" 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 = "haskell-devscripts" `elem` (flattenRelations (siBuildDepends si)) && "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 <- 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 <- 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 (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 -> [PkgName] 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 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 zcatOut, _, _) <- createProcess $ (proc "zcat" [binariesFiles arch]) { std_out = CreatePipe } (_, Just edosOut, _, _) <- createProcess $ (proc "edos-debcheck" ["-xml","-failures","-explain","-checkonly", intercalate "," pkgs]) { std_in = UseHandle zcatOut, 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 noPos)) 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) 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 = 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 Show a => Show (S.HashSet a) where -- show s = "fromList " ++ show (S.toList s)