diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -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 diff --git a/Dists.hs b/Dists.hs --- a/Dists.hs +++ b/Dists.hs @@ -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 diff --git a/Koji.hs b/Koji.hs --- a/Koji.hs +++ b/Koji.hs @@ -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] diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,6 +2,7 @@ [![Hackage](http://img.shields.io/hackage/v/fedora-haskell-tools.png)](http://hackage.haskell.org/package/fedora-haskell-tools) [![Stackage LTS](http://stackage.org/package/fedora-haskell-tools/badge/lts)](http://stackage.org/lts/package/fedora-haskell-tools) [![Stackage Nightly](http://stackage.org/package/fedora-haskell-tools/badge/nightly)](http://stackage.org/nightly/package/fedora-haskell-tools) +[![license](https://img.shields.io/badge/license-GPLv3+-brightgreen.svg)](https://www.gnu.org/licenses/gpl.html) # Fedora Haskell Tools diff --git a/RPM.hs b/RPM.hs --- a/RPM.hs +++ b/RPM.hs @@ -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 "" diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -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 diff --git a/Utils.hs b/Utils.hs --- a/Utils.hs +++ b/Utils.hs @@ -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] + diff --git a/fedora-haskell-tools.cabal b/fedora-haskell-tools.cabal --- a/fedora-haskell-tools.cabal +++ b/fedora-haskell-tools.cabal @@ -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, diff --git a/fhbuild.hs b/fhbuild.hs --- a/fhbuild.hs +++ b/fhbuild.hs @@ -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 diff --git a/fhbz.hs b/fhbz.hs --- a/fhbz.hs +++ b/fhbz.hs @@ -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" diff --git a/fhpkg.hs b/fhpkg.hs --- a/fhpkg.hs +++ b/fhpkg.hs @@ -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