fedora-haskell-tools 0.6 → 0.7
raw patch · 17 files changed
+1227/−1422 lines, 17 filesdep +fedora-distsdep +optparse-applicativedep +simple-cmddep ~basedep ~timenew-component:exe:fhmock
Dependencies added: fedora-dists, optparse-applicative, simple-cmd, simple-cmd-args, split
Dependency ranges changed: base, time
Files
- ChangeLog +14/−0
- Dists.hs +0/−91
- Koji.hs +0/−110
- README.md +9/−17
- RPM.hs +0/−146
- TODO +1/−0
- Utils.hs +0/−230
- fedora-haskell-tools.cabal +26/−20
- fhbuild.hs +0/−358
- fhbz.hs +15/−15
- fhmock.hs +99/−0
- fhpkg.hs +394/−435
- src/Build.hs +309/−0
- src/Koji.hs +140/−0
- src/Options.hs +10/−0
- src/RPM.hs +143/−0
- src/Utils.hs +67/−0
ChangeLog view
@@ -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
− Dists.hs
@@ -1,91 +0,0 @@--- |--- Module : Dists--- Copyright : (C) 2014-2017 Jens Petersen------ Maintainer : Jens Petersen <petersen@fedoraproject.org>--- 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
− Koji.hs
@@ -1,110 +0,0 @@--- |--- Module : Koji--- Copyright : (C) 2016-2017 Jens Petersen------ Maintainer : Jens Petersen <petersen@fedoraproject.org>--- 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]
README.md view
@@ -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.
− RPM.hs
@@ -1,146 +0,0 @@--- |--- Module : RPM--- Copyright : (C) 2015-2017 Jens Petersen------ Maintainer : Jens Petersen <petersen@fedoraproject.org>------ 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 ""
TODO view
@@ -3,6 +3,7 @@ # fhpkg - use optparse-applicative - only print header if output+- license-check command (from fhpkg.hs): - cache dist package lists?
− Utils.hs
@@ -1,230 +0,0 @@--- |--- Module : Cmd--- Copyright : (C) 2014 Jens Petersen------ Maintainer : Jens Petersen <petersen@fedoraproject.org>--- 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]-
fedora-haskell-tools.cabal view
@@ -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 <petersen@fedoraproject.org> Maintainer: Jens Petersen <petersen@fedoraproject.org>-Copyright: 2014-2017 Jens Petersen <petersen@fedoraproject.org>+Copyright: 2014-2019 Jens Petersen <petersen@fedoraproject.org> 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
− fhbuild.hs
@@ -1,358 +0,0 @@--- |--- Module : Build--- Copyright : (C) 2014-2017 Jens Petersen------ Maintainer : Jens Petersen <petersen@fedoraproject.org>--- 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
fhbz.hs view
@@ -2,7 +2,7 @@ -- | -- Module : Bugzilla--- Copyright : (C) 2014-2017 Jens Petersen+-- Copyright : (C) 2014-2018 Jens Petersen -- -- Maintainer : Jens Petersen <petersen@fedoraproject.org> --@@ -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"]
+ fhmock.hs view
@@ -0,0 +1,99 @@+-- |+-- Module : Mock+-- Copyright : (C) 2018-2019 Jens Petersen+--+-- Maintainer : Jens Petersen <petersen@fedoraproject.org>+--+-- 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"+
fhpkg.hs view
@@ -1,6 +1,6 @@ -- | -- Module : Packages--- Copyright : (C) 2017 Jens Petersen+-- Copyright : (C) 2017-2019 Jens Petersen -- -- Maintainer : Jens Petersen <petersen@fedoraproject.org> -- 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)
+ src/Build.hs view
@@ -0,0 +1,309 @@+-- |+-- Module : Build+-- Copyright : (C) 2014-2019 Jens Petersen+--+-- Maintainer : Jens Petersen <petersen@fedoraproject.org>+-- 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
+ src/Koji.hs view
@@ -0,0 +1,140 @@+-- |+-- Module : Koji+-- Copyright : (C) 2016-2019 Jens Petersen+--+-- Maintainer : Jens Petersen <petersen@fedoraproject.org>+-- 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+
+ src/Options.hs view
@@ -0,0 +1,10 @@+module Options+ (distArg)+ where++import FedoraDists+import Options.Applicative++distArg :: Parser Dist+distArg = argument auto (metavar "DIST")+
+ src/RPM.hs view
@@ -0,0 +1,143 @@+-- |+-- Module : RPM+-- Copyright : (C) 2015-2019 Jens Petersen+--+-- Maintainer : Jens Petersen <petersen@fedoraproject.org>+--+-- 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 ""
+ src/Utils.hs view
@@ -0,0 +1,67 @@+-- |+-- Module : Cmd+-- Copyright : (C) 2014, 2016-2018 Jens Petersen+--+-- Maintainer : Jens Petersen <petersen@fedoraproject.org>+-- 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)