[Pkg-haskell-commits] [tools] 01/01: New tool: binNMUs
Joachim Breitner
nomeata at moszumanska.debian.org
Tue Aug 26 00:21:00 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 8949c57ffe6ccc1dc591b8e4de2a40e75902992c
Author: Joachim Breitner <mail at joachim-breitner.de>
Date: Mon Aug 25 17:20:27 2014 -0700
New tool: binNMUs
which should be better and easier to use than the haskell-pkg-debcheck,
and also usable by others (e.g. the Ocaml team).
---
AcquireFile.hs | 63 +++++++++++
binNMUs.hs | 330 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
2 files changed, 393 insertions(+)
diff --git a/AcquireFile.hs b/AcquireFile.hs
new file mode 100644
index 0000000..f711e35
--- /dev/null
+++ b/AcquireFile.hs
@@ -0,0 +1,63 @@
+module AcquireFile (acquireFile) where
+
+import Codec.Compression.GZip (decompress)
+import qualified System.IO.Strict as S
+import System.IO
+import System.IO.Error
+import System.Directory
+import System.Exit
+import System.Process
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy.Char8 as BL
+import Control.Exception
+import Control.Monad
+import Data.List
+
+-- File acquirance
+
+acquireFile :: String -> Bool -> Bool -> IO B.ByteString
+acquireFile url ungz offline = do
+ cachePath <- chooseCachePath
+ case cachePath of
+ Nothing -> do
+ hPutStrLn stderr "chooseCachePath could not find a cache path"
+ exitFailure
+ Just path -> do
+ createDirectoryIfMissing False path
+ let savename = path ++ "/"++ map fixChar url
+ ex <- doesFileExist savename
+ when (offline && not ex) $ do
+ hPutStrLn stderr $ "Cached file for " ++ url ++ " does not exist, cannot use offline mode."
+ exitFailure
+ let args = [ "-R" , "-s", "-S", "-L", "-o", savename] ++
+ (if ex then ["-z", savename] else []) ++
+ [ url ]
+ unless offline $ do
+ readProcess "/usr/bin/curl" args ""
+ return ()
+ ex <- doesFileExist savename
+ unless ex $ do
+ hPutStrLn stderr $ "File " ++ savename ++ " does not exist after invoking"
+ hPutStrLn stderr $ intercalate " " ("curl" : args)
+ exitFailure
+ text <- BL.readFile savename
+ return $ if ungz
+ then BL.toStrict $ decompress text
+ else BL.toStrict $ text
+ where fixChar '/' = '_'
+ fixChar ':' = '_'
+ fixChar c = c
+
+chooseCachePath :: IO (Maybe String)
+chooseCachePath = do
+ result <- tryJust shouldCatch $ getAppUserDataDirectory "reasons"
+ hasHome <- getHomeDirectory >>= doesDirectoryExist
+ return $ case result of
+ Right dir -> if hasHome
+ then Just dir
+ else Nothing
+ Left _ -> Nothing
+ where shouldCatch e = if isDoesNotExistError e
+ then Just e
+ else Nothing
+
diff --git a/binNMUs.hs b/binNMUs.hs
new file mode 100644
index 0000000..80a2dd1
--- /dev/null
+++ b/binNMUs.hs
@@ -0,0 +1,330 @@
+import Text.Printf
+import Data.List
+import Data.List.Split
+import Data.Maybe
+import Data.Char
+import Data.Ord
+import Data.Function
+import Options.Applicative
+import qualified Data.Set as S
+import qualified Data.Map as M
+import Debian.Control.ByteString
+import Debian.Relation.Common
+import Debian.Relation.ByteString
+import Control.Monad
+import Text.Regex
+import System.IO
+import Control.Arrow
+import qualified Data.ByteString.Char8 as B
+
+import AcquireFile
+
+allArches :: [Arch]
+allArches = words "amd64 armel armhf hurd-i386 i386 mips mipsel powerpc s390x kfreebsd-amd64 kfreebsd-i386"
+
+type SourceName = String
+type Version = String
+type Arch = String
+
+data VirtPackage = VirtPackage {vpFull :: String, vpBase :: VirtPackageBase, vpHash :: String}
+ deriving (Eq, Show)
+type VirtPackageBase = String -- just the part without the hash (and without libghc-)
+
+data Status -- ^ Status of a binNMU
+ = Needed -- ^ This binNMU schould be scheduled
+ | Waiting -- ^ This binMU is already scheduled, but in state BD-Uninstallable
+ | Failed -- ^ This package is in a bad state in wanna-build
+ | DepsMissing -- ^ Some dependencies are not present at all (NEW?)
+ | WrongSrcVersion -- ^ Different source versions (out-of-date)
+ | WrongVersion -- ^ Wrong version in wanna build
+ | Missing -- ^ Doesn’t exist in wanna build?
+ deriving (Eq, Ord, Show)
+
+data Reason
+ = MissingDep VirtPackage
+ | UpgradedDep VirtPackage VirtPackage
+
+type BinNMU = (Binary, [Reason])
+
+data Binary = Binary
+ { bPkgName :: String
+ , bSourceName :: SourceName
+ , bArchitecture :: Arch
+ , bVersion :: Version
+ , bSrcVersion :: Version
+ , bDepends :: [VirtPackage] --simplified, we consider relevant deps only
+ , bProvides :: [VirtPackage]
+ }
+ deriving Show
+
+-- The main action
+
+run :: Conf -> IO ()
+run c = do
+ cBinNMUs <- concat <$> mapM (getNMUs c) (arches c)
+ presentBinNMUs cBinNMUs
+
+
+-- | Presentation of binNMUs
+
+presentBinNMUs :: [(Status, BinNMU)] -> IO ()
+presentBinNMUs cBinNMUs = do
+ forM_ (ordGroupBy fst cBinNMUs) $ \(s, cBinNMUs) -> do
+ unless (ignoreStatus s) $ do
+ putStrLn ("# " ++ statusHeader s)
+ putStr $ alignAt " . "
+ [ (if actStatus s then "" else "# ") ++ formatNMU nmu
+ | nmu <- sortBy (compare `on` bSrcVersion . fst) $ map snd cBinNMUs ]
+ putStrLn ""
+
+statusHeader :: Status -> String
+statusHeader Needed = "Actually required NMUs"
+statusHeader Waiting = "Already scheduled NMUs"
+statusHeader Failed = "Failed builds"
+statusHeader DepsMissing = "NMU seems pointless. Dependency in NEW?"
+statusHeader WrongSrcVersion = "Package out of date, will be rebuilt anyways"
+statusHeader WrongVersion = "PPackages and Wanna-Build are out of sync"
+statusHeader Missing = "Packages not known to Wanna-Build. Ignoring."
+
+actStatus :: Status -> Bool
+actStatus Needed = True
+actStatus _ = False
+
+ignoreStatus :: Status -> Bool
+ignoreStatus WrongSrcVersion = True
+ignoreStatus _ = False
+
+alignAt :: String -> [String] -> String
+alignAt d lines = unlines (map expands rows)
+ where rows = map (split (onSublist d)) lines
+ widths = [map length r ++ repeat 0 | r <- rows]
+ colwidths = map maximum (transpose widths)
+ expand n s = s ++ replicate (n - length s) ' '
+ expands [] = ""
+ expands r = concat (zipWith expand colwidths (init r)) ++ last r
+
+formatNMU :: BinNMU -> String
+formatNMU (b, d) =
+ printf "nmu %s_%s . %s . -m '%s'"
+ (bSourceName b)
+ (bSrcVersion b)
+ (bArchitecture b)
+ (intercalate ", " $ map formatReason d)
+
+formatReason :: Reason -> String
+formatReason (MissingDep d)
+ = printf "%s has disappeared" (vpFull d)
+formatReason (UpgradedDep d1 d2)
+ = printf "%s changed from %s to %s" (vpBase d1) (vpHash d1) (vpHash d2)
+
+
+ordGroupBy :: Ord b => (a -> b) -> [a] -> [(b, [a])]
+ordGroupBy f = M.toAscList . M.fromListWith (++) . map (f &&& (:[]))
+
+
+-- | Data aquisition and processing
+getNMUs :: Conf -> Arch -> IO [(Status, BinNMU)]
+getNMUs conf a = do
+ pkgs <- fetchArchive conf a
+ wbmap <- fetchWannaBuild conf a
+ let available = M.fromListWith (++) [ (vpBase v, [v])
+ | p <- pkgs, v <- bProvides p
+ ]
+ let binNMUs = mapMaybe (needsRebuild available) pkgs
+ let cBinNMUs = map (categorize available wbmap &&& id) binNMUs
+ return cBinNMUs
+
+-- Categorizing nmus
+
+categorize :: VirtPackageMap -> WBMap -> BinNMU -> Status
+categorize available wbmap (p,deps) =
+ case M.lookup (bSourceName p) wbmap of
+ Nothing -> Missing
+ Just (v,bv,s)
+ | v /= bSrcVersion p -> WrongSrcVersion
+ | s == "installed" && bv /= bVersion p
+ -> WrongVersion
+ | s `elem` waiting -> Waiting
+ | s == "installed" -> Needed
+ | otherwise -> Failed
+ where waiting = words "bd-uninstallable built uploaded"
+
+
+-- Calculating required binNMUs
+
+type VirtPackageMap = M.Map VirtPackageBase [VirtPackage]
+
+needsRebuild :: VirtPackageMap -> Binary -> Maybe BinNMU
+needsRebuild available b
+ | null reasons = Nothing
+ | otherwise = Just (b, reasons)
+ where
+ reasons = mapMaybe go (bDepends b)
+
+ go v = case M.lookup (vpBase v) available of
+ Nothing -> Just $ MissingDep v
+ Just vs | v `notElem` vs -> Just $ UpgradedDep v (head vs)
+ | otherwise -> Nothing
+
+-- Parsing virtual package names
+
+parseVirtPackage :: Conf -> String -> Maybe VirtPackage
+parseVirtPackage conf p = case matchRegex (regex conf) p of
+ Just [a,b] -> Just (VirtPackage p a b)
+ _ -> Nothing
+
+-- Reading wannabuild dumps
+wannaBuildDumpUrl :: Arch -> String
+wannaBuildDumpUrl a = printf "http://buildd.debian.org/stats/%s-dump.txt.gz" a
+
+type WBState = String
+type WBMap = M.Map SourceName (Version, Version, WBState)
+
+
+fetchWannaBuild :: Conf -> Arch -> IO WBMap
+fetchWannaBuild conf a = do
+ s <- acquireFile' conf url
+ case parseControl url s of
+ Left pe -> error $ show pe
+ Right c -> return $
+ M.fromList $
+ map parsePara $
+ unControl c
+ where
+ url = wannaBuildDumpUrl a
+
+ parsePara p =
+ ( reqField "package"
+ , ( reqField "version"
+ , reqField "version" ++ maybe "" ("+b"++) (optField "binary_nmu_version")
+ , map toLower $ reqField "state"
+ )
+ )
+ where reqField f = maybe (error $ printf "Missing field %s" f) B.unpack (fieldValue f p)
+ optField f = B.unpack <$> fieldValue f p
+
+
+
+-- Reading archive files
+
+builddPackageUrl :: Arch -> String
+builddPackageUrl 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
+ s <- acquireFile' conf url
+ case parseControl url s of
+ Left pe -> error $ show pe
+ Right c -> return $
+ filter interesting $
+ map parsePara $
+ unControl c
+ where
+ parsePara :: Paragraph -> Binary
+ parsePara p =
+ Binary
+ pkg
+ (maybe pkg (fst.splitSrc) (optField "Source"))
+ (reqField "Architecture")
+ v
+ (fromMaybe v (optField "Source" >>= snd . splitSrc))
+ (mapMaybe (parseVirtPackage conf) $ flatRels $ relField "Depends")
+ (mapMaybe (parseVirtPackage conf) $ flatRels $ relField "Provides")
+ where reqField f = maybe (error $ printf "Missing field %s" f) B.unpack (fieldValue f p)
+ optField f = B.unpack <$> fieldValue f p
+
+ pkg = reqField "Package"
+ v = reqField "Version"
+
+ relField :: String -> Relations
+ relField f = case parseRelations $ fromMaybe B.empty (fieldValue f p) 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
+
+
+interesting :: Binary -> Bool
+interesting b = not (null (bProvides b) && null (bDepends b))
+
+splitSrc :: String -> (SourceName, Maybe Version)
+splitSrc sf =
+ case words sf of
+ [s,('(':sv)] -> (s, Just (init sv))
+ [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)
+ let pkg1_names = S.fromList (map bPkgName pkgs1)
+ pkgs2 <- acquirePackages conf (sidPackageUrl a)
+ let pkgs2' = [ p | p <- pkgs2 , bPkgName p `S.notMember` pkg1_names ]
+ return $ pkgs1 ++ pkgs2'
+
+acquireFile' :: Conf -> String -> IO B.ByteString
+acquireFile' conf url = do
+ unless o $ hPutStr stderr $ printf "Fetching %s ..." url
+ unless o $ hFlush stderr
+ s <- acquireFile url True o
+ unless o $ hPutStrLn stderr $ printf " done."
+ return s
+ where o = offline conf
+
+-- Option parsing
+data Conf = Conf
+ { arches :: [Arch]
+ , regex :: Regex
+ , offline :: Bool
+ }
+
+parseArches :: String -> ReadM [Arch]
+parseArches s =
+ case split (dropBlanks $ dropDelims $ oneOf ";, ") s of
+ [] -> readerError "Empty list of architectures"
+ arches -> case filter (not . (`elem` allArches)) arches of
+ [] -> return arches
+ bad -> readerError $ "Unknown architectures: " ++ intercalate ", " bad
+
+conf :: Parser Conf
+conf = Conf
+ <$> nullOption (
+ long "arches" <>
+ metavar "ARCH,ARCH,..." <>
+ help "comma or space separated list of architectures" <>
+ value allArches <>
+ showDefaultWith (intercalate ", ") <>
+ reader parseArches
+ )
+ <*> mkRegex `fmap` strOption (
+ long "regex" <>
+ metavar "REGEX" <>
+ help "regular expression matching virtual package names, with two groups" <>
+ showDefault <>
+ value haskellRegex
+ )
+ <*> switch (
+ long "offline" <>
+ help "do not download files (cached files must be available)"
+ )
+
+haskellRegex :: String
+haskellRegex = "libghc-(.*)-dev-([0-9.]+-[0-9a-f]{5})"
+
+
+-- Main program
+
+main :: IO ()
+main = execParser opts >>= run
+ where
+ opts = info (helper <*> conf)
+ ( fullDesc
+ <> progDesc "Calculate Haskell packages to be binNMUed"
+ <> header "binNMUs - Calculate Haskell packages to be binNMUed" )
--
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