diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,17 @@ +* 0.7 (2019-02-28) +- merge fhbuild into fhpkg (please delete fhbuild) +- use simple-cmd and fedora-dists +- fhpkg: + - now uses simple-cmd-args + - diff accepts -u or -s + - diff-stackage -m flag + - separate refresh and update with stream option + - cmd now uses shell + - new commands: not-installed, tagged, remaining +- fhbz: close is now default +- new fhmock program +- use Dist type + * 0.6 (2018-08-07) - fhpkg - new commands: hackage-compare, merge, missing, count, leaf, unpushed, head-origin diff --git a/Dists.hs b/Dists.hs deleted file mode 100644 --- a/Dists.hs +++ /dev/null @@ -1,91 +0,0 @@ --- | --- Module : Dists --- Copyright : (C) 2014-2017 Jens Petersen --- --- Maintainer : Jens Petersen --- Stability : alpha --- Portability : portable --- --- Explanation: Fedora dist metadata - --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. - -module Dists (Dist, - dists, - distBranch, - distShort, - distVersion, - distRepo, - distTag, - distTarget, - distUpdates, - distOverride, - hackageRelease, - releaseVersion, - rawhide, - rpmDistTag) where - -import Data.Char (isDigit) -import Data.Maybe (fromMaybe, maybe) - -import Utils ((+-+)) - -type Dist = String - -dists :: [Dist] -dists = [rawhide, "f28", "f27", "f26", "epel7"] - -rawhide :: String -rawhide = "f29" - -sidetag :: Dist -> Maybe String -sidetag "f29" = Just "ghc" -sidetag _ = Nothing - -hackageRelease :: String -hackageRelease = "f28" - -distBranch :: Dist -> String -distBranch d | d == rawhide = "master" - | otherwise = d - -splitDist :: Dist -> (String, String) -splitDist = break isDigit - -distShort :: Dist -> String -distShort = fst . splitDist - -distVersion :: Dist -> String -distVersion = snd . splitDist - -distRepo :: Dist -> String -distRepo d | d == rawhide = "rawhide" - | distShort d == "f" = "fedora" - | distShort d `elem` ["epel", "el"] = "epel" -distRepo d = error $ "Unknown dist" +-+ d - -distUpdates :: Dist -> Maybe String -distUpdates d | distShort d == "f" = Just "updates" -distUpdates _ = Nothing - -distOverride :: Dist -> Bool -distOverride d = d `notElem` [rawhide, "f29" , "epel8"] - -distTag :: Dist -> String -distTag d = d ++ "-" ++ fromMaybe "build" (sidetag d) - -distTarget :: Dist -> String -distTarget d = maybe d (\ suff -> d ++ "-" ++ suff) (sidetag d) - -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 deleted file mode 100644 --- a/Koji.hs +++ /dev/null @@ -1,110 +0,0 @@ --- | --- Module : Koji --- Copyright : (C) 2016-2017 Jens Petersen --- --- Maintainer : Jens Petersen --- Stability : alpha --- Portability : *nix --- --- Explanation: Koji commands - --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. - -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, when) -import Data.List (isInfixOf, isPrefixOf) -import Data.Time.Clock (diffUTCTime, getCurrentTime) -import System.FilePath (()) - -import Dists (Dist, distTarget) -import RPM (pkgDir) -import Utils (cmd, cmd_, cmdBool, cmdFragile, cmdFragile_, grep, logMsg, (+-+)) - -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 <$> 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 - 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" - grep nvr fhbuilt - -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 --- parseKojiTask [] = Nothing --- parseKojiTask (l:ls) | "Created task:" `isPrefixOf` l = Just $ removePrefix "Created task: " l --- | otherwise = parseKojiTask ls - -notInKoji :: String -> FilePath -> String -> String -> IO Bool -notInKoji branch topdir tag pkg = do - latest <- kojiLatestPkg tag pkg - pkgpath <- pkgDir pkg branch topdir - 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 (kojicmd dist) ["list-pkgs", "--tag=" ++ dist] - -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 @@ -6,32 +6,24 @@ # Fedora Haskell Tools -## fhbuild +## fhpkg +Git clones and pull, etc Fedora Haskell package repos. +Can also generate Hackage distro meta data. Builds set of packages locally or in Koji or Mock. +(fhbuild has been merged into fhpkg.) For local builds unbuilt dependent packages are also built recursive. For updates built in Koji, buildroot overrides are created and waited for. +Chain builds packages with wait-repo. +Also checks that updated dependencies have been built first. -Please be careful using this: eg for Rawhide this can easily cause -package builds to take place in Koji when packages haven't been built -yet for the latest disttag. +Please be careful when using the build commands: +eg for Rawhide this can easily cause package builds to take place in Koji +when packages haven't been built yet for the latest disttag. See TODO for more planned features. -## fhpkg -Git clones and pull, etc Fedora Haskell package repos. -Can also generate Hackage distro meta data. - -Unless you specify a branch it will use "fedpkg clone -B". -It doesn't do anonymous cloning (-a) yet. - -This replaces the scripts: -- https://pagure.io/haskell-sig-old/blob/master/f/bin/haskell-pkgs.sh -- https://pagure.io/haskell-sig-old/blob/master/f/packages/current-packages - - -fhpkg and fhbuild may eventually be merged. ## fhbz Update version update bugs in Bugzilla for Haskell packages. diff --git a/RPM.hs b/RPM.hs deleted file mode 100644 --- a/RPM.hs +++ /dev/null @@ -1,146 +0,0 @@ --- | --- Module : RPM --- Copyright : (C) 2015-2017 Jens Petersen --- --- Maintainer : Jens Petersen --- --- Explanation: RPM utils - --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. - -module RPM (buildRequires, - derefSrcPkg, - haskellSrcPkgs, - Package, - packageManager, - pkgDir, - repoquery, - rpmInstall, - rpmspec) where - -#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,8,2)) -#else -import Control.Applicative ((<$>)) -#endif -import Control.Monad (when) -import Data.List (isPrefixOf, isSuffixOf, nub, (\\)) -import Data.Maybe (isJust, isNothing) -import System.Directory (doesDirectoryExist, findExecutable) -import System.FilePath (()) --- die is available in ghc-7.10 base-4.8 -import System.Exit (ExitCode (..), exitFailure, exitWith) -import System.IO (hPutStrLn, stderr) - -import Dists (Dist, distBranch, dists, distTag, releaseVersion) -import Utils (cmd, removePrefix, removeSuffix, sudo, (+-+)) - --- @since base 4.8.0.0 -die :: String -> IO a -die err = hPutStrLn stderr err >> exitFailure - -requireProgram :: String -> IO () -requireProgram c = do - mavail <- findExecutable c - when (isNothing mavail) $ die (c ++ ": command not found") - -optionalProgram :: String -> IO Bool -optionalProgram c = isJust <$> findExecutable c - -packageManager :: IO String -packageManager = do - havednf <- optionalProgram "dnf" - if havednf - then return "dnf" - else requireProgram "yum" >> return "yum" - -rpmInstall :: [String] -> IO () -rpmInstall rpms = do - pkginstaller <- packageManager - let (inst, arg) = if pkginstaller == "dnf" then ("dnf", "install") else ("yum", "localinstall") - sudo inst $ ["-y", "--nogpgcheck", arg] ++ rpms - -repoquery :: Maybe String -> [String] -> IO String -repoquery relver args = do - havednf <- optionalProgram "dnf" - let (prog, subcmd) = if havednf then ("dnf", ["repoquery", "--quiet"]) else ("repoquery", []) - releasever = case relver of - Nothing -> [] - Just rv -> ["--releasever=" ++ rv] - cmd prog (subcmd ++ releasever ++ args) - -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}"] - 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 - _ -> Nothing - -rpmspec :: [String] -> Maybe String -> FilePath -> IO String -rpmspec args mqf spec = do - let qf = maybe [] (\ q -> ["--queryformat", q]) mqf - 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 @@ -3,6 +3,7 @@ # fhpkg - use optparse-applicative - only print header if output +- license-check command (from fhpkg.hs): - cache dist package lists? diff --git a/Utils.hs b/Utils.hs deleted file mode 100644 --- a/Utils.hs +++ /dev/null @@ -1,230 +0,0 @@ --- | --- Module : Cmd --- Copyright : (C) 2014 Jens Petersen --- --- Maintainer : Jens Petersen --- Stability : alpha --- Portability : *nix --- --- Explanation: system/shell command utils - --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. - -module Utils (checkPkgsGit, - cmd, - cmd_, - cmdBool, - cmdFragile, - cmdFragile_, - cmdlog, - cmdMaybe, - cmdN, - cmdSilent, - cmdStdErr, - error_, - git, - git_, - gitBranch, - grep, - logMsg, - maybeRemovePrefix, - removePrefix, - removeSuffix, - singleLine, - sudo, - withCurrentDirectory, - (+-+) ) where - -#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,8,2)) -#else -import Control.Applicative ((<$>)) -#endif -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)) -import System.Directory (withCurrentDirectory) -#else -import Control.Exception (bracket) -import System.Directory (getCurrentDirectory, setCurrentDirectory) -#endif - -infixr 4 +-+ -(+-+) :: String -> String -> String -"" +-+ s = s -s +-+ "" = s -s +-+ t = s ++ " " ++ t - -cmdStdIn :: String -> [String] -> String -> IO String -cmdStdIn c as inp = removeTrailingNewline <$> readProcess c as inp - -cmd :: String -> [String] -> IO String -cmd c as = cmdStdIn c as "" - -removeTrailingNewline :: String -> String -removeTrailingNewline "" = "" -removeTrailingNewline str = - if last str == '\n' - then init str - else str - -singleLine :: String -> String -singleLine "" = "" -singleLine s = (head . lines) s - -cmdMaybe :: String -> [String] -> IO (Maybe String) -cmdMaybe c as = do - (ret, out, _err) <- readProcessWithExitCode c as "" - case ret of - ExitSuccess -> return $ Just $ removeTrailingNewline out - ExitFailure _ -> return Nothing - -cmdStdErr :: String -> [String] -> IO (String, String) -cmdStdErr c as = do - (_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 - -cmd_ :: String -> [String] -> IO () -cmd_ c as = do - ret <- rawSystem c as - case ret of - 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 - ---cmdAssert :: String -> String -> [String] -> IO () ---cmdAssert msg c as = do --- ret <- rawSystem c as --- case ret of --- ExitSuccess -> return () --- ExitFailure _ -> error msg - -cmdlogStdIn :: String -> [String] -> String -> IO () -cmdlogStdIn c as inp = do - date <- cmd "date" ["+%T"] - putStrLn $ date +-+ c +-+ unwords as - cmdStdIn_ c as inp - -cmdlog :: String -> [String] -> IO () -cmdlog c as = cmdlogStdIn c as "" - -logMsg :: String -> IO () -logMsg msg = do - date <- cmd "date" ["+%T"] - putStrLn $ date +-+ msg - -cmdBool :: String -> [String] -> IO Bool -cmdBool c as = do - ret <- rawSystem c as - case ret of - ExitSuccess -> return True - ExitFailure _ -> return False - --- hide stdout -cmdSilent :: String -> [String] -> IO () -cmdSilent c as = do - (ret, _, err) <- readProcessWithExitCode c as "" - case ret of - ExitSuccess -> return () - ExitFailure n -> error $ "\"" ++ c +-+ unwords as ++ "\"" +-+ "failed with status" +-+ show n ++ "\n" ++ err - -sudo :: String -> [String] -> IO () -sudo c as = cmdlog "sudo" (c:as) - ---shell :: String -> IO String ---shell c = cmd "sh" ["-c", c] - -removePrefix :: String -> String -> String -removePrefix prefix orig = - fromMaybe (error prefix +-+ "is not prefix of" +-+ orig) $ stripPrefix prefix orig - -maybeRemovePrefix :: String -> String -> String -maybeRemovePrefix prefix orig = - fromMaybe orig $ stripPrefix prefix orig - -removeSuffix :: String -> String -> String -removeSuffix suffix orig = - fromMaybe orig $ stripSuffix suffix orig - where - stripSuffix sf str = reverse <$> stripPrefix (reverse sf) (reverse str) - -error_ :: String -> a -#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,9,0)) -error_ = errorWithoutStackTrace -#else -error_ = error -#endif - -#if (defined(MIN_VERSION_directory) && MIN_VERSION_directory(1,2,3)) -#else -withCurrentDirectory :: FilePath -> IO a -> IO a -withCurrentDirectory dir action = - bracket getCurrentDirectory setCurrentDirectory $ \ _ -> do - setCurrentDirectory dir - action -#endif - -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,5 +1,5 @@ Name: fedora-haskell-tools -Version: 0.6 +Version: 0.7 Synopsis: Building and maintenance tools for Fedora Haskell Description: Tools for building and managing Fedora Haskell packages. @@ -9,51 +9,57 @@ License-file: COPYING Author: Jens Petersen Maintainer: Jens Petersen -Copyright: 2014-2017 Jens Petersen +Copyright: 2014-2019 Jens Petersen Category: Distribution Build-type: Simple Extra-source-files: README.md TODO ChangeLog Cabal-version: >=1.6 +Tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, + GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.3 source-repository head type: git location: https://github.com/fedora-haskell/fedora-haskell-tools -Executable fhbuild - Main-is: fhbuild.hs - Build-depends: base < 5, +Executable fhpkg + Main-is: fhpkg.hs + Build-depends: base >= 4.6 && < 5, + csv, directory, + fedora-dists, filepath, + HTTP, process, + simple-cmd >= 0.1.1, + split, time < 1.9, unix - Other-modules: Dists, Koji, RPM, Utils + Hs-Source-Dirs: src, . + Other-modules: Build, Koji, Options, Paths_fedora_haskell_tools, Utils + RPM GHC-options: -fwarn-missing-signatures -Wall Extensions: CPP Executable fhbz Main-is: fhbz.hs Build-depends: base < 5, + fedora-dists, time - Other-modules: Dists, Koji, RPM, Utils + Hs-Source-Dirs: src, . + Other-modules: Koji, RPM GHC-options: -fwarn-missing-signatures -Wall Extensions: CPP -Executable fhpkg - Main-is: fhpkg.hs +Executable fhmock + Main-is: fhmock.hs Build-depends: base < 5, - csv, - directory, - filepath, - HTTP, - process, - time < 1.9, - unix + fedora-dists, + optparse-applicative, + simple-cmd >= 0.1.1, + simple-cmd-args if impl(ghc<8.0) Build-depends: semigroups - Other-modules: Dists, - Koji, - RPM, - Utils + Hs-Source-Dirs: src, . + Other-modules: Options, Paths_fedora_haskell_tools GHC-options: -fwarn-missing-signatures -Wall Extensions: CPP diff --git a/fhbuild.hs b/fhbuild.hs deleted file mode 100644 --- a/fhbuild.hs +++ /dev/null @@ -1,358 +0,0 @@ --- | --- Module : Build --- Copyright : (C) 2014-2017 Jens Petersen --- --- Maintainer : Jens Petersen --- Stability : alpha --- --- Explanation: Main entry point for building RPM packages. - --- This program is free software: you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation, either version 3 of the License, or --- (at your option) any later version. - -module Main where - -#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,8,2)) -#else -import Control.Applicative ((<$>)) -#endif -import Control.Monad (filterM, unless, void, when) -import Data.Maybe -import Data.List (intercalate, isPrefixOf, nub) - -import System.Directory (doesDirectoryExist, doesFileExist, - getCurrentDirectory, setCurrentDirectory) -import System.Environment (getArgs, getProgName) -import System.Exit (ExitCode (..), exitWith) -import System.FilePath ((), dropExtension) -import System.IO (hPutStrLn, stderr) - -import Dists (Dist, dists, distBranch, distOverride, distTag, rpmDistTag) -import Koji (kojiBuilding, kojiCheckFHBuilt, kojiLatestPkg, kojiWaitPkg, - 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 - 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 - mode "koji" = Koji - mode "chain" = Chain - mode "pending" = Pending - mode "changed" = Changed - mode "built" = Built - mode "bump" = Bump - mode _ = error "Unknown command" - -commands :: [String] -commands = ["install", "mock" , "koji", "chain", "pending", "changed", "built", - "bump"] - -help :: IO () -help = do - progName <- getProgName - hPutStrLn stderr $ "Usage:" +-+ progName +-+ "CMD DIST PKG...\n" - ++ "\n" - ++ "Commands:\n" - ++ " install\t- build locally and install\n" - ++ " mock\t\t- build in mock\n" - ++ " koji\t\t- build in Koji\n" - ++ " chain\t\t- build deps recursively in Koji\n" - ++ " pending\t- show planned changes\n" - ++ " changed\t- show changed pkgs\n" - ++ " built\t\t- show pkgs whose NVR already built\n" - ++ " bump\t\t- bump release for NVRs already built\n" - exitWith (ExitFailure 1) - -type Arguments = (String, Dist, [String]) - -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 () -build topdir mode dist msubpkg mlast waitrepo (pkg:rest) = do - setCurrentDirectory topdir - let branch = distBranch dist - unless (mode `elem` [Pending, Changed, Built]) $ - putStrLn $ "\n==" +-+ pkg ++ ":" ++ branch +-+ "==" - dirExists <- doesDirectoryExist pkg - unless dirExists $ do - let anon = ["-a" | mode `notElem` [Koji, Chain]] - cmdlog (rpkg (Just dist)) $ ["clone", "-b", branch, pkg] ++ anon - wd <- pkgDir pkg branch "" - setCurrentDirectory wd - ignore <- doesFileExist ".fhbuild-ignore" - if ignore && mode `elem` [Install, Koji, Chain, Mock] then putStrLn "ignored" - else do - failing <- doesFileExist ".fhbuild-fail" - when (failing && mode /= Pending) $ do - putStrLn "skipped: found '.fhbuild-fail' file" - exitWith (ExitFailure 1) - retired <- doesFileExist "dead.package" - if retired then do - unless (mode == Pending) $ - putStrLn "skipping dead.package" - build topdir mode dist Nothing Nothing False rest - else do - pkggit <- do - gd <- doesFileExist ".git/config" - if gd then checkPkgsGit - else return False - if not pkggit - then if mode `elem` [Install, Koji, Chain] - then error $ "not a Fedora pkg git dir!:" +-+ wd - else build topdir mode dist Nothing Nothing False rest - else do - when dirExists $ do - actual <- gitBranch - when (branch /= actual) $ - cmd_ (rpkg (Just dist)) ["switch-branch", branch] - git_ "pull" ["-q"] - -- noupdate <- doesFileExist ".noupdate" - -- unless noupdate $ - -- void $ cmdBool "cabal-rpm" ["update"] - let spec = pkg ++ ".spec" - hasSpec <- doesFileExist spec - if not hasSpec - then putStrLn $ "No" +-+ spec - else do - nvr <- cmd (rpkg (Just dist)) ["verrel"] - let verrel = removePrefix (pkg ++ "-") nvr - tag = distTag dist - case mode of - Install -> do - let req = fromMaybe pkg msubpkg - installed <- cmdMaybe "rpm" ["-q", "--qf", "%{name}-%{version}-%{release}", req] - if Just (req ++ "-" ++ verrel) == installed - then putStrLn $ nvr +-+ "already installed!\n" - else do - putStrLn $ fromMaybe "Not installed" installed +-+ "->" +-+ nvr - 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 True) hmissing - unless (null srcs) $ do - putStrLn "Missing:" - mapM_ putStrLn srcs - build topdir Install dist Nothing Nothing False srcs - setCurrentDirectory $ topdir wd - stillMissing <- filterM notInstalled missing - unless (null stillMissing) $ do - putStrLn $ "Installing:" +-+ intercalate ", " stillMissing - rpmInstall stillMissing - putStrLn "" - putStrLn $ "Building" +-+ nvr - -- note "fedpkg --path dir local" saves .build.log in cwd - success <- cmdBool (rpkg (Just dist)) ["local"] - if not success - then do - waitForEnter - build topdir Install dist Nothing Nothing False [pkg] - else do - 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 (rpkg (Just dist)) ["mockbuild"] - build topdir Mock dist Nothing Nothing False rest - Koji -> do - unless (null rest) $ do - putStrLn $ show (length rest) +-+ "more packages" - putStrLn "" - latest <- kojiLatestPkg tag pkg - 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 dist - if building - then do - putStrLn $ nvr +-+ "is already building" - kojiWaitPkg topdir tag nvr - build topdir Koji dist Nothing Nothing False rest - else do - case mlast of - Nothing -> return () - Just (pkg', nvr') -> do - dep <- dependent pkg' pkg branch topdir - when dep $ do - putStrLn $ "Waiting for" +-+ nvr' - kojiWaitPkg topdir tag nvr' - 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 - when dep $ do - putStrLn $ "Waiting for" +-+ nvr - kojiWaitPkg topdir tag nvr - build topdir Koji dist Nothing (if dep then Just (pkg, nvr) else Nothing) False rest - Pending -> do - latest <- kojiLatestPkg tag pkg - unless (eqNVR nvr latest) $ - showNVRChange pkg latest nvr - build topdir Pending dist Nothing Nothing False rest - Changed -> do - latest <- kojiLatestPkg tag pkg - unless (eqNVR nvr latest) $ - putStrLn pkg - build topdir Changed dist Nothing Nothing False rest - Built -> do - latest <- kojiLatestPkg tag pkg - when (eqNVR nvr latest) $ - putStrLn pkg - build topdir Built dist Nothing Nothing False rest - Bump -> do - latest <- kojiLatestPkg tag pkg - when (eqNVR nvr latest) $ do - putStrLn pkg - cmd_ "rpmdev-bumpspec" ["-c", "rebuild", spec] - 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 $ Just nvr - else kojiLatestPkg tag pkg - 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 dist - if building - then do - putStrLn $ nvr +-+ "is already building" - kojiWaitPkg topdir tag nvr - unless (null rest) $ - build topdir Chain dist Nothing Nothing False rest - else do - showChange pkg latest nvr - putStrLn "" - srcs <- buildRequires spec >>= haskellSrcPkgs topdir dist - --print srcs - hmissing <- nub <$> filterM (notInKoji branch topdir tag) srcs - putStrLn "" - unless (null hmissing) $ do - putStrLn "Missing:" - mapM_ putStrLn hmissing - build topdir Chain dist Nothing Nothing True hmissing - setCurrentDirectory $ topdir wd - putStrLn "" - -- note "fedpkg --path dir local" saves .build.log in cwd - git_ "push" [] - putStrLn "" - rpkgBuild topdir dist nvr (if waitrepo then Just tag else Nothing) - bodhiOverride dist nvr - unless (null rest) $ do - putStrLn "" - putStrLn $ show (length rest) +-+ "packages left" - build topdir Chain dist Nothing (Just (pkg, nvr)) waitrepo rest - -maybePkgVer :: String -> Maybe String -> String -maybePkgVer pkg mver = pkg ++ maybe "" ("-" ++) mver - -notInstalled :: String -> IO Bool -notInstalled pkg = - not <$> cmdBool "rpm" ["--quiet", "-q", pkg] - -showChange :: Package -> Maybe String -> String -> IO () -showChange pkg mlatest nvr = do - git_ "log" ["-1"] - putStrLn "" - showNVRChange pkg mlatest nvr - -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 = - when (distOverride dist) $ - -- FIXME: improve Notes with recursive info - cmd_ "bodhi" ["overrides", "save", "--notes", "Haskell stack", nvr] - --- -- dereference meta BRs --- whatProvides :: String -> String -> IO String --- whatProvides relver pkg = do --- res <- repoquery relver ["--qf", "%{name}", "--whatprovides", pkg] --- --print res --- when (null res) $ do --- installed <- not <$> notInstalled pkg --- unless installed $ putStrLn $ "Warning:" +-+ pkg +-+ "not found by repoquery" --- return $ if null res then pkg else res - -eqNVR :: String -> Maybe String -> Bool -eqNVR p1 p2 = - Just (dropExtension p1) == fmap dropExtension p2 - --- "pkg = X.Y" -> ["pkg", "=", "X.Y"] -> ("pkg", Just "X.Y") -processDeps :: [String] -> (String, Maybe String) -processDeps [p, "=", v] = (p, Just v) -processDeps (p:_) = (p, Nothing) -processDeps [] = error "processDeps: empty string!" - -dependent :: String -> String -> String -> FilePath -> IO Bool -dependent dep pkg branch topdir = do - pkgpath <- pkgDir pkg branch topdir - grep dep $ pkgpath pkg ++ ".spec" - -displayLogTail :: FilePath -> IO () -displayLogTail f = do - ls <- lines <$> readFile f - let foot = 3 - disp = 12 - start = length ls - (disp + foot) - mapM_ putStrLn $ take disp $ drop start ls - -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 @@ -2,7 +2,7 @@ -- | -- Module : Bugzilla --- Copyright : (C) 2014-2017 Jens Petersen +-- Copyright : (C) 2014-2018 Jens Petersen -- -- Maintainer : Jens Petersen -- @@ -15,7 +15,7 @@ module Main where -#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,8,2)) +#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,8,0)) #else import Control.Applicative ((<$>)) #endif @@ -25,14 +25,14 @@ import Data.Maybe (fromMaybe, listToMaybe) import Data.Time.Clock (diffUTCTime, getCurrentTime) import System.Directory ({-doesFileExist, getCurrentDirectory,-} getModificationTime) -import System.Environment (getArgs, getEnv, getProgName) import System.Console.GetOpt (ArgDescr (..), ArgOrder (..), OptDescr (..), getOpt, usageInfo) +import System.Environment (getArgs, getEnv, getProgName) import System.FilePath (()) -import Dists (rawhide) +import FedoraDists (rawhide) import Koji (kojicmd) -import Utils ((+-+), cmd, cmd_, cmdStdErr, removePrefix, removeSuffix) +import SimpleCmd ((+-+), cmd, cmd_, cmdStdErr, removeStrictPrefix, removeSuffix) data BugState = BugState { bugNo :: String, @@ -42,7 +42,7 @@ whiteboard :: String } -data Flag = Close | Force | DryRun | NoComment | Refresh | State String +data Flag = Check | Force | DryRun | NoComment | Refresh | State String deriving (Eq, Show) isState :: Flag -> Bool @@ -56,7 +56,7 @@ , Option "r" ["refresh"] (NoArg Refresh) "update if status changed" , Option "s" ["state"] (ReqArg State "BUGSTATE") "bug state (default NEW)" , Option "N" ["no-comment"] (NoArg NoComment) "update the whiteboard only" - , Option "c" ["close"] (NoArg Close) "close bugs whose version is in Rawhide" + , Option "c" ["check"] (NoArg Check) "check update for missing deps" ] parseOpts :: [String] -> IO ([Flag], [String]) @@ -101,11 +101,11 @@ -- should not happen! unless (hkg `isPrefixOf` hkgver') $ putStrLn $ "Component and Summary inconsistent!" +-+ hkg +-+ hkgver' +-+ "<" ++ "http://bugzilla.redhat.com/" ++ bid ++ ">" - if Close `elem` opts then closeBug opts bid bcomp pkgver else do + if Check `notElem` opts then closeBug opts bid bcomp pkgver else do let force = Force `elem` opts refresh = Refresh `elem` opts when (hkgver /= hkgver' || force || refresh) $ do - updateCabalPackages + cabalUpdate (missing, err) <- cmdStdErr "cblrpm" ["missingdeps", hkgver'] let state' = if null missing && null err then "ok" else "deps" when ((hkgver, state) /= (hkgver', state') || force) $ do @@ -135,7 +135,7 @@ colon :: String -> (String, String) colon "" = ("","") -colon ps = (nv, if null s then "" else removePrefix ":" s) +colon ps = (nv, if null s then "" else removeStrictPrefix ":" s) where (nv, s) = break (== ':') ps @@ -154,7 +154,7 @@ updateBug :: String -> String -> String -> String -> String -> Bool -> IO () updateBug bid _bcomp hkgver missing state nocomment = do --- rebuilds <- if null missing then tail . lines <$> cmd "cblrepo" ["build", removeGhcPrefix bcomp] else return [] +-- rebuilds <- if null missing then tail <$> cmdLines "cblrepo" ["build", removeGhcPrefix bcomp] else return [] progname <- getProgName let comment = progname ++ ":" +-+ if null missing @@ -163,11 +163,11 @@ bugzillaModify $ ["--whiteboard==" ++ hkgver ++ ":" ++ state] ++ (if nocomment then [] else ["--comment=" ++ comment]) ++ [bid] -updateCabalPackages :: IO () -updateCabalPackages = do +cabalUpdate :: IO () +cabalUpdate = do home <- getEnv "HOME" - pkgs <- getModificationTime (home ".cabal/packages/hackage.haskell.org/00-index.tar.gz") + pkgs <- getModificationTime (home ".cabal/packages/hackage.haskell.org/01-index.tar.gz") now <- getCurrentTime let diff = diffUTCTime now pkgs - when (diff > 36000) $ + when (diff > 3600) $ cmd_ "cabal" ["update"] diff --git a/fhmock.hs b/fhmock.hs new file mode 100644 --- /dev/null +++ b/fhmock.hs @@ -0,0 +1,99 @@ +-- | +-- Module : Mock +-- Copyright : (C) 2018-2019 Jens Petersen +-- +-- Maintainer : Jens Petersen +-- +-- Explanation: Updating of Upstream Release Monitoring bugs + +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. + +import Data.List (sort) +import System.Environment (getArgs) + +import FedoraDists +import Options (distArg) +import Paths_fedora_haskell_tools (version) + +import SimpleCmd (cmd_) +import SimpleCmdArgs +import Options.Applicative +#if (defined(MIN_VERSION_optparse_applicative) && MIN_VERSION_optparse_applicative(0,13,0)) +--import Data.Semigroup ((<>)) +#endif + +-- mock :: [String] -> IO String +-- mock os = cmd "mock" os + +main :: IO () +main = do + args <- getArgs + simpleCmdArgs (Just version) "Fedora Haskell mock chroot tool" + "Mock chroot setup for doing Fedora Haskell building and checking.\nYou can also use any mock command without '--'." $ subcommands $ + map mockCmd commonMockCmds ++ + [ Subcommand "check" "Check all Haskell libs installable" $ + check <$> distArg + , Subcommand "repoquery" "Repoquery" $ + repoquery <$> distArg <*> many (strArg "PKG...") + , Subcommand "help" "mock help" $ pure $ mock_ ["--help"] + , Subcommand "mockcmds" "List mock commands" $ + pure $ putStrLn $ unwords $ sort allMockCmds + ] ++ + [ Subcommand c ("Run mock " ++ c ++ " command") (runMock <$> distArg <*> optCmdArg <*> some (strArg "OPT")) | length args >= 2, let c = head args, c `elem` allMockCmds] + where + mockCmd :: (String, Bool, String, Bool, String) -> Subcommand + mockCmd (com,needarg,var,externopt,desc) = + Subcommand com desc $ + runMock <$> distArg <*> optCmdArg <*> arbitrary needarg var externopt + + optCmdArg = + mkOpt <$> strArg "CMD" + where + mkOpt c = + case c of + ('-':'-':_) -> c + _ -> "--" ++ c + + arbitrary :: Bool -> String -> Bool -> Parser [String] + arbitrary needarg var externopt = + (["--" | externopt] ++) <$> (if needarg then some else many) (strArg (var ++ "...")) + + -- (cmd, needarg, VAR, externalopts, desc) + commonMockCmds = [ ("chroot", True, "CMD", True, "Exec command in chroot") + , ("clean", False, "OPT", False, "Clean chroot") + , ("init", False, "OPT", False, "Setup chroot") + , ("install", True, "PKG", False, "Install packages") + , ("rebuild", True, "SRPM", False, "Build package(s)") + , ("remove", True, "PKG", False, "Remove package") + , ("shell", False, "CMD", True, "Interactive shell command") + , ("update", False, "PKG", False, "Update chroot packages") + ] + +allMockCmds :: [String] +allMockCmds = sort + ["rebuild", "buildsrpm", "debug-config", "shell", "chroot", + "clean", "scrub", "init", "installdeps", "install", "update", + "remove", "orphanskill", "copyin", "copyout", + "pm-cmd", "yum-cmd", "dnf-cmd", "snapshot", "remove-snapshot", + "rollback-to", "umount", "mount"] + +check :: Dist -> IO () +check dist = runMock dist "--dnf-cmd" ["install", "ghc*devel"] + +repoquery :: Dist -> [String] -> IO () +repoquery dist ps = runMock dist "--dnf-cmd" $ "repoquery" : ps + + +runMock :: Dist -> String -> [String] -> IO () +runMock dist c cs = do + let conf = distRepo dist ++ "-" ++ releaseVersion dist ++ "-x86_64" + root = conf ++ "-haskell" + let opts = ["-r", conf, "--config-opts=root=" ++ root] + mock_ $ opts ++ (c:cs) + +mock_ :: [String] -> IO () +mock_ = cmd_ "mock" + diff --git a/fhpkg.hs b/fhpkg.hs --- a/fhpkg.hs +++ b/fhpkg.hs @@ -1,6 +1,6 @@ -- | -- Module : Packages --- Copyright : (C) 2017 Jens Petersen +-- Copyright : (C) 2017-2019 Jens Petersen -- -- Maintainer : Jens Petersen -- Stability : alpha @@ -14,16 +14,19 @@ module Main where -#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,8,2)) +import Control.Applicative (optional, some, (<|>) +#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,8,0)) #else -import Control.Applicative ((<$>)) + , pure, (<$>), (<*>) #endif -import Control.Monad (filterM, unless, when) -import Data.Char (isUpper, toLower, toUpper) + ) +import Control.Monad (filterM, unless, when, (>=>)) import Data.Maybe -import Data.List (find, isInfixOf, isPrefixOf, nub, partition, sort, (\\)) +import Data.List (intercalate, isInfixOf, isPrefixOf, nub, sort, (\\)) +import Data.List.Split (splitOn) import Network.HTTP (getRequest, getResponseBody, simpleHTTP) +import Options.Applicative (Parser, auto, flag', option, switch, strOption) import System.Directory (doesDirectoryExist, doesFileExist, getCurrentDirectory, getHomeDirectory, #if (defined(MIN_VERSION_directory) && MIN_VERSION_directory(1,2,5)) @@ -32,23 +35,26 @@ getDirectoryContents, #endif setCurrentDirectory) -import System.Environment (getArgs, getProgName) -import System.Exit (ExitCode (..), exitWith) -import System.FilePath ((), takeFileName) -import System.IO (BufferMode(..), hPutStrLn, hSetBuffering, stderr, - stdout) +import System.FilePath ((), (<.>), takeFileName) +import System.IO (BufferMode(..), hSetBuffering, stdout) --import System.Posix.Env (getEnv) import Text.CSV (parseCSV) -import Text.Read (readMaybe) -import Dists (Dist, dists, distBranch, distRepo, distUpdates, hackageRelease, - rawhide, releaseVersion) +import FedoraDists (Dist(..), distBranch, distRepo, distUpdates, + hackageRelease, rawhide) + +import SimpleCmd ((+-+), cmd, cmd_, cmdBool, cmdLines, cmdMaybe, cmdSilent, + grep_, removePrefix, shell_) +import SimpleCmd.Git (git, git_, gitBranch, isGitDir) +import SimpleCmdArgs + +import Build (build, readBuildCmd) import Koji (kojiListPkgs, rpkg) +import Options (distArg) +import Paths_fedora_haskell_tools (version) import RPM (buildRequires, haskellSrcPkgs, Package, pkgDir, repoquery, rpmspec) -import Utils ((+-+), checkPkgsGit, cmd, cmd_, cmdBool, cmdMaybe, cmdSilent, grep, - git, git_, gitBranch, maybeRemovePrefix, removePrefix, removeSuffix, - withCurrentDirectory) +import Utils (checkPkgsGit, withCurrentDirectory) #if (defined(MIN_VERSION_directory) && MIN_VERSION_directory(1,2,5)) #else @@ -60,269 +66,305 @@ main :: IO () main = do - 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 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 -> 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 + cwd <- getCurrentDirectory + simpleCmdArgs (Just version) "Fedora Haskell packages tool" + "Fedora packages maintenance tool" $ + subcommands $ + [ Subcommand "bump" "bump package release" $ + bump <$> strOption (optionMods 'm' "message" "CHANGELOG" "changelog message") <*> distArg <*> pkgArgs + , Subcommand "checkout" "fedpkg switch-branch" $ + repoAction_ True False (return ()) <$> distArg <*> pkgArgs + , Subcommand "clone" "clone repos" $ + clone <$> branching <*> distArg <*> pkgArgs + , Subcommand "clone-new" "clone new packages" $ + cloneNew <$> branching <*> distArg + , Subcommand "cmd" "arbitrary command (with args)" $ + execCmd <$> strOption (optionMods 'c' "cmd" "CMD" "command to execute") <*> distArg <*> pkgArgs + , Subcommand "count" "count number of packages" $ + (repoqueryHaskell False >=> (print . length)) <$> distArg + , Subcommand "diff" "git diff" $ + gitDiff <$> optional gitFormat + <*> optional (strOption (optionMods 'w' "with-branch" "BRANCH" "Branch to compare")) + <*> distArg <*> pkgArgs + , Subcommand "diff-origin" "git diff origin" $ + gitDiffOrigin <$> distArg <*> pkgArgs + , Subcommand "diff-branch" "compare branch with master" $ + repoAction False True compareRawhide <$> distArg <*> pkgArgs + , Subcommand "diff-stackage" "compare with stackage" $ + diffStackage <$> switch (switchMods 'm' "missing" "only list missing packages") <*> distArg <*> pkgArgs + , Subcommand "hackage" "generate Hackage distro data" $ + pure $ repoqueryHackageCSV hackageRelease + , Subcommand "hackage-compare" "compare with Hackage distro data" $ + pure hackageCompare + , Subcommand "head-origin" "head in sync with origin" $ + headOrigin <$> distArg <*> pkgArgs + , Subcommand "leaf" "list leaf packages" $ + leaves <$> switch (switchMods 'v' "deps" "show also deps") <*> distArg <*> pkgArgs + , Subcommand "list" "list packages" $ mapM_ putStrLn <$> pkgArgs + , Subcommand "merge" "git merge" $ + merge <$> strOption (optionMods 'f' "from" "BRANCH" "specify branch to merge from") <*> distArg <*> pkgArgs + , Subcommand "missing" "missing dependency source packages" $ + missingDeps <$> distArg <*> pkgArgs + , Subcommand "new" "new unbuilt packages" $ + (newPackages >=> mapM_ putStrLn) <$> distArg + , Subcommand "old-packages" "packages not in repoquery" $ + oldPackages <$> distArg <*> pkgArgs + , Subcommand "prep" "fedpkg prep" $ + prep <$> distArg <*> pkgArgs + , Subcommand "commit" "fedpkg commit" $ + commit <$> strOption (optionMods 'm' "message" "COMMITMSG" "commit message") <*> distArg <*> pkgArgs + , Subcommand "pull" "git pull repos" $ + repoAction_ True False (git_ "pull" ["--rebase"]) <$> distArg <*> pkgArgs + , Subcommand "push" "git push repos" $ + repoAction_ True False (git_ "push" []) <$> distArg <*> pkgArgs + , Subcommand "refresh" "cabal-rpm refresh" $ + repoAction True True refresh <$> distArg <*> pkgArgs + , Subcommand "remaining" "remaining packages to be built in TAG" $ + remaining <$> strArg "TAG" <*> pkgArgs + , Subcommand "unpushed" "show unpushed commits" $ + unpushed <$> switch (switchMods 's' "short" "no log") <*> distArg <*> pkgArgs + , Subcommand "update" "cabal-rpm update" $ + update <$> strOption (optionMods 's' "stream" "STACKAGESTREAM" "Stackage stream (lts-X)") <*> distArg <*> pkgArgs + , Subcommand "subpkgs" "list subpackages" $ + repoAction True True (\ p -> rpmspec [] (Just "%{name}-%{version}") (p <.> "spec") >>= mapM_ putStrLn) <$> distArg <*> pkgArgs + , Subcommand "tagged" "list koji DIST tagged builds" $ + listTagged_ <$> switch (switchMods 's' "short" "list packages not builds") <*> strArg "TAG" + , Subcommand "verrel" "show nvr of packages" $ + verrel <$> distArg <*> pkgArgs] ++ + map (buildCmd cwd) [ ("install", "build locally and install") + , ("mock", "build in mock") + , ("chain", "build deps recursively in Koji") + , ("koji", "build in Koji (deprecated)") + , ("pending", "show planned changes") + , ("changed", "show changed pkgs") + , ("built", "show pkgs whose NVR already built") + , ("bump", "bump release for NVRs already built") + , ("not-installed", "list packages not locally installed") + ] where - checkHackageDist mdist = - unless (isNothing mdist || mdist == Just hackageRelease) $ error $ "Hackage is currently for" +-+ hackageRelease ++ "!" + pkgArgs = some (strArg "PKG...") - withPackages :: Maybe Dist -> [Package] -> ([Package] -> IO ()) -> IO () - withPackages mdst pkgs act = - (if null pkgs then repoqueryHaskell False mdst else return pkgs) >>= act + branching = switch (switchMods 'B' "branches" "clone branch dirs (fedpkg clone -B)") --- name, summary -data Command = Command { cmdName :: CmdName , cmdDescription :: String} + gitFormat :: Parser DiffFormat + gitFormat = + flag' DiffShort (switchMods 's' "short" "Just output package name") <|> + DiffContext <$> option auto (optionMods 'u' "unified" "CONTEXT" "Lines of context") -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) + buildCmd cwd (c, desc) = + Subcommand c desc $ + build cwd Nothing Nothing False (readBuildCmd c) <$> distArg <*> pkgArgs --- 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 +data DiffFormat = + DiffShort | DiffContext Int + deriving (Eq) --- "some-command" -> SomeCommand -readCmd :: String -> CmdName -readCmd c = fromMaybe (error $ "Unknown command " ++ c) (readMaybe $ parse "" c) +bump :: String -> Dist -> [Package] -> IO () +bump msg = + repoAction True False bumpspec 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 + bumpspec pkg = + cmd_ "rpmdev-bumpspec" ["-c", msg, pkg <.> "spec"] -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"] +clone :: Bool -> Dist -> [Package] -> IO () +clone True dist pkgs = cloneAllBranches dist pkgs +clone False dist pkgs = + repoAction_ True False (return ()) dist pkgs -type CommandOptions = [(Option, Bool)] +cloneNew :: Bool -> Dist -> IO () +cloneNew True dist = + newPackages rawhide >>= cloneAllBranches dist +cloneNew False dist = + newPackages dist >>= repoAction_ True False (return ()) dist --- 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 _ = [] +execCmd :: String -> Dist -> [Package] -> IO () +execCmd "" _ _ = error "CMD string must be given" +execCmd cs dist pkgs = + repoAction_ True True (shell_ cs) dist pkgs -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)") - ] +gitDiff :: Maybe DiffFormat -> Maybe String -> Dist -> [Package] -> IO () +gitDiff fmt mbrnch = + repoAction False False doGitDiff + where + doGitDiff pkg = do + let branch = maybeToList mbrnch + contxt = case fmt of + (Just (DiffContext n)) -> ["-u", show n] + _ -> [] + short = fmt == Just DiffShort + out <- git "diff" $ branch ++ contxt + unless (null out) $ do + putStrLn $ if short then pkg else "==" +-+ pkg +-+ "==" + unless short $ putStrLn out -globalOpts :: [Option] -globalOpts = map fst globalOptsDesc +gitDiffOrigin :: Dist -> [Package] -> IO () +gitDiffOrigin dist = + repoAction_ True False (git_ "diff" ["origin/" ++ show dist]) dist -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) +diffStackage :: Bool -> Dist -> [Package] -> IO () +diffStackage missingOnly dist = + repoAction False True compareStackage dist where - 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 - --- add description -data Option = OptNull Char | OptArg Char String | OptLong String String + compareStackage :: Package -> IO () + compareStackage p = do + nvr <- cmd (rpkg dist) ["verrel"] + let stream = "lts-12" + stkg <- cmdMaybe "stackage" ["package", stream, removePrefix "ghc-" p] + let same = isJust stkg && fromJust stkg `isInfixOf` nvr + unless missingOnly $ + putStrLn $ nvr +-+ "(fedora)" + if missingOnly then when (isNothing stkg) $ putStrLn p + else + putStrLn $ (if same then "same" else fromMaybe "none" stkg) +-+ "(" ++ stream ++ ")" -instance Eq Option +hackageCompare :: IO () +hackageCompare = + repoqueryHaskell False hackageRelease >>= + compareHackage hackageRelease where - OptNull c == OptNull c' = c == c' - OptArg c _ == OptArg c' _ = c == c' - OptLong s _ == OptLong s' _ = s == s' - _ == _ = False + compareHackage :: Dist -> [Package] -> IO () + compareHackage 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 + fedora <- sort . map mungeRepo . lines <$> repoquery dist (["--repo=fedora", "--repo=updates", "--latest-limit=1", "--qf=%{name},%{version}"] ++ pkgs') + compareSets True hackage fedora -hasOptNull :: Char -> [Option] -> Bool -hasOptNull c opts = OptNull c `elem` opts + mungeHackage :: [String] -> PkgVer + mungeHackage [_,v,u] = PV (takeFileName u) v + mungeHackage _ = error "Malformed Hackage csv" -getOptVal :: Option -> [Option] -> Maybe String -getOptVal (OptNull _) _ = Nothing -getOptVal opt opts = maybe Nothing mval optval + 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 + +headOrigin :: Dist -> [Package] -> IO () +headOrigin dist = + repoAction False False gitHeadAtOrigin dist where - optval = find (== opt) opts - mval (OptNull _) = Nothing - mval (OptArg _ v) = Just v - mval (OptLong _ v) = Just v + gitHeadAtOrigin :: Package -> IO () + gitHeadAtOrigin pkg = do + -- use gitDiffQuiet + same <- cmdBool "git" ["diff", "--quiet", "origin/" ++ show dist ++ "..HEAD"] + when same $ putStrLn pkg ---isNull :: Option -> Bool ---isNull (OptNull _) = True ---isNull _ = False +leaves :: Bool -> Dist -> [Package] -> IO () +leaves verb = + repoAction verb True checkLeafPkg + where + -- FIXME: make a dependency cache + checkLeafPkg :: Package -> IO () + checkLeafPkg pkg = do + dir <- takeFileName <$> getCurrentDirectory + let branchdir = dir /= pkg + top = if branchdir then "../.." else ".." + spec = pkg <.> "spec" + subpkgs <- rpmspec ["--builtrpms"] (Just "%{name}") spec + allpkgs <- listDirectory top + let other = map (\ p -> top p (if branchdir then dir else "") p <.> "spec") $ allpkgs \\ [pkg] + 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 -instance Show Option +merge :: String -> Dist -> [Package] -> IO () +merge branch = + repoAction_ True False (git_ "merge" [branch]) + +missingDeps :: Dist -> [Package] -> IO () +missingDeps dist = + repoAction True True checkForMissingDeps dist where - show (OptNull c) = "-" ++ [c] - show (OptArg c v) = "-" ++ [c] ++ ('=':v) - show (OptLong s v) = "--" ++ s ++ ('=':v) + checkForMissingDeps :: Package -> IO () + checkForMissingDeps pkg = do + dir <- takeFileName <$> getCurrentDirectory + let top = if dir == pkg then ".." else "../.." + 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 -showOpts :: [Option] -> String -showOpts = unwords . map (\ s -> "[" ++ show s ++ "]") +oldPackages :: Dist -> [Package] -> IO () +oldPackages dist pkgs = do + repopkgs <- repoqueryHaskell True dist + mapM_ putStrLn (pkgs \\ repopkgs) -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 +prep :: Dist -> [Package] -> IO () +prep dist = + repoAction_ True True (cmd_ (rpkg dist) ["prep"]) dist -type Arguments = (CmdName, [Option], [Package]) +commit :: String -> Dist -> [Package] -> IO () +commit logmsg dist = + repoAction_ True True commitChanges dist + where + commitChanges :: IO () + commitChanges = do + -- use gitDiffQuiet + nochgs <- cmdBool "git" ["diff", "--quiet"] + if nochgs + then putStrLn "no changes" + else cmd_ (rpkg dist) ["commit", "-m", logmsg] --- 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) +unpushed :: Bool -> Dist -> [Package] -> IO () +unpushed nolog dist = + repoAction False True gitLogOneLine dist where - isFlag ['-', c] | c /= '-' = True - isFlag ('-':c:'=':_) | c /= '-' = True - isFlag ('-':'-':_) = True - isFlag _ = False + gitLogOneLine :: Package -> IO () + gitLogOneLine pkg = do + out <- git "log" ["origin/" ++ show dist ++ "..HEAD", "--pretty=oneline"] + unless (null out) $ + putStrLn $ pkg ++ if nolog then "" else (unwords . map replaceHash . words) out + where + replaceHash h = if length h /= 40 then h else ":" - 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 +verrel :: Dist -> [Package] -> IO () +verrel dist = + repoAction_ False True (cmd_ (rpkg dist) ["verrel"]) dist repoqueryHackageCSV :: Dist -> IO () repoqueryHackageCSV dist = do - pkgs <- repoqueryHaskell False (Just dist) - let relver = releaseVersion dist + pkgs <- repoqueryHaskell False dist -- Hackage csv chokes on final newline so remove it - 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 + init . unlines . sort . map (replace "\"ghc-" "\"") . lines <$> repoquery dist (["--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) @@ -335,43 +377,6 @@ 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 @@ -379,94 +384,105 @@ else x:replace a b xs replace _ _ [] = [] -repoqueryHaskell :: Bool -> Maybe Dist -> IO [Package] -repoqueryHaskell verbose mdist = do - let relver = maybe Nothing releaseVersion mdist +repoqueryHaskell :: Bool -> Dist -> IO [Package] +repoqueryHaskell verbose dist = do when verbose $ putStrLn "Getting packages from repoquery" - 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)"]) + let repo = distRepo dist + updates = maybeToList $ distUpdates dist + bin <- words <$> repoquery dist (["--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 -newPackages :: Maybe Dist -> IO [Package] -newPackages mdist = do - ps <- repoqueryHaskell True mdist - kps <- kojiListHaskell True mdist +newPackages :: Dist -> IO [Package] +newPackages dist = do + ps <- repoqueryHaskell True dist + kps <- kojiListHaskell True dist return $ kps \\ ps -kojiListHaskell :: Bool -> Maybe Dist -> IO [Package] -kojiListHaskell verbose mdist = do +kojiListHaskell :: Bool -> Dist -> IO [Package] +kojiListHaskell verbose dist = 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) + libs <- filter (\ p -> "ghc-" `isPrefixOf` p && p `notElem` ["ghc-rpm-macros", "ghc-srpm-macros"]) <$> kojiListPkgs dist 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 +cloneAllBranches :: Dist -> [Package] -> IO () +cloneAllBranches _ [] = return () +cloneAllBranches dist (pkg:rest) = do withCurrentDirectory "." $ do - let branchGiven = isJust mdist - branch = maybe "master" distBranch mdist - when header $ - putStrLn $ "\n==" +-+ pkg ++ (if branchGiven then ":" ++ branch else "") +-+ "==" + putStrLn $ "\n==" +-+ pkg +-+ "==" -- muser <- getEnv "USER" - home <- getHomeDirectory - haveSSH <- doesFileExist $ home ".ssh/id_rsa" + haveSSH <- do + home <- getHomeDirectory + doesFileExist $ home ".ssh/id_rsa" dirExists <- doesDirectoryExist pkg unless dirExists $ - 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_ (rpkg mdist) ["clone", "-b", branch, pkg, branch] - wd <- pkgDir pkg branch "" - setCurrentDirectory wd - pkggit <- do - gd <- doesFileExist ".git/config" - if gd - then checkPkgsGit - else return False - unless pkggit $ - error $ "not a Fedora pkg git dir!:" +-+ wd - when dirExists $ do - actual <- gitBranch - when (branch /= actual) $ - 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 + cmd_ (rpkg dist) $ ["clone"] ++ ["-a" | not haveSSH] ++ ["-B", pkg] + singleDir <- isGitDir pkg + when singleDir $ + error "branch checkout already exists!" + cloneAllBranches dist rest -repoAction_ :: Maybe Dist -> [Option] -> Bool -> Bool -> IO () -> [Package] -> IO () -repoAction_ mdist opts header needsSpec action = - repoAction mdist opts header needsSpec (const action) +repoAction :: Bool -> Bool -> (Package -> IO ()) -> Dist -> [Package] -> IO () +repoAction _ _ _ _ [] = return () +repoAction header needsSpec action dist (pkg:rest) = do + withCurrentDirectory "." $ do + let branch = distBranch dist + when header $ + putStrLn $ "\n==" +-+ pkg ++ ":" ++ branch +-+ "==" + -- muser <- getEnv "USER" + haveSSH <- do + home <- getHomeDirectory + doesFileExist $ home ".ssh/id_rsa" + fileExists <- doesFileExist pkg + dirExists <- doesDirectoryExist pkg + if fileExists + then error $ pkg +-+ "is a file" + else do + unless dirExists $ + cmd_ (rpkg dist) $ ["clone"] ++ ["-a" | not haveSSH] ++ ["-b", branch, pkg] + singleDir <- isGitDir pkg + unless singleDir $ do + branchDir <- doesDirectoryExist $ pkg branch + unless branchDir $ + withCurrentDirectory pkg $ + cmd_ (rpkg dist) ["clone", "-b", branch, pkg, branch] + wd <- pkgDir pkg branch "" + setCurrentDirectory wd + pkggit <- do + gd <- isGitDir "." + if gd + then checkPkgsGit + else return False + unless pkggit $ + error $ "not a Fedora pkg git dir!:" +-+ wd + when dirExists $ do + actual <- gitBranch + when (branch /= actual) $ + cmd_ (rpkg dist) ["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 header needsSpec action dist rest -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) +-+ "(" ++ stream ++ ")" +repoAction_ :: Bool -> Bool -> IO () -> Dist -> [Package] -> IO () +repoAction_ header needsSpec action = + repoAction header needsSpec (const action) compareRawhide :: Package -> IO () compareRawhide p = do - let spec = p ++ ".spec" - nvr <- removeDisttag <$> rpmspec ["--srpm"] (Just "%{name}-%{version}-%{release}") spec + let spec = p <.> "spec" + nvr <- removeDisttag . unwords <$> rpmspec ["--srpm"] (Just "%{name}-%{version}-%{release}") spec nvr' <- withCurrentDirectory "../master" $ do haveSpec <- doesFileExist spec unless haveSpec $ cmdSilent "git" ["pull"] - removeDisttag <$> rpmspec ["--srpm"] (Just "%{name}-%{version}-%{release}") spec + removeDisttag . unwords <$> rpmspec ["--srpm"] (Just "%{name}-%{version}-%{release}") spec if nvr == nvr' then putStrLn nvr else do @@ -478,99 +494,42 @@ isFromHackage :: Package -> IO Bool isFromHackage pkg = - grep "hackage.haskell.org/package/" $ pkg ++ ".spec" + grep_ "hackage.haskell.org/package/" $ pkg <.> "spec" -updateOrRefreshPackage :: Bool -> Package -> IO () -updateOrRefreshPackage refresh pkg = do +update :: String -> Dist -> [Package] -> IO () +update stream = + repoAction True True doUpdate + where + doUpdate :: Package -> IO () + doUpdate pkg = do + hckg <- isFromHackage pkg + if hckg + then cmd_ "cabal-rpm" ["update", "-s", stream] + else putStrLn "skipping since not hackage" + +refresh :: Package -> IO () +refresh pkg = do hckg <- isFromHackage pkg - let mode = if refresh then "refresh" else "update" if hckg - then cmd_ "cabal-rpm" [mode] + then cmd_ "cabal-rpm" ["refresh"] else putStrLn "skipping since not hackage" -commitChanges :: Maybe Dist -> [Option] -> IO () -commitChanges mdist [OptArg 'm' msg] = do - chgs <- cmd "git" ["diff"] - if null chgs - then putStrLn "no changes" - 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 +listTagged_ :: Bool -> String -> IO () +listTagged_ short tag = + listTagged short tag >>= mapM_ putStrLn -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 +listTagged :: Bool -> String -> IO [String] +listTagged short tag = do + builds <- map (head . words) <$> cmdLines "koji" ["list-tagged", "--quiet", tag] + return $ nub $ map (if short then dropVerrel else id) builds where - replaceHash h = if length h /= 40 then h else ":" + dropVerrel :: String -> String + dropVerrel nvr = + let parts = splitOn "-" nvr in + intercalate "-" $ take (length parts - 2) parts -gitHeadAtOrigin :: Maybe Dist -> Package -> IO () -gitHeadAtOrigin mdist pkg = do - same <- cmdBool "git" ["diff", "--quiet", maybe "origin" ("origin/" ++) mdist ++ "..HEAD"] - when same $ putStrLn pkg +remaining :: String -> [Package] -> IO () +remaining tag pkgs = do + built <- listTagged True tag + cmd_ "rpmbuild-order" $ ["sort", "-p"] ++ (pkgs \\ built) diff --git a/src/Build.hs b/src/Build.hs new file mode 100644 --- /dev/null +++ b/src/Build.hs @@ -0,0 +1,309 @@ +-- | +-- Module : Build +-- Copyright : (C) 2014-2019 Jens Petersen +-- +-- Maintainer : Jens Petersen +-- Stability : alpha +-- +-- Explanation: Main entry point for building RPM packages. + +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. + +module Build + (build, + readBuildCmd + ) +where + +#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,8,0)) +#else +import Control.Applicative ((<$>)) +#endif +import Control.Monad (filterM, unless, void, when) +import Data.Maybe +import Data.List (intercalate, isPrefixOf, nub) + +import System.Directory (doesDirectoryExist, doesFileExist, + setCurrentDirectory) +import System.Exit (ExitCode (..), exitWith) +import System.FilePath ((), dropExtension) + +import FedoraDists (Dist, distBranch, distOverride, rpmDistTag) +import Koji (kojiBuilding, kojiCheckFHBuilt, kojiLatestPkg, kojiWaitPkg, + notInKoji, rpkg, rpkgBuild) +import RPM (buildRequires, derefSrcPkg, haskellSrcPkgs, Package, + packageManager, pkgDir, rpmInstall, rpmspec) +import SimpleCmd ((+-+), cmd, cmd_, cmdBool, cmdLines, cmdMaybe, cmdlog, + cmdSilent, grep_, removeStrictPrefix, sudo) +import SimpleCmd.Git (git_, gitBranch, isGitDir) +import Utils (checkPkgsGit) + +data Command = Install | Mock | Koji | Chain | Pending | Changed | Built | Bump + | NotInstalled + deriving (Eq) + +readBuildCmd :: String -> Command +readBuildCmd "install" = Install +readBuildCmd "mock" = Mock +readBuildCmd "koji" = Koji +readBuildCmd "chain" = Chain +readBuildCmd "pending" = Pending +readBuildCmd "changed" = Changed +readBuildCmd "built" = Built +readBuildCmd "bump" = Bump +readBuildCmd "notinstalled" = NotInstalled +readBuildCmd _ = error "Unknown command" + +-- commands :: [String] +-- commands = ["install", "mock" , "koji", "chain", "pending", "changed", "built", +-- "bump", "notinstalled"] + +build :: FilePath -> Maybe String -> Maybe (String, String) -> Bool -> + Command -> Dist -> [String] -> IO () +build _ _ _ _ _ _ [] = return () +build topdir msubpkg mlast waitrepo mode dist (pkg:rest) = do + setCurrentDirectory topdir + let branch = distBranch dist + when (mode `notElem` [Pending, Changed, Built, NotInstalled]) $ + putStrLn $ "\n==" +-+ pkg ++ ":" ++ branch +-+ "==" + dirExists <- doesDirectoryExist pkg + unless dirExists $ do + let anon = ["-a" | mode `notElem` [Koji, Chain]] + cmdSilent (rpkg dist) $ ["clone", "-b", branch, pkg] ++ anon + wd <- pkgDir pkg branch "" + setCurrentDirectory wd + ignore <- doesFileExist ".fhbuild-ignore" + if ignore && mode `elem` [Install, Koji, Chain, Mock] then putStrLn "ignored" + else do + failing <- doesFileExist ".fhbuild-fail" + when (failing && mode /= Pending) $ do + putStrLn "skipped: found '.fhbuild-fail' file" + exitWith (ExitFailure 1) + retired <- doesFileExist "dead.package" + if retired then do + unless (mode `elem` [NotInstalled,Pending]) $ + putStrLn "skipping dead.package" + build topdir Nothing Nothing False mode dist rest + else do + pkggit <- do + gd <- isGitDir "." + if gd then checkPkgsGit + else return False + if not pkggit + then if mode `elem` [Install, Koji, Chain] + then error $ "not a Fedora pkg git dir!:" +-+ wd + else build topdir Nothing Nothing False mode dist rest + else do + when dirExists $ do + git_ "pull" ["-q"] + actual <- gitBranch + when (branch /= actual) $ + cmd_ (rpkg dist) ["switch-branch", branch] + -- noupdate <- doesFileExist ".noupdate" + -- unless noupdate $ + -- void $ cmdBool "cabal-rpm" ["update"] + let spec = pkg ++ ".spec" + hasSpec <- doesFileExist spec + if not hasSpec + then error $ "No" +-+ spec + else do + nvr <- cmd (rpkg dist) ["verrel"] + let verrel = removeStrictPrefix (pkg ++ "-") nvr + case mode of + Install -> do + let req = fromMaybe pkg msubpkg + installed <- cmdMaybe "rpm" ["-q", "--qf", "%{name}-%{version}-%{release}", req] + if Just (req ++ "-" ++ verrel) == installed + then putStrLn $ nvr +-+ "already installed!\n" + else do + putStrLn $ fromMaybe "Not installed" installed +-+ "->" +-+ nvr + 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 True) hmissing + unless (null srcs) $ do + putStrLn "Missing:" + mapM_ putStrLn srcs + build topdir Nothing Nothing False Install dist srcs + setCurrentDirectory $ topdir wd + stillMissing <- filterM notInstalled missing + unless (null stillMissing) $ do + putStrLn $ "Installing:" +-+ intercalate ", " stillMissing + rpmInstall stillMissing + putStrLn "" + putStrLn $ "Building" +-+ nvr + -- note "fedpkg --path dir local" saves .build.log in cwd + success <- cmdBool (rpkg dist) ["local"] + if not success + then do + waitForEnter + build topdir Nothing Nothing False Install dist [pkg] + else do + opkgs <- rpmspec ["--builtrpms"] (Just "%{name}") spec + rpms <- rpmspec ["--builtrpms", "--define=dist" +-+ rpmDistTag dist] (Just "%{arch}/%{name}-%{version}-%{release}.%{arch}.rpm") spec + putStrLn $ nvr +-+ "built\n" + instpkgs <- cmdLines "rpm" ("-qa":opkgs) + if null instpkgs + -- maybe filter out pandoc-pdf and xmonad* 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 Nothing Nothing False Install dist rest + Mock -> do + putStrLn $ "Mock building" +-+ nvr + cmdlog (rpkg dist) ["mockbuild"] + build topdir Nothing Nothing False Mock dist rest + Koji -> do + unless (null rest) $ do + putStrLn $ show (length rest) +-+ "more packages" + putStrLn "" + latest <- kojiLatestPkg dist pkg + if Just nvr == latest + then do + putStrLn $ nvr +-+ "already built!" + kojiWaitPkg topdir dist nvr + build topdir Nothing mlast False Koji dist rest + else do + building <- kojiBuilding pkg nvr dist + if building + then do + putStrLn $ nvr +-+ "is already building" + kojiWaitPkg topdir dist nvr + build topdir Nothing Nothing False Koji dist rest + else do + case mlast of + Nothing -> return () + Just (pkg', nvr') -> do + dep <- dependent pkg' pkg branch topdir + when dep $ do + putStrLn $ "Waiting for" +-+ nvr' + kojiWaitPkg topdir dist nvr' + showChange pkg latest nvr + putStrLn "" + git_ "push" [] + rpkgBuild topdir dist Nothing nvr waitrepo + bodhiOverride dist nvr + unless (null rest) $ do + dep <- dependent pkg (head rest) branch topdir + when dep $ do + putStrLn $ "Waiting for" +-+ nvr + kojiWaitPkg topdir dist nvr + build topdir Nothing (if dep then Just (pkg, nvr) else Nothing) False Koji dist rest + Pending -> do + latest <- kojiLatestPkg dist pkg + unless (eqNVR nvr latest) $ + showNVRChange pkg latest nvr + build topdir Nothing Nothing False Pending dist rest + Changed -> do + latest <- kojiLatestPkg dist pkg + unless (eqNVR nvr latest) $ + putStrLn pkg + build topdir Nothing Nothing False Changed dist rest + Built -> do + latest <- kojiLatestPkg dist pkg + when (eqNVR nvr latest) $ + putStrLn pkg + build topdir Nothing Nothing False Built dist rest + Bump -> do + latest <- kojiLatestPkg dist pkg + when (eqNVR nvr latest) $ do + putStrLn pkg + cmd_ "rpmdev-bumpspec" ["-c", "rebuild", spec] + cmd_ (rpkg dist) ["commit", "-m", "bump release"] + build topdir Nothing Nothing False Bump dist rest + NotInstalled -> do + opkg <- head <$> rpmspec ["--builtrpms"] (Just "%{name}") spec + inst <- cmdMaybe "rpm" ["-q", opkg] :: IO (Maybe String) + when (isNothing inst) $ putStrLn pkg + build topdir Nothing Nothing False NotInstalled dist rest + Chain -> do + fhbuilt <- kojiCheckFHBuilt topdir nvr + latest <- if fhbuilt + then return $ Just nvr + else kojiLatestPkg dist pkg + if Just nvr == latest + then do + putStrLn $ nvr +-+ "already built!" + unless (null rest) $ --do + --kojiWaitPkg topdir dist nvr + build topdir Nothing Nothing False Chain dist rest + else do + building <- kojiBuilding pkg nvr dist + if building + then do + putStrLn $ nvr +-+ "is already building" + kojiWaitPkg topdir dist nvr + unless (null rest) $ + build topdir Nothing Nothing False Chain dist rest + else do + showChange pkg latest nvr + putStrLn "" + srcs <- buildRequires spec >>= haskellSrcPkgs topdir dist + --print srcs + hmissing <- nub <$> filterM (notInKoji branch topdir dist) srcs + putStrLn "" + unless (null hmissing) $ do + putStrLn "Missing:" + mapM_ putStrLn hmissing + build topdir Nothing Nothing True Chain dist hmissing + setCurrentDirectory $ topdir wd + putStrLn "" + -- note "fedpkg --path dir local" saves .build.log in cwd + git_ "push" [] + putStrLn "" + rpkgBuild topdir dist Nothing nvr waitrepo + bodhiOverride dist nvr + unless (null rest) $ do + putStrLn "" + putStrLn $ show (length rest) +-+ "packages left" + build topdir Nothing (Just (pkg, nvr)) waitrepo Chain dist rest + +notInstalled :: String -> IO Bool +notInstalled pkg = + not <$> cmdBool "rpm" ["--quiet", "-q", pkg] + +showChange :: Package -> Maybe String -> String -> IO () +showChange pkg mlatest nvr = do + git_ "log" ["-1"] + putStrLn "" + showNVRChange pkg mlatest nvr + +showNVRChange :: Package -> Maybe String -> String -> IO () +showNVRChange pkg Nothing nvr = + putStrLn $ pkg +-+ "new" +-+ removeStrictPrefix (pkg ++ "-") nvr +showNVRChange pkg (Just latest) nvr = do + putStrLn $ pkg ++ ":" +-+ removeStrictPrefix prefix latest + putStrLn $ replicate (length pkg - 1) ' ' ++ "->" +-+ removeStrictPrefix prefix nvr + where + prefix = pkg ++ "-" + +bodhiOverride :: Dist -> String -> IO () +bodhiOverride dist nvr = + when (distOverride dist) $ + -- FIXME: improve Notes with recursive info + cmd_ "bodhi" ["overrides", "save", "--notes", "Haskell stack", nvr] + +eqNVR :: String -> Maybe String -> Bool +eqNVR p1 p2 = + Just (dropExtension p1) == fmap dropExtension p2 + +dependent :: String -> String -> String -> FilePath -> IO Bool +dependent dep pkg branch topdir = do + pkgpath <- pkgDir pkg branch topdir + grep_ dep $ pkgpath pkg ++ ".spec" + +waitForEnter :: IO () +waitForEnter = do + putStrLn "" + putChar '\a' + putStrLn "Press Enter after fixing" + void getLine diff --git a/src/Koji.hs b/src/Koji.hs new file mode 100644 --- /dev/null +++ b/src/Koji.hs @@ -0,0 +1,140 @@ +-- | +-- Module : Koji +-- Copyright : (C) 2016-2019 Jens Petersen +-- +-- Maintainer : Jens Petersen +-- Stability : alpha +-- Portability : *nix +-- +-- Explanation: Koji commands + +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. + +module Koji (kojiBuilding, + kojiCheckFHBuilt, + kojicmd, + kojiLatestPkg, + kojiListPkgs, + kojiWaitPkg, + notInKoji, + rpkg, + rpkgBuild + ) where + +#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,8,0)) +#else +import Control.Applicative ((<$>)) +#endif +import Control.Concurrent (threadDelay) +import Control.Monad (unless, when) +import Data.List (isInfixOf) +import Data.Maybe (fromMaybe) +import Data.Time.Clock (diffUTCTime, getCurrentTime) +import System.Directory (doesFileExist) +import System.Exit (ExitCode (..)) +import System.FilePath ((), (<.>)) +import System.IO (hPutStrLn, stderr) +import System.Process (readProcessWithExitCode, rawSystem) + +import FedoraDists (Dist, distTag, distTarget, kojicmd, rpkg) +import RPM (pkgDir) +import SimpleCmd (cmd, cmd_, cmdBool, grep_, logMsg, (+-+)) + +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 <$> kojisafe dist "latest-pkg" ["--quiet", distTag 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" + tag = distTag dist + already <- kojiCheckFHBuilt topdir nvr + unless already $ do + putStrLn $ "Waiting for" +-+ nvr +-+ "in" +-+ tag + cmdFragile_ (kojicmd dist) ["wait-repo", tag, "--build=" ++ nvr] + appendFile fhbuilt $ nvr ++ "\n" + +kojiCheckFHBuilt :: FilePath -> String -> IO Bool +kojiCheckFHBuilt topdir nvr = do + let fhbuilt = topdir ".fhbuilt" + grep_ nvr fhbuilt + +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 +-- parseKojiTask [] = Nothing +-- parseKojiTask (l:ls) | "Created task:" `isPrefixOf` l = Just $ removeStrictPrefix "Created task: " l +-- | otherwise = parseKojiTask ls + +notInKoji :: String -> FilePath -> Dist -> String -> IO Bool +notInKoji branch topdir dist pkg = do + latest <- kojiLatestPkg dist pkg + pkgpath <- pkgDir pkg branch topdir + let spec = pkg <.> "spec" + specExists <- doesFileExist $ pkgpath spec + if not specExists + then error $ spec +-+ "not found" + else do + local <- cmd (rpkg dist) ["--path", pkgpath, "verrel"] + if latest == Just local + then kojiWaitPkg topdir dist local >> return False + else return True + +kojiListPkgs :: Dist -> IO [String] +kojiListPkgs dist = + words <$> cmd (kojicmd dist) ["list-pkgs", "--tag=" ++ distTag dist] + +rpkgBuild :: FilePath -> Dist -> Maybe String -> String -> Bool -> IO () +rpkgBuild topdir dist mtarget nvr waitrepo = do + giturl <- cmd (rpkg dist) ["giturl"] + let target = fromMaybe (distTarget dist) mtarget + out <- cmd (kojicmd dist) ["build", "--nowait", "--fail-fast", target, 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" + when waitrepo $ kojiWaitPkg topdir dist nvr + 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] + +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 + diff --git a/src/Options.hs b/src/Options.hs new file mode 100644 --- /dev/null +++ b/src/Options.hs @@ -0,0 +1,10 @@ +module Options + (distArg) + where + +import FedoraDists +import Options.Applicative + +distArg :: Parser Dist +distArg = argument auto (metavar "DIST") + diff --git a/src/RPM.hs b/src/RPM.hs new file mode 100644 --- /dev/null +++ b/src/RPM.hs @@ -0,0 +1,143 @@ +-- | +-- Module : RPM +-- Copyright : (C) 2015-2019 Jens Petersen +-- +-- Maintainer : Jens Petersen +-- +-- Explanation: RPM utils + +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. + +module RPM (buildRequires, + derefSrcPkg, + haskellSrcPkgs, + Package, + packageManager, + pkgDir, + repoquery, + rpmInstall, + rpmspec) where + +#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,8,0)) +#else +import Control.Applicative ((<$>)) +#endif +import Control.Monad (when) +import Data.List (isPrefixOf, isSuffixOf, nub, (\\)) +import Data.Maybe (isJust, isNothing) +import System.Directory (doesDirectoryExist, findExecutable) +import System.FilePath (()) +-- die is available in ghc-7.10 base-4.8 +import System.Exit (ExitCode (..), exitFailure, exitWith) +import System.IO (hPutStrLn, stderr) + +import FedoraDists (Dist, distBranch, dists, distTag, releaseVersion) +import SimpleCmd (cmd, removeStrictPrefix, removeSuffix, sudo, (+-+)) +import qualified SimpleCmd.Rpm as S + +-- @since base 4.8.0.0 +die :: String -> IO a +die err = hPutStrLn stderr err >> exitFailure + +requireProgram :: String -> IO () +requireProgram c = do + mavail <- findExecutable c + when (isNothing mavail) $ die (c ++ ": command not found") + +optionalProgram :: String -> IO Bool +optionalProgram c = isJust <$> findExecutable c + +packageManager :: IO String +packageManager = do + havednf <- optionalProgram "dnf" + if havednf + then return "dnf" + else requireProgram "yum" >> return "yum" + +rpmInstall :: [String] -> IO () +rpmInstall rpms = do + pkginstaller <- packageManager + let (inst, arg) = if pkginstaller == "dnf" then ("dnf", "install") else ("yum", "localinstall") + sudo inst $ ["-y", "--nogpgcheck", arg] ++ rpms + +repoquery :: Dist -> [String] -> IO String +repoquery dist args = do + havednf <- optionalProgram "dnf" + let (prog, subcmd) = if havednf then ("dnf", ["repoquery", "--quiet"]) else ("repoquery", []) + releasever = ["--releasever=" ++ releaseVersion dist] + cmd prog (subcmd ++ releasever ++ args) + +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}"] + 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 dist (srcflag ++ repo ++ ["--whatprovides", key]) + return $ case res of + [p] -> Just p + ps | key `elem` ps -> Just key + _ -> Nothing + +rpmspec :: [String] -> Maybe String -> FilePath -> IO [String] +rpmspec args = + S.rpmspec (["--define", "ghc_version any"] ++ args) + +buildRequires :: FilePath -> IO [String] +buildRequires spec = + -- FIXME should resolve "pkgconfig()" etc + map (head . words) <$> 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 = removeStrictPrefix "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 -> Dist -> [Package] -> IO [Package] +haskellSrcPkgs topdir dist brs = do + ghcLibs <- do + let branch = distBranch dist + ghcDir <- pkgDir "ghc" branch topdir + filter isHaskellDevelPkg <$> rpmspec [] (Just "%{name}") (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/src/Utils.hs b/src/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils.hs @@ -0,0 +1,67 @@ +-- | +-- Module : Cmd +-- Copyright : (C) 2014, 2016-2018 Jens Petersen +-- +-- Maintainer : Jens Petersen +-- Stability : alpha +-- Portability : *nix +-- +-- Explanation: system/shell command utils + +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. + +module Utils (checkPkgsGit, + error', + withCurrentDirectory) where + +#if (defined(MIN_VERSION_directory) && MIN_VERSION_directory(1,2,3)) +import System.Directory (withCurrentDirectory) +#else +import Control.Exception (bracket) +import System.Directory (getCurrentDirectory, setCurrentDirectory) +#endif + +import SimpleCmd.Git (grepGitConfig) + + +-- singleLine :: String -> String +-- singleLine "" = "" +-- singleLine s = (head . lines) s + +-- 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) + +error' :: String -> a +#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,9,0)) +error' = errorWithoutStackTrace +#else +error' = error +#endif + +#if (defined(MIN_VERSION_directory) && MIN_VERSION_directory(1,2,3)) +#else +withCurrentDirectory :: FilePath -> IO a -> IO a +withCurrentDirectory dir action = + bracket getCurrentDirectory setCurrentDirectory $ \ _ -> do + setCurrentDirectory dir + action +#endif + +checkPkgsGit :: IO Bool +checkPkgsGit = + grepGitConfig "\\(pkgs\\|src\\)." + +-- 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)