fedora-haskell-tools 0.5.1 → 0.6
raw patch · 11 files changed
+830/−361 lines, 11 filesdep +HTTPdep +csvdep +semigroupsdep ~time
Dependencies added: HTTP, csv, semigroups
Dependency ranges changed: time
Files
- ChangeLog +20/−0
- Dists.hs +22/−14
- Koji.hs +58/−22
- README.md +1/−0
- RPM.hs +80/−15
- TODO +28/−8
- Utils.hs +64/−9
- fedora-haskell-tools.cabal +10/−7
- fhbuild.hs +82/−120
- fhbz.hs +11/−5
- fhpkg.hs +454/−161
ChangeLog view
@@ -1,3 +1,23 @@+* 0.6 (2018-08-07)+- fhpkg+ - new commands: hackage-compare, merge, missing, count, leaf, unpushed, head-origin+ - command options including arguments and global options+ - new -A option for all packages replaces default of all packages+ - new -b=branch option+ - some support for private git repos and branches+ - use line buffering for synchronous stdout+ - new -s short output option for diff and unpushed+ - compare-stackage now uses lts-11+- fhbuild+ - install: pause after failure+ - install: print number of packages left+ - install: dnf remove existing package+ - koji client robustness against broken connections+- use fedora and updates repos only for repoquery+- initial support for rpkg other than fedpkg+- ghc-8.4+- lot refactoring for utils etc+ * 0.5 (2018-02-16) - fhpkg - add commands for prep, refresh, diff-origin, push, and commit
Dists.hs view
@@ -25,9 +25,10 @@ distOverride, hackageRelease, releaseVersion,- rawhide) where+ rawhide,+ rpmDistTag) where -import Data.Char (isNumber)+import Data.Char (isDigit) import Data.Maybe (fromMaybe, maybe) import Utils ((+-+))@@ -35,23 +36,24 @@ type Dist = String dists :: [Dist]-dists = [rawhide, "f27", "f26", "f25", "epel7"]+dists = [rawhide, "f28", "f27", "f26", "epel7"] rawhide :: String-rawhide = "f28"+rawhide = "f29" -sidetag :: Maybe String-sidetag = Nothing -- Just "ghc"+sidetag :: Dist -> Maybe String+sidetag "f29" = Just "ghc"+sidetag _ = Nothing hackageRelease :: String-hackageRelease = "f27"+hackageRelease = "f28" distBranch :: Dist -> String distBranch d | d == rawhide = "master" | otherwise = d splitDist :: Dist -> (String, String)-splitDist = break isNumber+splitDist = break isDigit distShort :: Dist -> String distShort = fst . splitDist@@ -70,14 +72,20 @@ distUpdates _ = Nothing distOverride :: Dist -> Bool-distOverride d = d `notElem` [rawhide, "f28" {-, "epel7"-}]+distOverride d = d `notElem` [rawhide, "f29" , "epel8"] distTag :: Dist -> String-distTag d = d ++ "-" ++ fromMaybe "build" sidetag+distTag d = d ++ "-" ++ fromMaybe "build" (sidetag d) distTarget :: Dist -> String-distTarget d = maybe d (\ suff -> d ++ "-" ++ suff) sidetag+distTarget d = maybe d (\ suff -> d ++ "-" ++ suff) (sidetag d) -releaseVersion :: Dist -> String-releaseVersion r | r == rawhide = "rawhide"-releaseVersion r = distVersion r+releaseVersion :: Dist -> Maybe String+releaseVersion r | r == rawhide = Just "rawhide"+releaseVersion r = if all isDigit v then Just v else Nothing+ where+ v = distVersion r++rpmDistTag :: Dist -> String+rpmDistTag ('f':r) = ".fc" ++ r+rpmDistTag d = '.' : d
Koji.hs view
@@ -13,41 +13,59 @@ -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -module Koji where+module Koji (kojiBuilding,+ kojiCheckFHBuilt,+ kojicmd,+ kojiLatestPkg,+ kojiListPkgs,+ kojiWaitPkg,+ notInKoji,+ rpkg,+ rpkgBuild+ ) where #if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,8,2)) #else import Control.Applicative ((<$>)) #endif-import Control.Monad (unless)-import Data.List (isInfixOf)-import System.Directory (doesDirectoryExist)+import Control.Monad (unless, when)+import Data.List (isInfixOf, isPrefixOf)+import Data.Time.Clock (diffUTCTime, getCurrentTime) import System.FilePath ((</>)) -import Dists (Dist)-import Utils (cmd, cmd_, cmdBool)+import Dists (Dist, distTarget)+import RPM (pkgDir)+import Utils (cmd, cmd_, cmdBool, cmdFragile, cmdFragile_, grep, logMsg, (+-+)) -kojiLatestPkg :: Dist -> String -> IO String+kojicmd :: Dist -> String+kojicmd dist = if "rhel" `isPrefixOf` dist then "brew" else "koji"++kojisafe :: Dist -> String -> [String] -> IO String+kojisafe dist c as =+ cmdFragile (kojicmd dist) (c:as)++kojiLatestPkg :: Dist -> String -> IO (Maybe String) kojiLatestPkg dist pkg = do- res <- words <$> cmd "koji" ["latest-pkg", "--quiet", dist, pkg]- return $ if null res then "" else head res+ res <- words <$> kojisafe dist "latest-pkg" ["--quiet", dist, pkg]+ return $ if null res then Nothing else Just $ head res kojiWaitPkg :: FilePath -> Dist -> String -> IO () kojiWaitPkg topdir dist nvr = do let fhbuilt = topdir </> ".fhbuilt" already <- kojiCheckFHBuilt topdir nvr unless already $ do- cmd_ "koji" ["wait-repo", dist, "--build=" ++ nvr]+ putStrLn $ "Waiting for" +-+ nvr +-+ "in" +-+ dist+ cmdFragile_ (kojicmd dist) ["wait-repo", dist, "--build=" ++ nvr] appendFile fhbuilt $ nvr ++ "\n" kojiCheckFHBuilt :: FilePath -> String -> IO Bool kojiCheckFHBuilt topdir nvr = do let fhbuilt = topdir </> ".fhbuilt"- cmdBool "grep" ["-q", nvr, fhbuilt]+ grep nvr fhbuilt -kojiBuilding :: String -> String -> IO Bool-kojiBuilding pkg build = do- tasks <- lines <$> cmd "koji" ["list-tasks", "--mine", "--quiet"]+kojiBuilding :: String -> String -> Dist -> IO Bool+kojiBuilding pkg build dist = do+ tasks <- lines <$> kojisafe dist "list-tasks" ["--mine", "--quiet"] return $ any (build `isInfixOf`) tasks || any (("/" ++ pkg ++ ":") `isInfixOf`) tasks -- parseKojiTask :: [String] -> Maybe String@@ -59,16 +77,34 @@ notInKoji branch topdir tag pkg = do latest <- kojiLatestPkg tag pkg pkgpath <- pkgDir pkg branch topdir- local <- cmd "fedpkg" ["--path", pkgpath, "verrel"]- if latest == local- then kojiWaitPkg topdir tag latest >> return False+ local <- cmd (rpkg (Just tag)) ["--path", pkgpath, "verrel"]+ if latest == Just local+ then kojiWaitPkg topdir tag local >> return False else return True kojiListPkgs :: Dist -> IO [String] kojiListPkgs dist =- words <$> cmd "koji" ["list-pkgs", "--tag=" ++ dist]+ words <$> cmd (kojicmd dist) ["list-pkgs", "--tag=" ++ dist] -pkgDir :: String -> String -> FilePath -> IO FilePath-pkgDir dir branch top = do- b <- doesDirectoryExist $ top </> dir </> branch- return $ top </> dir </> if b then branch else ""+rpkg :: Maybe String -> String+rpkg Nothing = "fedpkg"+rpkg (Just dist) = if "rhel" `isPrefixOf` dist then "rhpkg" else "fedpkg"++rpkgBuild :: FilePath -> Dist -> String -> Maybe String -> IO ()+rpkgBuild topdir dist nvr waittag = do+ giturl <- cmd (rpkg (Just dist)) ["giturl"]+ out <- cmd (kojicmd dist) ["build", "--nowait", "--fail-fast", distTarget dist, giturl]+ putStrLn out+ let task = last . words . head $ lines out+ start <- getCurrentTime+ success <- cmdBool "koji" ["watch-task", task]+ if success+ then do+ logMsg $ nvr ++ " built"+ maybe (return ()) (\ t -> kojiWaitPkg topdir t nvr) waittag+ else do+ now <- getCurrentTime+ -- koji srpms typically take 2 minutes+ let countdown = 120 - round (diffUTCTime now start) :: Int+ when (countdown >= 0) $+ cmd_ "sleep" [show countdown]
README.md view
@@ -2,6 +2,7 @@ [](http://hackage.haskell.org/package/fedora-haskell-tools) [](http://stackage.org/lts/package/fedora-haskell-tools) [](http://stackage.org/nightly/package/fedora-haskell-tools)+[](https://www.gnu.org/licenses/gpl.html) # Fedora Haskell Tools
RPM.hs view
@@ -11,9 +11,13 @@ -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -module RPM (packageManager,+module RPM (buildRequires,+ derefSrcPkg,+ haskellSrcPkgs,+ Package,+ packageManager,+ pkgDir, repoquery,- repoquerySrc, rpmInstall, rpmspec) where @@ -22,15 +26,16 @@ import Control.Applicative ((<$>)) #endif import Control.Monad (when)+import Data.List (isPrefixOf, isSuffixOf, nub, (\\)) import Data.Maybe (isJust, isNothing)-import System.Directory (findExecutable)+import System.Directory (doesDirectoryExist, findExecutable) import System.FilePath ((</>)) -- die is available in ghc-7.10 base-4.8-import System.Exit (exitFailure)+import System.Exit (ExitCode (..), exitFailure, exitWith) import System.IO (hPutStrLn, stderr) -import Dists (Dist, distTag)-import Utils (cmd, sudo)+import Dists (Dist, distBranch, dists, distTag, releaseVersion)+import Utils (cmd, removePrefix, removeSuffix, sudo, (+-+)) -- @since base 4.8.0.0 die :: String -> IO a@@ -42,9 +47,7 @@ when (isNothing mavail) $ die (c ++ ": command not found") optionalProgram :: String -> IO Bool-optionalProgram c = do- mavail <- findExecutable c- return $ isJust mavail+optionalProgram c = isJust <$> findExecutable c packageManager :: IO String packageManager = do@@ -59,17 +62,24 @@ let (inst, arg) = if pkginstaller == "dnf" then ("dnf", "install") else ("yum", "localinstall") sudo inst $ ["-y", "--nogpgcheck", arg] ++ rpms -repoquery :: String -> [String] -> IO String+repoquery :: Maybe String -> [String] -> IO String repoquery relver args = do havednf <- optionalProgram "dnf" let (prog, subcmd) = if havednf then ("dnf", ["repoquery", "--quiet"]) else ("repoquery", [])- cmd prog (subcmd ++ ["--releasever=" ++ relver] ++ args)+ releasever = case relver of+ Nothing -> []+ Just rv -> ["--releasever=" ++ rv]+ cmd prog (subcmd ++ releasever ++ args) -repoquerySrc :: Dist -> String -> String -> IO (Maybe String)-repoquerySrc dist relver key = do+repoquerySrc :: Dist -> String -> IO (Maybe String)+repoquerySrc dist key = do havednf <- optionalProgram "dnf" let srcflag = if havednf then ["--qf=%{source_name}"] else ["--qf", "%{base_package_name}"]- res <- words <$> repoquery relver (srcflag ++ ["--repofrompath", "koji,http://kojipkgs.fedoraproject.org/repos" </> distTag dist </> "latest/x86_64/", "--whatprovides", key])+ relver = releaseVersion dist+ repo = if dist `elem` dists+ then ["--repo=koji-buildroot", "--repofrompath", "koji-buildroot,http://kojipkgs.fedoraproject.org/repos" </> distTag dist </> "latest/x86_64/"]+ else []+ res <- words <$> repoquery relver (srcflag ++ repo ++ ["--whatprovides", key]) return $ case res of [p] -> Just p ps | key `elem` ps -> Just key@@ -78,4 +88,59 @@ rpmspec :: [String] -> Maybe String -> FilePath -> IO String rpmspec args mqf spec = do let qf = maybe [] (\ q -> ["--queryformat", q]) mqf- cmd "rpmspec" (["-q"] ++ args ++ qf ++ [spec])+ cmd "rpmspec" (["-q"] ++ ["--define", "ghc_version any"] ++ args ++ qf ++ [spec])++buildRequires :: FilePath -> IO [String]+buildRequires spec =+ -- FIXME should resolve "pkgconfig()" etc+ map (head . words) . lines <$> rpmspec ["--buildrequires"] Nothing spec+-- >>= mapM (whatProvides relver)++type Package = String++derefSrcPkg :: FilePath -> Dist -> Bool -> Package -> IO Package+derefSrcPkg topdir dist verb pkg =+ if isHaskellDevelPkg pkg+ then+ do let lib = removeSuffix "-devel" pkg+ -- fixme: should check branch (dir)+ libExists <- doesDirectoryExist $ topdir </> lib+ if libExists+ then return lib+ else do+ -- todo: check bin has lib+ let bin = removePrefix "ghc-" lib+ binExists <- doesDirectoryExist $ topdir </> bin+ if binExists+ then return bin+ else derefSrcPkg topdir dist verb lib+ else+ do putStrLn $ "Repoquerying" +-+ pkg+ res <- repoquerySrc dist pkg+ case res of+ Nothing ->+ do putStrLn $ "Unknown package" +-+ removeSuffix "-devel" pkg+ exitWith (ExitFailure 1)+ Just s -> do+ when (pkg /= s && verb) $ putStrLn $ pkg +-+ "->" +-+ s+ return s++isHaskellDevelPkg :: Package -> Bool+isHaskellDevelPkg pkg = "ghc-" `isPrefixOf` pkg && ("-devel" `isSuffixOf` pkg) || pkg `elem`haskellTools++haskellTools :: [Package]+haskellTools = ["alex", "cabal-install", "gtk2hs-buildtools", "happy"]++haskellSrcPkgs :: FilePath -> String -> [Package] -> IO [Package]+haskellSrcPkgs topdir dist brs = do+ ghcLibs <- do+ let branch = distBranch dist+ ghcDir <- pkgDir "ghc" branch topdir+ filter isHaskellDevelPkg . words <$> rpmspec [] (Just "%{name}\n") (ghcDir </> "ghc.spec")+ let hdeps = filter (\ dp -> "ghc-" `isPrefixOf` dp || dp `elem` haskellTools) (brs \\ (["ghc-rpm-macros", "ghc-rpm-macros-extra"] ++ ghcLibs))+ nub <$> mapM (derefSrcPkg topdir dist False) hdeps++pkgDir :: String -> String -> FilePath -> IO FilePath+pkgDir dir branch top = do+ b <- doesDirectoryExist $ top </> dir </> branch+ return $ top </> dir </> if b then branch else ""
TODO view
@@ -1,18 +1,40 @@-Porting haskell-sig.git scripts:+split into separate packages or merge?? -use pkgdb-cli + cabal-sort for --all packages+# fhpkg+- use optparse-applicative+- only print header if output +(from fhpkg.hs):+- cache dist package lists?+- push subpackages to Hackage+- compare branch versions+- compare with LTS+- query-format string+ deps query tool -Parallelize+Parallelize builds +--from (--continue) eg when conflict stops fhpkg++allow master instead of rawhide++(`fhpkg clone -B branch pkg` doesn't really make sense)++check commands has all commands++count: option to query without updates++bodhi testing query?++# support chain-build+ # git - branch merging+* merge a/next koji build - build new packages across branches -# command options - debug output-- dist option (assume rawhide) # Building: rebuild* - recursive building for koji and mock@@ -28,9 +50,6 @@ - --liberal (allow failures) - reconnect to koji when disconnected (build or wait-repo) -# updating-- port update-pkg-ver- # checking - Fedora x < Fedora x+1 - git out of sync with koji, updates@@ -49,3 +68,4 @@ - include version checks # package ordering (sorting)+- use rpmbuild-order
Utils.hs view
@@ -13,16 +13,22 @@ -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. -module Utils (checkFedoraPkgGit,+module Utils (checkPkgsGit, cmd, cmd_, cmdBool,+ cmdFragile,+ cmdFragile_, cmdlog, cmdMaybe, cmdN, cmdSilent, cmdStdErr, error_,+ git,+ git_,+ gitBranch,+ grep, logMsg, maybeRemovePrefix, removePrefix,@@ -36,10 +42,12 @@ #else import Control.Applicative ((<$>)) #endif-import Control.Monad (void)-import Data.List (stripPrefix)+import Control.Concurrent (threadDelay)+import Control.Monad (unless, void, when)+import Data.List (isPrefixOf, stripPrefix) import Data.Maybe (fromMaybe) import System.Exit (ExitCode (..))+import System.IO (hPutStrLn, stderr) import System.Process (readProcess, readProcessWithExitCode, rawSystem) #if (defined(MIN_VERSION_directory) && MIN_VERSION_directory(1,2,3))@@ -84,6 +92,13 @@ (_ret, out, err) <- readProcessWithExitCode c as "" return (removeTrailingNewline out, removeTrailingNewline err) +-- cmdBoolStd :: String -> [String] -> IO (Bool, String)+-- cmdBoolStd c as = do+-- (ret, out, err) <- readProcessWithExitCode c as ""+-- case ret of+-- ExitSuccess -> return (True, out)+-- ExitFailure n -> hPutStrLn stderr ("\"" ++ c +-+ unwords as ++ "\"" +-+ "failed with status" +-+ show n ++ "\n" ++ err) >> return (False, out)+ cmdStdIn_ :: String -> [String] -> String -> IO () cmdStdIn_ c as inp = void $ cmdStdIn c as inp @@ -94,6 +109,29 @@ ExitSuccess -> return () ExitFailure n -> error $ "\"" ++ c +-+ unwords as ++ "\" failed with exit code" +-+ show n +cmdFragile :: String -> [String] -> IO String+cmdFragile c as = do+ (ret, out, err) <- readProcessWithExitCode c as ""+ case ret of+ ExitSuccess -> return out+ ExitFailure n -> do+ unless (null out) $ putStrLn out+ when (null (out ++ err)) $+ hPutStrLn stderr $ "\"" ++ c +-+ unwords as ++ "\"" +-+ "failed with status" +-+ show n+ unless (null err) $ hPutStrLn stderr err+ threadDelay 2000000+ cmdFragile c as++cmdFragile_ :: String -> [String] -> IO ()+cmdFragile_ c as = do+ ret <- rawSystem c as+ case ret of+ ExitSuccess -> return ()+ ExitFailure _ -> do+ hPutStrLn stderr $ "retrying \"" ++ c +-+ unwords as ++ "\""+ threadDelay 2000000+ cmdFragile_ c as+ -- dry-run cmdN :: String -> [String] -> IO () cmdN c as = putStrLn $ c +-+ unwords as@@ -128,11 +166,11 @@ -- hide stdout cmdSilent :: String -> [String] -> IO ()-cmdSilent c args = do- (ret, _, err) <- readProcessWithExitCode c args ""+cmdSilent c as = do+ (ret, _, err) <- readProcessWithExitCode c as "" case ret of ExitSuccess -> return ()- ExitFailure n -> error $ "\"" ++ c +-+ unwords args ++ "\"" +-+ "failed with status" +-+ show n ++ "\n" ++ err+ ExitFailure n -> error $ "\"" ++ c +-+ unwords as ++ "\"" +-+ "failed with status" +-+ show n ++ "\n" ++ err sudo :: String -> [String] -> IO () sudo c as = cmdlog "sudo" (c:as)@@ -170,6 +208,23 @@ action #endif -checkFedoraPkgGit :: IO Bool-checkFedoraPkgGit =- cmdBool "grep" ["-q", "-e", "\\(pkgs\\|src\\).fedoraproject.org", ".git/config"]+checkPkgsGit :: IO Bool+checkPkgsGit =+ grep "\\(pkgs\\|src\\)." ".git/config"++git :: String -> [String] -> IO String+git c as =+ cmd "git" ("--no-pager":c:as)++git_ :: String -> [String] -> IO ()+git_ c as =+ cmd_ "git" ("--no-pager":c:as)++gitBranch :: IO String+gitBranch =+ removePrefix "* " . head . filter (isPrefixOf "* ") . lines <$> cmd "git" ["branch"]++grep :: String -> FilePath -> IO Bool+grep pat file =+ cmdBool "grep" ["-q", pat, file]+
fedora-haskell-tools.cabal view
@@ -1,6 +1,6 @@ Name: fedora-haskell-tools-Version: 0.5.1-Synopsis: Building and managing tools for Fedora Haskell+Version: 0.6+Synopsis: Building and maintenance tools for Fedora Haskell Description: Tools for building and managing Fedora Haskell packages. Homepage: https://github.com/fedora-haskell/fedora-haskell-tools@@ -25,11 +25,9 @@ directory, filepath, process,+ time < 1.9, unix- Other-modules: Dists,- Koji,- RPM,- Utils+ Other-modules: Dists, Koji, RPM, Utils GHC-options: -fwarn-missing-signatures -Wall Extensions: CPP @@ -37,17 +35,22 @@ Main-is: fhbz.hs Build-depends: base < 5, time- Other-modules: Utils+ Other-modules: Dists, Koji, RPM, Utils GHC-options: -fwarn-missing-signatures -Wall Extensions: CPP Executable fhpkg Main-is: fhpkg.hs Build-depends: base < 5,+ csv, directory, filepath,+ HTTP, process,+ time < 1.9, unix+ if impl(ghc<8.0)+ Build-depends: semigroups Other-modules: Dists, Koji, RPM,
fhbuild.hs view
@@ -18,9 +18,9 @@ #else import Control.Applicative ((<$>)) #endif-import Control.Monad (filterM, unless, when)+import Control.Monad (filterM, unless, void, when) import Data.Maybe-import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, (\\))+import Data.List (intercalate, isPrefixOf, nub) import System.Directory (doesDirectoryExist, doesFileExist, getCurrentDirectory, setCurrentDirectory)@@ -29,25 +29,26 @@ import System.FilePath ((</>), dropExtension) import System.IO (hPutStrLn, stderr) -import Dists (Dist, dists, distBranch, distOverride, distTag, distTarget,- releaseVersion)+import Dists (Dist, dists, distBranch, distOverride, distTag, rpmDistTag) import Koji (kojiBuilding, kojiCheckFHBuilt, kojiLatestPkg, kojiWaitPkg,- notInKoji, pkgDir)-import RPM (packageManager, rpmInstall, repoquerySrc, rpmspec)-import Utils ((+-+), checkFedoraPkgGit, cmd, cmd_, cmdBool, cmdMaybe, cmdlog,- logMsg, removePrefix, removeSuffix, sudo)+ notInKoji, rpkg, rpkgBuild)+import RPM (buildRequires, derefSrcPkg, haskellSrcPkgs, Package,+ packageManager, pkgDir, rpmInstall, rpmspec)+import Utils ((+-+), checkPkgsGit, cmd, cmd_, cmdBool, cmdMaybe, cmdlog,+ git_, gitBranch, grep, removePrefix, removeSuffix, sudo) data Command = Install | Mock | Koji | Chain | Pending | Changed | Built | Bump deriving (Eq) main :: IO () main = do- margs <- getArgs >>= parseArgs- case margs of- Nothing -> return ()- Just (com, dist, pkgs) -> do+ args <- getArgs+ case args of+ (c:d:ps) -> do+ (com, dist, pkgs) <- parseArgs c d ps cwd <- getCurrentDirectory build cwd (mode com) dist Nothing Nothing False pkgs+ _ -> help where mode "install" = Install mode "mock" = Mock@@ -79,19 +80,13 @@ ++ " bump\t\t- bump release for NVRs already built\n" exitWith (ExitFailure 1) -type Arguments = Maybe (String, Dist, [String])--parseArgs :: [String] -> IO Arguments-parseArgs (c:dist:pkgs) | dist `notElem` dists = giveUp $ "Unknown dist '" ++ dist ++ "'"- | null pkgs = giveUp "Please specify a package."- | otherwise =- return $ Just (c, dist, map (removeSuffix "/") pkgs)-parseArgs _ = help >> return Nothing+type Arguments = (String, Dist, [String]) -giveUp :: String -> IO Arguments-giveUp err = do- hPutStrLn stderr err- return Nothing+parseArgs :: String -> String -> [String] -> IO Arguments+parseArgs c dist pkgs | dist `notElem` dists && not ("rhel-" `isPrefixOf` dist) = error $ "Unknown dist '" ++ dist ++ "'"+ | null pkgs = error "Please specify a package."+ | otherwise =+ return (c, dist, map (removeSuffix "/") pkgs) build :: FilePath -> Command -> Dist -> Maybe String -> Maybe (String, String) -> Bool -> [String] -> IO () build _ _ _ _ _ _ [] = return ()@@ -103,7 +98,7 @@ dirExists <- doesDirectoryExist pkg unless dirExists $ do let anon = ["-a" | mode `notElem` [Koji, Chain]]- cmdlog "fedpkg" $ ["clone", "-b", branch, pkg] ++ anon+ cmdlog (rpkg (Just dist)) $ ["clone", "-b", branch, pkg] ++ anon wd <- pkgDir pkg branch "" setCurrentDirectory wd ignore <- doesFileExist ".fhbuild-ignore"@@ -121,7 +116,7 @@ else do pkggit <- do gd <- doesFileExist ".git/config"- if gd then checkFedoraPkgGit+ if gd then checkPkgsGit else return False if not pkggit then if mode `elem` [Install, Koji, Chain]@@ -131,8 +126,8 @@ when dirExists $ do actual <- gitBranch when (branch /= actual) $- cmd_ "fedpkg" ["switch-branch", branch]- cmd_ "git" ["pull", "-q"]+ cmd_ (rpkg (Just dist)) ["switch-branch", branch]+ git_ "pull" ["-q"] -- noupdate <- doesFileExist ".noupdate" -- unless noupdate $ -- void $ cmdBool "cabal-rpm" ["update"]@@ -141,11 +136,9 @@ if not hasSpec then putStrLn $ "No" +-+ spec else do- nvr <- cmd "fedpkg" ["verrel"]+ nvr <- cmd (rpkg (Just dist)) ["verrel"] let verrel = removePrefix (pkg ++ "-") nvr- release = tail $ dropWhile (/= '-') verrel tag = distTag dist- relver = releaseVersion dist case mode of Install -> do let req = fromMaybe pkg msubpkg@@ -154,12 +147,12 @@ then putStrLn $ nvr +-+ "already installed!\n" else do putStrLn $ fromMaybe "Not installed" installed +-+ "->" +-+ nvr- cmd_ "git" ["--no-pager", "log", "-1"]+ git_ "log" ["-1"] putStrLn "" missing <- nub <$> (buildRequires spec >>= filterM notInstalled) -- FIXME sort into build order let hmissing = filter (\ dp -> "ghc-" `isPrefixOf` dp || dp `elem` ["alex", "cabal-install", "gtk2hs-buildtools", "happy"]) missing- srcs <- nub <$> mapM (derefSrcPkg topdir dist relver) hmissing+ srcs <- nub <$> mapM (derefSrcPkg topdir dist True) hmissing unless (null srcs) $ do putStrLn "Missing:" mapM_ putStrLn srcs@@ -172,39 +165,42 @@ putStrLn "" putStrLn $ "Building" +-+ nvr -- note "fedpkg --path dir local" saves .build.log in cwd- success <- cmdBool "fedpkg" ["local"]- unless success- fhbuildFail- opkgs <- lines <$> rpmspec ["--builtrpms"] (Just "%{name}\n") spec- rpms <- lines <$> rpmspec ["--builtrpms"] (Just ("%{arch}/%{name}-%{version}-" ++ release ++ ".%{arch}.rpm\n")) spec- putStrLn $ nvr +-+ "built\n"- instpkgs <- lines <$> cmd "rpm" ("-qa":opkgs)- if null instpkgs- -- maybe filter out pandoc-pdf if not installed- then rpmInstall rpms+ success <- cmdBool (rpkg (Just dist)) ["local"]+ if not success+ then do+ waitForEnter+ build topdir Install dist Nothing Nothing False [pkg] else do- pkgmgr <- packageManager- -- sudo pkgmgr ("--setopt=clean_requirements_on_remove=no":"remove":"-y":instpkgs)- sudo pkgmgr ("install":"-y":rpms)- setCurrentDirectory topdir+ opkgs <- lines <$> rpmspec ["--builtrpms"] (Just "%{name}\n") spec+ rpms <- lines <$> rpmspec ["--builtrpms", "--define=dist" +-+ rpmDistTag dist] (Just "%{arch}/%{name}-%{version}-%{release}.%{arch}.rpm\n") spec+ putStrLn $ nvr +-+ "built\n"+ instpkgs <- lines <$> cmd "rpm" ("-qa":opkgs)+ if null instpkgs+ -- maybe filter out pandoc-pdf if not installed+ then rpmInstall rpms+ else do+ pkgmgr <- packageManager+ sudo pkgmgr ("--setopt=clean_requirements_on_remove=no":"remove":"-y":instpkgs)+ sudo pkgmgr ("install":"-y":rpms)+ putStrLn ""+ putStrLn $ show (length rest) +-+ "packages left" build topdir Install dist Nothing Nothing False rest Mock -> do putStrLn $ "Mock building" +-+ nvr- cmdlog "fedpkg" ["mockbuild"]+ cmdlog (rpkg (Just dist)) ["mockbuild"] build topdir Mock dist Nothing Nothing False rest Koji -> do- putStrLn "'koji' mode is deprecated, please use 'chain'" unless (null rest) $ do putStrLn $ show (length rest) +-+ "more packages" putStrLn "" latest <- kojiLatestPkg tag pkg- if nvr == latest+ if Just nvr == latest then do putStrLn $ nvr +-+ "already built!" kojiWaitPkg topdir tag nvr build topdir Koji dist Nothing mlast False rest else do- building <- kojiBuilding pkg nvr+ building <- kojiBuilding pkg nvr dist if building then do putStrLn $ nvr +-+ "is already building"@@ -218,9 +214,10 @@ when dep $ do putStrLn $ "Waiting for" +-+ nvr' kojiWaitPkg topdir tag nvr'- showChange latest nvr- cmd_ "git" ["push"]- fedpkgBuild topdir dist nvr (if waitrepo then Just tag else Nothing)+ showChange pkg latest nvr+ putStrLn ""+ git_ "push" []+ rpkgBuild topdir dist nvr (if waitrepo then Just tag else Nothing) bodhiOverride dist nvr unless (null rest) $ do dep <- dependent pkg (head rest) branch topdir@@ -231,7 +228,7 @@ Pending -> do latest <- kojiLatestPkg tag pkg unless (eqNVR nvr latest) $- putStrLn $ latest +-+ "->" +-+ nvr+ showNVRChange pkg latest nvr build topdir Pending dist Nothing Nothing False rest Changed -> do latest <- kojiLatestPkg tag pkg@@ -248,21 +245,21 @@ when (eqNVR nvr latest) $ do putStrLn pkg cmd_ "rpmdev-bumpspec" ["-c", "rebuild", spec]- cmd_ "fedpkg" ["commit", "-m", "bump release"]+ cmd_ (rpkg (Just dist)) ["commit", "-m", "bump release"] build topdir Bump dist Nothing Nothing False rest Chain -> do fhbuilt <- kojiCheckFHBuilt topdir nvr latest <- if fhbuilt- then return nvr+ then return $ Just nvr else kojiLatestPkg tag pkg- if nvr == latest+ if Just nvr == latest then do putStrLn $ nvr +-+ "already built!" unless (null rest) $ --do --kojiWaitPkg topdir tag nvr build topdir Chain dist Nothing Nothing False rest else do- building <- kojiBuilding pkg nvr+ building <- kojiBuilding pkg nvr dist if building then do putStrLn $ nvr +-+ "is already building"@@ -270,16 +267,9 @@ unless (null rest) $ build topdir Chain dist Nothing Nothing False rest else do- showChange latest nvr- brs <- buildRequires spec- --print brs- ghcLibs <- do- ghcDir <- pkgDir "ghc" branch topdir- filter isHaskellDevelPkg . words <$> rpmspec [] (Just "%{name}\n") (ghcDir </> "ghc.spec")- -- FIXME sort into build order- let hdeps = filter (\ dp -> "ghc-" `isPrefixOf` dp || dp `elem` ["alex", "cabal-install", "gtk2hs-buildtools", "happy"]) (brs \\ (["ghc-rpm-macros", "ghc-rpm-macros-extra"] ++ ghcLibs))- --print hdeps- srcs <- filter (`notElem` ["ghc"]) . nub <$> mapM (derefSrcPkg topdir dist relver) hdeps+ showChange pkg latest nvr+ putStrLn ""+ srcs <- buildRequires spec >>= haskellSrcPkgs topdir dist --print srcs hmissing <- nub <$> filterM (notInKoji branch topdir tag) srcs putStrLn ""@@ -290,9 +280,9 @@ setCurrentDirectory $ topdir </> wd putStrLn "" -- note "fedpkg --path dir local" saves .build.log in cwd- cmd_ "git" ["push"]+ git_ "push" [] putStrLn ""- fedpkgBuild topdir dist nvr (if waitrepo then Just tag else Nothing)+ rpkgBuild topdir dist nvr (if waitrepo then Just tag else Nothing) bodhiOverride dist nvr unless (null rest) $ do putStrLn ""@@ -306,20 +296,20 @@ notInstalled pkg = not <$> cmdBool "rpm" ["--quiet", "-q", pkg] -showChange :: String -> String -> IO ()-showChange latest nvr = do- cmd_ "git" ["--no-pager", "log", "-1"]+showChange :: Package -> Maybe String -> String -> IO ()+showChange pkg mlatest nvr = do+ git_ "log" ["-1"] putStrLn ""- putStrLn $ latest +-+ "->" +-+ nvr ++ "\n"+ showNVRChange pkg mlatest nvr -fedpkgBuild :: FilePath -> Dist -> String -> Maybe String -> IO ()-fedpkgBuild topdir dist nvr waittag = do- giturl <- cmd "fedpkg" ["giturl"]- success <- cmdBool "koji" ["build", "--fail-fast", distTarget dist, giturl]- unless success- fhbuildFail- logMsg $ nvr +-+ "built"- maybe (return ()) (\ t -> kojiWaitPkg topdir t nvr) waittag+showNVRChange :: Package -> Maybe String -> String -> IO ()+showNVRChange pkg Nothing nvr =+ putStrLn $ pkg +-+ "new" +-+ removePrefix (pkg ++ "-") nvr+showNVRChange pkg (Just latest) nvr = do+ putStrLn $ pkg ++ ":" +-+ removePrefix prefix latest+ putStrLn $ replicate (length pkg - 1) ' ' ++ "->" +-+ removePrefix prefix nvr+ where+ prefix = pkg ++ "-" bodhiOverride :: Dist -> String -> IO () bodhiOverride dist nvr =@@ -337,36 +327,9 @@ -- unless installed $ putStrLn $ "Warning:" +-+ pkg +-+ "not found by repoquery" -- return $ if null res then pkg else res -buildRequires :: FilePath -> IO [String]-buildRequires spec =- -- FIXME should resolve "pkgconfig()" etc- (map (head . words) . lines) <$> rpmspec ["--buildrequires"] Nothing spec--- >>= mapM (whatProvides relver)--derefSrcPkg :: FilePath -> Dist -> String -> String -> IO String-derefSrcPkg topdir dist relver pkg =- if isHaskellDevelPkg pkg- then- do let base = removeSuffix "-devel" pkg- dirExists <- doesDirectoryExist $ topdir </> base- if dirExists then return base else derefSrcPkg topdir dist relver base- else- do putStrLn $ "Repoquerying" +-+ pkg- res <- repoquerySrc dist relver pkg- putStrLn $ pkg +-+ "->" +-+ show res- case res of- Nothing ->- do putStrLn $ "Unknown package" +-+ removeSuffix "-devel" pkg- fhbuildFail- Just s -> return s--gitBranch :: IO String-gitBranch =- (removePrefix "* " . head . filter (isPrefixOf "* ") . lines) <$> cmd "git" ["branch"]--eqNVR :: String -> String -> Bool+eqNVR :: String -> Maybe String -> Bool eqNVR p1 p2 =- dropExtension p1 == dropExtension p2+ Just (dropExtension p1) == fmap dropExtension p2 -- "pkg = X.Y" -> ["pkg", "=", "X.Y"] -> ("pkg", Just "X.Y") processDeps :: [String] -> (String, Maybe String)@@ -377,7 +340,7 @@ dependent :: String -> String -> String -> FilePath -> IO Bool dependent dep pkg branch topdir = do pkgpath <- pkgDir pkg branch topdir- cmdBool "grep" ["-q", dep, pkgpath </> pkg ++ ".spec"]+ grep dep $ pkgpath </> pkg ++ ".spec" displayLogTail :: FilePath -> IO () displayLogTail f = do@@ -387,10 +350,9 @@ start = length ls - (disp + foot) mapM_ putStrLn $ take disp $ drop start ls -fhbuildFail :: IO a-fhbuildFail = --do- --cmdlog "touch" [".fhbuild-fail"]- exitWith (ExitFailure 1)--isHaskellDevelPkg :: String -> Bool-isHaskellDevelPkg pkg = "ghc-" `isPrefixOf` pkg && ("-devel" `isSuffixOf` pkg)+waitForEnter :: IO ()+waitForEnter = do+ putStrLn ""+ putChar '\a'+ putStrLn "Press Enter after fixing"+ void getLine
fhbz.hs view
@@ -30,6 +30,8 @@ getOpt, usageInfo) import System.FilePath ((</>)) +import Dists (rawhide)+import Koji (kojicmd) import Utils ((+-+), cmd, cmd_, cmdStdErr, removePrefix, removeSuffix) data BugState = BugState {@@ -43,6 +45,10 @@ data Flag = Close | Force | DryRun | NoComment | Refresh | State String deriving (Eq, Show) +isState :: Flag -> Bool+isState (State _) = True+isState _ = False+ options :: [OptDescr Flag] options = [ Option "f" ["force"] (NoArg Force) "update even if no version change (implies --refresh)"@@ -56,7 +62,7 @@ parseOpts :: [String] -> IO ([Flag], [String]) parseOpts argv = case getOpt Permute options argv of- (os,ps,[] ) -> return (os,ps)+ (os,ps,[]) -> return (os,ps) (_,_,errs) -> do prog <- getProgName error $ concat errs ++ usageInfo (header prog) options@@ -65,7 +71,7 @@ main :: IO () main = do (opts, args) <- getArgs >>= parseOpts- let state = fromMaybe "NEW" $ listToMaybe $ map (\ (State s) -> s) $ filter (\ o -> case o of (State _) -> True ; _ -> False) opts+ let state = fromMaybe "NEW" $ listToMaybe $ map (\ (State s) -> s) $ filter isState opts bugs <- parseLines . lines <$> bugzillaQuery (["--cc=haskell-devel@lists.fedoraproject.org", "--bug_status=" ++ state, "--short_desc=is available", "--outputformat=%{id}\n%{component}\n%{bug_status}\n%{summary}\n%{status_whiteboard}"] ++ if null args then [] else ["--component=" ++ intercalate "," args]) mapM_ (checkBug opts) bugs @@ -135,9 +141,9 @@ closeBug :: [Flag] -> String -> String -> String -> IO () closeBug opts bid bcomp pkgver = do- rawhide <- cmd "koji" ["latest-pkg", "rawhide", bcomp, "--quiet"]- unless (null rawhide) $ do- let nvr = (head . words) rawhide+ latest <- cmd (kojicmd rawhide) ["latest-pkg", "rawhide", bcomp, "--quiet"]+ unless (null latest) $ do+ let nvr = (head . words) latest let nv = removeRelease nvr when (nv == pkgver) $ do putStrLn $ "closing" +-+ bid ++ ":" +-+ nv +-+ "in rawhide"
fhpkg.hs view
@@ -12,158 +12,366 @@ -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. --- Todo:--- cache dist package lists?--- push subpackages to Hackage--- compare branch versions--- compare with LTS--- arbitrary command--- query-format string- module Main where #if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,8,2)) #else import Control.Applicative ((<$>)) #endif-import Control.Monad (unless, when)+import Control.Monad (filterM, unless, when)+import Data.Char (isUpper, toLower, toUpper) import Data.Maybe-import Data.List (isInfixOf, isPrefixOf, nub, sort, (\\))+import Data.List (find, isInfixOf, isPrefixOf, nub, partition, sort, (\\)) +import Network.HTTP (getRequest, getResponseBody, simpleHTTP) import System.Directory (doesDirectoryExist, doesFileExist,- getHomeDirectory, setCurrentDirectory)+ getCurrentDirectory, getHomeDirectory,+#if (defined(MIN_VERSION_directory) && MIN_VERSION_directory(1,2,5))+ listDirectory,+#else+ getDirectoryContents,+#endif+ setCurrentDirectory) import System.Environment (getArgs, getProgName) import System.Exit (ExitCode (..), exitWith)-import System.FilePath ((</>))-import System.IO (hPutStrLn, stderr)+import System.FilePath ((</>), takeFileName)+import System.IO (BufferMode(..), hPutStrLn, hSetBuffering, stderr,+ stdout) --import System.Posix.Env (getEnv)+import Text.CSV (parseCSV)+import Text.Read (readMaybe) -import Dists (Dist, dists, distBranch, hackageRelease, releaseVersion)-import Koji (kojiListPkgs)-import RPM (repoquery, rpmspec)-import Utils ((+-+), checkFedoraPkgGit, cmd, cmd_, cmdBool, cmdMaybe, cmdSilent,- maybeRemovePrefix, removePrefix, withCurrentDirectory)+import Dists (Dist, dists, distBranch, distRepo, distUpdates, hackageRelease,+ rawhide, releaseVersion)+import Koji (kojiListPkgs, rpkg)+import RPM (buildRequires, haskellSrcPkgs, Package, pkgDir,+ repoquery, rpmspec)+import Utils ((+-+), checkPkgsGit, cmd, cmd_, cmdBool, cmdMaybe, cmdSilent, grep,+ git, git_, gitBranch, maybeRemovePrefix, removePrefix, removeSuffix,+ withCurrentDirectory) +#if (defined(MIN_VERSION_directory) && MIN_VERSION_directory(1,2,5))+#else+listDirectory :: FilePath -> IO [FilePath]+listDirectory path =+ filter f <$> getDirectoryContents path+ where f filename = filename /= "." && filename /= ".."+#endif+ main :: IO () main = do- margs <- getArgs >>= parseArgs- case margs of+ as <- getArgs+ if null as+ then help ""+ else+ runCommand $ parseCmdArgs as++runCommand :: Arguments -> IO ()+runCommand (com, os, ps) = do+ let (global, opts) = partition (`elem` globalOpts) os+ allpkgs = OptNull 'A' `elem` global+ mdist = getOptVal (OptArg 'b' "brnch") global+ hSetBuffering stdout LineBuffering+ case mdist of Nothing -> return ()- Just (com, mdist, pkgs) ->+ Just d -> if d `elem` dists || "rhel" `isPrefixOf` d+ then return ()+ else putStrLn "Unknown branch"+ when (not allpkgs && null ps && com `notElem` [Hackage, HackageCompare, Count]) $+ help "Please specify package(s)"+ if allpkgs && (not . null) ps+ then error "Cannot have '-A' and list of packages"+ else do+ pkgs <- if allpkgs+ then repoqueryHaskell False mdist+ else return ps case com of- "list" -> withPackages mdist pkgs (mapM_ putStrLn)- "count" -> withPackages mdist pkgs (print . length)- "hackage" -> do- let currentHackage = Just hackageRelease- unless (isNothing mdist || mdist == currentHackage) $ error $ "Hackage is currently for" +-+ fromJust currentHackage ++ "!"- withPackages currentHackage pkgs (repoqueryHackageCSV currentHackage)- "clone" -> withPackages mdist pkgs $- repoAction_ True False mdist (return ())- "clone-new" -> do- new <- newPackages mdist- withPackages mdist new $ repoAction_ True False mdist (return ())- "pull" -> withPackages mdist pkgs $- repoAction_ True False mdist (cmd_ "git" ["pull", "--rebase"])- "push" -> withPackages mdist pkgs $- repoAction_ True False mdist (cmd_ "git" ["push"])- "diff" -> withPackages mdist pkgs $- repoAction_ False False mdist (cmd_ "git" ["--no-pager", "diff"])- "diff-origin" -> withPackages mdist pkgs $- repoAction_ True False mdist (cmd_ "git" ["--no-pager", "diff", "origin"])- "diff-branch" -> withPackages mdist pkgs $- repoAction False True mdist compareRawhide- "diff-stackage" -> withPackages mdist pkgs $- repoAction True True mdist compareStackage- "verrel" -> withPackages mdist pkgs $- repoAction_ False True mdist (cmd_ "fedpkg" ["verrel"])- "update" -> withPackages mdist pkgs $- repoAction True True mdist updatePackage- "refresh" -> withPackages mdist pkgs $- repoAction_ True True mdist (cmd_ "cabal-rpm" ["refresh"])- "prep" -> withPackages mdist pkgs $- repoAction_ True True mdist (cmd_ "fedpkg" ["prep"])- "commit" -> withPackages mdist pkgs $- -- need to handle passing commit message- repoAction_ True True mdist (commitChanges "")- "subpkgs" -> withPackages mdist pkgs $- repoAction True True mdist (\ p -> rpmspec [] (Just "%{name}-%{version}") (p ++ ".spec") >>= putStrLn)- "new" -> newPackages mdist >>= mapM_ putStrLn- _ -> return ()+ List -> mapM_ putStrLn pkgs+ Count -> repoqueryHaskell False mdist >>= (print . length)+ Hackage -> do+ -- add check for no pkg args+ checkHackageDist mdist+ repoqueryHackageCSV hackageRelease+ HackageCompare -> do+ checkHackageDist mdist+ withPackages (Just hackageRelease) pkgs $ compareHackage (null pkgs) hackageRelease+ New -> newPackages mdist >>= mapM_ putStrLn+ OldPackages -> do+ repopkgs <- repoqueryHaskell True mdist+ mapM_ putStrLn $ pkgs \\ repopkgs++ -- repo actions (header, needs-spec :: Bool)+ Checkout -> repoAction_ mdist global True False (return ()) pkgs+ Clone -> repoAction_ mdist global True False (return ()) pkgs+ CloneNew ->+ newPackages mdist >>= repoAction_ mdist global True False (return ())+ Commit -> repoAction_ mdist global True True (commitChanges mdist opts) pkgs+ Cmd -> repoAction_ mdist global True True (execCmd opts) pkgs+ Diff -> repoAction mdist global False False (gitDiff opts) pkgs+ DiffBranch -> repoAction mdist global False True compareRawhide pkgs+ DiffOrigin -> repoAction_ mdist global True False (git_ "diff" [maybe "origin" ("origin/" ++) mdist]) pkgs+ DiffStackage -> repoAction mdist global True True (compareStackage mdist) pkgs+ HeadOrigin -> repoAction mdist global False False (gitHeadAtOrigin mdist) pkgs+ Leaf -> repoAction mdist global (OptNull 'v' `elem` opts) True (checkLeafPkg opts) pkgs+ Merge -> repoAction_ mdist global True False (gitMerge opts) pkgs+ Missing -> repoAction mdist global True True (checkForMissingDeps mdist) pkgs+ Pull -> repoAction_ mdist global True False (git_ "pull" ["--rebase"]) pkgs+ Push -> repoAction_ mdist global True False (git_ "push" []) pkgs+ Prep -> repoAction_ mdist global True True (cmd_ (rpkg mdist) ["prep"]) pkgs+ Refresh -> repoAction mdist global True True (updateOrRefreshPackage True) pkgs+ Unpushed -> repoAction mdist global False True (gitLogOneLine mdist opts) pkgs+ Update -> repoAction mdist global True True (updateOrRefreshPackage False) pkgs+ Verrel -> repoAction_ mdist global False True (cmd_ (rpkg mdist) ["verrel"]) pkgs+ Subpkgs -> repoAction mdist global True True (\ p -> rpmspec [] (Just "%{name}-%{version}\n") (p ++ ".spec") >>= putStrLn) pkgs where+ checkHackageDist mdist =+ unless (isNothing mdist || mdist == Just hackageRelease) $ error $ "Hackage is currently for" +-+ hackageRelease ++ "!"+ withPackages :: Maybe Dist -> [Package] -> ([Package] -> IO ()) -> IO ()- withPackages mdist pkgs act =- (if null pkgs then repoqueryHaskell False mdist else return pkgs) >>= act+ withPackages mdst pkgs act =+ (if null pkgs then repoqueryHaskell False mdst else return pkgs) >>= act -commands :: [(String, String)]-commands = [("clone", "clone repos"),- ("clone-new", "clone new packages"),- ("count", "count number of packages"),- ("diff", "git diff"),- ("diff-origin", "git diff origin"),- ("diff-branch","compare branch with master"),- ("diff-stackage","compare with stackage"),- ("hackage", "generate Hackage distro data"),- ("list", "list packages"),- ("new", "new unbuilt packages"),- ("prep", "fedpkg prep"),- ("commit", "fedpkg commit"),- ("pull", "git pull repos"),- ("push", "git push repos"),- ("update", "cabal-rpm update"),- ("refresh", "cabal-rpm refresh"),- ("subpkgs", "list subpackages"),- ("verrel", "show nvr of packages")]+-- name, summary+data Command = Command { cmdName :: CmdName , cmdDescription :: String} -cmds :: [String]-cmds = map fst commands+data CmdName = Checkout | Clone | CloneNew | Cmd | Count+ | Diff | DiffOrigin | DiffBranch | DiffStackage+ | Hackage | HackageCompare | HeadOrigin+ | List | Merge | New | OldPackages | Prep | Commit | Pull | Push+ | Unpushed | Update | Refresh | Subpkgs | Missing | Leaf | Verrel+ deriving (Read, Show, Eq) -help :: IO ()-help = do- progName <- getProgName- hPutStrLn stderr $ "Usage:" +-+ progName +-+ "CMD [DIST]\n"- ++ "\n"- ++ "Commands:\n"- mapM_ (putStrLn . (\(c, desc) -> " " ++ c ++ replicate (mx - length c) ' ' +-+ "-" +-+ desc)) commands+-- SomeCommand -> "some-command"+showCmd :: CmdName -> String+showCmd c = render "" (show c) +-+ showCmdOpts c+ where+ render :: String -> String -> String+ render os "" = os+ render "" (i:is) = render [toLower i] is+ render os (i:is) = render (os ++ if isUpper i then "-" ++ [toLower i] else [i]) is++-- "some-command" -> SomeCommand+readCmd :: String -> CmdName+readCmd c = fromMaybe (error $ "Unknown command " ++ c) (readMaybe $ parse "" c)+ where+ parse :: String -> String -> String+ parse os "" = os+ parse "" (i:is) = parse [toUpper i] is+ parse os ('-':is) = parse (os ++ [toUpper $ head is]) (tail is)+ parse os (i:is) = parse (os ++ [i]) is++commands :: [Command]+commands = [ Command Checkout "fedpkg switch-branch"+ , Command Clone "clone repos"+ , Command CloneNew "clone new packages"+ , Command Cmd "arbitrary command (with args)"+ , Command Count "count number of packages"+ , Command Diff "git diff"+ , Command DiffOrigin "git diff origin"+ , Command DiffBranch "compare branch with master"+ , Command DiffStackage "compare with stackage"+ , Command Hackage "generate Hackage distro data"+ , Command HackageCompare "compare with Hackage distro data"+ , Command HeadOrigin "head in sync with origin"+ , Command Leaf "list leaf packages"+ , Command List "list packages"+ , Command Merge "git merge"+ , Command Missing "missing dependency source packages"+ , Command New "new unbuilt packages"+ , Command OldPackages "packages not in repoquery"+ , Command Prep "fedpkg prep"+ , Command Commit "fedpkg commit"+ , Command Pull "git pull repos"+ , Command Push "git push repos"+ , Command Unpushed "show unpushed commits"+ , Command Update "cabal-rpm update"+ , Command Refresh "cabal-rpm refresh"+ , Command Subpkgs "list subpackages"+ , Command Verrel "show nvr of packages"]++type CommandOptions = [(Option, Bool)]++-- True: mandatory+-- False: optional+cmdOpts :: CmdName -> CommandOptions+cmdOpts Commit = [(OptArg 'm' "\"COMMITMSG\"", True)]+cmdOpts Diff = [(OptArg 'w' "BRANCH", False),+ (OptNull 's', False)]+cmdOpts Merge = [(OptArg 'f' "BRANCH", True)]+cmdOpts Cmd = [(OptLong "cmd" "\"command\"", True)]+cmdOpts Leaf = [(OptNull 'v', False)]+cmdOpts Unpushed = [(OptNull 's', False)]+cmdOpts _ = []++globalOptsDesc :: [(Option, String)]+globalOptsDesc =+ [ (OptNull 'A', "all Fedora Haskell packages")+ , (OptNull 'B', "clone branch dirs (fedpkg clone -B)")+ , (OptArg 'b' "BRANCH", "branch to use (fedpkg -b)")+ ]++globalOpts :: [Option]+globalOpts = map fst globalOptsDesc++help :: String -> IO a+help err = do+ if null err+ then do+ progName <- getProgName+ putStrLn $ "Usage:" +-+ progName +-+ "CMD" +-+ showOpts globalOptsNotAll +-+ "PKG..."+ putStrLn $ " " +-+ progName +-+ "CMD -A \n"+ putStrLn "Global options:"+ mapM_ (putStrLn . describeOpt) globalOptsDesc+ putStrLn ""+ putStrLn "Commands:"+ mapM_ renderCmd commands+ else hPutStrLn stderr err exitWith (ExitFailure 1) where- mx = maximum $ map length cmds+ globalOptsNotAll = filter (/= OptNull 'A') globalOpts+ cmds :: [CmdName]+ cmds = map cmdName commands+ mx = maximum $ map (length . showCmd) cmds+ renderCmd :: Command -> IO ()+ renderCmd (Command c desc) = do+ let txt = showCmd c+ putStrLn $ " " ++ txt ++ replicate (mx - length txt) ' ' +-+ "-" +-+ desc -type Package = String+-- add description+data Option = OptNull Char | OptArg Char String | OptLong String String -type Arguments = Maybe (String, Maybe Dist, [Package])+instance Eq Option+ where+ OptNull c == OptNull c' = c == c'+ OptArg c _ == OptArg c' _ = c == c'+ OptLong s _ == OptLong s' _ = s == s'+ _ == _ = False -parseArgs :: [String] -> IO Arguments-parseArgs [c] =- if c `elem` cmds- then return (Just (c, Nothing, []))- else giveUp $ "No such command '" ++ c ++ "'"-parseArgs (c:dist:pkgs) | c `notElem` cmds =- giveUp $ "No such command '" ++ c ++ "'"- | dist `notElem` dists =- return $ Just (c, Nothing, dist:pkgs)- | otherwise =- return $ Just (c, Just dist, pkgs)-parseArgs _ = help >> return Nothing+hasOptNull :: Char -> [Option] -> Bool+hasOptNull c opts = OptNull c `elem` opts -giveUp :: String -> IO Arguments-giveUp err = do- hPutStrLn stderr err- help >> return Nothing+getOptVal :: Option -> [Option] -> Maybe String+getOptVal (OptNull _) _ = Nothing+getOptVal opt opts = maybe Nothing mval optval+ where+ optval = find (== opt) opts+ mval (OptNull _) = Nothing+ mval (OptArg _ v) = Just v+ mval (OptLong _ v) = Just v +--isNull :: Option -> Bool+--isNull (OptNull _) = True+--isNull _ = False -kojiListHaskell :: Bool -> Maybe Dist -> IO [Package]-kojiListHaskell verbose mdist = do- when verbose $ putStrLn "Getting package list from Koji"- libs <- filter (\ p -> "ghc-" `isPrefixOf` p && p `notElem` ["ghc-rpm-macros", "ghc-srpm-macros"]) <$> kojiListPkgs (fromMaybe "rawhide" mdist)- when (null libs) $ error "No library packages found"- return $ sort $ nub libs+instance Show Option+ where+ show (OptNull c) = "-" ++ [c]+ show (OptArg c v) = "-" ++ [c] ++ ('=':v)+ show (OptLong s v) = "--" ++ s ++ ('=':v) -repoqueryHackageCSV :: Maybe Dist -> [Package] -> IO ()-repoqueryHackageCSV mdist pkgs = do- let relver = maybe "rawhide" releaseVersion mdist+showOpts :: [Option] -> String+showOpts = unwords . map (\ s -> "[" ++ show s ++ "]")++showCmdOpts :: CmdName -> String+showCmdOpts = unwords . map+ (\ (s,o) -> if o then show s else "[" ++ show s ++ "]") . cmdOpts++describeOpt :: (Option, String) -> String+describeOpt (opt, desc) =+ " " ++ show opt ++ ":" +-+ desc++type Arguments = (CmdName, [Option], [Package])++-- FIXME: should check mandatory opts present+parseCmdArgs :: [String] -> Arguments+parseCmdArgs [] = error "Need to pass more arguments" -- should not happen+parseCmdArgs as =+ let (os, args) = partition isFlag as in+ if null args+ then error "Please give an command"+ else+ let (cstr:rest) = args+ c = readCmd cstr+ opts =+ let res = map parseOpt os in+ if all (`elem` globalOpts ++ map fst (cmdOpts c)) res then res+ else error "invalid option"+ pkgs = map (removeSuffix "/") rest+ in if hasOptNull 'A' opts && (not . null) pkgs+ then error "Can't give packages with -A"+ else (c, opts, pkgs)+ where+ isFlag ['-', c] | c /= '-' = True+ isFlag ('-':c:'=':_) | c /= '-' = True+ isFlag ('-':'-':_) = True+ isFlag _ = False++ parseOpt :: String -> Option+ parseOpt [] = error "Empty option"+ parseOpt ['-',l] = OptNull l+ parseOpt ('-':l:'=':val) = OptArg l val+ parseOpt ('-':'-':assgn)+ | '=' `elem` assgn =+ let (n,v) = break (== '=') assgn+ in if null n || null v then error "malformed long option"+ else OptLong n (tail v)+ parseOpt ls = error $ "Cannot parse option:" +-+ ls++repoqueryHackageCSV :: Dist -> IO ()+repoqueryHackageCSV dist = do+ pkgs <- repoqueryHaskell False (Just dist)+ let relver = releaseVersion dist -- Hackage csv chokes on final newline so remove it- init . unlines . sort . map (replace "\"ghc-" "\"") . lines <$> repoquery relver (["--disablerepo=*", "--enablerepo=fedora", "--enablerepo=updates", "--latest-limit=1", "--qf=\"%{name}\",\"%{version}\",\"https://src.fedoraproject.org/rpms/%{name}\""] ++ pkgs) >>= putStr+ init . unlines . sort . map (replace "\"ghc-" "\"") . lines <$> repoquery relver (["--repo=fedora", "--repo=updates", "--latest-limit=1", "--qf=\"%{name}\",\"%{version}\",\"https://src.fedoraproject.org/rpms/%{name}\""] ++ pkgs) >>= putStr +data PkgVer = PV { pvPkg :: String, pvVer :: String}+ deriving (Eq)++instance Show PkgVer+ where+ show (PV p v) = p ++ "-" ++ v++instance Ord PkgVer+ where+ compare (PV p _) (PV p' _) = compare p p'++compareHackage :: Bool -> Dist -> [Package] -> IO ()+compareHackage all' dist pkgs = do+ hck <- simpleHTTP (getRequest "http://hackage.haskell.org/distro/Fedora/packages.csv") >>= getResponseBody+ let hackage = sort . either (error "Malformed Hackage csv") (map mungeHackage) $ parseCSV "packages.csv" hck+ relver = releaseVersion dist+ fedora <- sort . map mungeRepo . lines <$> repoquery relver (["--repo=fedora", "--repo=updates", "--latest-limit=1", "--qf=%{name},%{version}"] ++ pkgs)+ compareSets all' hackage fedora+ where+ mungeHackage :: [String] -> PkgVer+ mungeHackage [_,v,u] = PV (takeFileName u) v+ mungeHackage _ = error "Malformed Hackage csv"++ mungeRepo :: String -> PkgVer+ mungeRepo s | ',' `elem` s =+ let (p,v) = break (== ',') s in+ PV p (tail v)+ | otherwise = error "Malformed repoquery output"++compareSets :: Bool -> [PkgVer] -> [PkgVer] -> IO ()+compareSets _ [] [] = return ()+compareSets _ [] (f:fs) = do+ putStrLn ("New:" +-+ show f)+ compareSets False [] fs+compareSets all' (h:hs) [] = do+ when all' $ putStrLn ("Removed:" +-+ show h)+ compareSets all' hs []+compareSets all' (h:hs) (f:fs) | h == f = compareSets all' hs fs+ | h < f = do+ when all' $ putStrLn $ "Removed:" +-+ show h+ compareSets all' hs (f:fs)+ | h > f = do+ putStrLn $ "New:" +-+ show f+ compareSets all' (h:hs) fs+ | otherwise = do+ putStrLn $ pvPkg h ++ ":" +-+ pvVer h +-+ "->" +-+ pvVer f+ compareSets all' hs fs+ replace :: Eq a => [a] -> [a] -> [a] -> [a] replace a b s@(x:xs) = if a `isPrefixOf` s@@ -173,10 +381,11 @@ repoqueryHaskell :: Bool -> Maybe Dist -> IO [Package] repoqueryHaskell verbose mdist = do- -- fixme: should use repoquery instead:- let relver = maybe "rawhide" releaseVersion mdist+ let relver = maybe Nothing releaseVersion mdist when verbose $ putStrLn "Getting packages from repoquery"- bin <- words <$> repoquery relver ["--qf=%{source_name}", "--whatrequires", "libHSbase-*-ghc*.so()(64bit)"]+ let repo = maybe "rawhide" distRepo mdist+ updates = maybeToList $ maybe Nothing distUpdates mdist+ bin <- words <$> repoquery relver (["--repo=" ++ repo] ++ ["--repo=" ++ u | u <- updates] ++ ["--qf=%{source_name}", "--whatrequires", "libHSbase-*-ghc*.so()(64bit)"]) when (null bin) $ error "No libHSbase consumers found!" return $ sort $ nub bin @@ -186,69 +395,68 @@ kps <- kojiListHaskell True mdist return $ kps \\ ps -repoAction :: Bool -> Bool -> Maybe Dist -> (Package -> IO ()) -> [Package] -> IO ()-repoAction _ _ _ _ [] = return ()-repoAction header needsSpec mdist action (pkg:rest) = do+kojiListHaskell :: Bool -> Maybe Dist -> IO [Package]+kojiListHaskell verbose mdist = do+ when verbose $ putStrLn "Getting package list from Koji"+ libs <- filter (\ p -> "ghc-" `isPrefixOf` p && p `notElem` ["ghc-rpm-macros", "ghc-srpm-macros"]) <$> kojiListPkgs (fromMaybe "rawhide" mdist)+ when (null libs) $ error "No library packages found"+ return $ sort $ nub libs++repoAction :: Maybe Dist -> [Option] -> Bool -> Bool -> (Package -> IO ()) -> [Package] -> IO ()+repoAction _ _ _ _ _ [] = return ()+repoAction mdist opts header needsSpec action (pkg:rest) = do withCurrentDirectory "." $ do let branchGiven = isJust mdist branch = maybe "master" distBranch mdist when header $ putStrLn $ "\n==" +-+ pkg ++ (if branchGiven then ":" ++ branch else "") +-+ "==" -- muser <- getEnv "USER"- -- let anon = "-a" home <- getHomeDirectory haveSSH <- doesFileExist $ home </> ".ssh/id_rsa" dirExists <- doesDirectoryExist pkg unless dirExists $- cmd_ "fedpkg" $ ["clone"] ++ ["-a" | not haveSSH] ++ (if branchGiven then ["-b", branch] else ["-B"]) ++ [pkg]+ cmd_ (rpkg mdist) $ ["clone"] ++ ["-a" | not haveSSH] ++ (if hasOptNull 'B' opts then ["-B"] else ["-b", branch]) ++ [pkg] singleDir <- doesFileExist $ pkg </> ".git/config" unless singleDir $ do branchDir <- doesDirectoryExist $ pkg </> branch unless branchDir $ withCurrentDirectory pkg $- cmd_ "fedpkg" ["clone", "-b", branch, pkg, branch]+ cmd_ (rpkg mdist) ["clone", "-b", branch, pkg, branch] wd <- pkgDir pkg branch "" setCurrentDirectory wd pkggit <- do gd <- doesFileExist ".git/config" if gd- then checkFedoraPkgGit+ then checkPkgsGit else return False unless pkggit $ error $ "not a Fedora pkg git dir!:" +-+ wd when dirExists $ do actual <- gitBranch when (branch /= actual) $- cmd_ "fedpkg" ["switch-branch", branch]- isDead <- doesFileExist "dead.package"- unless isDead $ do- let spec = pkg ++ ".spec"- hasSpec <- doesFileExist spec- unless hasSpec $ putStrLn "No spec file!"- unless (needsSpec && not hasSpec) $- action pkg- repoAction header needsSpec mdist action rest--repoAction_ :: Bool -> Bool -> Maybe Dist -> IO () -> [Package] -> IO ()-repoAction_ header needsSpec mdist action =- repoAction header needsSpec mdist (const action)--pkgDir :: String -> String -> FilePath -> IO FilePath-pkgDir dir branch top = do- b <- doesDirectoryExist $ top </> dir </> branch- return $ top </> dir </> if b then branch else ""+ cmd_ (rpkg mdist) ["switch-branch", branch]+ isDead <- doesFileExist "dead.package"+ unless isDead $ do+ let spec = pkg ++ ".spec"+ hasSpec <- doesFileExist spec+ -- FIXME: silence for cmds that only output package names (eg unpushed -s)+ unless hasSpec $ putStrLn $ (if header then "" else pkg ++ ": ") ++ "No spec file!"+ unless (needsSpec && not hasSpec) $+ action pkg+ repoAction mdist opts header needsSpec action rest -gitBranch :: IO String-gitBranch =- (removePrefix "* " . head . filter (isPrefixOf "* ") . lines) <$> cmd "git" ["branch"]+repoAction_ :: Maybe Dist -> [Option] -> Bool -> Bool -> IO () -> [Package] -> IO ()+repoAction_ mdist opts header needsSpec action =+ repoAction mdist opts header needsSpec (const action) -compareStackage :: Package -> IO ()-compareStackage p = do- nvr <- cmd "fedpkg" ["verrel"]- stkg <- cmdMaybe "stackage" ["package", "lts", maybeRemovePrefix "ghc-" p]+compareStackage :: Maybe Dist -> Package -> IO ()+compareStackage mdist p = do+ nvr <- cmd (rpkg mdist) ["verrel"]+ let stream = "lts-11"+ stkg <- cmdMaybe "stackage" ["package", stream, maybeRemovePrefix "ghc-" p] let same = isJust stkg && fromJust stkg `isInfixOf` nvr putStrLn $ removePrefix (p ++ "-") nvr +-+ "(fedora)"- putStrLn $ (if same then "same" else fromMaybe "none" stkg) +-+ "(lts)"+ putStrLn $ (if same then "same" else fromMaybe "none" stkg) +-+ "(" ++ stream ++ ")" compareRawhide :: Package -> IO ()@@ -268,16 +476,101 @@ where removeDisttag = reverse . tail . dropWhile (/= '.') . reverse -updatePackage :: Package -> IO ()-updatePackage pkg = do- hckg <- cmdBool "grep" ["-q", "hackage.haskell.org/package/", pkg ++ ".spec"]+isFromHackage :: Package -> IO Bool+isFromHackage pkg =+ grep "hackage.haskell.org/package/" $ pkg ++ ".spec"+++updateOrRefreshPackage :: Bool -> Package -> IO ()+updateOrRefreshPackage refresh pkg = do+ hckg <- isFromHackage pkg+ let mode = if refresh then "refresh" else "update" if hckg- then cmd_ "cabal-rpm" ["update"]+ then cmd_ "cabal-rpm" [mode] else putStrLn "skipping since not hackage" -commitChanges :: String -> IO ()-commitChanges msg = do+commitChanges :: Maybe Dist -> [Option] -> IO ()+commitChanges mdist [OptArg 'm' msg] = do chgs <- cmd "git" ["diff"] if null chgs then putStrLn "no changes"- else cmd_ "fedpkg" ["commit", "-m", msg]+ else cmd_ (rpkg mdist) ["commit", "-m", msg]+commitChanges _ _ = error "commit requires: -m=\"commit message\""++gitMerge :: [Option] -> IO ()+gitMerge [OptArg 'f' branch] = git_ "merge" [branch]+gitMerge _ = error "merge needs -f=BRANCH option"++gitDiff :: [Option] -> Package -> IO ()+gitDiff opts pkg = do+ let mbrnch = getOptVal (OptArg 'w' "branch") opts+ branch = maybeToList mbrnch+ short = hasOptNull 's' opts+ out <- git "diff" branch+ if short+ then unless (null out) $ putStrLn pkg+ else putStrLn out++execCmd :: [Option] -> IO ()+execCmd [OptLong "cmd" cs]+ | null cs = error "a string must be passed to --cmd="+ | otherwise = let (c:args) = words cs in+ cmd_ c args+execCmd _ = error "cmd needs --cmd= option"++checkForMissingDeps :: Maybe Dist -> Package -> IO ()+checkForMissingDeps mdist pkg = do+ dir <- takeFileName <$> getCurrentDirectory+ let top = if dir == pkg then ".." else "../.."+ dist = fromMaybe rawhide mdist+ spec = pkg ++ ".spec"+ hasSpec <- doesFileExist spec+ if hasSpec+ then do+ deps <- buildRequires (pkg ++ ".spec") >>= haskellSrcPkgs top dist+ mapM_ (checkMissing top) deps+ else putStrLn "no spec file found!"+ where+ checkMissing :: FilePath -> Package -> IO ()+ checkMissing top dep = do+ exists <- doesDirectoryExist $ top </> dep+ unless exists $ putStrLn $ "Missing" +-+ dep++-- fixme: make a dependency cache+checkLeafPkg :: [Option] -> Package -> IO ()+checkLeafPkg opts pkg = do+ dir <- takeFileName <$> getCurrentDirectory+ let branchdir = dir /= pkg+ top = if branchdir then "../.." else ".."+ spec = pkg ++ ".spec"+ subpkgs <- lines <$> rpmspec ["--builtrpms"] (Just "%{name}\n") spec+ allpkgs <- listDirectory top+ let other = map (\ p -> top </> p </> (if branchdir then dir else "") </> p ++ ".spec") $ allpkgs \\ [pkg]+ verb = hasOptNull 'v' opts+ found <- filterM (dependsOn subpkgs) other+ if null found+ then putStrLn pkg+ else when verb $ mapM_ putStrLn found+ where+ dependsOn :: [Package] -> Package -> IO Bool+ dependsOn subpkgs p = do+ file <- doesFileExist p+ if file+ then do+ deps <- buildRequires p+ return $ any (`elem` deps) subpkgs+ else return False++gitLogOneLine :: Maybe Dist -> [Option] -> Package -> IO ()+gitLogOneLine mdist opts pkg = do+ out <- git "log" [maybe "origin" ("origin/" ++) mdist ++ "..HEAD", "--pretty=oneline"]+ let short = hasOptNull 's' opts+ unless (null out) $+ putStrLn $ pkg ++ if short then "" else (unwords . map replaceHash . words) out+ where+ replaceHash h = if length h /= 40 then h else ":"++gitHeadAtOrigin :: Maybe Dist -> Package -> IO ()+gitHeadAtOrigin mdist pkg = do+ same <- cmdBool "git" ["diff", "--quiet", maybe "origin" ("origin/" ++) mdist ++ "..HEAD"]+ when same $ putStrLn pkg