fbrnch 1.4 → 1.5
raw patch · 44 files changed
+1626/−956 lines, 44 filesdep +eitherdep +fedora-releasesdep +saydep −fedora-distsdep ~copr-apidep ~paguredep ~rpmbuild-order
Dependencies added: either, fedora-releases, say, select-rpms, unordered-containers
Dependencies removed: fedora-dists
Dependency ranges changed: copr-api, pagure, rpmbuild-order, simple-prompt
Files
- CHANGELOG.md +56/−0
- README.md +19/−10
- fbrnch.cabal +17/−7
- src/Bodhi.hs +3/−2
- src/Branches.hs +35/−17
- src/Bugzilla.hs +2/−2
- src/Cmd/Autospec.hs +34/−0
- src/Cmd/Build.hs +104/−100
- src/Cmd/Bump.hs +89/−56
- src/Cmd/Clone.hs +16/−10
- src/Cmd/Commit.hs +30/−23
- src/Cmd/Compare.hs +20/−12
- src/Cmd/Copr.hs +284/−96
- src/Cmd/Diff.hs +11/−7
- src/Cmd/FTBFS.hs +1/−1
- src/Cmd/Fetch.hs +21/−0
- src/Cmd/Import.hs +94/−46
- src/Cmd/Install.hs +19/−57
- src/Cmd/ListBranches.hs +7/−3
- src/Cmd/ListPackages.hs +18/−17
- src/Cmd/Local.hs +3/−26
- src/Cmd/Parallel.hs +33/−16
- src/Cmd/PkgReview.hs +4/−28
- src/Cmd/Prep.hs +12/−6
- src/Cmd/Pull.hs +56/−0
- src/Cmd/PullPush.hs +0/−79
- src/Cmd/Push.hs +25/−0
- src/Cmd/RequestRepo.hs +18/−14
- src/Cmd/ReviewPackage.hs +127/−0
- src/Cmd/Reviews.hs +6/−4
- src/Cmd/Scratch.hs +1/−0
- src/Cmd/Sort.hs +3/−1
- src/Cmd/Status.hs +89/−147
- src/Cmd/Unpushed.hs +65/−0
- src/Cmd/Update.hs +11/−23
- src/Git.hs +2/−1
- src/Koji.hs +18/−8
- src/ListReviews.hs +21/−6
- src/Main.hs +75/−45
- src/Package.hs +90/−31
- src/Pagure.hs +1/−0
- src/Repoquery.hs +9/−5
- src/RpmBuild.hs +72/−49
- src/Types.hs +5/−1
CHANGELOG.md view
@@ -1,5 +1,61 @@ # Changelog +## 1.5 (2024-08-17)+* fedora-releases (using bodhi) replaces fedora-dists (pdc): explicit imports+- 'bugs': also include product in prefix+- 'bump': fix handling of autorelease+- 'clone': --group allows cloning all of group's packages (#46)+- 'clone': print no of repos+- 'command' --if-output: drop trailing newline+- 'commit': add --dryrun+- 'commit': require --message for %autochangelog+- 'compare': no longer reorders branches, checks their existence+- 'copr --new': create a new copr project+* 'copr': no longer rebuilds nvr's unless --force+* 'copr': does not resubmit existing successful or in-progress nvr's+- 'copr': add --monitor+- 'copr': fix bug where only first two source packages got built+- 'copr': sort chroots by arch; distless srpm+- 'diff' can now take multiple filters+- 'ftbfs': use --details with koji-tool+- 'import': if no branches requested, skip requestPkgBranches+* 'install': use select-rpms library refactored from koji-tool+- 'list': check number of results and prompt if >1000 unless --force+* 'parallel': support chain-build args with colon interspersed layers+- 'parallel': retry kojiWaitTask+- 'parallel': --must-push to enforce commit bumps+- 'parallel': koji-tool use --children to get failed buildArch+- 'parallel': only do parallelBranches build if more than 1 branch+* 'parallel': better concurrent output with say library+* 'prep','update': use cwd for %_sourcedir+- 'prep': --allow-head+- 'pull': add --rebase+- 'push': print log relative to origin+- 'repoquery': add testing repos (not yet using fedora-repoquery)+- 'request-repo': retry listing existing scm requests+- 'request-repos': add --skip-request-check and rename --retry to --resubmit+* 'review-package --interactive': new lighter review mode without mock+* 'reviews': new --assignee, --submitted and --submitter options+* 'sort': default to chain-build output+- 'sort': skip getDynSourcesMacros for dead.package+- 'status': add --latest-commit+- 'unpush --bump': now uses 'bump' code+- 'unpushed': add --check-nvr and do not print every "dead package"+* 'update': git add patches+- 'update-review': end with bug url+- '--dryrun' is now an alias for '--dry-run'+- Package pkgNameVerRelDist: use fedpkg verrel if autorelease+- RpmBuild: checkSourcesMatch yesNo prompt for git amend+- fix stack build of HsOpenSSL with gcc14 -Wno-incompatible-pointer-types+- fix systemBranch to determine rawhide correctly via distBranch+- generateSrpmNoDist: also warn if generated srpm is different to prediction+- generateSrpmNoDist: fallback to fedpkg for autospec+- kojiWatchTask: use koji-tool tasks --children to get failed task+- module refactorings from Local, PkgReview, PullPush, Status+- more consistent prompt handling of 'commit'/'update'/'review' messages+- require rpmbuild-order 0.4.12 to order rust crates and rubygems+- withPackagesByBranches: git fetch earlier to get new branches+ ## 1.4 (2024-05-03) - buildSrpm: filter .src.rpm filename - checkSourcesMatch: prompt before amending and abort if still dirty
README.md view
@@ -9,7 +9,7 @@ Fedora developers use a lot of time building packages across releases and workflow for adding new packages, etc. fbrnch was made to help (semi-)automate common workflows to save time-and effort, and avoid common some mistakes.+and effort, and avoid some common mistakes. fbrnch is distributed under the GPL license version 2 or later. @@ -39,7 +39,7 @@ One can change the branch of one or more packages: ```-$ fbrnch switch f40 [package] ...+$ fbrnch switch f41 [package] ... ``` You can also git pull over packages:@@ -97,13 +97,13 @@ You can merge branches with: ```-$ fbrnch merge f39 package+$ fbrnch merge f40 package ```-which will offer to merge f39 (or up to a git hash you choose) into f38.+which will offer to merge f41 (or up to a git hash you choose) into f40. Merging can also be done together with building: ```-$ fbrnch build f39 package+$ fbrnch build f41 package ``` will ask if you want to merge newer commits from a newer branch, then push and build it.@@ -181,6 +181,10 @@ builds a list of packages in a sidetag (generating it if no sidetags exist) in parallel ordered by build dependencies. +For a long list of packages, it is generally better to+`fbrnch sort` them first and then use the generated chain-build style+output as arguments to `fbrnch parallel`.+ When building for a branch, merging from the next newer branch will be offered unless using `--no-merge` (then you may prefer to run `fbrnch merge <branch> ...` first instead).@@ -190,7 +194,8 @@ you can select one using `--target`. They can be listed with `fbrnch sidetags`. -After parallel building you can create a Bodhi update from the sidetag.+After parallel building completes,+you can create a Bodhi update from the sidetag. It is also possible to build a package in parallel across branches and push them to Bodhi.@@ -220,13 +225,16 @@ $ fbrnch reviews ``` They can be filtered by status with various options like-`--approved` or `--created` (or another bugzilla `--user`).+`--approved` or `--created` (or another bugzilla `--submitter`), etc. One can also search for the review(s) of a specific package with: ``` $ fbrnch find-review package-name ``` +Package reviews can be performed with `fbrnch review-package`.+It also has a lightweight `--interactive` mode for streamlined reviews.+ #### Request repos Once a review has been approved ```@@ -262,7 +270,7 @@ `$ fbrnch --version` ```-1.4+1.5 ``` `$ fbrnch --help`@@ -299,7 +307,8 @@ scratch-x86_64 Koji x86_64 scratch build of package update-sources Download and update newer sources update-version Update package in dist-git to newer version- sort Sort packages in build dependency order+ sort Sort packages in build dependency order (default+ format: chain-build) prep Prep sources local Build locally srpm Build srpm@@ -443,7 +452,7 @@ - Lightning talk for devconf.cz 2021: [youtube](https://www.youtube.com/watch?v=O2-6rDuPMRA&t=2s) ## Contribute-Bug reports, feedback, and pull requests are all highly appreciated.+Bug reports, feedback, and pull requests are all much appreciated. Do report any unsupported or inconsistent workflow steps.
fbrnch.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: fbrnch-version: 1.4+version: 1.5 synopsis: Fedora packager tool to build package branches description: fbrnch (fedora branch or "f-branch" for short) is@@ -47,6 +47,7 @@ other-modules: Bodhi Branches Bugzilla+ Cmd.Autospec Cmd.Bugs Cmd.Build Cmd.Bump@@ -55,6 +56,7 @@ Cmd.Compare Cmd.Copr Cmd.Diff+ Cmd.Fetch Cmd.FTBFS Cmd.Import Cmd.Install@@ -68,10 +70,12 @@ Cmd.Parallel Cmd.PkgReview Cmd.Prep- Cmd.PullPush+ Cmd.Pull+ Cmd.Push --Cmd.Repoquery Cmd.RequestBranch Cmd.RequestRepo+ Cmd.ReviewPackage Cmd.Reviews Cmd.Scratch Cmd.SideTags@@ -79,6 +83,7 @@ Cmd.SrcDeps Cmd.Status Cmd.Switch+ Cmd.Unpushed Cmd.Update Cmd.WaitRepo Common@@ -108,26 +113,29 @@ bugzilla-redhat >= 1.0.1, bytestring, config-ini,- copr-api,+ copr-api >= 0.2, directory >= 1.2.3,+ either, email-validate, extra,- fedora-dists >= 2.1.1,+ fedora-releases, filepath, http-conduit, http-directory >= 0.1.5, http-query, koji, network-uri,- pagure >= 0.1,+ pagure >= 0.2.1, pretty-terminal, process, -- regex-tdfa,- rpmbuild-order >= 0.4.11,+ rpmbuild-order >= 0.4.12, rpm-nvr >= 0.1.2,+ say,+ select-rpms, simple-cmd >= 0.2.3, simple-cmd-args >= 0.1.8,- simple-prompt >= 0.2,+ simple-prompt >= 0.2.3, text, time, typed-process >= 0.2.4.0,@@ -139,6 +147,8 @@ build-depends: semigroups if impl(ghc<8.4) build-depends: http-common < 0.8.3.4+ if impl(ghc<9)+ build-depends: unordered-containers ghc-options: -threaded -Wall
src/Bodhi.hs view
@@ -29,6 +29,7 @@ import Common.System import qualified Common.Text as T import Package+import Types (ChangeType(ChangeBodhi)) checkAutoBodhiUpdate :: Branch -> IO Bool checkAutoBodhiUpdate Rawhide = return True@@ -147,10 +148,10 @@ then getSummaryURL spec else if usechangelog- then cleanChangelog spec+ then cleanChangelog True spec else -- FIXME list open bugs- changeLogPrompt True spec+ changeLogPrompt ChangeBodhi spec if trim (lower changelog) `elem` ["no","n"] then return False else do
src/Branches.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ module Branches ( activeBranches, fedoraBranches,@@ -7,12 +9,11 @@ localBranches, pagurePkgBranches, mockRoot,- module Distribution.Fedora.Branch,+ Branch(..), AnyBranch(..), anyBranch, isRelBranch, onlyRelBranch,- partitionBranches, BranchOpts(..), listOfBranches, listOfAnyBranches,@@ -29,16 +30,17 @@ gitLines ) where -import Common-import Common.System--import Data.Either-import Data.Tuple-import Distribution.Fedora.Branch+import Data.Either (partitionEithers)+import Distribution.Fedora.Branch (Branch(..), eitherBranch, getFedoraBranched,+ getFedoraBranches, getLatestFedoraBranch,+ readActiveBranch, eitherActiveBranch,+ readBranch) import SimpleCmd.Git import SimplePrompt (promptEnter, promptInitial) import qualified System.Info (arch) +import Common+import Common.System import Pagure data AnyBranch = RelBranch Branch | OtherBranch String@@ -58,10 +60,6 @@ show (RelBranch br) = show br show (OtherBranch obr) = obr -partitionBranches :: [String] -> ([Branch],[String])-partitionBranches args =- swap . partitionEithers $ map eitherBranch args- activeBranches :: [Branch] -> [String] -> [Branch] activeBranches active = -- newest branch first@@ -126,8 +124,19 @@ onlyRelBranch (OtherBranch br) = error' $ "Non-release branch not allowed:" +-+ br systemBranch :: IO Branch-systemBranch =- readBranch' . init . removePrefix "PLATFORM_ID=\"platform:" <$> cmd "grep" ["PLATFORM_ID=", "/etc/os-release"]+systemBranch = do+ platform <- init . removePrefix "PLATFORM_ID=\"platform:" <$> cmd "grep" ["PLATFORM_ID=", "/etc/os-release"]+ if platform == "eln"+ then return Rawhide+ else+ case readBranch platform of+ Just br -> do+ branched <- getLatestFedoraBranch+ return $+ if br > branched+ then Rawhide+ else br+ Nothing -> error' $ "could not determine system branch from platform" +-+ platform listOfBranches :: Bool -> Bool -> BranchesReq -> IO [Branch] listOfBranches distgit _active (BranchOpt AllBranches) =@@ -209,7 +218,6 @@ gitCurrentBranchWarn else return br - checkOnBranch :: IO () checkOnBranch = void gitCurrentBranch @@ -237,8 +245,7 @@ AllFedora -> filter isFedoraBranch activenew AllEPEL -> filter isEPELBranch activenew ExcludeBranches xbrs -> activenew \\ xbrs- inp <- promptInitial "Confirm branches to request" $ unwords (map show requested)- return $ map (readActiveBranch' activenew) $ words inp+ confirmBranches activenew requested where branchingPrompt :: [Branch] -> IO [Branch] branchingPrompt active = do@@ -248,6 +255,17 @@ in if all isRelBranch abrs then return $ map onlyRelBranch abrs else branchingPrompt active++ confirmBranches :: [Branch] -> [Branch] -> IO [Branch]+ confirmBranches activenew requested = do+ inp <- promptInitial "Confirm branches to request" $ unwords (map show requested)+ let (errs,oks) = partitionEithers $+ map (eitherActiveBranch activenew) $ words inp+ if null errs+ then return oks+ else do+ putStrLn $ "unknown branches:" +-+ unwords errs+ confirmBranches activenew requested data BranchesReq = BranchOpt BranchOpts | Branches [Branch]
src/Bugzilla.hs view
@@ -428,10 +428,10 @@ putBugVer :: Bug -> IO () putBugVer bug = do- T.putStr $ "[" <> prodVersion <> "] "+ T.putStr $ "[" <> pref <> "] " putBug bug where- prodVersion = T.unwords (bugVersion bug)+ pref = T.unwords (bugProduct bug : bugVersion bug) putBugId :: BugId -> IO () putBugId bid =
+ src/Cmd/Autospec.hs view
@@ -0,0 +1,34 @@+module Cmd.Autospec (+ autospecCmd+ )+where++import Control.Monad.Extra (unlessM)+import SimpleCmd (cmd, cmd_)+import System.Directory (doesFileExist)++import Branches+import Git+import Package++-- FIXME calculate baserelease+autospecCmd :: Bool -> [String] -> IO ()+autospecCmd force pkgs =+ withPackagesByBranches HeaderMay False cleanGitFetchActive ExactlyOne autospecPkg (Branches [Rawhide], pkgs)+ where+ autospecPkg :: Package -> AnyBranch -> IO ()+ autospecPkg _pkg br = do+ gitSwitchBranch br+ let changelogfile = "changelog"+ exists <- doesFileExist changelogfile+ if exists+ then+ if force+ then do+ cmd "rpmautospec" ["generate-changelog"] >>=+ writeFile changelogfile+ unlessM (null <$> git "status" ["--porcelain", "--untracked=no"]) $ do+ git_ "add" [changelogfile]+ git_ "commit" ["-m", "refresh changelog"]+ else putStrLn "'changelog' file already exists"+ else cmd_ "rpmautospec" ["convert"]
src/Cmd/Build.hs view
@@ -5,14 +5,14 @@ BuildOpts(..) ) where +import Distribution.Fedora.Branch (branchDestTag, branchTarget) import SimplePrompt (promptEnter, yesNo) -import Common-import Common.System- import Bodhi import Bugzilla import Branches+import Common+import Common.System import Cmd.Merge import Git import Krb@@ -121,109 +121,113 @@ if tty && (not merged || (newrepo && ancestor && length unmerged == 1)) then refPrompt unpushed $ "Press Enter to push and build" ++ (if length unpushed > 1 then "; or give ref to push" else "") ++ (if not newrepo then "; or 'no' to skip pushing" else "") else return $ Just $ commitRef $ head unpushed- let dryrun = buildoptDryrun opts- buildstatus <- maybeTimeout 30 $ kojiBuildStatus nvr let msidetagTarget = buildoptSidetagTarget opts- mwaitrepo = buildoptWaitrepo opts target <- targetMaybeSidetag dryrun True br msidetagTarget- case buildstatus of- Just BuildComplete -> do- putStrLn $ showNVR nvr +-+ "is already built"- when (isJust mpush) $- error' "Please bump the spec file"- when (br /= Rawhide && isNothing msidetagTarget) $ do- updateExists <- maybeTimeout 30 $ bodhiBuildExists nvr- autoupdate <- checkAutoBodhiUpdate br- -- FIXME update referenced bugs for autoupdate branch- unless autoupdate $ do- if updateExists- then putStrLn "update exists"- else do- mbug <- bzReviewAnon- bodhiUpdate dryrun (buildoptUpdate opts) mbug (buildoptUseChangelog opts) spec $ showNVR nvr- whenJust moverride $ \days -> do- tags <- maybeTimeout 30 $ kojiNVRTags nvr- unless (any (`elem` tags) [show br, show br ++ "-updates", show br ++ "-override"]) $- bodhiCreateOverride dryrun (Just days) nvr- when (isJust mlastpkg && mlastpkg /= Just pkg || mwaitrepo == Just True) $- when ((isJust moverride && mwaitrepo /= Just False) ||- (autoupdate && mwaitrepo == Just True)) $- kojiWaitRepo dryrun True True target nvr- Just BuildBuilding -> do- putStrLn $ showNVR nvr +-+ "is already building"- when (isJust mpush) $- error' "Please bump the spec file"- whenJustM (kojiGetBuildTaskID fedoraHub (showNVR nvr)) kojiWatchTask- -- FIXME do override- _ -> do- mbuildref <-- case mpush of- Nothing -> Just <$> git "show-ref" ["--hash", "origin/" ++ show br]- _ -> return mpush- opentasks <- kojiOpenTasks pkg mbuildref target- case opentasks of- [task] -> do- putStrLn $ showNVR nvr +-+ "task" +-+ displayID task +-+ "is already open"+ buildRun spec nvr merged mpush unpushed target msidetagTarget moverride+ where+ dryrun = buildoptDryrun opts++ buildRun spec nvr merged mpush unpushed target msidetagTarget moverride = do+ let mwaitrepo = buildoptWaitrepo opts+ buildstatus <- maybeTimeout 30 $ kojiBuildStatus nvr+ case buildstatus of+ Just BuildComplete -> do+ putStrLn $ showNVR nvr +-+ "is built" when (isJust mpush) $ error' "Please bump the spec file"- kojiWatchTask task- (_:_) -> error' $ show (length opentasks) +-+ "open" +-+ unPackage pkg +-+ "tasks already!"- [] -> do- let tag =- if target == branchTarget br then branchDestTag br else target- mlatest <- kojiLatestNVR tag $ unPackage pkg- if equivNVR nvr mlatest- then putStrLn $ showNVR nvr +-+ "is already latest" +-+ if Just nvr /= mlatest then "(modulo disttag)" else ""- else do- when (null unpushed || merged && br /= Rawhide) $ do- putStrLn $ showNVR nvr ++ "\n"- firstBuild <- do- mtestingRepo <- bodhiTestingRepo br- case mtestingRepo of- Nothing -> return $ isNothing mlatest- Just testing -> do- mnewest <- kojiLatestNVR testing $ unPackage pkg- case mnewest of- Nothing -> return $ isNothing mlatest- Just newest -> do- newestTags <- kojiNVRTags newest- unless (any (`elem` newestTags) [show br, show br ++ "-updates", show br ++ "-updates-pending"]) $ do- -- FIXME print how many days left- putStrLn $ "Warning:" +-+ showNVR newest +-+ "still in testing?"- promptEnter "Press Enter to continue"- return False- unless (buildoptStash opts) $- unlessM isGitDirClean $- error' "local changes remain (dirty)"- unless dryrun krbTicket- whenJust mpush $ \ref ->- unless dryrun $- gitPush False $ Just $ ref ++ ":" ++ show br- unlessM (null <$> gitOneLineLog ("origin/" ++ show br ++ "..HEAD")) $- unless dryrun $ do- ok <- yesNo "Unpushed changes remain, continue"- unless ok $ error' "aborted"- -- FIXME parse build output- unless dryrun $- kojiBuildBranch target pkg mbuildref ["--fail-fast" | not (buildoptNoFailFast opts)]- mBugSess <-- if firstBuild && isJust (fst (buildoptUpdate opts))- then bzReviewSession- else return Nothing+ when (br /= Rawhide && isNothing msidetagTarget) $ do+ updateExists <- maybeTimeout 30 $ bodhiBuildExists nvr autoupdate <- checkAutoBodhiUpdate br- if autoupdate- then whenJust mBugSess $- \ (bid,session) -> putBugBuild dryrun session bid nvr- else do- when (isNothing msidetagTarget) $ do- whenJust (fmap fst mBugSess) $- \bid -> putStr "review bug: " >> putBugId bid- -- FIXME diff previous changelog?- bodhiUpdate dryrun (buildoptUpdate opts) (fmap fst mBugSess) (buildoptUseChangelog opts) spec $ showNVR nvr- -- FIXME prompt for override note- whenJust moverride $ \days ->+ -- FIXME update referenced bugs for autoupdate branch+ unless autoupdate $ do+ if updateExists+ then putStrLn "update exists"+ else do+ mbug <- bzReviewAnon+ bodhiUpdate dryrun (buildoptUpdate opts) mbug (buildoptUseChangelog opts) spec $ showNVR nvr+ whenJust moverride $ \days -> do+ tags <- maybeTimeout 30 $ kojiNVRTags nvr+ unless (any (`elem` tags) [show br, show br ++ "-updates", show br ++ "-override"]) $ bodhiCreateOverride dryrun (Just days) nvr when (isJust mlastpkg && mlastpkg /= Just pkg || mwaitrepo == Just True) $ when ((isJust moverride && mwaitrepo /= Just False) || (autoupdate && mwaitrepo == Just True)) $- kojiWaitRepo dryrun True True target nvr+ kojiWaitRepo dryrun True True target nvr+ Just BuildBuilding -> do+ putStrLn $ showNVR nvr +-+ "is already building"+ when (isJust mpush) $+ error' "Please bump the spec file"+ whenJustM (kojiGetBuildTaskID fedoraHub (showNVR nvr)) kojiWatchTask+ buildRun spec nvr merged mpush unpushed target msidetagTarget moverride+ _ -> do+ mbuildref <-+ case mpush of+ Nothing -> Just <$> git "show-ref" ["--hash", "origin/" ++ show br]+ _ -> return mpush+ opentasks <- kojiOpenTasks pkg mbuildref target+ case opentasks of+ [task] -> do+ putStrLn $ showNVR nvr +-+ "task" +-+ displayID task +-+ "is already open"+ when (isJust mpush) $+ error' "Please bump the spec file"+ kojiWatchTask task+ (_:_) -> error' $ show (length opentasks) +-+ "open" +-+ unPackage pkg +-+ "tasks already!"+ [] -> do+ let tag =+ if target == branchTarget br then branchDestTag br else target+ mlatest <- kojiLatestNVR tag $ unPackage pkg+ if equivNVR nvr mlatest+ then putStrLn $ showNVR nvr +-+ "is already latest" +-+ if Just nvr /= mlatest then "(modulo disttag)" else ""+ else do+ when (null unpushed || merged && br /= Rawhide) $ do+ putStrLn $ showNVR nvr ++ "\n"+ firstBuild <- do+ mtestingRepo <- bodhiTestingRepo br+ case mtestingRepo of+ Nothing -> return $ isNothing mlatest+ Just testing -> do+ mnewest <- kojiLatestNVR testing $ unPackage pkg+ case mnewest of+ Nothing -> return $ isNothing mlatest+ Just newest -> do+ newestTags <- kojiNVRTags newest+ unless (any (`elem` newestTags) [show br, show br ++ "-updates", show br ++ "-updates-pending"]) $ do+ -- FIXME print how many days left+ putStrLn $ "Warning:" +-+ showNVR newest +-+ "still in testing?"+ promptEnter "Press Enter to continue"+ return False+ unless (buildoptStash opts) $+ unlessM isGitDirClean $+ error' "local changes remain (dirty)"+ unless dryrun krbTicket+ whenJust mpush $ \ref ->+ unless dryrun $+ gitPush False $ Just $ ref ++ ":" ++ show br+ unlessM (null <$> gitOneLineLog ("origin/" ++ show br ++ "..HEAD")) $+ unless dryrun $ do+ ok <- yesNo "Unpushed changes remain, continue"+ unless ok $ error' "aborted"+ -- FIXME parse build output+ unless dryrun $+ kojiBuildBranch target pkg mbuildref ["--fail-fast" | not (buildoptNoFailFast opts)]+ mBugSess <-+ if firstBuild && isJust (fst (buildoptUpdate opts))+ then bzReviewSession+ else return Nothing+ autoupdate <- checkAutoBodhiUpdate br+ if autoupdate+ then whenJust mBugSess $+ \ (bid,session) -> putBugBuild dryrun session bid nvr+ else do+ when (isNothing msidetagTarget) $ do+ whenJust (fmap fst mBugSess) $+ \bid -> putStr "review bug: " >> putBugId bid+ -- FIXME diff previous changelog?+ bodhiUpdate dryrun (buildoptUpdate opts) (fmap fst mBugSess) (buildoptUseChangelog opts) spec $ showNVR nvr+ -- FIXME prompt for override note+ whenJust moverride $ \days ->+ bodhiCreateOverride dryrun (Just days) nvr+ when (isJust mlastpkg && mlastpkg /= Just pkg || mwaitrepo == Just True) $+ when ((isJust moverride && mwaitrepo /= Just False) ||+ (autoupdate && mwaitrepo == Just True)) $+ kojiWaitRepo dryrun True True target nvr
src/Cmd/Bump.hs view
@@ -1,8 +1,12 @@ module Cmd.Bump- ( bumpPkgs,+ ( bumpCmd,+ bumpPkg ) where +import Distribution.Fedora.Branch (branchDestTag)+import System.IO.Extra+ import Branches import Common import Common.System@@ -10,65 +14,94 @@ import Koji import Package -import System.IO.Extra- -- FIXME --force -- FIXME --target-bumpPkgs :: Bool -> Bool -> Maybe CommitOpt -> Maybe String+bumpCmd :: Bool -> Bool -> Maybe String -> Maybe String -> (BranchesReq,[String]) -> IO ()-bumpPkgs dryrun local mopt mclog =+bumpCmd dryrun local mcmsg mclog = withPackagesByBranches (boolHeader local) False (if local then cleanGit else cleanGitFetchActive)- AnyNumber bumpPkg- where- bumpPkg :: Package -> AnyBranch -> IO ()- bumpPkg pkg br = do- dead <- doesFileExist "dead.package"- if dead- then putStrLn "dead package"+ AnyNumber (bumpPkg dryrun local mcmsg mclog)++bumpPkg :: Bool -> Bool -> Maybe String -> Maybe String+ -> Package -> AnyBranch -> IO ()+bumpPkg dryrun local mcmsg mclog pkg br = do+ dead <- doesFileExist "dead.package"+ if dead+ then putStrLn "dead package"+ else do+ spec <- localBranchSpecFile pkg br+ unpushed <- gitOneLineLog $ "origin/" ++ show br ++ "..HEAD"+ displayCommits True unpushed+ autorelease <- isAutoRelease spec+ if autorelease+ then+ if not (null unpushed)+ then putStrLn $ "autorelease: unpushed" +-++ case length unpushed of+ 1 -> "commit"+ n -> show n +-+ "commits"+ else+ if dryrun+ then putStrLn "autorelease: bump with commit" else do- spec <- localBranchSpecFile pkg br- rbr <-- case br of- RelBranch rbr -> return rbr- OtherBranch _ -> systemBranch- newnvr <- pkgNameVerRel' rbr spec- moldnvr <-- if local- then- withTempFile $ \tempfile -> do- git "show" ["origin:" ++ spec] >>= writeFile tempfile- pkgNameVerRel rbr tempfile- else- case br of- RelBranch rbr' ->- let tag = branchDestTag rbr'- in kojiLatestNVR tag $ unPackage pkg- -- FIXME fallback to local?- _ -> return Nothing- if equivNVR newnvr moldnvr- then do- git_ "log" ["origin..HEAD", "--pretty=oneline"]- let clmsg =- case mclog of- Just clog -> clog- Nothing ->- case mopt of- Just (CommitMsg msg) -> msg- _ -> "rebuild"- autorelease <- isAutoRelease spec- unless (autorelease || dryrun) $- cmd_ "rpmdev-bumpspec" ["-c", clmsg, spec] let copts =- case mopt of- Nothing -> ["-m", if autorelease then "rebuild" else "bump release"]- Just opt ->- case opt of- CommitMsg msg -> ["-m", msg]- -- FIXME reject amend if already pushed- CommitAmend -> ["--amend", "--no-edit"]- -- FIXME quiet commit?- if dryrun- then putStrLn "would be bumped with commit"- else git_ "commit" $ "-a" : (if autorelease then ("--allow-empty" :) else id) copts- else putStrLn "already bumped"+ "-m" :+ case mcmsg of+ Just msg -> [msg]+ Nothing ->+ case mclog of+ Just cl -> [cl]+ Nothing -> ["bump release"]+ git_ "commit" $ "-a" : "--allow-empty" : copts+ else do+ rbr <-+ case br of+ RelBranch rbr -> return rbr+ OtherBranch _ -> systemBranch+ newnvr <- pkgNameVerRel' rbr spec+ moldnvr <-+ if local+ then do+ withTempDir $ \tempdir -> do+ git "show" ["origin:" ++ spec] >>=+ writeFile (tempdir </> spec)+ withCurrentDirectory tempdir $ do+ oldautorel <- isAutoRelease (tempdir </> spec)+ if not oldautorel+ then pkgNameVerRel rbr spec+ else do+ -- FIXME check version unchanged before cloning+ clonePkg True AnonClone (Just rbr) $ unPackage pkg+ withCurrentDirectory (unPackage pkg) $+ pkgNameVerRel rbr spec+ else+ case br of+ RelBranch rbr' ->+ let tag = branchDestTag rbr'+ in kojiLatestNVR tag $ unPackage pkg+ -- FIXME fallback to local?+ _ -> return Nothing+ whenJust moldnvr $ \o -> putStrLn $ showNVR o +-+ "->"+ putStrLn $ showNVR newnvr+ if equivNVR newnvr moldnvr+ then do+ git_ "log" ["origin..HEAD", "--pretty=oneline"]+ let clog =+ case mclog of+ Just cl -> cl+ Nothing ->+ case mcmsg of+ Just msg -> msg+ _ -> "rebuild"+ unless (autorelease || dryrun) $+ cmd_ "rpmdev-bumpspec" ["-c", clog, spec]+ let copts =+ case mcmsg of+ Nothing -> ["-m", "bump release"]+ Just msg -> ["-m", msg]+ -- FIXME quiet commit?+ if dryrun+ then putStrLn "would be bumped with commit"+ else git_ "commit" $ "-a" : (if autorelease then ("--allow-empty" :) else id) copts+ else putStrLn "already bumped"
src/Cmd/Clone.hs view
@@ -1,27 +1,33 @@ module Cmd.Clone (cloneCmd, CloneRequest(..)) where -import Common.System-import qualified Common.Text as T+import Control.Monad (when) import Branches+import Common.System+import qualified Common.Text as T import Krb import Package import Pagure -data CloneRequest = CloneUser (Maybe String)- | ClonePkgs (Maybe Branch, [String])+data CloneRequest = CloneGroup String+ | CloneUser (Maybe String)+ | ClonePkgs [String] -- FIXME allow pagure repo wildcard -- FIXME (detect commit rights or a ssh key?)-cloneCmd :: CloneRequest -> IO ()-cloneCmd request = do- (mbr,pkgs) <- case request of+cloneCmd :: Maybe Branch -> CloneRequest -> IO ()+cloneCmd mbr request = do+ pkgs <- case request of CloneUser mid -> do userid <- maybe fasIdFromKrb return mid- ps <- map (takeFileName . T.unpack) <$> pagureUserRepos srcfpo userid- return (Nothing, ps)+ map (takeFileName . T.unpack) <$> pagureUserRepos srcfpo userid -- FIXME detect/prevent "path/dir"- ClonePkgs mbps -> return mbps+ ClonePkgs ps -> return ps+ CloneGroup grp -> do+ map (takeFileName . T.unpack) <$> pagureGroupRepos srcfpo False grp mfas <- maybeFasIdFromKrb+ let no = length pkgs+ when (no > 1) $+ putStrLn $ "cloning" +-+ show no +-+ "pkg repos" let auth = maybe AnonClone (const UserClone) mfas mapM_ (clonePkg False auth mbr) pkgs
src/Cmd/Commit.hs view
@@ -1,5 +1,5 @@ module Cmd.Commit- ( commitPkgs,+ ( commitCmd, ) where @@ -14,9 +14,9 @@ -- FIXME use branches after all? -- FIXME handle multiline changelog entries with "-m description" -- FIXME --undo last change: eg undo accidential --amend--- FIXME for single package assume --all if no stage-commitPkgs :: Maybe CommitOpt -> Bool -> Bool -> [String] -> IO ()-commitPkgs mopt firstLine unstaged paths = do+-- FIXME --empty+commitCmd :: Bool -> Maybe CommitOpt -> Bool -> Bool -> [String] -> IO ()+commitCmd dryrun mopt firstLine unstaged paths = do when (isJust mopt && firstLine) $ error' "--first-line cannot be used with other commit msg options" if null paths@@ -41,26 +41,33 @@ Nothing -> do changelog <- do spec <- findSpecfile- clog <- lines <$> cleanChangelog spec- case clog of- [] -> readCommitMsg- [msg] -> return msg- msgs ->- if firstLine- then return $ removePrefix "- " $ head msgs- else do- diff <- git "diff" ["-U0", if addall then "HEAD" else "--cached"]- let newlogs =- filter (\c -> ('+' : c) `elem` lines (unquoteMacros diff)) clog- case newlogs of- [] -> putStrLn diff >> readCommitMsg- [msg] -> return (removePrefix "- " msg)- [m,m'] -> mapM_ putStrLn newlogs >>- return (unlines $ map (removePrefix "- ") [m,"",m'])- (m:ms) -> mapM_ putStrLn newlogs >>- return (unlines (removePrefix "- " m:"":ms))+ autochangelog <- grep_ "^%autochangelog" spec+ if autochangelog+ -- rpmautospec generates "Uncommitted changes"+ then error' "set commit msg with --message"+ else do+ clog <- lines <$> cleanChangelog True spec+ case clog of+ [] -> readCommitMsg+ [msg] -> return msg+ msgs ->+ if firstLine+ then return $ removePrefix "- " $ head msgs+ else do+ diff <- git "diff" ["-U0", if addall then "HEAD" else "--cached"]+ let newlogs =+ filter (\c -> ('+' : c) `elem` lines (unquoteMacros diff)) clog+ case newlogs of+ [] -> putStrLn diff >> readCommitMsg+ [msg] -> return (removePrefix "- " msg)+ [m,m'] -> mapM_ putStrLn newlogs >>+ return (unlines $ map (removePrefix "- ") [m,"",m'])+ (m:ms) -> mapM_ putStrLn newlogs >>+ return (unlines (removePrefix "- " m:"":ms)) return ["-m", changelog]- git_ "commit" $ ["-a" | addall] ++ opts+ if dryrun+ then cmdN "git" $ ["-a" | addall] ++ opts+ else git_ "commit" $ ["--dry-run" | dryrun] ++ ["-a" | addall] ++ opts readCommitMsg :: IO String readCommitMsg = do
src/Cmd/Compare.hs view
@@ -8,6 +8,7 @@ import Git import Package +-- FIXME warn if older branch ahead compareCmd :: Bool -> Maybe String -> AnyBranch -> AnyBranch -> [String] -> IO () compareCmd long mignore br1 br2 pkgs = do if null pkgs@@ -24,21 +25,28 @@ comparePkg pkgdir = withExistingDirectory pkgdir $ unlessM (doesFileExist "dead.package") $ do- let (br1',br2') =- case (br1, br2) of- (RelBranch b1, RelBranch b2) | b2 < b1 -> (br2,br1)- _ -> (br1,br2)- localbranches <- gitLines "branch" ["--format=%(refname:short)"]- forM_ [br1',br2'] $ \br ->- unless (show br `elem` localbranches) $ gitSwitchBranch br- output <- ignoredLines <$> gitLines "log" (["--format=reference" | not long] ++ [show br1' ++ ".." ++ show br2'])- unless (null output) $ do- unless (null pkgs) $- getPackageName pkgdir >>= putPkgHdr- mapM_ putStrLn output+ localbranches <- localBranches True+ oldcurrent <- gitCurrentBranch+ have1 <- haveBranch localbranches br1+ have2 <- haveBranch localbranches br2+ newcurrent <- gitCurrentBranch+ when (newcurrent /= oldcurrent) $+ gitSwitchBranch oldcurrent+ when (have1 && have2) $ do+ output <- ignoredLines <$> gitLines "log" (["--format=reference" | not long] ++ [show br1 ++ ".." ++ show br2])+ unless (null output) $ do+ unless (null pkgs) $+ getPackageName pkgdir >>= putPkgHdr+ mapM_ putStrLn output ignoredLines :: [String] -> [String] ignoredLines = case mignore of Nothing -> id Just ignore -> filter (not . (ignore `isInfixOf`))++ haveBranch :: [String] -> AnyBranch -> IO Bool+ haveBranch locals br =+ if show br `elem` locals+ then return True+ else gitSwitchBranch' True $ onlyRelBranch br
src/Cmd/Copr.hs view
@@ -1,70 +1,141 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} module Cmd.Copr ( BuildBy(..),- coprCmd+ coprCmd,+ CoprMode(..) ) where +import Data.Aeson.Types (Object)+#if MIN_VERSION_aeson(2,0,0)+import Data.Aeson.Key+import qualified Data.Aeson.KeyMap as M+#else+import qualified Data.HashMap.Strict as M+#endif+import Data.Char (isDigit)+import Data.Either.Combinators (whenLeft) import Data.Ini.Config+import Data.RPM.NVR (nvrVerRel)+import Data.RPM.VerRel (showVerRel)+import Data.Tuple.Extra (first)+import Distribution.Fedora.Branch (getFedoraBranches, getFedoraBranched) import Network.HTTP.Query (lookupKey, lookupKey') import System.Environment.XDG.BaseDir (getUserConfigDir) import System.Time.Extra (sleep) import Web.Fedora.Copr (coprChroots, fedoraCopr)-import Web.Fedora.Copr.API (coprGetBuild)+import Web.Fedora.Copr.API (coprGetBuild, coprGetBuildList, coprMonitorProject) import Branches import Common import Common.System import qualified Common.Text as T import Package-import RpmBuild (generateSrpm)+import RpmBuild (generateSrpmNoDist) import Types (Archs(..)) -data BuildBy = SingleBuild | ValidateByRelease | ValidateByArch | BuildByRelease- deriving (Eq)+data BuildBy = SingleBuild+ | ValidateByRelease+ | ValidateByArch+ | BuildByRelease+ deriving Eq coprServer :: String coprServer = "copr.fedorainfracloud.org" +data Chroot = Chroot { chrootBranch :: Branch+ , chrootArch :: Arch }+ deriving Eq++releaseToBranch :: String -> Branch+releaseToBranch release+ | "fedora-" `isPrefixOf` release =+ case dropPrefix "fedora-" release of+ "rawhide" -> Rawhide+ n | all isDigit n -> Fedora (read n)+ | otherwise -> error' $ "unknown fedora release:" +-+ release+ | "epel-" `isPrefixOf` release =+ let next = "-next" `isSuffixOf` release+ in case dropSuffix "-next" (dropPrefix "epel-" release) of+ n | all isDigit n -> (if next then EPELNext else EPEL) $ read n+ | otherwise -> error' $ "unknown epel release:" +-+ release+ | otherwise = error' $ "unknown release:" +-+ release++branchToRelease :: Branch -> String+branchToRelease Rawhide = "fedora-rawhide"+branchToRelease (Fedora n) = "fedora-" ++ show n+branchToRelease (EPEL n) = "epel-" ++ show n+branchToRelease (EPELNext n) = "epel-" ++ show n ++ "-next"++readChroot :: String -> Chroot+readChroot ch =+ case stripInfixEnd "-" ch of+ Nothing -> error' $ "invalid chroot:" +-+ ch+ Just (b,a) -> Chroot (releaseToBranch b) (readArch a)++showChroot :: Chroot -> String+showChroot (Chroot br ar) = branchToRelease br ++ '-' : showArch ar++data Arch = X86_64 | I686 | AARCH64 | PPC64LE | S390X+ deriving (Eq, Enum)++allCoprArchs :: [Arch]+allCoprArchs = [X86_64 ..]++readArch :: String -> Arch+readArch "x86_64" = X86_64+readArch "i686" = I686+readArch "aarch64" = AARCH64+readArch "ppc64le" = PPC64LE+readArch "s390x" = S390X+readArch a = error' $ "unknown arch:" +-+ a++showArch :: Arch -> String+showArch X86_64 = "x86_64"+showArch I686 = "i686"+showArch AARCH64 = "aarch64"+showArch PPC64LE = "ppc64le"+showArch S390X = "s390x"++data CoprMode = ListChroots | CoprMonitor | CoprBuild | CoprNew++-- FIXME take ExclusiveArch/ExcludeArch into account+-- FIXME -1 for only first unbuilt chroot+-- FIXME check branch -- FIXME handle fedora-eln -- FIXME make project optional (if same as pkg??) or configurable ? -- FIXME repo config with a setup command? -- FIXME interact with copr dist-git -- FIXME parallel copr builds--- FIXME --exclude-arch--- FIXME skip existing builds--- FIXME distless srpm -- FIXME time builds?-coprCmd :: Bool -> Bool -> BuildBy -> Maybe Archs -> String+coprCmd :: Bool -> CoprMode -> Bool -> BuildBy -> Maybe Archs -> String -> (BranchesReq,[String]) -> IO ()-coprCmd dryrun listchroots buildBy marchs project (breq, pkgs) = do- chroots <- coprGetChroots- if listchroots- then mapM_ putStrLn chroots- else- if null pkgs then do- pkg <- do- dirpkg <- getPackageName "."- exists <- doesFileExist $ packageSpec dirpkg- if exists- then return dirpkg- else Package . takeBaseName <$> findSpecfile- coprBuildPkg chroots False pkg- else- mapM_ (\(n,p) -> withExistingDirectory p $ coprBuildPkg chroots (n>0) (Package p)) $ zip (reverse [0,length pkgs - 1]) pkgs+coprCmd dryrun mode force buildBy marchs project (breq, pkgs) = do+ user <- getUsername+ case mode of+ ListChroots -> coprGetChroots user >>= mapM_ (putStrLn . showChroot)+ CoprMonitor -> coprMonitorPackages user project >>= mapM_ printPkgRes+ CoprNew -> coprNewProject dryrun project marchs breq pkgs+ CoprBuild -> do+ chroots <- coprGetChroots user+ if null pkgs+ then coprBuildPkg user chroots False+ else+ mapM_ (\(n,p) -> withExistingDirectory p $ coprBuildPkg user chroots (n>0)) $ zip (reverse [0..length pkgs - 1]) pkgs where- coprGetChroots = do- username <- getUsername- chroots <- map T.unpack <$> coprChroots coprServer username project+ coprGetChroots :: String -> IO [Chroot]+ coprGetChroots user = do+ chroots <- map (readChroot . T.unpack) <$> coprChroots coprServer user project when (null chroots) $- error' $ "No chroots found for" +-+ username ++ "/" ++ project+ error' $ "No chroots found for" +-+ user ++ "/" ++ project branches <- case breq of Branches brs -> if null brs- then return $ (map (releaseBranch . T.pack) . nub . map removeArch) chroots+ then return $ (nub . map chrootBranch) chroots else listOfBranches False False breq BranchOpt AllFedora -> filter isFedoraBranch <$> getFedoraBranches BranchOpt AllEPEL -> filter isEPELBranch <$> getFedoraBranched@@ -73,64 +144,62 @@ -- FIXME sort archs appropriately case marchs of Nothing ->- [chroot | chroot <- chroots, removeArch chroot `elem` map branchRelease branches]+ [chroot | arch <- sortArchs allCoprArchs, br <- branches, let chroot = Chroot br arch, chroot `elem` chroots]+ -- FIXME warn about missing arch chroots Just (Archs archs) ->- [chroot | arch <- archs, br <- branches, let chroot = branchRelease br ++ "-" ++ arch, chroot `elem` chroots]+ [chroot | arch <- sortArchs (map readArch archs), br <- branches, let chroot = Chroot br arch, chroot `elem` chroots]+ -- FIXME warn about missing arch chroots Just (ExcludedArchs exarchs) ->- [chroot | chroot <- chroots, takeArch chroot `notElem` exarchs, removeArch chroot `elem` map branchRelease branches]+ [chroot | arch <- sortArchs allCoprArchs, arch `notElem` map readArch exarchs, br <- branches, let chroot = Chroot br arch, chroot `elem` chroots] if null buildroots then error' "No valid chroots" else return buildroots - coprBuildPkg buildroots morepkgs _pkg = do+ coprBuildPkg :: String -> [Chroot] -> Bool -> IO ()+ coprBuildPkg user buildroots morepkgs = do -- FIXME check is pkg.spec+ -- was: localBranchSpecFile pkg (RelBranch Rawhide) spec <- findSpecfile -- pkg <- takeFileName <$> getCurrentDirectory- -- hack to avoid generating srpm for dryrun srpm <- if not dryrun- then generateSrpm Nothing spec -- FIXME: let distopt = ["--undefine", "dist"]- else return spec- case buildBy of- SingleBuild -> coprBuild dryrun project srpm spec buildroots- -- FIXME or default to secondary parallel to previous primary- ValidateByRelease -> do- let initialChroots =- let primaryArch = releaseArch $ head buildroots- in map pure $ filter (isArch primaryArch) buildroots- remainingChroots = buildroots \\ concat initialChroots- staggerBuilds srpm spec initialChroots remainingChroots- ValidateByArch -> do- let initialChroots =- let newestRelease = removeArch $ head buildroots- in map pure $ filter (newestRelease `isPrefixOf`) buildroots- remainingChroots = buildroots \\ concat initialChroots- staggerBuilds srpm spec initialChroots remainingChroots- BuildByRelease -> do- let releaseChroots = groupBy sameRelease buildroots- staggerBuilds srpm spec releaseChroots []+ then generateSrpmNoDist True False Nothing spec+ else return spec -- hack to avoid generating srpm for dryrun+ verrel <- showVerRel . nvrVerRel <$> pkgNameVerRelNodist spec+ actualpkg <- cmd "rpmspec" ["-q", "--srpm", "--qf", "%{name}", spec]+ builtChroots <- existingChrootBuilds user project (Package actualpkg) verrel buildroots+ let finalChroots = buildroots \\ if force then [] else map taskChroot builtChroots+ if null finalChroots+ then putStrLn $ actualpkg ++ '-' : verrel +-+ "built"+ else+ case buildBy of+ SingleBuild -> coprBuild dryrun user project srpm spec finalChroots+ -- FIXME or default to secondary parallel to previous primary+ ValidateByRelease -> do+ let initialChroots =+ let primaryArch = chrootArch $ head finalChroots+ in map pure $ filter (isArch primaryArch) finalChroots+ remainingChroots = finalChroots \\ concat initialChroots+ staggerBuilds srpm spec initialChroots remainingChroots+ ValidateByArch -> do+ let initialChroots =+ let newestRelease = chrootBranch $ head finalChroots+ in map pure $ filter ((== newestRelease) . chrootBranch) finalChroots+ remainingChroots = finalChroots \\ concat initialChroots+ staggerBuilds srpm spec initialChroots remainingChroots+ BuildByRelease -> do+ let releaseChroots = groupBy sameRelease finalChroots+ staggerBuilds srpm spec releaseChroots [] when morepkgs putNewLn-- removeArch relarch = init $ dropWhileEnd (/= '-') relarch- takeArch = takeWhileEnd (/= '-')-- staggerBuilds srpm spec initialChroots remainingChroots = do- mapM_ (coprBuild dryrun project srpm spec) initialChroots- unless (null remainingChroots) $- coprBuild dryrun project srpm spec remainingChroots-- releaseArch = takeWhileEnd (/= '-')-- isArch arch release = releaseArch release == arch-- sameRelease r1 r2 = removeArch r1 == removeArch r2+ where+ staggerBuilds :: FilePath -> FilePath -> [[Chroot]] -> [Chroot] -> IO ()+ staggerBuilds srpm spec initialChroots remainingChroots = do+ mapM_ (coprBuild dryrun user project srpm spec) initialChroots+ unless (null remainingChroots) $+ coprBuild dryrun user project srpm spec remainingChroots -branchRelease :: Branch -> String-branchRelease Rawhide = "fedora-rawhide"-branchRelease (Fedora n) = "fedora-" ++ show n-branchRelease (EPEL n) = "epel-" ++ show n-branchRelease (EPELNext n) = "epel-" ++ show n ++ "-next"+ isArch arch release = chrootArch release == arch ---data Chroot = Chroot Release Arch+ sameRelease r1 r2 = chrootBranch r1 == chrootBranch r2 getUsername :: IO String getUsername = do@@ -153,55 +222,174 @@ let config = parseIniFile ini iniparser return $ either error' record config -coprBuild :: Bool -> String -> FilePath -> FilePath -> [String] -> IO ()-coprBuild _ _ _ _ [] = error' "No chroots chosen"-coprBuild dryrun project srpm spec buildroots = do- let chrootargs = mconcat [["-r", bldrt] | bldrt <- buildroots]+-- from copr/frontend/coprs_frontend/coprs/logic/builds_logic.py+-- FIXME after adding to copr-api+coprProcessingStates :: [String]+coprProcessingStates =+ ["running", "pending", "starting", "importing", "waiting"]++-- coprEndedStates :: [String]+-- coprEndedStates =+-- ["canceled", "failed", "skipped", "succeeded"]++-- FIXME restrict to requested chroots?+existingChrootBuilds :: String -> String -> Package -> String -> [Chroot]+ -> IO [CoprTask]+existingChrootBuilds user project actualpkg verrel chroots = do+ monitorPkgs <- coprMonitorPackages user project+ let pkgmonitor = fromMaybe [] $ lookup actualpkg monitorPkgs+ let buildingChroots =+ filterTasks verrel (`elem` coprProcessingStates) pkgmonitor+ if null buildingChroots+ then return $ filterTasks verrel (`notElem` ["failed","skipped"]) pkgmonitor+ else do+ mapM_ printCoprTask buildingChroots+ putNewLn+ forM_ buildingChroots $ \building ->+ when (taskChroot building `elem` chroots) $+ -- FIXME check failure+ void $ coprWatchBuild Nothing $ Left building+ return buildingChroots++filterTasks :: String -> (String -> Bool) -> [CoprTask] -> [CoprTask]+filterTasks verrel statustest =+ filter (\CoprTask{..} -> taskVerRel == verrel && statustest taskStatus)++coprBuild :: Bool -> String -> String -> FilePath -> FilePath -> [Chroot] -> IO ()+coprBuild _ _ _ _ _ [] = error' "No chroots chosen"+coprBuild dryrun user project srpm spec buildroots = do+ let chrootargs = mconcat [["-r", showChroot bldrt] | bldrt <- buildroots] buildargs = ["build", "--nowait"] ++ chrootargs ++ [project, srpm] putNewLn- putStrLn $ unwords buildroots+ putStrLn $ unwords $ map showChroot buildroots unless dryrun $ do output <- cmd "copr" buildargs putStrLn output let bid = read $ last $ words $ last $ lines output- ok <- timeIO $ coprWatchBuild bid Nothing+ ok <- timeIO $ coprWatchBuild Nothing $ Right bid unless ok $ do putStrLn $ "Failed: copr" +-+ unwords buildargs -- FIXME determine which chroot(s) failed- username <- getUsername -- eg 06482247 let zbid = let s = show bid in (if length s < 8 then ('0' :) else id) s actualpkg <- cmd "rpmspec" ["-q", "--srpm", "--qf", "%{name}", spec]- error' $ "https://download.copr.fedorainfracloud.org/results" +/+ username +/+ project +/+ head buildroots +/+ zbid ++ "-" ++ actualpkg +/+ "builder-live.log.gz"+ -- FIXME which chroot?+ -- FIXME print buildlog size+ error' $ "https://download.copr.fedorainfracloud.org/results" +/+ user +/+ project +/+ showChroot (head buildroots) +/+ zbid ++ "-" ++ actualpkg +/+ "builder-live.log.gz" --- FIXME idea: Maybe Seconds to increment sleep-coprWatchBuild :: Int -> Maybe String -> IO Bool-coprWatchBuild bid mstate = do+-- FIXME idea: Maybe Seconds to increment FIXME+-- sleep should have all chroots in pending CoprTask build+coprWatchBuild :: Maybe String -> Either CoprTask Int -> IO Bool+coprWatchBuild mstate ebuild = do+ let bid = either taskBuild id ebuild res <- coprGetBuild fedoraCopr bid case lookupKey "state" res of Just state -> if mstate == Just state- then sleep 20 >> coprWatchBuild bid mstate+ then sleep 20 >> coprWatchBuild mstate (Right bid) else do- logMsg $ "Build" +-+ show bid +-+ state+ whenLeft ebuild $ \t -> putStrLn $ "#" +-+ showChroot (taskChroot t)+ logMsg $ "Build" +-+ show bid +-+ state +-+ either taskVerRel (const "") ebuild case state of "succeeded" -> return True "skipped" -> return True "canceled" -> return False "failed" -> return False- _ -> sleep 1 >> coprWatchBuild bid (Just state)+ _ -> sleep 1 >> coprWatchBuild (Just state) (Right bid) Nothing -> do let err = lookupKey' "error" res logMsg $ "Error:" +-+ err return False --- #if !MIN_VERSION_simple_cmd(0,1,4)--- error' :: String -> a--- #if MIN_VERSION_base(4,9,0)--- error' = errorWithoutStackTrace--- #else--- error' = error--- #endif--- #endif+archPriorities :: [(Arch,Int)]+archPriorities = [(X86_64,1), (AARCH64,2)]++sortArchs :: [Arch] -> [Arch]+sortArchs = sortBy priority+ where+ priority a1 a2 =+ let mp1 = lookup a1 archPriorities+ mp2 = lookup a2 archPriorities+ in+ case (mp1,mp2) of+ (Just p1,Just p2) ->+ compare p1 p2+ (Just _, Nothing) -> LT+ (Nothing, Just _) -> GT+ (Nothing,Nothing) -> EQ++type CoprPackage = (Package,[CoprTask])++data CoprTask = CoprTask {taskChroot :: Chroot,+ taskBuild :: Int,+ taskStatus :: String,+ taskVerRel :: String+ }++-- FIXME wait for None package to appear+coprMonitorPackages :: String -> String -> IO [CoprPackage]+coprMonitorPackages user proj = do+ builds <- coprGetBuildList fedoraCopr user proj []+ mapM_ coprWaitPackage (lookupKey' "items" builds :: [Object])+ mapMaybe pkgResults . lookupKey' "packages" <$>+ coprMonitorProject fedoraCopr user proj []+ where+ pkgResults :: Object -> Maybe CoprPackage+ pkgResults obj = do+ name <- lookupKey "name" obj+ chroots <- map (first toText) . M.toList <$> lookupKey "chroots" obj+ return (Package name, mapMaybe chrootResult chroots)+#if !MIN_VERSION_aeson(2,0,0)+ where toText = id+#endif++ chrootResult :: (T.Text,Object) -> Maybe CoprTask+ chrootResult (chroot, obj) = do+ state <- lookupKey "state" obj+ version <- lookupKey "pkg_version" obj+ build <- lookupKey "build_id" obj+ return $ CoprTask (readChroot (T.unpack chroot)) build state version++printPkgRes :: (Package, [CoprTask]) -> IO ()+printPkgRes (pkg,chroots) = do+ putStrLn $ "# " <> unPackage pkg+ mapM_ printCoprTask chroots+ putNewLn++printCoprTask :: CoprTask -> IO ()+printCoprTask (CoprTask chr build status version) =+ putStrLn $ showChroot chr +-+ show build ++ ":" +-+ status +-+ version++coprWaitPackage :: Object -> IO ()+coprWaitPackage build = do+ case buildResult of+ Nothing -> error' "unknown source_package"+ Just (_, "failed", _) -> return ()+ Just (_, _, Just _pkg) -> return ()+ Just (bid, _, Nothing) -> do+ sleep 5+ print bid+ coprGetBuild fedoraCopr bid >>= coprWaitPackage+ where+ buildResult = do+ bid <- lookupKey "id" build+ source <- lookupKey "source_package" build+ state <- lookupKey "state" build+ let mname = lookupKey "name" source+ return (bid :: Int, state :: String, mname :: Maybe String)++coprNewProject :: Bool -> String -> Maybe Archs -> BranchesReq -> [String]+ -> IO ()+coprNewProject dryrun project marchs breq pkgs = do+ branches <- listOfBranches False False breq+ let archs =+ case marchs of+ Nothing -> [X86_64]+ Just (Archs as) -> map readArch as+ Just (ExcludedArchs eas) -> allCoprArchs \\ map readArch eas+ let chroots = [ Chroot b a | b <- branches, a <- archs]+ (if dryrun then cmdN else cmd_) "copr" $ "create" : concatMap (\ch -> ["--chroot", showChroot ch]) chroots ++ [project]+ unless (null pkgs) $+ coprCmd False CoprBuild False ValidateByRelease Nothing project (breq, pkgs)
src/Cmd/Diff.hs view
@@ -28,9 +28,9 @@ -- FIXME diff other branches without switching -- FIXME --older/--newer branch-diffCmd :: Bool -> Bool -> DiffWork -> DiffFormat -> Bool -> Maybe DiffFilter+diffCmd :: Bool -> Bool -> DiffWork -> DiffFormat -> Bool -> [DiffFilter] -> Maybe AnyBranch -> (Maybe Branch,[String]) -> IO ()-diffCmd debug speconly work fmt ignorebumps mpatt mwbr =+diffCmd debug speconly work fmt ignorebumps patts mwbr = withPackagesMaybeBranch (if debug then HeaderMust else HeaderNone) False dirtyGit diffPkg where diffPkg :: Package -> AnyBranch -> IO ()@@ -91,7 +91,7 @@ (RelBranch rwbr, RelBranch rbr) -> ["-R" | rwbr > rbr] _ -> [] diff <- gitLines "diff" $ contxt ++ workOpts ++ revdiff ++ withBranch ++ workArgs ++ file- let diffout = (maybe id filterPattern mpatt . simplifyDiff fmt) diff+ let diffout = (mapMaybe (filterPatterns patts) . simplifyDiff fmt) diff -- FIXME: sometimes we may want to list even if diff but no diffout unless (null diffout) $ unless (ignorebumps && isTrivialRebuildCommit diffout) $@@ -107,7 +107,11 @@ simplifyDiff DiffStats ds = if null ds then ds else init ds simplifyDiff _ ds = ds - filterPattern :: DiffFilter -> [String] -> [String]- filterPattern (DiffMatch patt) = filter (patt `isInfixOf`)- filterPattern (DiffNotMatch patt) = filter (not . (patt `isInfixOf`))- -- void $ runProcess $ setStderr nullStream $ proc "grep" [pat, file]+ filterPatterns :: [DiffFilter] -> String -> Maybe String+ filterPatterns [] str = Just str+ filterPatterns (df:dfs) str =+ if filterPattern df str then filterPatterns dfs str else Nothing++ filterPattern :: DiffFilter -> String -> Bool+ filterPattern (DiffMatch patt) = (patt `isInfixOf`)+ filterPattern (DiffNotMatch patt) = not . (patt `isInfixOf`)
src/Cmd/FTBFS.hs view
@@ -86,7 +86,7 @@ print status case status of BuildFailed -> do- cmdLog "koji-tool" ["tasks", "-T", "-s", "fail", "-b", showNVR nvr]+ cmdLog "koji-tool" ["tasks", "--details", "-T", "-s", "fail", "-b", showNVR nvr] putNewLn BuildComplete -> do if bugStatus bug `elem` ["NEW", "ASSIGNED", "POST"]
+ src/Cmd/Fetch.hs view
@@ -0,0 +1,21 @@+module Cmd.Fetch (+ fetchPkgs+ )+where++import Branches+import Git+import Package++fetchPkgs :: [String] -> IO ()+fetchPkgs args =+ withPackagesByBranches+ (if length args > 1 then HeaderMust else HeaderMay)+ False+ dirtyGit+ Zero+ fetchPkg (Branches [],args)+ where+ fetchPkg :: Package -> AnyBranch -> IO ()+ fetchPkg _pkg _br =+ gitFetchSilent False
src/Cmd/Import.hs view
@@ -1,6 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} -module Cmd.Import (importCmd) where+module Cmd.Import (+ importCmd,+ downloadReviewSRPM,+ upstreamDir+ )+where import Common import Common.System@@ -48,52 +53,95 @@ -- FIXME get session from importPkgs (bid,session) <- approvedReviewBugIdSession pkg putBugId bid- putNewLn- comments <- getComments session bid- mapM_ showComment comments- putNewLn- putStr "Review bug: "- putBugId bid- putNewLn- promptEnter "Press Enter to continue"- let srpms = map (T.replace "/reviews//" "/reviews/") $ concatMap findSRPMs comments- mapM_ T.putStrLn srpms- case (filter (".src.rpm" `isSuffixOf`) . words . T.unpack . last) srpms of- [] -> error' "no srpm filename found"- srcrpms ->- case filter (isURI . maybeEncodeURI) srcrpms of- [] -> error "no valid srpm urls found"- [srpmurl] -> do- let srpmfile = takeFileName srpmurl- -- FIXME if havesrpm then print local filename- promptEnter $ "Press Enter to import" +-+ srpmfile- havesrpm <- doesFileExist srpmfile- unless havesrpm $- cmd_ "curl" ["--silent", "--show-error", "--remote-name", srpmurl]- krbTicket- fedpkg_ "import" [srpmfile]- git_ "commit" ["--message", "import rhbz#" ++ show bid]- nvr <- pkgNameVerRel' Rawhide (pkg <.> "spec")- ok <- yesNoDefault True $ "Press Enter to push and build" +-+ showNVR nvr- when ok $ do- gitPush True Nothing- -- FIXME build more branches- kojiBuildBranch "rawhide" (Package pkg) Nothing ["--fail-fast"]- putBugBuild False session bid nvr- existing <- fedoraBranchesNoRawhide (localBranches False)- when (null existing) $ do- brs <- getRequestedBranches [] breq- requestPkgBranches False False mock (Branches brs) (Package pkg)- srpmurls -> error' $ "multiple srpm urls:" +-+ unwords srpmurls+ srpmfile <- downloadReviewSRPM False True pkg bid session+ promptEnter $ "Press Enter to import" +-+ srpmfile+ krbTicket+ fedpkg_ "import" [srpmfile]+ git_ "commit" ["--message", "import rhbz#" ++ show bid]+ nvr <- pkgNameVerRel' Rawhide (pkg <.> "spec")+ ok <- yesNoDefault True $ "Press Enter to push and build" +-+ showNVR nvr+ when ok $ do+ gitPush True Nothing+ -- FIXME build more branches+ kojiBuildBranch "rawhide" (Package pkg) Nothing ["--fail-fast"]+ putBugBuild False session bid nvr+ existing <- fedoraBranchesNoRawhide (localBranches False)+ when (null existing) $ do+ brs <- getRequestedBranches [] breq+ unless (null brs) $+ requestPkgBranches False False mock (Branches brs) (Package pkg) when (pkg /= takeFileName dir) $ setCurrentDirectory dir - where- findSRPMs :: Comment -> [T.Text]- findSRPMs =- filter (\ l -> "https://" `T.isInfixOf` l && any (`T.isPrefixOf` T.toLower l) ["srpm url:", "srpm:", "new srpm:", "updated srpm:"] && ".src.rpm" `T.isSuffixOf` l) . T.lines . commentText+downloadReviewSRPM :: Bool -> Bool -> String -> Int -> BugzillaSession+ -> IO FilePath+downloadReviewSRPM getspec prompt pkg bid session = do+ putNewLn+ comments <- getComments session bid+ mapM_ showComment comments+ putNewLn+ putStr "Review bug: "+ putBugId bid+ putNewLn+ when prompt $+ promptEnter "Press Enter to continue"+ when getspec $+ downloadSpec comments+ let srpms = map (T.replace "/reviews//" "/reviews/") $ concatMap findSRPMs comments+ mapM_ T.putStrLn srpms+ unless (null srpms) putNewLn+ downloadSRPM (last srpms)+ where+ findSRPMs :: Comment -> [T.Text]+ findSRPMs =+ filter (\ l -> "https://" `T.isInfixOf` l && any (`T.isPrefixOf` T.toLower l) ["srpm url:", "srpm:", "new srpm:", "updated srpm:"] && ".src.rpm" `T.isSuffixOf` l) . T.lines . commentText - maybeEncodeURI cs =- if '%' `elem` cs- then cs- else escapeURIString isUnescapedInURI cs+ findSpecs :: Comment -> [T.Text]+ findSpecs =+ filter (\ l -> "https://" `T.isInfixOf` l && any (`T.isPrefixOf` T.toLower l) ["spec url:", "spec:", "new spec:", "updated spec:"] && T.pack (pkg <.> "spec") `T.isSuffixOf` l) . T.lines . commentText++ maybeEncodeURI cs =+ if '%' `elem` cs+ then cs+ else escapeURIString isUnescapedInURI cs++ downloadSRPM :: T.Text -> IO FilePath+ downloadSRPM srpm = do+ case (filter (".src.rpm" `isSuffixOf`) . words . T.unpack) srpm of+ [] -> error' "no srpm filename found"+ srcrpms ->+ case filter (isURI . maybeEncodeURI) srcrpms of+ [] -> error "no valid srpm urls found"+ [srpmurl] -> do+ let srpmfile = takeFileName srpmurl+ -- FIXME if havesrpm then print local filename+ havesrpm <- doesFileExist srpmfile+ if havesrpm+ then putStrLn $ srpmfile +-+ "already exists"+ else+ -- was "--silent"+ cmd_ "curl" ["--show-error", "--remote-name", srpmurl]+ return srpmfile+ srpmurls -> error' $ "multiple srpm urls:" +-+ unwords srpmurls++ downloadSpec :: [Comment] -> IO ()+ downloadSpec comments = do+ let specs = map (T.replace "/reviews//" "/reviews/") $ concatMap findSpecs comments+ mapM_ T.putStrLn specs+ unless (null specs) putNewLn+ case (filter ((pkg <.> "spec") `isSuffixOf`) . words . T.unpack . last) specs of+ [] -> error' "no spec filename found"+ specfiles ->+ case filter (isURI . maybeEncodeURI) specfiles of+ [] -> error "no valid spec urls found"+ [specurl] -> do+ let specfile = upstreamDir </> takeFileName specurl+ havespec <- doesFileExist specfile+ if havespec+ then putStrLn $ specfile +-+ "already exists"+ else+ cmd_ "curl" ["--silent", "--show-error", "--create-dirs", "--output", specfile, specurl]+ specurls -> error' $ "multiple spec urls:" +-+ unwords specurls++upstreamDir :: FilePath+upstreamDir = "UPSTREAM"
src/Cmd/Install.hs view
@@ -2,14 +2,12 @@ module Cmd.Install ( installCmd,- notInstalledCmd+ notInstalledCmd,+ Select(..) ) where import Data.RPM-#if !MIN_VERSION_simple_cmd(0,2,7)-import System.Posix.User (getEffectiveUserID)-#endif-import SimplePrompt (promptEnter)+import SelectRPMs import Branches import Cmd.Merge@@ -29,8 +27,9 @@ -- FIXME --check any/all of package installed -- FIXME add --debug or respect --verbose for dnf commands installCmd :: Bool -> Bool -> Maybe Branch -> Maybe ForceShort -> [BCond]- -> Bool -> Bool -> Bool -> Bool -> (Maybe Branch,[String]) -> IO ()-installCmd quiet recurse mfrom mforceshort bconds reinstall nobuild nobuilddeps allsubpkgs (mbr, pkgs) = do+ -> Bool -> Bool -> Bool -> Select -> (Maybe Branch,[String])+ -> IO ()+installCmd quiet recurse mfrom mforceshort bconds reinstall nobuild nobuilddeps select (mbr, pkgs) = do when (recurse && isShortCircuit mforceshort) $ error' "cannot use --recurse and --shortcircuit" withPackagesMaybeBranch (boolHeader (recurse || length pkgs > 1)) True Nothing installPkg (mbr, pkgs)@@ -49,15 +48,16 @@ mergeCmd False False True Nothing False mfrom (Branches [onlyRelBranch br], ["."]) localBranchSpecFile pkg br rpms <- builtRpms br spec- -- removing arch let nvras = map readNVRA rpms+ -- FIXME can this be removed now? already <- filterM nvraInstalled nvras if isJust mforceshort || null already || reinstall- then doInstallPkg mforceshort spec rpms already+ then doInstallPkg mforceshort spec rpms else putStrLn $ unlines (map showNVRA already) ++ "\nalready installed!\n" where- doInstallPkg mforceshort' spec rpms already = do+ doInstallPkg mforceshort' spec rpms = do+ -- FIXME show source NVR (eg not pandoc-common) putStrLn $ (showNVR . dropArch . readNVRA) (head rpms) unless (nobuilddeps || nobuild) $ do missingdeps <- nub <$> (buildRequires spec >>= filterM notInstalled)@@ -71,40 +71,22 @@ mpkgdir <- lookForPkgDir rbr ".." dep case mpkgdir of Nothing -> putStrLn $ dep +-+ "not known"- Just pkgdir -> installCmd quiet recurse mfrom mforceshort bconds reinstall nobuild nobuilddeps allsubpkgs (mbr, [pkgdir]) >> putNewLn+ Just pkgdir -> installCmd quiet recurse mfrom mforceshort bconds reinstall nobuild nobuilddeps select (mbr, [pkgdir]) >> putNewLn -- FIXME option to enable/disable installing missing deps -- FIXME --skip-missing-deps or prompt else installDeps True spec- wasbuilt <-+ -- FIXME unused+ _wasbuilt <- if nobuild then return True else buildRPMs quiet False False mforceshort' bconds rpms br spec unless (isShortCircuit mforceshort') $ do- toinstalls <-- if allsubpkgs- then return rpms- else do- ps <- filterM (pkgInstalled . rpmName . readNVRA) rpms- return $ if null ps then rpms else ps- if reinstall || mforceshort' == Just ForceBuild- then do- let reinstalls =- filter (\ f -> readNVRA f `elem` already) toinstalls- unless (null reinstalls) $- sudoLog "/usr/bin/dnf" $ "reinstall" : "-q" : "-y" : reinstalls- let remaining = filterDebug $ toinstalls \\ reinstalls- unless (null remaining) $- sudoLog "/usr/bin/dnf" $ "install" : "-q" : "-y" : remaining- else do- let command = "/usr/bin/dnf" : "install" : "-q" : "-y" : filterDebug toinstalls- cmdN "sudo" command- ok <- cmdBool "sudo" command- unless ok $- if wasbuilt- then error' $ "error from:" +-+ unwords command- else do- promptEnter "Press Enter to rebuild package"- doInstallPkg (Just ForceBuild) spec rpms already+ let nvras = rpmsToNVRAs rpms+ -- FIXME: prefix = fromMaybe (nvrName nvr) mprefix+ decided <- decideRPMs No False Nothing select (unPackage pkg) nvras+ -- FIXME dryrun and debug+ -- FIXME return Bool?+ installRPMs False False Nothing No $ groupOnArch "RPMS" decided lookForPkgDir :: Branch -> FilePath -> String -> IO (Maybe FilePath) lookForPkgDir rbr topdir p = do@@ -133,8 +115,6 @@ sysbr <- systemBranch repoquery sysbr rbr ["--qf=%{source_name}", "--whatprovides", p] - filterDebug = filter (\p -> not (any (`isInfixOf` p) ["-debuginfo-", "-debugsource-"]))- notInstalledCmd :: (Maybe Branch,[String]) -> IO () notInstalledCmd = withPackagesMaybeBranchNoHeadergit notInstalledPkg@@ -161,21 +141,3 @@ pkgInstalled :: String -> IO Bool pkgInstalled pkg = cmdBool "rpm" ["--quiet", "-q", pkg]--#if !MIN_VERSION_simple_cmd(0,2,7)-sudoLog :: String -- ^ command- -> [String] -- ^ arguments- -> IO ()-sudoLog = sudoInternal cmdLog- where- sudoInternal :: (String -> [String] -> IO a) -> String -> [String] -> IO a- sudoInternal exc c args = do- uid <- getEffectiveUserID- sd <- if uid == 0- then return Nothing- else findExecutable "sudo"- let noSudo = isNothing sd- when (uid /= 0 && noSudo) $- warning "'sudo' not found"- exc (fromMaybe c sd) (if noSudo then args else c:args)-#endif
src/Cmd/ListBranches.hs view
@@ -4,10 +4,11 @@ ) where -import Common-import Common.System+import Distribution.Fedora.Branch (getFedoraBranches, readBranch) import Branches+import Common+import Common.System import Git import Package @@ -76,7 +77,10 @@ if breq == Branches [] then do -- FIXME better to filter inactive instead active <- getFedoraBranches- let result = if missing then active \\ mapMaybe readBranch brs else activeBranches active brs+ let result =+ if missing+ then active \\ mapMaybe readBranch brs+ else activeBranches active brs putStr $ unPackage pkg ++ ": " putStrLn $ (unwords . map show) result else do
src/Cmd/ListPackages.hs view
@@ -9,6 +9,7 @@ import Data.Aeson import Fedora.Pagure+import SimplePrompt (yesNoDefault) import Branches import Common@@ -20,20 +21,31 @@ data Packager = Owner String | Committer String --- FIXME remote/pagures branch and --remote or --no-remote-listCmd :: Bool -> Maybe Packager -> [String] -> IO ()-listCmd count mpackager pkgs = do- unless (count || isJust mpackager || not (null pkgs)) $+-- FIXME remote/pagure branch and --remote or --no-remote+listCmd :: Bool -> Bool -> Maybe Packager -> [String] -> IO ()+listCmd force count mpackager pkgs = do+ unless (force || count || isJust mpackager || not (null pkgs)) $ error' "Please give a package pattern, --count, or --owner/--username" if null pkgs then listPackage Nothing else mapM_ (listPackage . Just) pkgs where+ -- FIXME add default --max-pages? listPackage :: Maybe String -> IO () listPackage mpattern = do let path = "projects" params = makeKey "short" "1" ++ fork ++ packager ++ makeKey "namespace" "rpms" ++ maybeKey "pattern" mpattern- pages <- queryPaged srcfpo count path params ("pagination", "page")- mapM_ printPage pages+ mnum <- queryPagureCount srcfpo path params "pagination"+ whenJust mnum $ \num ->+ if count+ then print num+ else do+ ok <-+ if num > 1000 && not force+ then yesNoDefault False $ show num +-+ "results, continue"+ else return True+ when ok $ do+ pages <- queryPagureCountPaged srcfpo False path params ("pagination", "page")+ mapM_ printPage pages where packager = case mpackager of@@ -48,17 +60,6 @@ let projects = lookupKey' "projects" result :: [Object] in mapM_ (T.putStrLn . lookupKey' "name") projects---- FIXME limit max number of pages (10?) or --pages-queryPaged :: String -> Bool -> String -> Query -> (String,String) -> IO [Object]-queryPaged server count path params (pagination,paging) =- if count- then do- mnum <- queryPagureCount server path params pagination- print $ fromMaybe (error' "pages not found") mnum- return []- else- queryPagurePaged server path params (pagination,paging) -- FIXME add --count listLocalCmd :: (Maybe Branch, [String]) -> IO ()
src/Cmd/Local.hs view
@@ -1,5 +1,4 @@ module Cmd.Local (- autospecCmd, commandCmd, countCmd, installDepsCmd,@@ -13,7 +12,7 @@ import qualified Data.ByteString.Lazy.Char8 as B import Data.Char (isDigit)-import System.Environment+import System.Environment (getEnvironment) import qualified System.Process as P import qualified System.Process.Typed as TP import System.Exit@@ -86,11 +85,11 @@ (ret,out) <- TP.readProcessInterleaved $ TP.setEnv (("p",unPackage pkg):curEnv) $ TP.shell cs- unless (B.null out) $ do+ whenJust (B.unsnoc out) $ \(bs,l) -> do if compact then putStr $ unPackage pkg ++ ": " else putPkgAnyBrnchHdr pkg br- B.putStr out+ B.putStrLn $ if l == '\n' then bs else out return ret else do let p = (P.shell cs) { P.env = Just (("p",unPackage pkg):curEnv) }@@ -171,28 +170,6 @@ return $ subdir </> spec else error' "failed to extract spec file" else error' $ "no such file:" +-+ srpm---- FIXME calculate baserelease-autospecCmd :: Bool -> [String] -> IO ()-autospecCmd force pkgs =- withPackagesByBranches HeaderMay False cleanGitFetchActive ExactlyOne autospecPkg (Branches [Rawhide], pkgs)- where- autospecPkg :: Package -> AnyBranch -> IO ()- autospecPkg _pkg br = do- gitSwitchBranch br- let changelogfile = "changelog"- exists <- doesFileExist changelogfile- if exists- then- if force- then do- cmd "rpmautospec" ["generate-changelog"] >>=- writeFile changelogfile- unlessM (null <$> git "status" ["--porcelain", "--untracked=no"]) $ do- git_ "add" [changelogfile]- git_ "commit" ["-m", "refresh changelog"]- else putStrLn "'changelog' file already exists"- else cmd_ "rpmautospec" ["convert"] moveArtifactsCmd :: Bool -> [String] -> IO () moveArtifactsCmd remove pkgs =
src/Cmd/Parallel.hs view
@@ -8,9 +8,12 @@ import Common.System import Control.Concurrent.Async+import Control.Exception.Extra (retry) import Data.RPM.NVR (NVR)+import Distribution.Fedora.Branch (branchDestTag, branchTarget) import Distribution.RPM.Build.Order (dependencyLayersRpmOpts) import Fedora.Bodhi hiding (bodhiUpdate)+import Say import SimplePrompt (prompt, promptEnter, yesNo) import System.Console.Pretty import System.Time.Extra (sleep)@@ -35,7 +38,6 @@ -- FIXME offer to untag overrides afterwards -- FIXME merge --from--- FIXME print koji url of failed process or use koji-tool -- FIXME option to build multiple packages over branches in parallel -- FIXME use --wait-build=NVR -- FIXME check sources as early as possible@@ -45,10 +47,11 @@ -- FIXME support non-sidetag update for parallel packages -- FIXME print layers if few packages? -- FIXME push update-parallelBuildCmd :: Bool -> Maybe Bool -> Int -> Maybe SideTagTarget -> Double- -> (Maybe UpdateType, UpdateSeverity)+-- FIXME use more say+parallelBuildCmd :: Bool -> Maybe Bool -> Int -> Maybe SideTagTarget -> Bool+ -> Double -> (Maybe UpdateType, UpdateSeverity) -> (BranchesReq, [String]) -> IO ()-parallelBuildCmd dryrun mmerge firstlayer msidetagTarget delay mupdate (breq, pkgs) =+parallelBuildCmd dryrun mmerge firstlayer msidetagTarget mustpush delay mupdate (breq, pkgs) = do branches <- case pkgs of@@ -67,8 +70,9 @@ error' "You can only specify target with one branch" case pkgs of [] -> getPackageName "." >>= parallelBranches branches- [p] -> withExistingDirectory p $- getPackageName p >>= parallelBranches branches+ [p] | length branches > 1 ->+ withExistingDirectory p $+ getPackageName p >>= parallelBranches branches _ -> forM_ branches $ \rbr -> do mtargetSidetag <-@@ -84,14 +88,14 @@ return $ Just (Target tag) _ -> error' $ "multiple existing sidetags:" +-+ show tags else return msidetagTarget- forM_ pkgs $ \p ->+ forM_ (filter (/= ":") pkgs) $ \p -> when (mmerge /= Just False) $ withExistingDirectory p $ do pkg <- getPackageName p mergeNewerBranch (Just pkg) rbr getDynSourcesMacros $ packageSpec pkg distopts <- distRpmOptions rbr- allLayers <- dependencyLayersRpmOpts distopts pkgs+ allLayers <- getLayers distopts pkgs let layers = drop firstlayer allLayers when (isNothing msidetagTarget && length allLayers > 1) $ unlessM (checkAutoBodhiUpdate rbr) $@@ -230,7 +234,7 @@ Just (Left except) -> do print except let pkg = fst job- putStrLn $ "**" +-+ color Magenta pkg +-+ "job" +-+ color Magenta "failed" +-+ "**" +-+ if singlejob then "" else "(" ++ plural (length jobs) "job" +-+ "left" +-+ maybe "" (\l -> "in layer" +-+ show l) mlayer ++ ")"+ sayString $ "**" +-+ color Magenta pkg +-+ "job" +-+ color Magenta "failed" +-+ "**" +-+ if singlejob then "" else "(" ++ plural (length jobs) "job" +-+ "left" +-+ maybe "" (\l -> "in layer" +-+ show l) mlayer ++ ")" watchJobs singlejob mlayer (pkg : fails) dones jobs -- FIXME prefix output with package name@@ -245,7 +249,13 @@ checkForSpecFile spec nvr <- pkgNameVerRel' br spec unpushed <- gitOneLineLog $ "origin/" ++ show br ++ "..HEAD"- unless (null unpushed) $ do+ if null unpushed+ then+ when mustpush $ do+ ok <- yesNo "Nothing to push, okay to continue"+ unless ok $+ error' "no commits with --must-push"+ else do putStrLn $ showNVR nvr +-+ "(" ++ target ++ ")" +-+ if nopkgs > 1 then pluralException n (if morelayers then Nothing else Just "last") "more" "more" +-+ maybe "" (\l -> "in layer" +-+ show l) mlayer@@ -267,7 +277,7 @@ case buildstatus of Just BuildComplete -> do -- FIXME detect old stable existing build- putStrLn $ color Green (showNVR nvr) +-+ "is already" +-+ color Green "built"+ sayString $ color Green (showNVR nvr) +-+ "is already" +-+ color Green "built" when (br /= Rawhide && morelayers && target == branchTarget br) $ do tags <- kojiNVRTags nvr unless (any (`elem` tags) [show br, show br ++ "-updates", show br ++ "-override"]) $@@ -278,7 +288,7 @@ kojiWaitRepo dryrun (nopkgs > 5) True target nvr return $ Done pkg nvr br changelog Just BuildBuilding -> do- putStrLn $ color Yellow (showNVR nvr) +-+ "is already" +-+ color Yellow "building"+ sayString $ color Yellow (showNVR nvr) +-+ "is already" +-+ color Yellow "building" mtask <- kojiGetBuildTaskID fedoraHub $ showNVR nvr case mtask of Nothing -> error' $ "Task for" +-+ showNVR nvr +-+ "not found"@@ -317,17 +327,17 @@ kojiWaitTaskAndRepo (isNothing mlatest) nvr task return $ Done pkg nvr br changelog where+ -- throws error on build failure kojiWaitTaskAndRepo :: Bool -> NVR -> TaskID -> IO () kojiWaitTaskAndRepo newpkg nvr task = do- finish <- kojiWaitTask task+ finish <- retry 3 $ kojiWaitTask task if finish- then putStrLn $ color Green $ showNVR nvr +-+ "build success"+ then sayString $ color Green $ showNVR nvr +-+ "build success" -- FIXME print koji task url else do whenJustM (findExecutable "koji-tool") $ \kojitool -> -- FIXME cmdLog deprecated- -- FIXME use --children (koji-tool-1.1.2)- cmdLog kojitool ["tasks", displayID task, "-s", "fail"]+ cmdLog kojitool ["tasks", "--children", displayID task, "-s", "fail"] error' $ color Red $ showNVR nvr +-+ "build failed" autoupdate <- checkAutoBodhiUpdate br if autoupdate then@@ -380,3 +390,10 @@ Nothing -> error' "could not determine Update id" Just _updateid -> return () _ -> error' $ "impossible happened: more than one update found for" +-+ showNVR (last nvrs)++getLayers :: [String] -> [String] -> IO [[String]]+getLayers distopts pkgs =+ if ":" `elem` pkgs+ -- FIXME check no interdeps+ then return $ splitOn [":"] pkgs+ else dependencyLayersRpmOpts distopts pkgs
src/Cmd/PkgReview.hs view
@@ -3,8 +3,7 @@ module Cmd.PkgReview ( createReview, updateReview,- ScratchOption(..),- reviewPackage+ ScratchOption(..) ) where import Common@@ -21,6 +20,7 @@ import Krb import Package import RpmBuild+import Types (ChangeType(ChangeReview)) data ScratchOption = ScratchBuild | ScratchTask Int | SkipScratch deriving Eq@@ -100,9 +100,9 @@ error' "This NVR was already posted on the review bug: please bump" mockRpmLint mock pkg spec srpm (mkojiurl,specSrpmUrls) <- buildAndUpload mscratchOpt srpm pkg spec- changelog <- changeLogPrompt False spec+ changelog <- changeLogPrompt ChangeReview spec commentBug session bid (specSrpmUrls <> (if null changelog then "" else "\n\n" <> changelog) <> maybe "" ("\n\nKoji scratch build: " <>) mkojiurl)- -- putStrLn "Review bug updated"+ putBugId bid where checkLocalFile :: FilePath -> IO FilePath checkLocalFile f =@@ -144,27 +144,3 @@ builtRpms (RelBranch Rawhide) spec >>= filterM doesFileExist -- FIXME parse # of errors/warnings void $ cmdBool "rpmlint" $ spec:srpm:rpms---- FIXME does not work with pkg dir/spec:--- 'fbrnch: No spec file found'--- FIXME: option to only download/prep files-reviewPackage :: Maybe String -> IO ()-reviewPackage Nothing = do- -- FIXME catch no spec file- spec <- findSpecfile- srpm <- generateSrpm Nothing spec- cmd_ "fedora-review" ["-rn", srpm]-reviewPackage (Just pkgbug) = do- bugs <- bugsAnon $- if all isDigit pkgbug- then packageReview .&&. statusNewAssigned .&&. bugIdIs (read pkgbug)- else pkgReviews pkgbug .&&. statusNewAssigned- case bugs of- [bug] -> do- putReviewBug False bug- promptEnter "Press Enter to run fedora-review"- -- FIXME support copr build- -- FIXME if toolbox set REVIEW_NO_MOCKGROUP_CHECK- cmd_ "fedora-review" ["-b", show (bugId bug)]- [] -> error' $ "No package review found for" +-+ pkgbug- _ -> error' $ "More than one review bug found for" +-+ pkgbug
src/Cmd/Prep.hs view
@@ -16,11 +16,12 @@ deriving Eq -- FIXME prompt for cloning-prepCmd :: Maybe PrepPre -> Bool -> Bool -> (Maybe Branch,[String]) -> IO ()-prepCmd mpre verbose deps (mbr,pkgs) = do+prepCmd :: Maybe PrepPre -> Bool -> Bool -> Bool -> (Maybe Branch,[String])+ -> IO ()+prepCmd mpre verbose deps allowhead (mbr,pkgs) = do when (mpre == Just PrepClone) $- cloneCmd (ClonePkgs (mbr, pkgs))- withPackagesMaybeBranchNoHeadergit prepPackage (mbr,pkgs)+ cloneCmd mbr (ClonePkgs pkgs)+ withPackagesMaybeBranch HeaderNone False (if allowhead then dirtyGitHEAD else Nothing) prepPackage (mbr,pkgs) where prepPackage :: Package -> AnyBranch -> IO () prepPackage pkg br = do@@ -33,7 +34,7 @@ putStr $ unPackage pkg ++ ": " putStrLn "dead.package" else do- spec <- localBranchSpecFile pkg br+ spec <- if allowhead then findSpecfile else localBranchSpecFile pkg br unlessM (doesFileExist spec) $ error' $ spec +-+ "not found" getSourcesMacros spec@@ -45,6 +46,11 @@ -- newline avoids error starting on same line putStr $ "Prepping" +-+ showNVR nvr ++ ": " _ -> return ()+ sourcediropt <- do+ distgit <- isGitRepo+ if distgit+ then sourceDirCwdOpt+ else return [] timeIO $- (if verbose then cmdLog else cmdSilent') "rpmbuild" $ "-bp" : ["--nodeps" | not deps] ++ [spec]+ (if verbose then cmdLog else cmdSilent') "rpmbuild" $ "-bp" : ["--nodeps" | not deps] ++ sourcediropt ++ [spec] putStrLn "done"
+ src/Cmd/Pull.hs view
@@ -0,0 +1,56 @@+module Cmd.Pull (+ pullPkgs,+ PullOpt(..)+ )+where++import Branches+import Common+--import Common.System (error')+import Git+import Package++data PullOpt =+ PullLenient | PullNoFetch | PullStash | PullRebase+ deriving Eq++-- FIXME pulling more than one branch+-- FIXME print nvr after pulling or old -> new+pullPkgs :: Maybe PullOpt -> (BranchesReq, [String]) -> IO ()+pullPkgs pullopt (breq,args) =+ withPackagesByBranches+ (if length args > 1 then HeaderMust else HeaderMay)+ False+ (case pullopt of+ Just PullLenient -> Nothing+ Just PullRebase -> Nothing -- FIXME+ Just PullNoFetch -> cleanGit+ Just PullStash -> stashGitFetch+ Nothing -> cleanGitFetch)+ AnyNumber pullPkg (breq,args)+ where+ pullPkg :: Package -> AnyBranch -> IO ()+ pullPkg pkg br =+ if pullopt == Just PullLenient+ then do+ haveGit <- isPkgGitRepo+ if haveGit+ then gitFetchSilent True+ else putStrLn $ "ignoring" +-+ unPackage pkg+ else doPullPkg+ where+ -- FIXME using rebase for branched may be risky+ doPullPkg :: IO ()+ doPullPkg = do+ current <- getReleaseBranchWarn+ unless (breq == Branches [] || RelBranch current == br) $+ gitSwitchBranch br+ if pullopt == Just PullRebase+ then git_ "pull" ["origin"]+ else gitMergeOrigin current+ when (pullopt == Just PullStash) $ do+ stashes <- git "stash" ["list"]+ case line1 stashes of+ (s0,_) | stashedWithFbrnch `isSuffixOf` s0 ->+ git_ "stash" ["pop", "--quiet"]+ _ -> return ()
− src/Cmd/PullPush.hs
@@ -1,79 +0,0 @@-module Cmd.PullPush (- pullPkgs,- PullOpts(..),- fetchPkgs,- pushPkgs)-where--import Branches-import Common-import Common.System (error')-import Git-import Package--data PullOpts =- PullLenient | PullNoFetch | PullStash- deriving Eq---- FIXME pulling more than one branch--- FIXME print nvr after pulling or old -> new-pullPkgs :: Maybe PullOpts -> (BranchesReq, [String]) -> IO ()-pullPkgs pullopts (breq,args) =- withPackagesByBranches- (if length args > 1 then HeaderMust else HeaderMay)- False- (case pullopts of- Just PullLenient -> Nothing- Just PullNoFetch -> cleanGit- Just PullStash -> stashGitFetch- Nothing -> cleanGitFetch)- AnyNumber pullPkg (breq,args)- where- pullPkg :: Package -> AnyBranch -> IO ()- pullPkg pkg br =- if pullopts == Just PullLenient- then do- haveGit <- isPkgGitRepo- if haveGit- then doPullPkg- else putStrLn $ "ignoring" +-+ unPackage pkg- else doPullPkg- where- doPullPkg :: IO ()- doPullPkg = do- current <- getReleaseBranchWarn- unless (breq == Branches [] || RelBranch current == br) $- gitSwitchBranch br- gitMergeOrigin current- when (pullopts == Just PullStash) $ do- stashes <- git "stash" ["list"]- case line1 stashes of- (s0,_) | stashedWithFbrnch `isSuffixOf` s0 ->- git_ "stash" ["pop", "--quiet"]- _ -> return ()--fetchPkgs :: [String] -> IO ()-fetchPkgs args =- withPackagesByBranches- (if length args > 1 then HeaderMust else HeaderMay)- False- dirtyGit- Zero- fetchPkg (Branches [],args)- where- fetchPkg :: Package -> AnyBranch -> IO ()- fetchPkg _pkg _br =- gitFetchSilent False--pushPkgs :: Bool -> Bool -> Maybe String -> (BranchesReq, [String]) -> IO ()-pushPkgs dryrun nofetch mref (breq, pkgs) = do- when (isJust mref && length pkgs > 1) $- error' "can only specify ref for single package"- withPackagesByBranches HeaderMust False (if nofetch then cleanGit else cleanGitFetch) AnyNumber pushPkg (breq, pkgs)- where- pushPkg :: Package -> AnyBranch -> IO ()- pushPkg _pkg _br = do- whenJustM (gitShortLog1 Nothing) $ putStrLn . showCommit- if dryrun- then checkOnBranch- else gitPush False mref
+ src/Cmd/Push.hs view
@@ -0,0 +1,25 @@+module Cmd.Push (+ pushPkgs+ )+where++import Control.Monad.Extra (when, whenJustM)+import Data.Maybe (isJust)+import SimpleCmd (error')++import Branches+import Git+import Package++pushPkgs :: Bool -> Bool -> Maybe String -> (BranchesReq, [String]) -> IO ()+pushPkgs dryrun nofetch mref (breq, pkgs) = do+ when (isJust mref && length pkgs > 1) $+ error' "can only specify ref for single package"+ withPackagesByBranches HeaderMust False (if nofetch then cleanGit else cleanGitFetch) AnyNumber pushPkg (breq, pkgs)+ where+ pushPkg :: Package -> AnyBranch -> IO ()+ pushPkg _pkg br = do+ whenJustM (gitShortLog1 $ Just $ "origin/" ++ show br ++ "..HEAD") $ putStrLn . showCommit+ if dryrun+ then checkOnBranch+ else gitPush False mref
src/Cmd/RequestRepo.hs view
@@ -2,33 +2,34 @@ module Cmd.RequestRepo (requestRepos) where -import Common-import qualified Common.Text as T-+import Control.Exception.Extra (retry) import Network.HTTP.Directory (httpExists, httpManager) import SimpleCmd import SimplePrompt (promptEnter, promptInitial) import Branches import Bugzilla+import Common+import qualified Common.Text as T import Krb import ListReviews import Package import Pagure -- FIXME separate pre-checked listReviews and direct pkg call, which needs checks-requestRepos :: Bool -> Bool -> Bool -> (BranchesReq, [String]) -> IO ()-requestRepos mock allstates retry (breq, ps) = do- when (retry && length ps /= 1) $- error' "--retry only for a single package"+requestRepos :: Bool -> Bool -> Bool -> Bool -> (BranchesReq, [String])+ -> IO ()+requestRepos mock allstates skipcheck resubmit (breq, ps) = do+ when (resubmit && length ps /= 1) $+ error' "can only --resubmit for a single package" pkgs <- if null ps then map reviewBugToPackage <$> listReviewsAll allstates ReviewWithoutRepoReq else return ps- mapM_ (requestRepo mock retry breq) pkgs+ mapM_ (requestRepo mock skipcheck resubmit breq) pkgs -- FIXME also accept bugid instead-requestRepo :: Bool -> Bool -> BranchesReq -> String -> IO ()-requestRepo mock retry breq pkg = do+requestRepo :: Bool -> Bool -> Bool -> BranchesReq -> String -> IO ()+requestRepo mock skipcheck resubmit breq pkg = do putStrLn pkg (bug,session) <- approvedReviewBugSession pkg putBug bug@@ -40,14 +41,16 @@ if created then putStrLn "scm repo was already created" else do- requests <- existingRepoRequests+ requests <-+ if skipcheck then return [] else existingRepoRequests unless (null requests) $ do putStrLn "Request exists:" mapM_ printScmIssue requests- -- don't retry if succeeded- when (retry && pagureIssueCloseStatus (head requests) == Just "Processed") $+ -- don't resubmit if succeeded+ -- FIXME head+ when (resubmit && pagureIssueCloseStatus (head requests) == Just "Processed") $ error' "The last repo request was already successfully Processed"- when (null requests || retry) $ do+ when (null requests || resubmit) $ do checkNoPagureRepo putNewLn comments <- getComments session bid@@ -77,6 +80,7 @@ existingRepoRequests = do fasid <- fasIdFromKrb erecent <-+ retry 2 $ pagureListProjectIssueTitlesStatus pagureio "releng/fedora-scm-requests" [makeItem "author" fasid, makeItem "status" "all",
+ src/Cmd/ReviewPackage.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE OverloadedStrings #-}++module Cmd.ReviewPackage (+ reviewPackage+ ) where++import Common+import Common.System++import Data.Char+import SelectRPMs (selectDefault)+import SimplePrompt (promptEnter, yesNoDefault)++import Branches+import Bugzilla+import Cmd.Import (downloadReviewSRPM, upstreamDir)+import Cmd.Install (installCmd)+import Cmd.Local (localCmd)+import Git (isGitRepo, git_, gitBool)+import Package+import RpmBuild++-- FIXME does not work with pkg dir/spec: 'fbrnch: No spec file found'+-- FIXME --user to download all user's review requests+reviewPackage :: Bool -> Maybe String -> IO ()+reviewPackage _ Nothing = do+ -- FIXME catch no spec file+ spec <- findSpecfile+ srpm <- generateSrpm Nothing spec+ cmd_ "fedora-review" ["-rn", srpm]+reviewPackage interactive (Just pkgbug) = do+ let epkgbid =+ if all isDigit pkgbug+ then Right $ read pkgbug+ else Left pkgbug+ (bugs,session) <- bugsSession $+ case epkgbid of+ Right bid -> packageReview .&&. statusNewAssigned .&&. bugIdIs bid+ Left pkg -> pkgReviews pkg .&&. statusNewAssigned+ case bugs of+ [bug] -> do+ putReviewBug False bug+ let bid = bugId bug+ pkg = reviewBugToPackage bug+ if interactive+ then reviewPackageInteractive bid pkg session bug+ else do+ promptEnter "Press Enter to run fedora-review"+ -- FIXME support copr build+ -- FIXME if toolbox set REVIEW_NO_MOCKGROUP_CHECK+ cmd_ "fedora-review" ["-b", show bid]+ [] -> error' $ "No package review found for" +-+ pkgbug+ _ -> error' $ "More than one review bug found for" +-+ pkgbug++reviewPackageInteractive :: Int -> String -> BugzillaSession -> Bug -> IO ()+reviewPackageInteractive bid pkg session bug = do+ let dir = show bid ++ '-' : pkg+ -- FIXME check if current directory+ exists <- doesDirectoryExist dir+ unless exists $+ createDirectory dir+ setCurrentDirectory dir+ srpm <- downloadReviewSRPM True False pkg bid session+ importsrpm <-+ if exists+ then do+ putStrLn $ "in" +-+ dir </> ":\n"+ cmd_ "ls" ["-F"]+ putNewLn+ -- FIXME default to no if nvr unchanged?+ yesNoDefault True "Press Enter to install/prep srpm"+ else return True+ let spec = pkg <.> "spec"+ when importsrpm $ do+ isgit <- isGitRepo+ unless isgit $ git_ "init" []+ -- FIXME override %_sourcedir so it doesn't put elsewhere?+ sourcediropt <- sourceDirCwdOpt+ cmd_ "rpm" $ ["-ivh", srpm] ++ sourcediropt+ git_ "add" [spec]+ allsrcs <- map sourceFieldFile <$> cmdLines "spectool" [spec]+ forM_ allsrcs $ \src ->+ unless (isArchiveFile src) $+ git_ "add" [src]+ putStrLn $ "# Diff with" +-+ upstreamDir+ cmd_ "diff" ["-u", spec, upstreamDir </> spec]+ withCurrentDirectory upstreamDir $+ void $ getSources spec+ diff <- lines <$> cmdIgnoreErr "diff" ["--brief", ".", upstreamDir] ""+ let filterdiff = filter (\d -> not (any (`isSuffixOf` d) ["SPEC","SRPMS","RPMS","BUILD","BUILDROOT","src.rpm",".log", ".git", upstreamDir])) diff+ if null filterdiff+ then putStrLn $ "no difference with" +-+ upstreamDir ++ "/"+ else mapM_ putStrLn filterdiff+ unlessM (gitBool "diff" ["--quiet", "--cached"]) $+ git_ "commit" ["-m", srpm]+ putStrLn "# Build"+ -- FIXME or download rpms+ build <- yesNoDefault importsrpm "Build package locally"+ when build $+ localCmd False False Nothing [] (Branches [],[])+ putStrLn "# RpmLint"+ void $ cmdBool "rpmlint" ["."] -- FIXME $ spec:srpm:rpms+ whenM (yesNoDefault importsrpm "Install packages locally") $ do+ installCmd False False Nothing Nothing [] False True True selectDefault (Nothing,[])+ rpms <- cmdLines "rpmspec" ["-q", "--rpms", "--qf", "%{name}\n", spec]+ whenM (yesNoDefault importsrpm "Rpmlint installed packages") $ do+ (_ok, out, err) <- cmdFull "rpmlint" ("-i" : rpms) ""+ let rpmlintout = "rpmlint.output"+ writeFile rpmlintout out+ let nolines = length $ lines out+ if nolines > 20+ then do+ cmd_ "tail" [rpmlintout]+ putStrLn $ show nolines +-+ "lines saved to" +-+ rpmlintout+ else putStrLn out+ unless (null err) $ warning $ "rpmlint stderr:\n" ++ err+ putNewLn+ putStrLn "# Licensing"+ -- FIXME use build subdir+ -- FIXME filter out files not in tarball or prep+ cmdLines "licensecheck" ["-r", "BUILD"] >>=+ -- handle "FILEPATH: *No copyright* UNKNOWN [generated file]"+ mapM_ putStrLn . filter (not . (" UNKNOWN" `isInfixOf`))+ cmd_ "rpmspec" ["-q", "--srpm", "--qf", "Spec license: %{license}\n", spec]+ putNewLn+ putReviewBug False bug+ putStrLn $ "Review dir is" +-+ dir
src/Cmd/Reviews.hs view
@@ -9,10 +9,12 @@ -- FIXME add --state or --new, --modified, etc -- FIXME display time of last update-reviewsCmd :: Bool -> Bool -> Bool -> Maybe String -> Maybe String- -> ReviewStatus -> IO ()-reviewsCmd short allstates assignee muser mpat status = do- listReviewsFull assignee muser mpat allstates status >>=+reviewsCmd :: Bool -> Bool -> Maybe (Maybe String) -> Maybe (Maybe String)+ -> Maybe String -> ReviewStatus -> IO ()+reviewsCmd short allstates Nothing Nothing Nothing status =+ reviewsCmd short allstates Nothing (Just Nothing) Nothing status+reviewsCmd short allstates mmassignee mmreporter mpat status = do+ listReviewsFull mmassignee mmreporter mpat allstates status >>= mapM_ (putReviewBug short) . sortBugsByStatus . sortBugsByID when short putNewLn
src/Cmd/Scratch.hs view
@@ -9,6 +9,7 @@ ) where import Data.RPM.NVR (NVR)+import Distribution.Fedora.Branch (branchTarget) import Branches import Common
src/Cmd/Sort.hs view
@@ -12,6 +12,7 @@ import Distribution.RPM.Build.Order (dependencySortRpmOpts, dependencySortParallel, dependencyLayers)+import System.Directory (doesFileExist) import Branches import Git@@ -45,7 +46,8 @@ setupPkg :: Package -> AnyBranch -> IO () setupPkg pkg br = do whenM isPkgGitRepo $ gitSwitchBranch br- getDynSourcesMacros $ packageSpec pkg+ unlessM (doesFileExist "dead.package") $+ getDynSourcesMacros $ packageSpec pkg toRpmOption :: RpmWith -> [String] toRpmOption (RpmWith opt) = ["--with=" ++ opt]
src/Cmd/Status.hs view
@@ -2,8 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} module Cmd.Status (- statusCmd,- unpushedCmd+ statusCmd ) where @@ -13,6 +12,7 @@ import Data.Fixed import Data.Time.Clock import Data.Time.LocalTime+import Distribution.Fedora.Branch (branchDestTag) import Fedora.Bodhi import Bugzilla@@ -26,8 +26,8 @@ -- FIXME --pending -- FIXME handle not cloned (remote only) -- FIXME silence fetching of new branches? (for --reviews etc)-statusCmd :: Bool -> Bool -> (BranchesReq,[String]) -> IO ()-statusCmd nofetch reviews (breq, pkgs) = do+statusCmd :: Bool -> Bool -> Bool -> (BranchesReq,[String]) -> IO ()+statusCmd nofetch reviews latestcommit (breq, pkgs) = do reviewpkgs <- if reviews then map reviewBugToPackage <$> listReviewsAll True ReviewRepoCreated@@ -39,87 +39,92 @@ statusBranch :: Package -> AnyBranch -> IO () statusBranch _ (OtherBranch _) = error' "status currently only defined for release branches"- statusBranch pkg rbr@(RelBranch br) = do- brExists <- checkIfRemoteBranchExists rbr- if not brExists- then do- name <- getDirectoryName- putStrLn $ name +-+ "has no branch" +-+ show br- else do- gitSwitchBranch rbr- let spec = packageSpec pkg- exists <- doesFileExist spec- if not exists- then- ifM initialPkgRepo- (putStrLn $ show br ++ ": initial repo")- (putStrLn $ "missing" +-+ spec)+ statusBranch pkg rbr@(RelBranch br) =+ if latestcommit+ then do+ putStr $ unPackage pkg ++ ": "+ whenJustM (gitShortLog1 Nothing) $ putStrLn . showCommit+ else do+ brExists <- checkIfRemoteBranchExists rbr+ if not brExists+ then do+ name <- getDirectoryName+ putStrLn $ name +-+ "has no branch" +-+ show br else do- mnvr <- pkgNameVerRel br spec- case mnvr of- Nothing -> do- putStrLn "undefined NVR!\n"- putStr "HEAD "- whenJustM (gitShortLog1 Nothing) $ putStrLn . showCommit- Just nvr -> do- -- unless (br == Rawhide) $ do- -- newerBr <- newerBranch br <$> getFedoraBranches- -- ancestor <- gitBool "merge-base" ["--is-ancestor", "HEAD", show newerBr]- -- when ancestor $ do- -- unmerged <- gitOneLineLog $ "HEAD..origin/" ++ show newerBr- -- unless (null unmerged) $ do- -- putStrLn $ "Newer commits in" +-+ show newerBr ++ ":"- -- mapM_ putStrLn unmerged- munpushed <- gitShortLog1 $ Just $ "origin/" ++ show br ++ "..HEAD"- case munpushed of- Nothing -> do- mbuild <- kojiGetBuildID fedoraHub (showNVR nvr)- case mbuild of- Nothing -> do- mlatest <- kojiLatestNVR (branchDestTag br) (unPackage pkg)- case mlatest of- Nothing -> putStrLn $ "new" +-+ showNVR nvr- Just latest ->- putStrLn $ if equivNVR nvr mlatest then showNVR latest +-+ "is latest modulo disttag" else showNVR latest +-+ "->\n" ++ showNVR nvr- Just buildid -> do- tags <- kojiBuildTags fedoraHub (buildIDInfo buildid)- if null tags- then do- mstatus <- kojiBuildStatus nvr- -- FIXME show pending archs building- whenJust mstatus $ \ status ->- -- FIXME better Show BuildStatus- putStr $ showNVR nvr +-+ "(" ++ show status ++ ")"- else do- -- FIXME hide testing if ga/stable- putStr $ showNVR nvr +-+ "(" ++ unwords tags ++ ")"- unless (isStable tags) $ do- updates <- bodhiUpdates- [makeItem "display_user" "0",- makeItem "builds" (showNVR nvr)]- case updates of- [] -> putStrLn "No update found"- [update] -> do- -- FIXME could show minus time left using stable_days?- let msince = lookupKey "date_testing" update :: Maybe LocalTime- case msince of- Nothing -> return ()- Just date -> do- let since = localTimeToUTC utc date- current <- getCurrentTime- let diff = diffUTCTime current since- putAge diff- _ -> putStrLn "More than one update found!"- putNewLn- Just unpushed ->- let prefix =- let pref =- (if length pkgs > 1 then unPackage pkg else "") +-+- case breq of- Branches brs | length brs <= 1 -> ""- _ -> show br- in if null pref then "" else pref ++ ":"- in putStrLn $ prefix +-+ showCommit unpushed+ gitSwitchBranch rbr+ let spec = packageSpec pkg+ exists <- doesFileExist spec+ if not exists+ then+ ifM initialPkgRepo+ (putStrLn $ show br ++ ": initial repo")+ (putStrLn $ "missing" +-+ spec)+ else do+ mnvr <- pkgNameVerRel br spec+ case mnvr of+ Nothing -> do+ putStrLn "undefined NVR!\n"+ putStr "HEAD "+ whenJustM (gitShortLog1 Nothing) $ putStrLn . showCommit+ Just nvr -> do+ -- unless (br == Rawhide) $ do+ -- newerBr <- newerBranch br <$> getFedoraBranches+ -- ancestor <- gitBool "merge-base" ["--is-ancestor", "HEAD", show newerBr]+ -- when ancestor $ do+ -- unmerged <- gitOneLineLog $ "HEAD..origin/" ++ show newerBr+ -- unless (null unmerged) $ do+ -- putStrLn $ "Newer commits in" +-+ show newerBr ++ ":"+ -- mapM_ putStrLn unmerged+ munpushed <- gitShortLog1 $ Just $ "origin/" ++ show br ++ "..HEAD"+ case munpushed of+ Nothing -> do+ mbuild <- kojiGetBuildID fedoraHub (showNVR nvr)+ case mbuild of+ Nothing -> do+ mlatest <- kojiLatestNVR (branchDestTag br) (unPackage pkg)+ case mlatest of+ Nothing -> putStrLn $ "new" +-+ showNVR nvr+ Just latest ->+ putStrLn $ if equivNVR nvr mlatest then showNVR latest +-+ "is latest modulo disttag" else showNVR latest +-+ "->\n" ++ showNVR nvr+ Just buildid -> do+ tags <- kojiBuildTags fedoraHub (buildIDInfo buildid)+ if null tags+ then do+ mstatus <- kojiBuildStatus nvr+ -- FIXME show pending archs building+ whenJust mstatus $ \ status ->+ -- FIXME better Show BuildStatus+ putStr $ showNVR nvr +-+ "(" ++ show status ++ ")"+ else do+ -- FIXME hide testing if ga/stable+ putStr $ showNVR nvr +-+ "(" ++ unwords tags ++ ")"+ unless (isStable tags) $ do+ updates <- bodhiUpdates+ [makeItem "display_user" "0",+ makeItem "builds" (showNVR nvr)]+ case updates of+ [] -> putStrLn "No update found"+ [update] -> do+ -- FIXME could show minus time left using stable_days?+ let msince = lookupKey "date_testing" update :: Maybe LocalTime+ case msince of+ Nothing -> return ()+ Just date -> do+ let since = localTimeToUTC utc date+ current <- getCurrentTime+ let diff = diffUTCTime current since+ putAge diff+ _ -> putStrLn "More than one update found!"+ putNewLn+ Just unpushed ->+ let prefix =+ let pref =+ (if length pkgs > 1 then unPackage pkg else "") +-++ case breq of+ Branches brs | length brs <= 1 -> ""+ _ -> show br+ in if null pref then "" else pref ++ ":"+ in putStrLn $ prefix +-+ showCommit unpushed where isStable :: [String] -> Bool isStable = not . all ("-testing" `isSuffixOf`)@@ -135,66 +140,3 @@ #if !MIN_VERSION_time(1,8,0) nominalDay = 3600 * 24 :: NominalDiffTime #endif---unpushedCmd :: Bool -> Bool -> (BranchesReq,[String]) -> IO ()-unpushedCmd latest bump (breq, pkgs) =- -- FIXME dirty not okay for multiple branches?- withPackagesByBranches (if latest then HeaderMay else HeaderMust) False dirtyGit AnyNumber unpushedBranch (breq, pkgs)- where- -- FIXME note dirty when local changes- unpushedBranch :: Package -> AnyBranch -> IO ()- unpushedBranch _ (OtherBranch _) =- error' "status currently only defined for release branches"- unpushedBranch pkg rbr@(RelBranch br) = do- brExists <- checkIfRemoteBranchExists rbr- if not brExists- then do- name <- getDirectoryName- putStrLn $ name +-+ "has no branch" +-+ show br- else do- gitSwitchBranch rbr- let spec = packageSpec pkg- prefix =- let pref =- (if length pkgs > 1 && latest- then unPackage pkg else "") +-+- case breq of- Branches brs | length brs <= 1 -> ""- _ -> show br- in if null pref then "" else pref ++ ":"- haveSpec <- doesFileExist spec- if not haveSpec- then- ifM initialPkgRepo- (putStrLn $ prefix +-+ "initial repo") $- ifM (doesFileExist "dead.package")- (putStrLn $ prefix +-+ "dead package") $- putStrLn $ prefix +-+ "missing" +-+ spec- else do- whenM (isNothing <$> pkgNameVerRel br spec) $ do- putStrLn "undefined NVR!\n"- putStr "HEAD "- unpushed <- gitShortLogN (if latest then Just 1 else Nothing) $- Just $ "origin/" ++ show br ++ "..HEAD"- if null unpushed- then- when bump $ doBump spec- else- if latest- then whenJust (listToMaybe unpushed) $ putCommit prefix- else mapM_ (putCommit prefix) unpushed-- putCommit prefix = putStrLn . (prefix +-+) . showCommit-- doBump spec = do- checkWorkingDirClean False- dead <- doesFileExist "dead.package"- if dead- then putStrLn "dead package"- else do- putStrLn "bumping"- autorelease <- isAutoRelease spec- unless autorelease $- cmd_ "rpmdev-bumpspec" ["-c", "rebuild", spec]- git_ "commit" $ "-a" : (if autorelease then ("--allow-empty" :) else id) ["-m", "bump release"]
+ src/Cmd/Unpushed.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Cmd.Unpushed (+ unpushedCmd+ )+where+++import Branches+import Cmd.Bump (bumpPkg)+import Common+import Common.System+import Git+import Package++unpushedCmd :: Bool -> Bool -> Bool -> (BranchesReq,[String]) -> IO ()+unpushedCmd checknvr latest bump (breq, pkgs) =+ -- FIXME dirty not okay for multiple branches?+ withPackagesByBranches (if latest then HeaderMay else HeaderMust) False dirtyGit AnyNumber unpushedBranch (breq, pkgs)+ where+ -- FIXME note dirty when local changes+ unpushedBranch :: Package -> AnyBranch -> IO ()+ unpushedBranch _ (OtherBranch _) =+ error' "status currently only defined for release branches"+ unpushedBranch pkg rbr@(RelBranch br) = do+ brExists <- checkIfRemoteBranchExists rbr+ if not brExists+ then do+ name <- getDirectoryName+ putStrLn $ name +-+ "has no branch" +-+ show br+ else do+ gitSwitchBranch rbr+ let spec = packageSpec pkg+ prefix =+ let pref =+ (if length pkgs > 1 && latest+ then unPackage pkg else "") +-++ case breq of+ Branches brs | length brs <= 1 -> ""+ _ -> show br+ in if null pref then "" else pref ++ ":"+ haveSpec <- doesFileExist spec+ if not haveSpec+ then+ ifM initialPkgRepo+ (putStrLn $ prefix +-+ "initial repo") $+ unlessM (doesFileExist "dead.package") $+ putStrLn $ prefix +-+ "missing" +-+ spec+ else do+ when (checknvr || length pkgs < 10) $+ whenM (isNothing <$> pkgNameVerRel br spec) $ do+ putStrLn "undefined NVR!\n"+ putStr "HEAD "+ unpushed <- gitShortLogN (if latest then Just 1 else Nothing) $+ Just $ "origin/" ++ show br ++ "..HEAD"+ if null unpushed+ then+ when bump $ bumpPkg False False Nothing Nothing pkg rbr+ else+ if latest+ then whenJust (listToMaybe unpushed) $ putCommit prefix+ else mapM_ (putCommit prefix) unpushed++ putCommit prefix = putStrLn . (prefix +-+) . showCommit
src/Cmd/Update.hs view
@@ -4,6 +4,9 @@ ) where +import Data.RPM.VerCmp+import SimplePrompt (promptEnter)+ import Branches import Common import Common.System@@ -12,9 +15,6 @@ import Krb import Package -import Data.RPM.VerCmp-import SimplePrompt (promptEnter)- -- FIXME if autorelease, drop -b baserelease -- FIXME --no-prep to avoid overwriting ongoing build -- FIXME don't bump release if already bumped@@ -42,8 +42,9 @@ else if null pkgs then Nothing else dirty withPackagesMaybeBranch HeaderMay False mgitops (updatePkg onlysources force allowHEAD pkgGit mver) (mbr, pkgs) -updatePkg :: Bool -> Bool -> Bool -> Bool -> Maybe String -> Package -> AnyBranch- -> IO ()+-- FIXME use tempdir or don't prep to prevent overwriting an ongoing build+updatePkg :: Bool -> Bool -> Bool -> Bool -> Maybe String -> Package+ -> AnyBranch -> IO () updatePkg onlysources force allowHEAD distgit mver pkg br = do when (distgit && br /= RelBranch Rawhide && isRelBranch br) $ promptEnter $ "Are you sure you want to update" +-+ show br +-+ "branch?! Press Enter to continue"@@ -96,9 +97,10 @@ -- FIXME only if not all exist cmd_ "spectool" ["-g", "-S", spec] patches <- map sourceFieldFile <$> cmdLines "spectool" ["-P", spec]- forM_ patches $ \patch ->+ forM_ patches $ \patch -> do unlessM (doesFileExist patch) $- cmd_ "spectool" ["-g", "-P", spec]+ cmd_ "spectool" ["-g", "-P", spec]+ git_ "add" [patch] when force $ do let archives = filter isArchiveFile existing forM_ archives removeFile@@ -112,24 +114,10 @@ cmd_ "rpmdev-bumpspec" ["-c", "update to" +-+ newver, spec] git_ "commit" ["-a", "-m", "update to" +-+ newver] putStr "Prepping... "- cmdSilent' "rpmbuild" ["-bp", "--nodeps", spec]+ sourcediropt <- sourceDirCwdOpt+ cmdSilent' "rpmbuild" $ "-bp" : sourcediropt ++ ["--nodeps", spec] putStrLn "done" -- FIXME git amend (if previous commit was update)- where- sourceFieldFile :: String -> FilePath- sourceFieldFile field =- if null field then- -- should be impossible- error "empty source field!"- else (takeFileName . last . words) field-- -- FIXME handle .tgz?- isArchiveFile :: FilePath -> Bool- isArchiveFile f =- any ($ f) [(".tar." `isInfixOf`),- (".zip" `isSuffixOf`),- (".gpg" `isSuffixOf`),- (".tgz" `isSuffixOf`)] pkgVerRel :: FilePath -> IO (String,String) pkgVerRel spec = do
src/Git.hs view
@@ -36,6 +36,7 @@ ) where import Data.Char (isSpace)+import Distribution.Fedora.Branch (newerBranch) import SimpleCmd.Git import SimplePrompt @@ -165,7 +166,7 @@ if ok then putStrLn $ if quiet then "done" else last (lines err) else do- when quiet $ putStrLn ""+ when quiet putNewLn putStrLn $ unwords ("git" : args) +-+ "failed with\n" ++ err yes <- yesNo "Retry git push" -- FIXME going to fail if ref no longer on branch
src/Koji.hs view
@@ -31,8 +31,13 @@ import qualified Data.ByteString.Lazy.Char8 as B import Data.Fixed (Micro) import Data.RPM.NVR (NVR, maybeNVR, nvrName)+import Data.Time.Clock+import Data.Time.Format+import Data.Time.LocalTime+import Distribution.Fedora.Branch (branchTarget) import Distribution.Koji import qualified Distribution.Koji.API as Koji+import Say (sayString) import SimplePrompt (promptEnter) import System.Exit import System.Process.Typed@@ -146,7 +151,7 @@ Just TaskFailed -> do whenJustM (findExecutable "koji-tool") $ \kojitool -> -- FIXME cmdLog deprecated- cmdLog kojitool ["tasks", displayID task, "--tail", "-s", "fail"]+ cmdLog kojitool ["tasks", "--children", displayID task, "--tail", "-s", "fail"] error' "Task failed!" Just TaskCanceled -> return () _ -> kojiWatchTask task@@ -165,8 +170,6 @@ Just ts -> if ts `elem` openTaskStates then do- -- this makes parallel too noisy- --putChar '.' sleep 20 kojiWaitTask task else return $ ts == TaskClosed@@ -238,14 +241,15 @@ Nothing -> error "create_event not found" Just event -> do latest <- kojiLatestNVRRepo buildtag event (nvrName nvr)+ tz <- getCurrentTimeZone if latest == Just nvr- then logMsg $ showNVR nvr +-++ then logSay tz $ showNVR nvr +-+ if isNothing moldrepo then "is in" +-+ buildtag else "appeared" else do when (isNothing moldrepo && not quiet) $- logMsg $ "Waiting for" +-+ buildtag +-+ "to have" +-+ showNVR nvr+ logSay tz $ "Waiting for" +-+ buildtag +-+ "to have" +-+ showNVR nvr waitRepo buildtag mrepo kojiTagArchs :: String -> IO [String]@@ -290,9 +294,10 @@ out <- if dryrun then return $ "Side tag '" ++ buildtag ++ "'"- else if create- then head . lines <$> fedpkg "request-side-tag" ["--base-tag", buildtag]- else error' "incorrect side-tag create request"+ else+ if create+ then head . lines <$> fedpkg "request-side-tag" ["--base-tag", buildtag]+ else error' "incorrect side-tag create request" if "Side tag '" `isPrefixOf` out then do putNewLn@@ -306,3 +311,8 @@ else error' "'fedpkg request-side-tag' failed" [tag] -> return tag _ -> error' $ "More than one user side-tag found for" +-+ show br++logSay :: TimeZone -> String -> IO ()+logSay tz str = do+ now <- utcToLocalTime tz <$> getCurrentTime+ sayString $ formatTime defaultTimeLocale "%T" now +-+ str
src/ListReviews.hs view
@@ -7,6 +7,8 @@ listReviewsFull ) where +import SimpleCmd (error')+ import Common import Branches@@ -25,15 +27,28 @@ listReviews = listReviewsAll False listReviewsAll :: Bool -> ReviewStatus -> IO [Bug]-listReviewsAll = listReviewsFull False Nothing Nothing+listReviewsAll = listReviewsFull Nothing (Just Nothing) Nothing -- FIXME: --unassigned-listReviewsFull :: Bool -> Maybe String -> Maybe String -> Bool- -> ReviewStatus-> IO [Bug]-listReviewsFull assignee muser mpat allopen status = do+listReviewsFull :: Maybe (Maybe String) -> Maybe (Maybe String)+ -> Maybe String -> Bool -> ReviewStatus -> IO [Bug]+listReviewsFull Nothing Nothing Nothing _ _ =+ error' "please specify either report, assignee, or package name pattern"+listReviewsFull mmassignee mmreporter mpat allopen status = do session <- bzApiKeySession- accountid <- getBzAccountId session muser- let reviews = (if assignee then assigneeIs else reporterIs) accountid .&&. maybe packageReview pkgReviewsPrefix mpat+ massignedto <-+ case mmassignee of+ Nothing -> return Nothing+ Just massignee ->+ Just <$> getBzAccountId session massignee+ mreporter <-+ case mmreporter of+ Nothing -> return Nothing+ Just mreporter ->+ Just <$> getBzAccountId session mreporter+ let reviews = maybe id (\a -> (assigneeIs a .&&.)) massignedto $+ maybe id (\r -> (reporterIs r .&&.)) mreporter $+ maybe packageReview pkgReviewsPrefix mpat open = if allopen then statusOpen else case status of
src/Main.hs view
@@ -3,13 +3,15 @@ module Main (main) where import Data.Maybe (fromMaybe)-import Distribution.Fedora.Branch+import Distribution.Fedora.Branch (partitionBranches, readBranch) #if !MIN_VERSION_simple_cmd_args(0,1,7) import Options.Applicative (maybeReader, ReadM) #endif+import SelectRPMs (selectRpmsOption) import SimpleCmdArgs -- commands+import Cmd.Autospec import Cmd.Bugs import Cmd.Build import Cmd.Bump@@ -18,6 +20,7 @@ import Cmd.Compare import Cmd.Copr import Cmd.Diff+import Cmd.Fetch import Cmd.FTBFS import Cmd.Import import Cmd.Install@@ -31,10 +34,12 @@ import Cmd.Parallel import Cmd.PkgReview import Cmd.Prep-import Cmd.PullPush+import Cmd.Pull+import Cmd.Push --import Cmd.Repoquery import Cmd.RequestBranch import Cmd.RequestRepo+import Cmd.ReviewPackage import Cmd.Reviews import Cmd.Scratch import Cmd.SideTags@@ -42,6 +47,7 @@ import Cmd.SrcDeps import Cmd.Status import Cmd.Switch+import Cmd.Unpushed import Cmd.Update import Cmd.WaitRepo @@ -62,7 +68,8 @@ subcommands [ Subcommand "clone" "Clone packages" $ cloneCmd- <$> cloneRequest+ <$> optional (optionWith branchM 'b' "branch" "BRANCH" "branch")+ <*> cloneRequest , Subcommand "switch" "Switch branch" $ switchCmd <$> verboseOpt "verbose output"@@ -75,6 +82,7 @@ statusCmd <$> switchWith 'n' "no-fetch" "Do not git fetch to save time" <*> switchWith 'r' "reviews" "Status of reviewed packages"+ <*> switchWith 'l' "latest-commit" "Show the last commit" <*> branchesPackages , Subcommand "merge" "Merge from newer branch" $ mergeCmd@@ -87,7 +95,8 @@ <*> branchesPackages , Subcommand "unpushed" "Show unpushed commits" $ unpushedCmd- <$> switchWith 'l' "latest" "Only show latest unpushed commit"+ <$> switchWith 'c' "check-nvr" "Check NVR defined [default for < 10 pkgs]"+ <*> switchWith 'l' "latest" "Only show latest unpushed commit" <*> switchWith 'b' "bump" "Bump release (and commit) if no local commits" <*> branchesPackages , Subcommand "build" "Build package(s) in Koji" $@@ -96,7 +105,8 @@ <*> branchesPackages , Subcommand "list" "List packages in pagure" $ listCmd- <$> switchWith 'c' "count" "Print number of packages"+ <$> forceOpt "Do not prompt if large number of results"+ <*> switchWith 'c' "count" "Print number of packages" <*> optional packagerOpt <*> many (pkgArg "PKGPAT...") , Subcommand "list-local" "List packages in branch" $@@ -115,9 +125,10 @@ <*> mergeOpt <*> optionalWith auto 'l' "skip-to-layer" "LAYERNO" "Skip the first N layers [default 0]" 0 <*> optional (sidetagTargetOpt $ Just "or creates one for you (with 'fedpkg request-side-tag --base-tag')")+ <*> switchLongWith "must-push" "Error if no unpushed commits" <*> optionalWith auto 'd' "delay" "SECONDS" "Sleep delay between starting builds [default 4.0]" 4 <*> updateOpt- <*> branchesPackages+ <*> branchesPackagesDesc "BRANCH... PKG1... [:] PKG2..." , Subcommand "sidetags" "List user's side-tags" $ sideTagsCmd <$> switchLongWith "remove" "Remove one or more sidetags"@@ -142,7 +153,7 @@ <*> switchLongWith "stagger" "Stagger archs" <*> rebuildSrpmOpt <*> noFailFastOpt- <*> switchLongWith "allow-head" "allow detached HEAD"+ <*> allowHeadOpt <*> optional archesOpt <*> many (sidetagTargetOpt Nothing) <*> optional scratchSourceOpt@@ -151,7 +162,7 @@ scratchCmdAarch64 <$> dryrunOpt "Dry run: do not build" <*> rebuildSrpmOpt- <*> switchLongWith "allow-head" "allow detached HEAD"+ <*> allowHeadOpt <*> switchWith 'X' "exclude-arch" "Exclude aarch64" <*> many (sidetagTargetOpt Nothing) <*> optional scratchSourceOpt@@ -160,23 +171,23 @@ scratchCmdX86_64 <$> dryrunOpt "Dry run: do not build" <*> rebuildSrpmOpt- <*> switchLongWith "allow-head" "allow detached HEAD"+ <*> allowHeadOpt <*> switchWith 'X' "exclude-arch" "Exclude x86_64" <*> many (sidetagTargetOpt Nothing) <*> optional scratchSourceOpt <*> branchesPackages , Subcommand "update-sources" "Download and update newer sources" $ updateCmd True- <$> switchWith 'f' "force" "Download upstream sources even if they exist locally"+ <$> forceOpt "Download upstream sources even if they exist locally" <*> switchWith 'H' "allow-head" "For updating inside rebase" <*> maybeBranchPackages False , Subcommand "update-version" "Update package in dist-git to newer version" $ updateCmd <$> switchWith 's' "sources-only" "Only update sources"- <*> switchWith 'f' "force" "Download upstream sources even if they exist locally"+ <*> forceOpt "Download upstream sources even if they exist locally" <*> switchWith 'H' "allow-head" "For updating inside rebase" <*> maybeBranchPackages False- , Subcommand "sort" "Sort packages in build dependency order" $+ , Subcommand "sort" "Sort packages in build dependency order (default format: chain-build)" $ sortCmd <$> sortDisplayOpt <*> optional rpmWithOpt@@ -186,17 +197,18 @@ <$> optional prepPreOpts <*> verboseOpt "show rpmbuild output" <*> switchWith 'd' "deps" "require deps to be installed"+ <*> allowHeadOpt <*> maybeBranchPackages False , Subcommand "local" "Build locally" $ localCmd <$> quietOpt "Hide the build.log until it errors"- <*> switchWith 'd' "debug" "show the rpmbuild command"+ <*> debugOpt "show the rpmbuild command" <*> optional forceshortOpt <*> many bcondOpt <*> branchesPackages , Subcommand "srpm" "Build srpm" $ srpmCmd- <$> switchWith 'f' "force" "regenerate even if spec older than existing srpm"+ <$> forceOpt "regenerate even if spec older than existing srpm" <*> maybeBranchPackages False , Subcommand "srpm-spec" "Show the spec file in an srpm" $ srpmSpecCmd@@ -204,12 +216,12 @@ <*> some (strArg "SRPM") , Subcommand "diff" "Diff local changes" $ diffCmd- <$> switchWith 'd' "debug" "use package headers"+ <$> debugOpt "use package headers" <*> switchWith 'o' "spec-only" "Only diff spec file" <*> diffWorkOpt <*> diffFormatOpt <*> switchWith 'i' "ignore-bumps" "Ignore pure release bumps"- <*> optional diffFilterOpt+ <*> many diffFilterOpt <*> optional (optionWith anyBranchM 'w' "with-branch" "BRANCH" "branch") <*> maybeBranchPackages False , Subcommand "compare" "Show commits between branches" $@@ -249,7 +261,7 @@ <*> switchWith 'r' "reinstall" "reinstall rpms" <*> switchLongWith "no-build" "do not (re-)build (install built rpms)" <*> switchLongWith "ignore-builddeps" "do not install builddeps"- <*> switchWith 'a' "all-subpackages" "install all subpackages (default if none currently installed)"+ <*> selectRpmsOption <*> maybeBranchPackages False , Subcommand "not-installed" "Packages not installed locally" $ notInstalledCmd@@ -259,16 +271,18 @@ <$> optional (strOptionWith 's' "summary" "KEY" "Search for bugs containing keyword") <*> manyPackages , Subcommand "bump" "Bump release for package" $- bumpPkgs+ bumpCmd <$> dryrunOpt "Dry run: do not bump" <*> switchWith 'l' "local" "Use local origin rather than checking latest koji"- <*> optional commitOpts+ <*> optional (strOptionWith 'm' "message" "COMMITMSG"+ "Specify commit message") <*> optional (strOptionWith 'c' "changelog" "CLOGENTRY" "Override changelog entry [default: rebuild]") <*> branchesPackages , Subcommand "commit" "Git commit packages" $- commitPkgs- <$> optional commitOpts+ commitCmd+ <$> dryrunOpt "Dry run: do not commit"+ <*> optional commitOpts <*> switchWith '1' "first-line" "use first line of changelog" <*> switchWith 'a' "unstaged" "include unstaged changes" <*> manyPackages@@ -303,20 +317,26 @@ <*> optional (strArg "SPECFILE") , Subcommand "review-package" "Run fedora-review on a package Review Request bug" $ reviewPackage- <$> optional (pkgArg "PACKAGE/BZID")+ <$> switchWith 'i' "interactive" "Download and check package review without fedora-review mock build"+ <*> optional (pkgArg "PACKAGE/BZID") , Subcommand "reviews" "List package reviews" $ reviewsCmd <$> reviewShortOpt <*> reviewAllStatusOpt- <*> switchWith 'T' "assigned-to" "List reviews assigned to user"- <*> optional (strOptionWith 'U' "user" "USER" "Bugzilla user email")+ <*> optional+ (flagLongWith' Nothing "assigned" "Package reviewer" <|>+ Just <$> strOptionLongWith "assignee" "BZUSER" "Package review submitter")+ <*> optional+ (flagLongWith' Nothing "submitted" "Submitted reviews [default if no assignee specified]" <|>+ Just <$> strOptionWith 's' "submitter" "BZUSER" "Package review submitter") <*> optional (strOptionWith 'p' "pattern" "PKGPREFIX" "Package pattern prefix") <*> reviewStatusOpt , Subcommand "request-repos" "Request dist git repo for new approved packages" $ requestRepos <$> mockOpt True <*> reviewAllStatusOpt- <*> switchWith 'r' "retry" "Re-request repo"+ <*> switchWith 's' "skip-request-check" "Skip check for existing fedora-scm-requests issue"+ <*> switchWith 'r' "resubmit" "Re-request repo" <*> branchesPackages , Subcommand "import" "Import new approved created packages from bugzilla review" $ importCmd@@ -345,7 +365,10 @@ , Subcommand "copr" "Build package(s) in Fedora Copr" $ coprCmd <$> dryrunOpt "Dry run: do not build"- <*> switchWith 'l' "list-chroots" "Show project chroots"+ <*> (flagWith' ListChroots 'l' "list-chroots" "Show project chroots" <|>+ flagLongWith' CoprNew "new" "Create new copr repo" <|>+ flagWith CoprBuild CoprMonitor 'm' "monitor" "Show project chroots")+ <*> forceOpt "build even if existing n-v-r" <*> buildByOpt <*> optional archesOpt <*> pkgArg "PROJECT"@@ -375,7 +398,7 @@ <*> maybeBranchPackages False , Subcommand "autospec" "Convert package to use rpmautospec" $ autospecCmd- <$> switchWith 'f' "force" "Refresh changelog file to current"+ <$> forceOpt "Refresh changelog file to current" <*> manyPackages , Subcommand "move-artifacts" "Move old rpm artifacts into rpmbuild dirs" $ moveArtifactsCmd@@ -387,10 +410,11 @@ cloneRequest = flagWith' (CloneUser Nothing) 'M' "mine" "Your packages" <|> CloneUser . Just <$> strOptionWith 'u' "user" "USER" "Packages of FAS user" <|>- ClonePkgs <$> maybeBranchPackages True+ CloneGroup <$> strOptionWith 'g' "group" "GROUP" "Packages of package group" <|>+ ClonePkgs <$> somePackages reviewShortOpt :: Parser Bool- reviewShortOpt = switchWith 's' "short" "Only output the package name"+ reviewShortOpt = switchLongWith "short" "Only output the package name" reviewAllStatusOpt :: Parser Bool reviewAllStatusOpt = switchWith 'A' "all-status" "include all open states"@@ -426,8 +450,8 @@ manyPackages :: Parser [String] manyPackages = many (pkgArg "PKGPATH...") - -- somePackages :: Parser [String]- -- somePackages = some (pkgArg "PKGPATH...")+ somePackages :: Parser [String]+ somePackages = some (pkgArg "PKG...") branchesOpt :: Parser (Maybe BranchOpts) branchesOpt =@@ -471,10 +495,13 @@ [br] -> (Just br,pkgs) _ -> error' $ "cannot have more than one branch:" +-+ unwords (map show brs) - -- FIXME split later to prevent branches after packages branchesPackages :: Parser (BranchesReq, [String])- branchesPackages =- branchesReqPkgs <$> branchesOpt <*> many (pkgArg "BRANCH... PKGPATH...")+ branchesPackages = branchesPackagesDesc "BRANCH... PKGPATH..."++ -- FIXME split later to prevent branches after packages+ branchesPackagesDesc :: String -> Parser (BranchesReq, [String])+ branchesPackagesDesc desc =+ branchesReqPkgs <$> branchesOpt <*> many (pkgArg desc) where branchesReqPkgs :: Maybe BranchOpts -> [String] -> (BranchesReq, [String]) branchesReqPkgs mbrnchopts args =@@ -540,9 +567,11 @@ archesOpt :: Parser Archs archesOpt = Archs <$> some archOpt <|> ExcludedArchs <$> some excludeArch - -- FIXME allow "dryrun"- dryrunOpt = switchWith 'n' "dry-run"+ dryrunOpt desc = switchWith 'n' "dry-run" desc <|>+ switchLongWith "dryrun" "alias for --dry-run" + debugOpt = switchWith 'd' "debug"+ skipFetchOpt = switchWith 'S' "skip-fetch" "Do not git fetch" updateOpt :: Parser (Maybe UpdateType, UpdateSeverity)@@ -593,22 +622,19 @@ strOptionWith 'm' "message" "COMMITMSG" "commit message" <|> flagWith' CommitAmend 'A' "amend" "Amend commit" - pullOpts :: Parser PullOpts+ pullOpts :: Parser PullOpt pullOpts = flagWith' PullLenient 'l' "lenient" "Ignore non-git dirs and files" <|> flagWith' PullNoFetch 'f' "no-fetch" "Skip git fetch" <|>- flagWith' PullStash 's' "stash" "Stash local changes"+ flagWith' PullStash 's' "stash" "Stash local changes" <|>+ flagWith' PullRebase 'r' "rebase" "Git pull instead of fetch" buildByOpt = flagWith' SingleBuild 'S' "single" "Non-progressive normal single build" <|> flagWith' BuildByRelease 'R' "by-release" "Builds by release" <|> flagWith ValidateByRelease ValidateByArch 'A' "by-arch" "Build across latest release archs first (default is across releases for primary arch)" commandOpt = strOptionWith 'c' "cmd" "SHELLCOMMAND" "Shell command to run in $p" targetOpt :: Parser String- targetOpt =- checkNotRawhide <$> strOptionWith 't' "target" "TARGET" "Koji target"- where- checkNotRawhide "rawhide" = error' "'rawhide' is not a valid target!"- checkNotRawhide t = t+ targetOpt = strOptionWith 't' "target" "TARGET" "Koji target" sidetagTargetOpt :: Maybe String -> Parser SideTagTarget sidetagTargetOpt mdesc =@@ -647,8 +673,8 @@ sortDisplayOpt :: Parser SortDisplay sortDisplayOpt = flagWith' SortParallel 'p' "parallel" "Group dependent packages on separate lines"- <|> flagWith' SortChain 'c' "chain" "chain-build output"- <|> flagWith SortPlain SortLayers 'l' "layers" "output parallel layers"+ <|> flagWith' SortLayers 'l' "layers" "output parallel layers"+ <|> flagWith SortChain SortPlain 's' "separated" "Dependent grouping separated by empty lines" -- for waitrepo waitfetchOpt :: Parser WaitFetch@@ -666,3 +692,7 @@ quietOpt :: String -> Parser Bool quietOpt = switchWith 'q' "quiet"++ allowHeadOpt = switchLongWith "allow-head" "allow detached HEAD"++ forceOpt = switchWith 'f' "force"
src/Package.hs view
@@ -9,7 +9,7 @@ getChangelog, cleanChangelog, changeLogPrompt,- getBranchDist,+ releaseSystemBranch, getPackageName, getSummaryURL, findSpecfile,@@ -40,22 +40,28 @@ packageSpec, pkgNameVerRel, pkgNameVerRel',+ pkgNameVerRelNodist, equivNVR, editSpecField,- isAutoRelease+ isAutoChangelog,+ isAutoRelease,+ sourceFieldFile,+ isArchiveFile,+ sourceDirCwdOpt ) where import Data.RPM (NV(..), VerRel(..)) import Data.RPM.NVR (maybeNVR, NVR(..))-import Distribution.Fedora hiding (Fedora,EPEL,EPELNext)+import Distribution.Fedora.Branch import SimpleCmd.Rpm-import SimplePrompt (prompt)+import SimplePrompt (prompt, promptInitial) import Branches import Common import Common.System import Git import Krb+import Types (ChangeType(..)) fedpkg :: String -> [String] -> IO String fedpkg c args =@@ -71,36 +77,46 @@ unless have $ error' $ spec +-+ "not found" -- FIXME allow editor to be used-changeLogPrompt :: Bool -> FilePath -> IO String-changeLogPrompt isupdate spec = do- clog <- cleanChangelog spec+changeLogPrompt :: ChangeType -> FilePath -> IO String+changeLogPrompt change spec = do+ clog <- cleanChangelog (change /= ChangeReview) spec putNewLn putStrLn "```"- putStr clog+ putStrLn clog putStrLn "```" -- FIXME is this actually useful? tty <- isTty if not tty then return clog else do- userlog <- prompt $ "Press Enter to use above or input" +-+ (if isupdate then "update" else "change") +-+ "summary now" ++ if isupdate then "; or 'no' to skip update" else ""+ -- FIXME ask what to do: edit/skip/append?+ userlog <- promptInitial+ ("Describe" +-++ case change of+ ChangeBodhi -> "update"+ ChangeCommit -> "commit"+ ChangeReview -> "change"+ +-+ "summary now"+ ++ (if change == ChangeBodhi then "; or 'no' to skip update" else "")+ ++ ":\n")+ clog return $ if null userlog then clog else userlog getChangelog :: FilePath -> IO [String] getChangelog spec = do- autochangelog <- grep_ "^%autochangelog" spec+ autochangelog <- isAutoChangelog spec if autochangelog then takeWhile (not . null) . drop 1 <$> cmdLines "rpmautospec" ["generate-changelog", spec] else cmdLines "rpmspec" ["-q", "--srpm", "--qf", "%{changelogtext}", spec] -cleanChangelog :: FilePath -> IO String-cleanChangelog spec = do+cleanChangelog :: Bool -> FilePath -> IO String+cleanChangelog nobullet spec = do ls <- getChangelog spec return $ case filter ("- " `isPrefixOf`) ls of- [l] -> removePrefix "- " l ++ "\n"- _ -> unlines ls+ [l] | nobullet -> removePrefix "- " l+ _ -> intercalate "\n" ls getSummaryURL :: FilePath -> IO String getSummaryURL spec = do@@ -259,7 +275,8 @@ -- For now assume spec filename = package name Just spec -> return $ takeBaseName spec Nothing -> getDirectoryName- when (count && length pkgs >= 2) $+ when (count && length pkgs >= 2) $ do+ putNewLn putStrLn $ plural n "package" +-+ "left" unless (isNothing mspec || mspec == Just (unPackage pkg <.> "spec")) $ putStrLn $ "Warning: package name (" ++ unPackage pkg ++ ") differs from spec filename!"@@ -277,6 +294,9 @@ else return $ Just cur else Just <$> gitCurrentBranch else return Nothing+ let fetch = have gitOptFetch+ -- quiet to avoid output before header+ when fetch $ gitFetchSilent True brs <- listOfAnyBranches (haveGit && not (have gitOptHEAD)) (have gitOptActive) breq case limitBranches of ZeroOrOne | length brs > 1 ->@@ -287,14 +307,12 @@ ExactlyOne | length brs > 1 -> error' "please only specify one branch" _ -> return ()- let fetch = have gitOptFetch when ((header /= HeaderNone || fetch) && dir /= ".") $ case brs of [br] -> when (fetch || header == HeaderMust) $ putPkgAnyBrnchHdr pkg br _ -> when (fetch || header /= HeaderNone) $ putPkgHdr pkg when haveGit $ when (have gitOptClean) $ checkWorkingDirClean (have gitOptStash)- when fetch $ gitFetchSilent False -- FIXME!! no branch restriction when (breq `elem` map BranchOpt [AllBranches,AllFedora,AllEPEL]) $ putStrLn $ "Branches:" +-+ unwords (map show brs) ++ "\n"@@ -361,23 +379,38 @@ matches <- filter ("Release:" `isPrefixOf`) <$> grep "%autorelease" spec return $ not (null matches) --- FIXME return NVR??+isAutoChangelog :: FilePath -> IO Bool+isAutoChangelog = grep_ "^%autochangelog"+ pkgNameVerRel :: Branch -> FilePath -> IO (Maybe NVR)-pkgNameVerRel br spec = do- disttag <- rpmDistTag <$> branchDist br+pkgNameVerRel = pkgNameVerRelDist . Just++pkgNameVerRelDist :: Maybe Branch -> FilePath -> IO (Maybe NVR)+pkgNameVerRelDist Nothing spec = do+ nvrs <- rpmspec ["--srpm", "--undefine=dist"] (Just "%{name}-%{version}-%{release}") spec+ return $+ case nvrs of+ [] -> Nothing+ [nvr] -> maybeNVR nvr+ _ -> error' "could not determine unique nvr"+pkgNameVerRelDist (Just br) spec = do+ disttag <- branchDistTag br -- workaround dist with bootstrap hostdist <- cmd "rpm" ["--eval", "%{dist}"] -- FIXME more precise regexp with "Release:" autorelease <- isAutoRelease spec nvrs <- do- pkggit <- isPkgGitRepo- if autorelease && pkggit- then do- --putStrLn "%autorelease detected"- mfedpkg <- findExecutable "fedpkg"- when (isNothing mfedpkg) $- error' "requires fedpkg.."- cmdLines "fedpkg" ["verrel"]+ if autorelease+ then do+ pkggit <- isPkgGitRepo+ if pkggit+ then do+ mfedpkg <- findExecutable "fedpkg"+ when (isNothing mfedpkg) $+ error' "requires fedpkg.."+ cmdLines "fedpkg" ["verrel"]+ else+ error' "cannot determine NVR accurately for autorelease outside dist-git" else rpmspec ["--srpm"] (Just "%{name}-%{version}-%{release}") spec seq disttag $ return $@@ -393,10 +426,17 @@ Nothing -> error' $ "rpmspec failed to parse" +-+ spec Just nvr -> return nvr -getBranchDist :: AnyBranch -> IO Dist-getBranchDist (RelBranch br) = branchDist br-getBranchDist (OtherBranch _) = systemBranch >>= branchDist+pkgNameVerRelNodist :: FilePath -> IO NVR+pkgNameVerRelNodist spec = do+ mnvr <- pkgNameVerRelDist Nothing spec+ case mnvr of+ Nothing -> error' $ "rpmspec failed to parse" +-+ spec+ Just nvr -> return nvr +releaseSystemBranch :: AnyBranch -> IO Branch+releaseSystemBranch (RelBranch br) = return br+releaseSystemBranch (OtherBranch _) = systemBranch+ -- FIXME should be more strict about dist tag (eg .fcNN only) equivNVR :: NVR -> Maybe NVR -> Bool equivNVR _ Nothing = False@@ -495,3 +535,22 @@ splitRelease :: NVR -> (NV,String) splitRelease (NVR n (VerRel v r)) = (NV n v, r) #endif++sourceFieldFile :: String -> FilePath+sourceFieldFile field =+ if null field then+ -- should be impossible+ error "empty source field!"+ else (takeFileName . last . words) field++isArchiveFile :: FilePath -> Bool+isArchiveFile f =+ any ($ f) [(".tar." `isInfixOf`),+ (".zip" `isSuffixOf`),+ (".gpg" `isSuffixOf`),+ (".tgz" `isSuffixOf`)]++sourceDirCwdOpt :: IO [String]+sourceDirCwdOpt = do+ cwd <- getCurrentDirectory+ return ["--define", "_sourcedir" +-+ cwd]
src/Pagure.hs view
@@ -1,6 +1,7 @@ module Pagure ( srcfpo, pagureio,+ pagureGroupRepos, pagureListGitBranches, pagureListProjectIssueTitlesStatus, IssueTitleStatus(..),
src/Repoquery.hs view
@@ -9,6 +9,8 @@ import Bodhi (bodhiTestingRepo) import Branches +-- FIXME use fedora-repoquery library+-- FIXME default to package repoquery :: Branch -> Branch -> [String] -> IO String repoquery sysbr br args = do mtesting <- bodhiTestingRepo br@@ -19,10 +21,12 @@ case br of Rawhide -> ["--disablerepo=*", "--enablerepo=rawhide"] Fedora _ -> ["--disablerepo=*", "--enablerepo=fedora"] ++- ["--enablerepo=updates"| isJust mtesting] +++ ["--enablerepo=updates-testing" | isJust mtesting] ++ ["--releasever=" ++ branchVersion br]- EPEL _ -> ["--disablerepo=*", "--enablerepo=epel",- "--releasever=" ++ branchVersion br]- EPELNext _ -> ["--disablerepo=*", "--enablerepo=epel-next",- "--releasever=" ++ branchVersion br]+ EPEL _ -> ["--disablerepo=*", "--enablerepo=epel"] +++ ["--enablerepo=epel-testing" | isJust mtesting] +++ ["--releasever=" ++ branchVersion br]+ EPELNext _ -> ["--disablerepo=*", "--enablerepo=epel-next"] +++ ["--enablerepo=epel-next-testing" | isJust mtesting] +++ ["--releasever=" ++ branchVersion br] cmd "dnf" (["repoquery", "--quiet"] ++ brOpts ++ args)
src/RpmBuild.hs view
@@ -8,6 +8,7 @@ getDynSourcesMacros, generateSrpm, generateSrpm',+ generateSrpmNoDist, BCond(..), ForceShort(..), isShortCircuit,@@ -22,11 +23,11 @@ import Data.Char (isDigit) import Data.Either (partitionEithers) import Data.RPM-import qualified Distribution.Fedora as Dist-import Distribution.Fedora (Dist)+import Distribution.Fedora.Branch (branchDistTag, branchRelease)+import Distribution.Fedora.Release (Release(releaseVersion)) import Network.HTTP.Directory (Manager, httpExists, httpManager) import SimpleCmd.Rpm-import SimplePrompt (promptEnter)+import SimplePrompt (promptEnter, yesNo) import System.Console.Pretty import System.IO.Extra (withTempDir) import System.Posix.Files@@ -38,31 +39,36 @@ import Git import Package -distOpt :: Dist -> [String]-distOpt dist =- ["--define", "dist" +-+ "%{?distprefix}" ++ Dist.rpmDistTag dist]+distOpt :: Branch -> IO [String]+distOpt br = do+ disttag <- branchDistTag br+ return ["--define", "dist" +-+ "%{?distprefix}" ++ disttag] +distOptAny :: AnyBranch -> IO [String]+distOptAny b =+ releaseSystemBranch b >>= distOpt+ -- FIXME hardcoding distRpmOptions :: Branch -> IO [String] distRpmOptions br =- map ("--define=" ++) <$>- case br of- Rawhide -> do- dist <- Dist.getRawhideDist- let ver = case dist of- Dist.Fedora n -> show n- _ -> error' $ "impossible rawhide version:" +-+ show dist- return ["fedora" +-+ ver, "fc" ++ ver +-+ "1"]- Fedora n -> return ["fedora" +-+ show n, "fc" ++ show n +-+ "1"]- EPEL n -> return ["rhel" +-+ show n, "el" ++ show n +-+ "1"]- EPELNext n -> return ["rhel" +-+ show n, "el" ++ show n +-+ "1"]+ map ("--define=" ++) <$> do+ release <- branchRelease br+ return $+ case br of+ Rawhide ->+ let ver = releaseVersion release+ in ["fedora" +-+ ver, "fc" ++ ver +-+ "1"]+ Fedora n ->+ ["fedora" +-+ show n, "fc" ++ show n +-+ "1"]+ EPEL n -> ["rhel" +-+ show n, "el" ++ show n +-+ "1"]+ EPELNext n -> ["rhel" +-+ show n, "el" ++ show n +-+ "1"] builtRpms :: AnyBranch -> FilePath -> IO [FilePath] builtRpms br spec = do- dist <- getBranchDist br+ distopt <- distOptAny br rpmdir <- fromMaybe "" <$> rpmEval "%{_rpmdir}" autoreleaseOpt <- getAutoReleaseOptions spec- rpms <- rpmspec (["--builtrpms", "--define", "dist" +-+ Dist.rpmDistTag dist] ++ autoreleaseOpt) (Just (rpmdir </> "%{arch}/%{name}-%{version}-%{release}.%{arch}.rpm")) spec+ rpms <- rpmspec ("--builtrpms" : distopt ++ autoreleaseOpt) (Just (rpmdir </> "%{arch}/%{name}-%{version}-%{release}.%{arch}.rpm")) spec if null rpms then error' $ spec +-+ "does not seem to create any rpms" else return rpms@@ -95,7 +101,7 @@ then return msourcedir else return Nothing isPkgGit <- isPkgGitRepo- (patches,srcs) <- partitionEithers . map sourceFieldFile+ (patches,srcs) <- partitionEithers . map sourcePatchFile <$> cmdLines "spectool" ["-a", spec] forM_ srcs $ \ src -> do exists <- doesFileExist src &&^ checkCompression src@@ -132,8 +138,8 @@ error' $ "missing patch:" +-+ patch return $ srcs ++ patches where- sourceFieldFile :: String -> Either FilePath FilePath- sourceFieldFile field =+ sourcePatchFile :: String -> Either FilePath FilePath+ sourcePatchFile field = case word1 field of (f,v) -> -- rpmdevtools 9.3 (spectool always lists --all)@@ -178,59 +184,75 @@ generateSrpm = generateSrpm' False generateSrpm' :: Bool -> Maybe AnyBranch -> FilePath -> IO FilePath-generateSrpm' force mbr spec = do+generateSrpm' = generateSrpmNoDist False++generateSrpmNoDist :: Bool -> Bool -> Maybe AnyBranch -> FilePath -> IO FilePath+generateSrpmNoDist nodist force mbr spec = do srcs <- getSources spec- distopt <- case mbr of- Nothing -> return []- Just br -> do- dist <- getBranchDist br- return $ distOpt dist+ distopt <-+ if nodist+ then return ["--define", "dist %{nil}"]+ else+ case mbr of+ Nothing -> return []+ Just br -> do+ rbr <- releaseSystemBranch br+ distOpt rbr msrcrpmdir <- rpmEval "%{_srcrpmdir}"- srpmfile <- cmd "rpmspec" $ ["-q", "--srpm"] ++ distopt ++ ["--qf", fromMaybe "" msrcrpmdir </> "%{name}-%{version}-%{release}.src.rpm", spec]- cwd <- getCurrentDirectory- let sourcediropt = ["--define", "_sourcedir" +-+ cwd]- opts = distopt ++ sourcediropt+ autoreleaseOpt <- getAutoReleaseOptions spec+ srpmfile <- cmd "rpmspec" $ ["-q", "--srpm"] ++ distopt ++ autoreleaseOpt ++ ["--qf", fromMaybe "" msrcrpmdir </> "%{name}-%{version}-%{release}.src.rpm", spec]+ sourcediropt <- sourceDirCwdOpt+ let srcrpmdiropt = maybe [] (\dir -> ["--define", "_srcrpmdir" +-+ dir])+ msrcrpmdir+ opts = distopt ++ sourcediropt ++ srcrpmdiropt if force then- buildSrpm opts+ buildSrpm srpmfile opts else do exists <- doesFileExist srpmfile if not exists- then buildSrpm opts+ then buildSrpm srpmfile opts else do srpmTime <- getModificationTime srpmfile fileTimes <- mapM getModificationTime (spec:srcs) if any (srpmTime <) fileTimes- then buildSrpm opts+ then buildSrpm srpmfile opts else do -- pretty print with ~/ putStrLn $ srpmfile +-+ "is up to date" return srpmfile where- buildSrpm opts = do- -- 1. prevent Ctrl-c from truncating srpm to corrupted file:- -- 'Error: Downloaded rpm http://kojipkgs-cache01.s390.fedoraproject.org/work/cli-build/1691493908.5614614.AzJmareV/ghc9.4-9.4.6-22.fc39.src.rpm is corrupted:'- -- 2. can end with stdout "RPM build warnings:" etc- -- https://github.com/rpm-software-management/rpm/issues/2494- outs <- words <$> uninterruptibleMask_ (cmd "rpmbuild" (opts ++ ["-bs", spec]))+ buildSrpm predicted opts = do+ autospec <- isRpmAutospec spec+ outs <-+ -- prevent Ctrl-c from truncating srpm to corrupted file+ fmap words . uninterruptibleMask_ $+ if autospec+ then cmd "fedpkg" $ "srpm" : opts+ else cmd "rpmbuild" (opts ++ ["-bs", spec]) case filter ("src.rpm" `isExtensionOf`) outs of [srpm] -> do putStrLn $ "Created" +-+ takeFileName srpm+ unless (predicted == srpm) $+ warning $ "different to predicted NVR:" +-+ predicted return srpm srpms -> error' $ "could not determined generated srpm filename" +-+ unwords srpms +isRpmAutospec :: FilePath -> IO Bool+isRpmAutospec spec = do+ isAutoChangelog spec ||^ isAutoRelease spec+ data BCond = BuildWith String | BuildWithout String instance Show BCond where show (BuildWith s) = "--with=" ++ s show (BuildWithout s) = "--without=" ++ s - getAutoReleaseOptions :: FilePath -> IO [String] getAutoReleaseOptions spec = do autorelease <- isAutoRelease spec if autorelease then do- -- FIXME upstream bug "--number-only" doesn't work+ -- upstream bug "--number-only" doesn't work calculated <- cmd "rpmautospec" ["calculate-release", spec] return ["--define", "_rpmautospec_release_number" +-+ dropPrefix "Calculated release number: " calculated] else return []@@ -266,16 +288,15 @@ else do installDeps True spec void $ getSources spec- dist <- getBranchDist br- cwd <- getCurrentDirectory+ distopt <- distOptAny br autoreleaseOpt <- getAutoReleaseOptions spec+ sourcediropt <- sourceDirCwdOpt let buildopt = case mforceshort of Just ShortCompile -> ["-bc", "--short-circuit"] Just ShortInstall -> ["-bi", "--short-circuit"] _ -> "-bb" : ["--noclean" | noclean]- sourcediropt = ["--define", "_sourcedir" +-+ cwd]- args = sourcediropt ++ distOpt dist +++ args = sourcediropt ++ distopt ++ buildopt ++ map show bconds ++ autoreleaseOpt ++ [spec] date <- cmd "date" ["+%T"] rbr <- anyBranchToRelease br@@ -385,11 +406,13 @@ src `notElem` gitfiles) sourcefiles unless (null missing) $ do+ -- FIXME maybe change to yesNo promptEnter $ color Red $ unwords missing +-+ "not in sources, press Enter to fix"+ -- FIXME check if already fixed before proceeding updatePkg True False False True Nothing pkg br git_ "status" ["--short"]- promptEnter "Please Enter to amend commit and continue"- git_ "commit" ["--amend"]+ ok <- yesNo "Amend commit"+ when ok $ git_ "commit" ["--amend"] unlessM isGitDirClean $ error' "local changes remain (dirty)" checkOnBranch
src/Types.hs view
@@ -1,7 +1,8 @@ module Types ( Archs(..), SideTagTarget(..),- maybeTarget+ maybeTarget,+ ChangeType(..) ) where @@ -13,3 +14,6 @@ maybeTarget :: Maybe SideTagTarget -> Maybe String maybeTarget (Just (Target t)) = Just t maybeTarget _ = Nothing++data ChangeType = ChangeBodhi | ChangeCommit | ChangeReview+ deriving Eq