fbrnch 1.1.2 → 1.2
raw patch · 45 files changed
+1175/−666 lines, 45 filesdep −optparse-applicativedep ~rpmbuild-orderdep ~simple-cmd-args
Dependencies removed: optparse-applicative
Dependency ranges changed: rpmbuild-order, simple-cmd-args
Files
- CHANGELOG.md +68/−0
- README.md +44/−36
- fbrnch.cabal +10/−7
- src/Bodhi.hs +61/−44
- src/Branches.hs +1/−1
- src/Bugzilla.hs +2/−2
- src/Cmd/Build.hs +33/−27
- src/Cmd/Compare.hs +10/−4
- src/Cmd/Copr.hs +1/−1
- src/Cmd/Diff.hs +10/−21
- src/Cmd/FTBFS.hs +4/−3
- src/Cmd/Import.hs +5/−5
- src/Cmd/Install.hs +38/−25
- src/Cmd/ListPackages.hs +19/−1
- src/Cmd/Local.hs +6/−6
- src/Cmd/Merge.hs +54/−36
- src/Cmd/Mock.hs +3/−2
- src/Cmd/Override.hs +1/−1
- src/Cmd/Owner.hs +55/−0
- src/Cmd/Parallel.hs +90/−117
- src/Cmd/PkgReview.hs +1/−0
- src/Cmd/Prep.hs +1/−1
- src/Cmd/PullPush.hs +15/−1
- src/Cmd/Repoquery.hs +0/−24
- src/Cmd/RequestBranch.hs +100/−48
- src/Cmd/RequestRepo.hs +9/−5
- src/Cmd/Reviews.hs +1/−1
- src/Cmd/Scratch.hs +49/−40
- src/Cmd/SideTags.hs +15/−8
- src/Cmd/Sort.hs +5/−4
- src/Cmd/SrcDeps.hs +38/−0
- src/Cmd/Status.hs +6/−5
- src/Cmd/Update.hs +8/−1
- src/Cmd/WaitRepo.hs +7/−5
- src/Common.hs +5/−1
- src/Git.hs +122/−61
- src/InterleaveOutput.hs +1/−1
- src/Koji.hs +35/−5
- src/Krb.hs +1/−1
- src/Main.hs +77/−36
- src/Package.hs +63/−54
- src/Patch.hs +53/−0
- src/Prompt.hs +11/−24
- src/Repoquery.hs +28/−0
- src/Types.hs +9/−1
CHANGELOG.md view
@@ -1,5 +1,73 @@ # Changelog +## 1.2 (2022-11-12)+- Bodhi: for template file prompt instead of using fedpkg update+- Bodhi: updates need to be comma separated (#36, Otto Liljalaakso)+- Git gitMergeable: new logic for detecting older branch ahead/diverged+- Git getNewerBranch: restore epel9 merge inheriting from fedora+- Git: rename gitShortLog to gitOneLineLog with long hash format+- Main: fix overlapping -s/-S options+- Package buildRPMs: with tee return error if build failed+- Package pkgNameVerRel: seq disttag for early error+- Package: add withPackagesBranch, withPackagesMaybeBranch always ZeroOrOne+- Prompt refPrompt: allow "n" for no+- SrcDeps: factor out srcDeps (for request-branches --recursive)+- bodhiUpdate: take comma-separated nvrs and check all the updates (#36)+- 'build': initial support for --sidetag+- buildRPMs: add --noclean switch for 'local' builds+- 'compare': add --ignore to filter out matching commits+- 'diff': fold --quiet into DiffFormat and add --ignore-bumps+- getNewerBranch now only returns next branch+- getRequestedBranches now only returns new branches out of specified+- gitFetchSilent,gitFetchSilent': quiet option+- gitFetchSilent: newline before filtered output+- gitSwitchBranch': do not warn about missing branch if quiet+- 'install': also count down when recursing+- 'install': offer to merge and add --from to override branch+- 'install': only update installed subpackages, unless --all-subpackages+- kojiBuild': don't log if no output+- 'local' --debug: outputs command (refactor buildRPMs)+- 'local': add --short-compile and rename --short-circuit to --short-install+- long-only options need simple-cmd-args-0.1.8+- 'merge': --skip-bumps up to N (trivial) commits & --show-all; Commit and Patch+- 'merge': add --dryrun+- 'merge': fix getting newer branch when no --from+- mergeBranch,gitMergeOrigin: no more gratuitous merge rebasing+- 'mock': add simple --short-circuit option for install stage+- new 'owner' command: prints owner and admins of package(s)+- new 'fetch' command+- new 'list-local' command: lists packages in branch with spec file+- new 'src-deps' command: wrapper of rpmbuild-order (r)deps+- 'override','waitrepo': print message before waiting+- 'parallel' build: respect --no-merge+- 'parallel': also accept "n" for "no" update+- 'parallel': also time parallel branches dir+- 'parallel': display package's number and layer+- 'parallel': do not prompt for update when update disabled+- 'parallel': dryrun for merge and delay until bodhiSidetagUpdate+- 'parallel': filter out rawhide from parallel branch package builds update (#36)+- 'parallel': formatting - use +-+, plural, don't color "is already"+- 'parallel': no longer prompt for sidetag removal+- 'parallel': only write "in layer" if there are layers+- 'parallel': print pkg brnch header before merging+- 'parallel': sidetag prompt now needs 'yes' to delete+- 'request-branches/repos': check 100 fedora-scm-requests for duplicate+- 'request-branches': add --quiet to suppress "exists" messages+- 'request-branches': add --recurse-from BRANCH+- 'request-branches': add another fedpkg failure error+- 'request-branches': do not fetch if remote branch known+- 'request-branches': improve --quiet help+- 'request-branches': output if exists, again+- 'scratch' builds now support multiple (serial) targets+- 'scratch','waitrepo': now also accept --sidetag+- 'scratch-x86_64','scratch-aarch64': add --exclude-arch to invert arch selection+- 'sidetags': add --remove option+- srcDeps uses depsGraphDeps from rpmbuild-order-0.4.10+- targetMaybeSidetag: add dryrun parameter+- 'update': renamed to update-version+- 'update-version': check/download missing patches with spectool+- 'update-version': warn if branch+ ## 1.1.2 (2022-07-30) - add scratch-x86_64 and scratch-aarch64 shortcut commands - bodhiUpdate now takes multiple builds: used for parallelBranches (#30)
README.md view
@@ -39,7 +39,7 @@ One can change the branch of one or more packages: ```-$ fbrnch switch f36 [package] ...+$ fbrnch switch f37 [package] ... ``` You can also git pull over packages:@@ -79,10 +79,10 @@ ``` ### Commit, Merging and Building in Koji-The update command helps with updating a package after editing the spec file-to a newer version:+The update-version command helps with updating a package+after editing the spec file to a newer version: ```-$ fbrnch update+$ fbrnch update-version ``` which will download the new tarball and upload it, etc. @@ -92,17 +92,18 @@ ``` $ fbrnch commit ```-It uses any rpm changelog, or you can pass `-m "..."` or amend with `-a`.+It uses any rpm changelog for the commit message,+or you can pass `-m "..."` or amend with `-a`. You can merge branches with: ```-$ fbrnch merge f35 package+$ fbrnch merge f36 package ```-which will offer to merge f36 (or some of it) into f35.+which will offer to merge f37 (or up to a git hash you choose) into f36. Merging can also be done together with building: ```-$ fbrnch build f36 package+$ fbrnch build f37 package ``` will ask if you want to merge newer commits from a newer branch, then push and build it.@@ -111,15 +112,15 @@ If the NVR is currently building it will be picked up by `fbrnch build`. Completed branch builds can be pushed to Bodhi. -You can also build all branches:+You can also build all active branches: ``` $ fbrnch build -B package ```-or all fedora branches:+or only all fedora branches: ``` $ fbrnch build -F package ```-or all epel branches:+or only all epel branches: ``` $ fbrnch build -E package ```@@ -148,6 +149,7 @@ ``` this works in the current package dir like other commands, installing any missing dependencies with `sudo dnf builddep`.+(It also works for a non-git package dir.) Or one can specify the path to the package. @@ -176,17 +178,21 @@ ``` $ fbrnch parallel --sidetag rawhide pkg-x pkg-y pkg-z pkg-xy pkg-xy-z ```-generates a sidetag and builds a list of packages there-in parallel ordered by build dependencies. When building for a branch-merging from newer branch will be offered unless using `--no-merge`.+builds a list of packages in a sidetag (generating it if needed)+in parallel ordered by build dependencies. +When building for a branch, merging from newer branch will be offered+unless using `--no-merge`+(though you may prefer to run `fbrnch merge <branch> ...` first instead).+ Except for rawhide using a sidetag is required.-If you have more than one branch sidetag, you can select one using `--target`.+If you have more than one branch active sidetag for a branch,+you can select one using `--target`. After parallel building you can create a Bodhi update from the sidetag. It is also possible to build a package in parallel across branches-and push to Bodhi.+and push them to Bodhi. ### Creating new packages/branches @@ -211,7 +217,7 @@ $ fbrnch reviews ``` They can be filtered by status with various options like-`--approved` or `--created`.+`--approved` or `--created` (or another bugzilla `--user`). One can also search for the review(s) of a specific package with: ```@@ -223,21 +229,21 @@ ``` $ fbrnch request-repos ```-will request repos for approved package(s) and offer to request branches.+will request repo(s) for approved package(s) and offer to request branches. #### Import a new package After the repo has been created ``` $ fbrnch import ```-will clone the repo and offer to import the srpm-directly from the latest url in the approved package review,+will clone the repo(s) and offer to import the srpm+directly from the latest url in the approved package review(s), which can then be built directly into Koji Rawhide-and the package review is updated.+and the package review(s) updated. #### Request branches If you prefer you can request branches after the repo is created-or package imported with+(or package is imported) with ``` $ fbrnch request-branches ```@@ -251,7 +257,7 @@ ``` $ fbrnch --version-1.1.2+1.2 $ fbrnch --help Fedora branch building tool @@ -264,13 +270,14 @@ --version Show version Available commands:- clone clone packages+ clone Clone packages switch Switch branch nvr Print name-version-release status Status package/branch status merge Merge from newer branch build Build package(s) in Koji list List packages in pagure+ list-local List packages in branch branches List package branches parallel Parallel build packages in Koji sidetags List user's side-tags@@ -279,13 +286,14 @@ scratch Scratch build package in Koji scratch-aarch64 Koji aarch64 scratch build of package scratch-x86_64 Koji x86_64 scratch build of package- update Update package in dist-git to newer version+ update-version Update package in dist-git to newer version sort Sort packages in build dependency order prep Prep sources local Build locally srpm Build srpm diff Diff local changes compare Show commits between branches+ src-deps List source package dependencies mock Local mock build install-deps Install package build dependencies install Build locally and install package(s)@@ -294,7 +302,9 @@ bump Bump release for package commit Git commit packages pull Git pull packages+ fetch Git fetch packages push Git push packages+ owner List package owner(s) create-review Create a Package Review request update-review Update a Package Review review-package Run fedora-review on a package Review Request bug@@ -351,11 +361,11 @@ ## rpmbuild configuration You may want to set `~/.rpmmacros` to use particular directories,-since unlike fedpkg, fbrnch follows the macros set in `~/.rpmmacros`.--By default rpmbuild uses `~/rpmbuild/`.+since unlike fedpkg, fbrnch follows the local rpmbuild directory macros:+rpmbuild defaults to directories under `~/rpmbuild/`+but this can be overridden by the user in `~/.rpmmacros` as follows. -Two common alternative configurations might be either:+Two common alternative configurations in `~/.rpmmacros` might be either: 1) use the package directory for everything (like fedpkg does): ```@@ -402,11 +412,10 @@ - https checkouts are currently treated as anonymous git checkouts ## Motivation, history, talks-This project started off (as "fedbrnch") basically as a simple tool to-build a package across branches (ie for current releases). Then bugzilla-and Bodhi integration was added, and gradually more features, including-some generic commands across packages which had already been done before-in fedora-haskell-tools.+This project started off as a simple tool to build a package across branches+(ie for current releases). Then bugzilla and Bodhi integration was added,+and gradually more features, including some generic commands across packages+inspired by the older fedora-haskell-tools project. I have given a couple of short talks about fbranch: - Nest with Fedora: [youtube](https://www.youtube.com/watch?v=40kTBsA674U) and [slides](https://github.com/juhp/presentations/blob/master/fedora-nest-2020-fbrnch/fbrnch-nest.md)@@ -415,10 +424,9 @@ ## Contribute Bug reports, feedback, and pull requests are all highly appreciated. -Please report any unsupported or unintuitive workflow steps.+Do report any unsupported or inconsistent workflow steps. See the TODO list and also the FIXME comments scattered across the source.-Do open an issue before embarking on larger changes. Authors of the code:
fbrnch.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: fbrnch-version: 1.1.2+version: 1.2 synopsis: Fedora packager tool to build package branches description: fbrnch (fedora branch) is a convenient packaging tool for@@ -62,17 +62,19 @@ Cmd.Merge Cmd.Mock Cmd.Override+ Cmd.Owner Cmd.Parallel Cmd.PkgReview Cmd.Prep Cmd.PullPush- Cmd.Repoquery+ --Cmd.Repoquery Cmd.RequestBranch Cmd.RequestRepo Cmd.Reviews Cmd.Scratch Cmd.SideTags Cmd.Sort+ Cmd.SrcDeps Cmd.Status Cmd.Switch Cmd.Update@@ -87,8 +89,10 @@ ListReviews Package Pagure+ Patch Paths_fbrnch Prompt+ Repoquery Types hs-source-dirs: src@@ -96,7 +100,7 @@ build-depends: aeson, async,- -- pretty-terminal needs 4.9:+ -- pretty-terminal depends on base >= 4.9 (ghc8) base >= 4.9 && < 5, bodhi, bugzilla-redhat >= 1.0,@@ -114,19 +118,18 @@ http-query, koji, network-uri,- -- (for simple_cmd_args < 0.1.7):- optparse-applicative, pagure >= 0.1, pretty-terminal, process, -- regex-tdfa,- rpmbuild-order >= 0.4.8,+ rpmbuild-order >= 0.4.10, rpm-nvr >= 0.1.2, simple-cmd >= 0.2.3,- simple-cmd-args >= 0.1.6,+ simple-cmd-args >= 0.1.8, text, time, typed-process >= 0.2.4.0,+ -- for aeson-1 compatibility: unordered-containers, utf8-string, unix,
src/Bodhi.hs view
@@ -117,60 +117,66 @@ bodhiTestingRepo Rawhide = return Nothing bodhiTestingRepo br = do obj <- bodhiRelease (show br)- return $ case lookupKey "testing_repository" obj :: Maybe String of- Nothing -> Nothing- Just _ -> lookupKey' "testing_tag" obj+ return $+ case lookupKey "testing_repository" obj :: Maybe String of+ Nothing -> Nothing+ Just _ -> lookupKey' "testing_tag" obj +-- push comma separated list of builds for a package to bodhi bodhiUpdate :: Bool -> (Maybe UpdateType, UpdateSeverity) -> Maybe BugId- -> Bool -> FilePath -> [String] -> IO ()+ -> Bool -> FilePath -> String -> IO () bodhiUpdate _ _ _ _ _ [] = error' "cannot make empty update" bodhiUpdate dryrun (mupdate,severity) mreview usechangelog spec nvrs = do case mupdate of Nothing -> return ()- Just updateType -> do+ Just updateType -> unless dryrun $ do -- use cmdLog to debug, but notes are not quoted- updatedone <-- if updateType == TemplateUpdate- then do- cmd_ "fedpkg" ["update"]- return True- else do- -- FIXME also query for open existing bugs- changelog <- if isJust mreview- then getSummaryURL spec- else if usechangelog- then cleanChangelog spec- else- -- FIXME list open bugs- changeLogPrompt (Just "update") spec- if trim (lower changelog) == "no"- then return False- else do- let cbugs = extractBugReferences changelog- bugs = let bids = [show rev | Just rev <- [mreview]] ++ cbugs in- if null bids then [] else ["--bugs", intercalate "," bids]- when (isJust mreview &&- updateType `elem` [SecurityUpdate,BugfixUpdate]) $- warning "overriding update type with 'newpackage'"- putStrLn $ "Creating Bodhi Update for " ++ unwords nvrs ++ ":"- -- FIXME check for Bodhi URL to confirm update- cmd_ "bodhi" (["updates", "new", "--type", if isJust mreview then "newpackage" else show updateType, "--severity", show severity, "--request", "testing", "--notes", changelog, "--autokarma", "--autotime", "--close-bugs"] ++ bugs ++ nvrs)+ updatedone <- do+ mtemplate <- maybeTemplate updateType+ case mtemplate of+ Just file -> do+ cmd_ "bodhi" ["updates", "new", "--file", file, nvrs] return True+ Nothing -> do+ -- FIXME also query for open existing bugs+ changelog <- if isJust mreview+ then getSummaryURL spec+ else+ if usechangelog+ then cleanChangelog spec+ else+ -- FIXME list open bugs+ changeLogPrompt (Just "update") spec+ if trim (lower changelog) `elem` ["no","n"]+ then return False+ else do+ let cbugs = extractBugReferences changelog+ bugs =+ let bids = [show rev | Just rev <- [mreview]] ++ cbugs in+ if null bids+ then []+ else ["--bugs", intercalate "," bids]+ when (isJust mreview &&+ updateType `elem` [SecurityUpdate,BugfixUpdate]) $+ warning "overriding update type with 'newpackage'"+ putStrLn $ "Creating Bodhi Update for " ++ nvrs ++ ":"+ -- FIXME check for Bodhi URL to confirm update+ cmd_ "bodhi" $ ["updates", "new", "--type", if isJust mreview then "newpackage" else show updateType, "--severity", show severity, "--request", "testing", "--notes", changelog, "--autokarma", "--autotime", "--close-bugs"] ++ bugs ++ [nvrs]+ return True when updatedone $ do- -- FIXME avoid this if we know the update URL- case head nvrs of- nvr -> do- updatequery <- bodhiUpdates [makeItem "display_user" "0", makeItem "builds" nvr]- case updatequery of- [] -> do- putStrLn "bodhi submission failed"- prompt_ "Press Enter to resubmit to Bodhi"- bodhiUpdate dryrun (mupdate,severity) mreview usechangelog spec nvrs- [update] -> case lookupKey "url" update of- Nothing -> error' "Update created but no url"- Just uri -> putStrLn uri- _ -> error' $ "impossible happened: more than one update found for " ++ nvr+ -- FIXME avoid this if we know the update URLs (split update does not seem to return URLs)+ updates <- bodhiUpdates [makeItem "display_user" "0", makeItem "builds" nvrs]+ if null updates+ then do+ putStrLn $ "bodhi submission failed for " ++ nvrs+ prompt_ "Press Enter to resubmit to Bodhi"+ bodhiUpdate dryrun (mupdate,severity) mreview usechangelog spec nvrs+ else+ forM_ updates $ \update ->+ case lookupKey "url" update of+ Nothing -> error' "Update created but no url"+ Just uri -> putStrLn uri where extractBugReferences :: String -> [String] extractBugReferences clog =@@ -182,3 +188,14 @@ -- make sure is contemporary 7-digit bug (if length ds > 6 then (ds :) else id) $ extractBugReferences more++ maybeTemplate :: UpdateType -> IO (Maybe FilePath)+ maybeTemplate TemplateUpdate = do+ file <- prompt "Please input the update template filepath"+ exists <- doesFileExist file+ if exists+ then return $ Just file+ else do+ putStrLn ("no such file: " ++ file)+ maybeTemplate TemplateUpdate+ maybeTemplate _ = return Nothing
src/Branches.hs view
@@ -226,7 +226,7 @@ case breq of Branches brs -> if null brs then branchingPrompt activenew- else return brs+ else return $ [b | b <- brs, b `elem` activenew] BranchOpt request -> do let requested = case request of AllBranches -> activenew
src/Bugzilla.hs view
@@ -397,7 +397,7 @@ -- comment0 from fedora-create-review has leading newline T.putStrLn $ "(Comment " <> intAsText (commentCount cmt) <> ") <" <> commentCreator cmt <> "> " <> (T.pack . show) (commentCreationTime cmt) <> "\n" mapM_ (T.putStrLn . (" " <>)) $ dropDuplicates . removeLeadingNewline . T.lines $ commentText cmt- putStrLn ""+ putNewLn checkRepoCreatedComment :: BugzillaSession -> BugId -> IO Bool checkRepoCreatedComment session bid =@@ -421,7 +421,7 @@ putBug bug = do T.putStrLn $ bugSummary bug <> " (" <> bugStatus bug <> ")" putBugId $ bugId bug- putStrLn ""+ putNewLn putBugVer :: Bug -> IO () putBugVer bug = do
src/Cmd/Build.hs view
@@ -17,11 +17,12 @@ import Koji import Package import Prompt+import Types data BuildOpts = BuildOpts { buildoptMerge :: Maybe Bool , buildoptNoFailFast :: Bool- , buildoptTarget :: Maybe String+ , buildoptSidetagTarget :: Maybe SideTagTarget , buildoptOverride :: Maybe Int , buildoptWaitrepo :: Maybe Bool , buildoptDryrun :: Bool@@ -46,7 +47,7 @@ -- FIXME --yes buildCmd :: BuildOpts -> (BranchesReq, [String]) -> IO () buildCmd opts (breq, pkgs) = do- let singleBrnch = if isJust (buildoptTarget opts)+ let singleBrnch = if isJust (buildoptSidetagTarget opts) then ZeroOrOne else AnyNumber mlastOfPkgs = if length pkgs > 1@@ -82,54 +83,57 @@ case buildoptMerge opts of Just False -> return False Just True -> do- newer <- getNewerBranch br- mergeBranch True True (ancestor,unmerged) newer br >> return True+ whenJustM (getNewerBranch br) $ \newer ->+ mergeBranch (buildoptDryrun opts) True True False (ancestor,unmerged) newer br+ return True Nothing -> if ancestor && (newrepo || tty) then do- newer <- getNewerBranch br- mergeBranch True False (ancestor,unmerged) newer br >> return True+ whenJustM (getNewerBranch br) $ \newer ->+ mergeBranch (buildoptDryrun opts) True False True (ancestor,unmerged) newer br+ return True else do unless (br == Rawhide) $- putStrLn "newer branch is not ancestor"+ putStrLn "newer branch cannot be merged" return False let spec = packageSpec pkg checkForSpecFile spec checkSourcesMatch spec- unpushed <- gitShortLog $ "origin/" ++ show br ++ "..HEAD"+ unpushed <- gitOneLineLog $ "origin/" ++ show br ++ "..HEAD" nvr <- pkgNameVerRel' br spec- putStrLn ""+ putNewLn mpush <-- if null unpushed then return Nothing+ if null unpushed+ then return Nothing else do when (not merged || br == Rawhide) $ do putStrLn $ nvr ++ "\n" putStrLn "Local commits:"- mapM_ putStrLn unpushed- putStrLn ""+ displayCommits True unpushed+ putNewLn -- see mergeBranch for: unmerged == 1 (774b5890) if tty && (not merged || (newrepo && ancestor && length unmerged == 1)) then do refPrompt unpushed $ "Press Enter to push and build" ++ (if length unpushed > 1 then "; or give a ref to push" else "") ++ (if not newrepo then "; or 'no' to skip pushing" else "")- else return $ Just Nothing+ else return $ Just $ commitRef $ head unpushed let dryrun = buildoptDryrun opts buildstatus <- maybeTimeout 30 $ kojiBuildStatus nvr- let mtarget = buildoptTarget opts- target = fromMaybe (branchTarget br) mtarget+ let msidetagTarget = buildoptSidetagTarget opts mwaitrepo = buildoptWaitrepo opts+ target <- targetMaybeSidetag dryrun br msidetagTarget case buildstatus of Just BuildComplete -> do putStrLn $ nvr ++ " is already built" when (isJust mpush) $ error' "Please bump the spec file"- when (br /= Rawhide && isNothing mtarget) $ do+ when (br /= Rawhide && isNothing msidetagTarget) $ do tags <- maybeTimeout 30 $ kojiNVRTags nvr autoupdate <- checkAutoBodhiUpdate br -- FIXME update referenced bugs for autoupdate branch unless autoupdate $ do unless (any (`elem` tags) [show br, show br ++ "-updates", show br ++ "-updates-pending", show br ++ "-updates-testing", show br ++ "-updates-testing-pending"]) $ do mbug <- bzReviewAnon- bodhiUpdate dryrun (buildoptUpdate opts) mbug (buildoptUseChangelog opts) spec [nvr]+ bodhiUpdate dryrun (buildoptUpdate opts) mbug (buildoptUseChangelog opts) spec nvr unless (any (`elem` tags) [show br, show br ++ "-updates", show br ++ "-override"]) $ whenJust moverride $ \days -> bodhiCreateOverride dryrun (Just days) nvr@@ -144,9 +148,10 @@ whenJustM (kojiGetBuildTaskID fedoraHub nvr) kojiWatchTask -- FIXME do override _ -> do- mbuildref <- case mpush of- Nothing -> Just <$> git "show-ref" ["--hash", "origin/" ++ show br]- _ -> return $ join mpush+ 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@@ -156,7 +161,8 @@ kojiWatchTask task (_:_) -> error' $ show (length opentasks) ++ " open " ++ unPackage pkg ++ " tasks already!" [] -> do- let tag = fromMaybe (branchDestTag br) mtarget+ let tag =+ if target == branchTarget br then branchDestTag br else target mlatest <- kojiLatestNVR tag $ unPackage pkg if equivNVR nvr (fromMaybe "" mlatest) then putStrLn $ nvr ++ " is already latest" ++ if Just nvr /= mlatest then " (modulo disttag)" else ""@@ -178,11 +184,11 @@ prompt_ "Press Enter to continue" return False unless dryrun krbTicket- whenJust mpush $ \ mref ->+ whenJust mpush $ \ref -> unless dryrun $- gitPushSilent $ fmap (++ ":" ++ show br) mref- unlessM (null <$> gitShortLog ("origin/" ++ show br ++ "..HEAD")) $- when (mpush == Just Nothing && not dryrun) $+ gitPushSilent $ Just $ ref ++ ":" ++ show br+ unlessM (null <$> gitOneLineLog ("origin/" ++ show br ++ "..HEAD")) $+ when (isJust mpush && not dryrun) $ error' "Unpushed changes remain" unless (buildoptAllowDirty opts) $ unlessM isGitDirClean $@@ -199,11 +205,11 @@ then whenJust mBugSess $ \ (bid,session) -> putBugBuild dryrun session bid nvr else do- when (isNothing mtarget) $ 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 [nvr]+ bodhiUpdate dryrun (buildoptUpdate opts) (fmap fst mBugSess) (buildoptUseChangelog opts) spec nvr -- FIXME prompt for override note whenJust moverride $ \days -> bodhiCreateOverride dryrun (Just days) nvr
src/Cmd/Compare.hs view
@@ -8,8 +8,8 @@ import Git import Package -compareCmd :: Bool -> AnyBranch -> AnyBranch -> [String] -> IO ()-compareCmd long br1 br2 pkgs = do+compareCmd :: Bool -> Maybe String -> AnyBranch -> AnyBranch -> [String] -> IO ()+compareCmd long mignore br1 br2 pkgs = do if null pkgs then do unlessM isPkgGitRepo $@@ -31,8 +31,14 @@ localbranches <- gitLines "branch" ["--format=%(refname:short)"] forM_ [br1',br2'] $ \br -> unless (show br `elem` localbranches) $ gitSwitchBranch br- output <- git "log" $ ["--format=reference" | not long] ++ [show br1' ++ ".." ++ show br2']+ output <- ignoredLines <$> gitLines "log" (["--format=reference" | not long] ++ [show br1' ++ ".." ++ show br2']) unless (null output) $ do unless (null pkgs) $ getPackageName pkgdir >>= putPkgHdr- putStrLn output+ mapM_ putStrLn output++ ignoredLines :: [String] -> [String]+ ignoredLines =+ case mignore of+ Nothing -> id+ Just ignore -> filter (not . (ignore `isInfixOf`))
src/Cmd/Copr.hs view
@@ -153,7 +153,7 @@ coprBuild dryrun project srpm buildroots = do let chrootargs = mconcat [["-r", bldrt] | bldrt <- buildroots] buildargs = ["build", "--nowait"] ++ chrootargs ++ [project, srpm]- putStrLn ""+ putNewLn putStrLn $ unwords buildroots unless dryrun $ do output <- cmd "copr" buildargs
src/Cmd/Diff.hs view
@@ -10,9 +10,11 @@ import Common.System import Git import Package+import Patch data DiffFormat =- DiffDefault | DiffContext Int | DiffMinimal | DiffStatus | DiffStats+ DiffDefault | DiffContext Int | DiffMinimal | DiffStatus | DiffStats |+ DiffQuiet deriving Eq data DiffWork =@@ -26,10 +28,10 @@ -- FIXME diff other branches without switching -- FIXME --older/--newer branch-diffCmd :: Bool -> DiffWork -> DiffFormat -> Bool -> Maybe DiffFilter -> Maybe AnyBranch- -> (Maybe Branch,[String]) -> IO ()-diffCmd speconly work fmt quiet mpatt mwbr =- withPackagesMaybeBranch HeaderNone False dirtyGit ZeroOrOne diffPkg+diffCmd :: Bool -> DiffWork -> DiffFormat -> Bool -> Maybe DiffFilter+ -> Maybe AnyBranch -> (Maybe Branch,[String]) -> IO ()+diffCmd speconly work fmt ignorebumps mpatt mwbr =+ withPackagesMaybeBranch HeaderNone False dirtyGit diffPkg where diffPkg :: Package -> AnyBranch -> IO () diffPkg pkg br = do@@ -77,28 +79,15 @@ let diffout = (maybe id filterPattern mpatt . simplifyDiff fmt) diff -- FIXME: sometimes we may want to list even if diff but no diffout unless (null diffout) $- if quiet+ unless (ignorebumps && isTrivialRebuildCommit diffout) $+ if fmt == DiffQuiet then putStrLn $ unPackage pkg else do putPkgAnyBrnchHdr pkg br mapM_ putStrLn diffout where simplifyDiff :: DiffFormat -> [String] -> [String]- simplifyDiff DiffMinimal ds =- (maybeRemoveDiffGit . filterCommon) ds- where- filterCommon =- -- flist is from swish- let flist fs a = map ($ a) fs in- filter (not . or . flist (map isPrefixOf ["--- a/", "+++ b/", "index ", "@@ -"]))-- maybeRemoveDiffGit ls =- let spec = unPackage pkg <.> "spec"- specDiffGit = "diff --git a/" ++ spec ++ " b/" ++ spec- gitDiffs = filter ("diff --git a/" `isPrefixOf`) ls in- if gitDiffs == [specDiffGit]- then delete specDiffGit ls- else ls+ simplifyDiff DiffMinimal ds = simplifyMinimalDiff ds -- drop "2 files changed, 113 insertions(+)" simplifyDiff DiffStats ds = if null ds then ds else init ds simplifyDiff _ ds = ds
src/Cmd/FTBFS.hs view
@@ -18,6 +18,7 @@ -- FIXME option for status filter -- FIXME check arch+-- FIXME ask resolution ftbfsCmd :: Bool -> Bool -> Maybe FTBFSBugs -> (Maybe Branch, [FilePath]) -> IO () ftbfsCmd dryrun short mbugsopt (mbr,pkgs) = do@@ -86,14 +87,14 @@ case status of BuildFailed -> do cmdLog "koji-tool" ["tasks", "-T", "-s", "fail", "-b", nvr]- putChar '\n'+ putNewLn BuildComplete -> do if bugStatus bug `elem` ["NEW", "ASSIGNED", "POST"] then do when dryrun $ putBug bug putBugBuild dryrun session (bugId bug) nvr- putChar '\n'+ putNewLn else do putBugURLStatus bug- putChar '\n'+ putNewLn _ -> return ()
src/Cmd/Import.hs view
@@ -35,7 +35,7 @@ when (pkg /= takeFileName dir) $ do -- FIXME check git repo exists clonePkg True UserClone Nothing pkg- putStrLn ""+ putNewLn setCurrentDirectory pkg -- FIXME: check branch is rawhide unlessM isGitRepo $ error' "Not a git repo"@@ -47,13 +47,13 @@ -- FIXME get session from importPkgs (bid,session) <- approvedReviewBugIdSession pkg putBugId bid- putStrLn ""+ putNewLn comments <- getComments session bid mapM_ showComment comments- putStrLn ""+ putNewLn putStr "Review bug: " putBugId bid- putStrLn ""+ putNewLn prompt_ "Press Enter to continue" let srpms = map (T.replace "/reviews//" "/reviews/") $ concatMap findSRPMs comments when (null srpms) $ error "No srpm urls found!"@@ -77,7 +77,7 @@ existing <- fedoraBranchesNoRawhide (localBranches False) when (null existing) $ do brs <- getRequestedBranches [] breq- requestPkgBranches False mock (Branches brs) (Package pkg)+ requestPkgBranches False False mock (Branches brs) (Package pkg) when (pkg /= takeFileName dir) $ setCurrentDirectory dir where
src/Cmd/Install.hs view
@@ -6,39 +6,45 @@ import Data.RPM import Branches+import Cmd.Merge import Common import Common.System import Git import Package import Prompt+import Repoquery --- FIXME package countdown -- FIXME --ignore-uninstalled subpackages -- FIXME --skip-unavailable -- FIXME --check any/all of package installed -- FIXME add --debug or respect --verbose for dnf commands-installCmd :: Bool -> Bool -> Maybe ForceShort -> [BCond] -> Bool- -> (Maybe Branch,[String]) -> IO ()-installCmd verbose recurse mforceshort bconds reinstall (mbr, pkgs) = do- when (recurse && mforceshort == Just ShortCircuit) $+installCmd :: Bool -> Bool -> Maybe Branch -> Maybe ForceShort -> [BCond]+ -> Bool -> Bool -> (Maybe Branch,[String]) -> IO ()+installCmd verbose recurse mfrom mforceshort bconds reinstall allsubpkgs (mbr, pkgs) = do+ when (recurse && isShortCircuit mforceshort) $ error' "cannot use --recurse and --shortcircuit"- withPackagesMaybeBranch (boolHeader (length pkgs > 1)) True Nothing ZeroOrOne installPkg (mbr, pkgs)+ withPackagesMaybeBranch (boolHeader (recurse || length pkgs > 1)) True Nothing installPkg (mbr, pkgs) where installPkg :: Package -> AnyBranch -> IO () installPkg pkg br = do whenJust mbr $ gitSwitchBranch . RelBranch- spec <- localBranchSpecFile pkg br+ spec <-+ if isNothing mfrom+ then localBranchSpecFile pkg br+ else do+ mergeCmd False True Nothing False mfrom (Branches [onlyRelBranch br], ["."])+ localBranchSpecFile pkg br rpms <- builtRpms br spec -- removing arch- let packages = map (readNVRA . takeFileName) rpms- installed <- filterM rpmInstalled packages- if isJust mforceshort || null installed || reinstall- then doInstallPkg mforceshort spec rpms installed- else putStrLn $ unlines (map showNVRA installed) +++ let nvras = map readNVRA rpms+ already <- filterM nvraInstalled nvras+ if isJust mforceshort || null already || reinstall+ then doInstallPkg mforceshort spec rpms already+ else putStrLn $ unlines (map showNVRA already) ++ "\nalready installed!\n" where- doInstallPkg mforceshort' spec rpms installed = do- putStrLn $ (showNVR . dropArch . readNVRA . takeFileName) (head rpms)+ doInstallPkg mforceshort' spec rpms already = do+ putStrLn $ (showNVR . dropArch . readNVRA) (head rpms) missingdeps <- nub <$> (buildRequires spec >>= filterM notInstalled) unless (null missingdeps) $ if recurse@@ -50,27 +56,34 @@ mpkgdir <- lookForPkgDir rbr ".." dep case mpkgdir of Nothing -> putStrLn $ dep ++ " not known"- Just pkgdir -> installCmd verbose recurse mforceshort bconds reinstall (mbr, [pkgdir]) >> putStrLn ""+ Just pkgdir -> installCmd verbose recurse mfrom mforceshort bconds reinstall allsubpkgs (mbr, [pkgdir]) >> putNewLn -- FIXME option to enable/disable installing missing deps else installDeps True spec- wasbuilt <- buildRPMs (not verbose) mforceshort' bconds rpms br spec- unless (mforceshort' == Just ShortCircuit) $+ wasbuilt <- buildRPMs (not verbose) 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 . takeFileName) f `elem` installed) rpms+ let reinstalls =+ filter (\ f -> readNVRA f `elem` already) toinstalls unless (null reinstalls) $ sudo_ "/usr/bin/dnf" $ "reinstall" : "-q" : "-y" : reinstalls- let remaining = filterDebug $ rpms \\ reinstalls+ let remaining = filterDebug $ toinstalls \\ reinstalls unless (null remaining) $ sudo_ "/usr/bin/dnf" $ "install" : "-q" : "-y" : remaining else do- ok <- cmdBool "sudo" $ "/usr/bin/dnf" : "install" : "-q" : "-y" : filterDebug rpms+ ok <- cmdBool "sudo" $ "/usr/bin/dnf" : "install" : "-q" : "-y" : filterDebug toinstalls unless ok $ if wasbuilt then error' "build failed to install" else do prompt_ "Press Enter to rebuild package"- doInstallPkg (Just ForceBuild) spec rpms installed+ doInstallPkg (Just ForceBuild) spec rpms already lookForPkgDir :: Branch -> FilePath -> String -> IO (Maybe FilePath) lookForPkgDir rbr topdir p = do@@ -103,7 +116,7 @@ notInstalledCmd :: (Maybe Branch,[String]) -> IO () notInstalledCmd =- withPackagesMaybeBranchNoHeadergit ZeroOrOne notInstalledPkg+ withPackagesMaybeBranchNoHeadergit notInstalledPkg where notInstalledPkg :: Package -> AnyBranch -> IO () notInstalledPkg pkg br = do@@ -111,10 +124,10 @@ unless dead $ do spec <- findSpecfile rpms <- builtRpms br spec- let packages = map (readNVRA . takeFileName) rpms- installed <- filterM rpmInstalled packages+ let nvras = map readNVRA rpms+ installed <- filterM nvraInstalled nvras when (null installed) $ do- let pkgnames = map rpmName packages+ let pkgnames = map rpmName nvras older <- filterM pkgInstalled pkgnames if null older then putStrLn $ unPackage pkg
src/Cmd/ListPackages.hs view
@@ -2,16 +2,20 @@ module Cmd.ListPackages ( listCmd,- Packager(..)+ Packager(..),+ listLocalCmd ) where import Data.Aeson import Fedora.Pagure +import Branches import Common import Common.System import qualified Common.Text as T+import Git (gitSwitchBranch')+import Package import Pagure data Packager = Owner String | Committer String@@ -55,3 +59,17 @@ return [] else queryPagurePaged server path params (pagination,paging)++-- FIXME add --count+listLocalCmd :: (Maybe Branch, [String]) -> IO ()+listLocalCmd =+ withPackagesMaybeBranch HeaderNone False dirtyGit listLocalPkg+ where+ listLocalPkg :: Package -> AnyBranch -> IO ()+ listLocalPkg _ (OtherBranch _) =+ error' "other branches not supported yet"+ listLocalPkg pkg (RelBranch br) = do+ exists <- gitSwitchBranch' True br+ when exists $+ whenM (isJust <$> maybeFindSpecfile) $+ putStrLn $ unPackage pkg
src/Cmd/Local.hs view
@@ -20,9 +20,9 @@ import Git import Package -localCmd :: Bool -> Maybe ForceShort -> [BCond] -> (BranchesReq, [String])- -> IO ()-localCmd quiet mforceshort bconds =+localCmd :: Bool -> Bool -> Maybe ForceShort -> [BCond]+ -> (BranchesReq, [String]) -> IO ()+localCmd quiet debug mforceshort bconds = withPackagesByBranches HeaderNone False Nothing ZeroOrOne localBuildPkg where localBuildPkg :: Package -> AnyBranch -> IO ()@@ -31,11 +31,11 @@ rpms <- if isJust mforceshort then return [] else builtRpms br spec- void $ buildRPMs quiet mforceshort bconds rpms br spec+ void $ buildRPMs quiet debug True mforceshort bconds rpms br spec installDepsCmd :: (Maybe Branch,[String]) -> IO () installDepsCmd =- withPackagesMaybeBranch HeaderNone False Nothing ZeroOrOne installDepsPkg+ withPackagesMaybeBranch HeaderNone False Nothing installDepsPkg where installDepsPkg :: Package -> AnyBranch -> IO () installDepsPkg pkg br =@@ -43,7 +43,7 @@ srpmCmd :: Bool -> (Maybe Branch,[String]) -> IO () srpmCmd force =- withPackagesMaybeBranchNoHeadergit ZeroOrOne srpmBuildPkg+ withPackagesMaybeBranchNoHeadergit srpmBuildPkg where srpmBuildPkg :: Package -> AnyBranch -> IO () srpmBuildPkg pkg br = do
src/Cmd/Merge.hs view
@@ -4,83 +4,101 @@ getNewerBranch) where +import Numeric.Natural (Natural)+ import Common import Common.System import Branches import Git import Package-import Prompt+import Patch -mergeCmd :: Bool -> Maybe Branch -> (BranchesReq,[String]) -> IO ()-mergeCmd noprompt mfrom =+mergeCmd :: Bool -> Bool -> Maybe Natural -> Bool -> Maybe Branch+ -> (BranchesReq,[String]) -> IO ()+mergeCmd dryrun noprompt mnotrivial showall mfrom = withPackagesByBranches HeaderMay False cleanGitFetchActive AnyNumber runMergeBranch where runMergeBranch :: Package -> AnyBranch -> IO () runMergeBranch _ (OtherBranch _) = error' "merge only defined for release branches" runMergeBranch _pkg (RelBranch br) = do- exists <- gitSwitchBranch' br+ exists <- gitSwitchBranch' False br when exists $ do- from <- maybe (getNewerBranch br) return mfrom- when (from == br) $- error' "cannot merge branch to itself"- gitMergeOrigin br- unmerged <- mergeable from br- mergeBranch False noprompt unmerged from br+ mfrom' <- if isJust mfrom+ then return mfrom+ else getNewerBranch br+ whenJust mfrom' $ \from -> do+ when (from == br) $+ error' "cannot merge branch to itself"+ unless dryrun $+ gitMergeOrigin br+ (ancestor,unmerged) <- mergeable from br+ unmerged' <- filterOutTrivial mnotrivial unmerged+ mergeBranch dryrun False noprompt showall (ancestor,unmerged') from br+ where+ filterOutTrivial :: Maybe Natural -> [Commit] -> IO [Commit]+ filterOutTrivial Nothing cs = return cs+ filterOutTrivial _ [] = return []+ filterOutTrivial (Just no) css@(c:cs) =+ if no == 0+ then return css+ else do+ -- drop oneline+ ls <- tail <$> gitLines "show" ["-U1", "--pretty=oneline", commitRef c]+ if isTrivialRebuildCommit ls+ then filterOutTrivial (Just (no -1)) cs+ else return css -- FIXME maybe require local branch already here-mergeable :: Branch -> Branch -> IO (Bool,[String])+mergeable :: Branch -> Branch -> IO (Bool,[Commit]) mergeable _ Rawhide = return (False,[]) mergeable from _ = do locals <- localBranches True gitMergeable (show from `notElem` locals) from -- FIXME return merged ref-mergeBranch :: Bool -> Bool -> (Bool,[String]) -- (ancestor,unmerged)+mergeBranch :: Bool -> Bool -> Bool -> Bool+ -> (Bool,[Commit]) -- (ancestor,unmerged) -> Branch -> Branch -> IO ()-mergeBranch _ _ _ _ Rawhide = return ()-mergeBranch _ _ (_,[]) _ _ = return ()-mergeBranch build noprompt (True, unmerged) from br = do+mergeBranch _ _ _ _ _ _ Rawhide = return ()+mergeBranch _ _ _ _ (_,[]) _ _ = return ()+mergeBranch dryrun build noprompt showall (True, unmerged) from br = do isnewrepo <- initialPkgRepo- unless (null unmerged) $ do- putStrLn $ (if isnewrepo || noprompt then "Merging from" else "New commits in") ++ " " ++ show from ++ ":"- mapM_ putStrLn unmerged- unpushed <- gitShortLog $ "origin/" ++ show br ++ "..HEAD"+ putStrLn $ (if isnewrepo || noprompt then "Merging from" else "New commits in") ++ " " ++ show from ++ ":"+ displayCommits showall unmerged+ unpushed <- gitOneLineLog $ "origin/" ++ show br ++ "..HEAD" unless (null unpushed) $ do putStrLn "Local commits:"- mapM_ putStrLn unpushed- -- FIXME avoid Mass_Rebuild bumps+ displayCommits showall unpushed mmerge <- if isnewrepo && length unmerged == 1 || noprompt- then return $ Just Nothing- else refPrompt unmerged $ "Press Enter to merge " ++ show from +++ then return $ Just $ commitRef (head unmerged)+ else refPrompt unmerged ("Press Enter to merge " ++ show from ++ (if build then " and build" else "") ++ (if length unmerged > 1 then "; or give a ref to merge" else "") ++- "; or 'no' to skip merge"+ "; or 'no' to skip merge") -- ensure still on same branch! gitSwitchBranch (RelBranch br)- whenJust mmerge $ \ mhash -> do- let ref = case mhash of- Nothing -> show from- Just hash -> hash+ whenJust mmerge $ \ ref -> do locals <- localBranches True unless (show from `elem` locals) $ git_ "fetch" ["origin", show from ++ ":" ++ show from]- git_ "merge" ["--quiet", ref]-mergeBranch build noprompt (False,unmerged) from br = do+ unless dryrun $+ git_ "merge" ["--quiet", ref]+mergeBranch dryrun build noprompt showall (False,unmerged) from br = do putStrLn $ show from ++ " branch is not directly mergeable:"- mapM_ putStrLn unmerged- putStrLn ""- unpushed <- gitShortLog $ "origin/" ++ show br ++ "..HEAD"+ displayCommits False unmerged+ putNewLn+ unpushed <- gitOneLineLog $ "origin/" ++ show br ++ "..HEAD" unless (null unpushed) $ do putStrLn "Local commits:"- mapM_ putStrLn unpushed+ displayCommits showall unpushed mmerge <- if noprompt then return Nothing else conflictPrompt unmerged $ "Press Enter to skip merge" ++ (if build then " and build" else "") ++ "; or give a ref or 'HEAD' to attempt merge" -- ensure still on same branch! gitSwitchBranch (RelBranch br)- whenJust mmerge $ \ ref -> do+ whenJust mmerge $ \ ref ->+ unless dryrun $ git_ "merge" [ref]- git_ "rebase" []
src/Cmd/Mock.hs view
@@ -12,7 +12,7 @@ import Git import Package -data NoClean = NoCleanBefore | NoCleanAfter | NoCleanAll+data NoClean = NoCleanBefore | NoCleanAfter | NoCleanAll | MockShortCircuit deriving Eq -- FIXME add repo/copr for build@@ -36,7 +36,7 @@ mockBuildPkgs :: Bool -> [String] -> Branch -> IO () mockBuildPkgs noswitch pkgs br = do srpms <- mapM (prepSrpm (RelBranch br)) pkgs- putStrLn ""+ putNewLn rootBr <- maybe getReleaseBranch return mroot let resultdir = case srpms of@@ -51,6 +51,7 @@ Just NoCleanBefore -> ["--no-clean"] Just NoCleanAfter -> ["--no-cleanup-after"] Just NoCleanAll -> ["--no-clean", "--no-cleanup-after"]+ Just MockShortCircuit -> ["--short-circuit", "install"] mockopts_common c = [c, "--root", mockRoot rootBr] ++ noclean ++ ["--enable-network" | network] mockbuild_opts = mockopts_common command ++ ["--config-opts=cleanup_on_failure=False" | mnoclean `elem` [Nothing, Just NoCleanBefore]] ++ resultdir ++ srpms mockshell_opts = mockopts_common "--shell" ++ ["--no-clean" | "--no-clean" `notElem` noclean]
src/Cmd/Override.hs view
@@ -31,5 +31,5 @@ putStrLn nvr tags <- kojiNVRTags nvr unless (any (`elem` tags) [show br, show br ++ "-updates", show br ++ "-override"]) $- unlessM (checkAutoBodhiUpdate br) $ do+ unlessM (checkAutoBodhiUpdate br) $ bodhiCreateOverride dryrun mduration nvr
+ src/Cmd/Owner.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}++module Cmd.Owner (+ ownerCmd+ )+where++import Network.HTTP.Query (lookupKey)++import Common+import Common.System+import Package+import Pagure++-- FIXME option for email+-- FIXME option to output owner's packages on separate lines+ownerCmd :: [String] -> IO ()+ownerCmd pkgs = do+ if null pkgs+ then void $ ownerPkg "."+ else do+ pkgowners <- mapM ownerPkg pkgs+ when (length pkgs > 1) $ do+ putNewLn+ let maintain = groupSort pkgowners+ forM_ maintain $ \(o,ps) ->+ putStrLn $ o ++ ": " ++ unwords (map unPackage ps)+ where+ ownerPkg :: String -> IO (String,Package)+ ownerPkg path = do+ pkg <- getPackageName path+ when (length pkgs > 1) $+ putStr $ unPackage pkg ++ " "+ epkginfo <- pagureProjectInfo srcfpo ("rpms" </> unPackage pkg)+ case epkginfo of+ Left err -> error' err+ Right pkginfo -> do+ case lookupKey "user" pkginfo of+ Nothing -> error' "user not found"+ Just user ->+ case userName user of+ Nothing -> error' "user name not found"+ Just (name,full) -> do+ putStr $ name +-+ "(" ++ full ++ ")"+ whenJust (lookupKey "access_users" pkginfo >>= lookupKey "admin") $ putStrLn . formatAdmins+ return (name,pkg)++ userName user = do+ name <- lookupKey "name" user+ full <- lookupKey "fullname" user+ return (name,full)++ formatAdmins :: [String] -> String+ formatAdmins [] = ""+ formatAdmins as = ' ' : unwords as
src/Cmd/Parallel.hs view
@@ -23,15 +23,13 @@ import Koji import Package import Prompt--data SideTagTarget = SideTag | Target String--maybeTarget :: Maybe SideTagTarget -> Maybe String-maybeTarget (Just (Target t)) = Just t-maybeTarget _ = Nothing+import Types --- (pkg, nvr)-type Job = (String, Async (String,String))+data JobDone = JobDone {jobNvr :: String,+ jobBranch :: Branch,+ _jobClog :: String+ }+type JobAsync = (String, Async JobDone) -- FIXME print koji url of failed process or use koji-tool -- FIXME option to build multiple packages over branches in parallel@@ -62,13 +60,14 @@ when (isJust mtarget && length branches > 1) $ error' "You can only specify target with one branch" case pkgs of- [] -> timeIO $ parallelBranches "." branches+ [] -> parallelBranches "." branches [p] -> withExistingDirectory p $ parallelBranches p branches _ ->- forM_ branches $ \ rbr -> do+ forM_ branches $ \rbr -> do forM_ pkgs $ \p ->- withExistingDirectory p $ mergeNewerBranch p rbr+ when (mmerge /= Just False) $+ withExistingDirectory p $ mergeNewerBranch rbr allLayers <- dependencyLayers pkgs let layers = drop firstlayer allLayers when (isNothing msidetagTarget && length allLayers > 1) $@@ -76,19 +75,21 @@ error' "You must use --target/--sidetag to build package layers for this branch" when (length branches > 1) $ putStrLn $ "# " ++ show rbr- target <- targetMaybeSidetag rbr+ target <- targetMaybeSidetag dryrun rbr msidetagTarget nvrclogs <- concatMapM (timeIO . parallelBuild target rbr) (zip [firstlayer..length allLayers] $ init $ tails layers) -- tails ends in []- unless (isNothing msidetagTarget || dryrun) $ do+ unless (isNothing (fst mupdate)) $+ unless (isNothing msidetagTarget) $+ -- FIXME check for an existing sidetag update when (target /= branchTarget rbr) $ do- let changelog = intercalate "" $ renderChangelogs nvrclogs- putStrLn ""- putStrLn changelog- input <- prompt "Press Enter to use above or input update summary now; or 'no' to skip update"- unless (trim (lower input) == "no") $- bodhiSidetagUpdate rbr (map fst nvrclogs) target $- if null input then changelog else input+ let changelog = intercalate "" $ renderChangelogs nvrclogs+ putNewLn+ putStrLn changelog+ input <- prompt "Press Enter to use above or input update summary now; or 'no' to skip update"+ unless (trim (lower input) `elem` ["no","n"] || dryrun) $+ bodhiSidetagUpdate rbr (map jobNvr nvrclogs) target $+ if null input then changelog else input where parallelBranches :: FilePath -> [Branch] -> IO () parallelBranches pkgdir brs = do@@ -96,46 +97,48 @@ currentbranch <- gitCurrentBranch putStrLn $ "= Building " ++ pluralException (length brs) "branch" "branches" ++ " in parallel:" putStrLn $ unwords $ map show brs- jobs <- mapM setupBranch brs- (failures,nvrclogs) <- watchJobs [] [] jobs+ pkg <- getPackageName pkgdir+ jobs <- mapM (setupBranch pkg) brs+ (failures,nvrclogs) <- timeIO $ watchJobs Nothing [] [] jobs -- switch back to the original branch when (length brs /= 1) $ gitSwitchBranch currentbranch unless (null failures) $ error' $ "Build failures: " ++ unwords failures when (isNothing msidetagTarget) $ do- pkg <- getPackageName pkgdir let spec = packageSpec pkg- bodhiUpdate dryrun mupdate Nothing False spec $ map fst nvrclogs+ bodhiUpdate dryrun mupdate Nothing False spec $+ intercalate "," $+ map jobNvr $+ filter ((/= Rawhide) . jobBranch) nvrclogs where -- FIXME time jobs- setupBranch :: Branch -> IO Job- setupBranch br = do- target <- targetMaybeSidetag br- when (mmerge /= Just False) $ mergeNewerBranch (show br) br- job <- startBuild False False target br "." >>= async+ setupBranch :: Package -> Branch -> IO JobAsync+ setupBranch pkg br = do+ putPkgBrnchHdr pkg br+ target <- targetMaybeSidetag dryrun br msidetagTarget+ when (mmerge /= Just False) $ mergeNewerBranch br+ job <- startBuild Nothing 0 False False target pkg br "." >>= async unless dryrun $ sleep 3 return (show br,job) - mergeNewerBranch :: String -> Branch -> IO ()- mergeNewerBranch desc br = do+ mergeNewerBranch :: Branch -> IO ()+ mergeNewerBranch br = do gitSwitchBranch (RelBranch br) (ancestor,unmerged) <- newerMergeable br- newer <- getNewerBranch br- when (ancestor && not (null unmerged)) $- putStrLn $ "Checking " ++ desc ++ ":"- mergeBranch True (mmerge == Just True) (ancestor,unmerged) newer br- putStrLn ""+ unless dryrun $+ whenJustM (getNewerBranch br) $ \newer -> do+ mergeBranch dryrun True (mmerge == Just True) False (ancestor,unmerged) newer br -- FIXME time builds or layers parallelBuild :: String -> Branch -> (Int,[[String]])- -> IO [(String,String)]+ -> IO [JobDone] parallelBuild _ _ (_,[]) = return [] -- should not reach here parallelBuild target br (layernum, layer:nextLayers) = do krbTicket putStrLn $ "\n= Building parallel layer #" ++ show layernum ++ if nopkgs > 1- then " (" ++ show nopkgs ++ " packages):"+ then " (" ++ show nopkgs +-+ "packages):" else ":" putStrLn $ unwords layer -- maybe print total pending packages@@ -144,19 +147,19 @@ let layerspkgs = map length nextLayers in case layerspkgs of [l] -> plural l "package"- _ -> show layerspkgs ++ " packages"- jobs <- mapM setupBuild layer+ _ -> show layerspkgs +-+ "packages"+ jobs <- zipWithM setupBuild (reverse [0..(length layer - 1)]) layer when (null jobs) $ error' "No jobs run"- (failures,nvrs) <- watchJobs [] [] jobs+ (failures,nvrs) <- watchJobs (Just layernum) [] [] jobs -- FIXME prompt to continue? if null failures then return nvrs else do let pending = sum $ map length nextLayers- error' $ "Build failures in layer " ++ show layernum ++ ": " +++ error' $ "Build failures in layer" +-+ show layernum ++ ": " ++ unwords failures ++ "\n\n" ++- show pending ++ " pending packages" +++ plural pending "pending package" ++ if pending > 0 then ":\n" ++ unwords (map unwords nextLayers)@@ -165,53 +168,52 @@ nopkgs = length layer layersleft = length nextLayers - setupBuild :: String -> IO Job- setupBuild pkg = do- job <- startBuild (layersleft > 0) (nopkgs > 5) target br pkg+ setupBuild :: Int -> String -> IO JobAsync+ setupBuild n dir = do+ pkg <- getPackageName dir+ putPkgBrnchHdr pkg br+ job <- startBuild (Just layernum) n (layersleft > 0) (nopkgs > 5) target pkg br dir >>= async- unless dryrun $ sleep 3- return (pkg,job)+ unless dryrun $ sleep 4+ return (unPackage pkg,job) - -- (failures,successes)- watchJobs :: [String] -> [(String,String)] -> [Job]- -> IO ([String],[(String,String)])- watchJobs fails results [] = return (fails,results)- watchJobs fails results (job:jobs) = do+ watchJobs :: Maybe Int -> [String] -> [JobDone] -> [JobAsync]+ -> IO ([String],[JobDone]) -- (failures,successes)+ watchJobs _ fails results [] = return (fails,results)+ watchJobs mlayer fails results (job:jobs) = do status <- poll (snd job) case status of- Nothing -> sleep 1 >> watchJobs fails results (jobs ++ [job])+ Nothing -> sleep 1 >> watchJobs mlayer fails results (jobs ++ [job]) -- (nvr,changelog) Just (Right result) -> do- putStrLn $ color Yellow (fst result) ++ " job completed (" ++ show (length jobs) ++ " left in layer)"- watchJobs fails (result:results) jobs+ putStrLn $ plural (length jobs) "job" +-+ "left" +-+ maybe "" (\l -> "in layer" +-+ show l) mlayer+ watchJobs mlayer fails (result:results) jobs Just (Left except) -> do print except let pkg = fst job- putStrLn $ "** " ++ color Magenta pkg ++ " job " ++ color Magenta "failed" ++ " ** (" ++ show (length jobs) ++ " left in layer)"- watchJobs (pkg : fails) results jobs+ putStrLn $ "** " ++ color Magenta pkg +-+ "job" +-+ color Magenta "failed" ++ " ** (" ++ plural (length jobs) "job" +-+ "left" +-+ maybe "" (\l -> "in layer" +-+ show l) mlayer ++ ")"+ watchJobs mlayer (pkg : fails) results jobs -- FIXME prefix output with package name- startBuild :: Bool -> Bool -> String -> Branch -> String- -> IO (IO (String,String))- startBuild morelayers background target br pkgdir =- withExistingDirectory pkgdir $ do+ startBuild :: Maybe Int -> Int -> Bool -> Bool -> String -> Package+ -> Branch -> String -> IO (IO JobDone)+ startBuild mlayer n morelayers background target pkg br dir =+ withExistingDirectory dir $ do gitSwitchBranch (RelBranch br)- pkg <- getPackageName pkgdir- putPkgBrnchHdr pkg br- unpushed <- gitShortLog $ "origin/" ++ show br ++ "..HEAD"- unless (null unpushed) $- mapM_ putStrLn unpushed let spec = packageSpec pkg checkForSpecFile spec+ nvr <- pkgNameVerRel' br spec+ unpushed <- gitOneLineLog $ "origin/" ++ show br ++ "..HEAD" unless (null unpushed) $ do+ putStrLn $ nvr ++ " (" ++ target ++ ")" +-+ show n +-+ "more" +-++ maybe "" (\l -> "in layer" +-+ show l) mlayer+ putNewLn+ displayCommits True unpushed+ unless (null unpushed) $ do checkSourcesMatch spec unless dryrun $ gitPushSilent Nothing- nvr <- pkgNameVerRel' br spec- putStrLn $ nvr ++ " (" ++ target ++ ")" changelog <- unlines <$> getChangelog spec- when (null unpushed) $- putStrLn changelog -- FIXME should compare git refs -- FIXME check for target buildstatus <- kojiBuildStatus nvr@@ -220,7 +222,7 @@ case buildstatus of Just BuildComplete -> do -- FIXME detect old stable existing build- putStrLn $ color Green nvr ++ " is " ++ color Green "already built"+ putStrLn $ color Green 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"]) $@@ -229,17 +231,22 @@ return $ do when morelayers $ kojiWaitRepo dryrun background target nvr- return (nvr,changelog)+ return $ JobDone nvr br changelog Just BuildBuilding -> do- putStrLn $ nvr ++ " is already building"+ putStrLn $ color Yellow nvr +-+ "is already" +-+ color Yellow "building" mtask <- kojiGetBuildTaskID fedoraHub nvr case mtask of Nothing -> error' $ "Task for " ++ nvr ++ " not found" Just task -> return $ do kojiWaitTaskAndRepo (isNothing mlatest) nvr task- return (nvr,changelog)+ return $ JobDone nvr br changelog _ -> do+ when (null unpushed) $ do+ putStrLn $ nvr ++ " (" ++ target ++ ")" +-+ show n +-+ "more" +-++ maybe "" (\l -> "in layer" +-+ show l) mlayer+ putNewLn+ putStrLn changelog buildref <- git "show-ref" ["--hash", "origin/" ++ show br] opentasks <- kojiOpenTasks pkg (Just buildref) target case opentasks of@@ -247,7 +254,7 @@ putStrLn $ nvr ++ " task is already open" return $ do kojiWaitTaskAndRepo (isNothing mlatest) nvr task- return (nvr,changelog)+ return $ JobDone nvr br changelog (_:_) -> error' $ show (length opentasks) ++ " open " ++ unPackage pkg ++ " tasks already" [] -> do if equivNVR nvr (fromMaybe "" mlatest)@@ -256,12 +263,12 @@ else do -- FIXME parse build output if dryrun- then return $ return (nvr,"<changelog>")+ then return $ return $ JobDone nvr br "<changelog>" else do task <- kojiBuildBranchNoWait target pkg Nothing $ "--fail-fast" : ["--background" | background] return $ do kojiWaitTaskAndRepo (isNothing mlatest) nvr task- return (nvr,changelog)+ return $ JobDone nvr br changelog where kojiWaitTaskAndRepo :: Bool -> String -> TaskID -> IO () kojiWaitTaskAndRepo newpkg nvr task = do@@ -286,10 +293,10 @@ kojiWaitRepo dryrun background target nvr -- FIXME map nvr to package?- renderChangelogs :: [(String,String)] -> [String]+ renderChangelogs :: [JobDone] -> [String] renderChangelogs [] = []- renderChangelogs ((nvr,clog):nvrclogs) =- unlines [nvr, "", clog] : renderChangelogs nvrclogs+ renderChangelogs ((JobDone nvr _ clog):jobs) =+ unlines [nvr, "", clog] : renderChangelogs jobs -- FIXME how to catch authentication errors? bodhiSidetagUpdate :: Branch -> [String] -> String -> String -> IO ()@@ -304,17 +311,13 @@ putStrLn "Paste update template now:" template <- getContents cmdBool "bodhi" ["updates", "new", "--file", template, "--from-tag", sidetag]- -- perhaps testing works now? (though seems there is a delay at least) else cmdBool "bodhi" ["updates", "new", "--type", show updateType , "--severity", show severity, "--request", "testing", "--notes", if null notes then "to be written" else notes, "--autokarma", "--autotime", "--close-bugs", "--from-tag", sidetag] if not ok then bodhiSidetagUpdate rbr nvrs sidetag notes else unlessM (checkAutoBodhiUpdate rbr) $ do- prompt_ "After editing the update, press Enter to remove the sidetag"- fedpkg_ "remove-side-tag" [sidetag]- -- arguably we already received the Updateid from the above bodhi- -- command, but we query it here via nvr- -- prompt_ "Press Enter to edit update just to unlock it from sidetag"+ -- arguably we already received the Updateid from the above bodhi command,+ -- but we query it here via nvr res <- bodhiUpdates [makeItem "display_user" "0", makeItem "builds" (last nvrs)] case res of [] -> do@@ -325,34 +328,4 @@ case lookupKey "updateid" update :: Maybe String of Nothing -> error' "could not determine Update id" Just _updateid -> return ()- -- -- disconnect the update from the sidetag- -- -- so it can be changed after sidetag closed- -- -- see https://github.com/fedora-infra/bodhi/issues/4563 for the auto options- -- fails with: {"status": "error", "errors": [{"location": "body", "name": "from_tag", "description": "The supplied from_tag doesn't exist."}, {"location": "body", "name": "builds", "description": "ACL validation mechanism was unable to determine ACLs."}]}- -- cmd_ "bodhi" ["updates", "edit", updateid,- -- "--request", "testing"] -- was "--autokarma", "--autotime"- -- putStrLn "Update edited to unlock from sidetag" _ -> error' $ "impossible happened: more than one update found for " ++ last nvrs-- targetMaybeSidetag :: Branch -> IO String- targetMaybeSidetag br =- case msidetagTarget of- Nothing -> return $ branchTarget br- Just (Target t) -> return t- Just SideTag -> do- tags <- map (head . words) <$> kojiUserSideTags (Just br)- case tags of- [] -> do- Just (buildtag,_desttag) <- kojiBuildTarget fedoraHub (show br)- out <- head . lines <$> fedpkg "request-side-tag" ["--base-tag", buildtag]- if "Side tag '" `isPrefixOf` out- then do- putStrLn out- let sidetag =- init . dropWhileEnd (/= '\'') $ dropPrefix "Side tag '" out- putStrLn $ "waiting for " ++ sidetag ++ " repo"- cmd_ "koji" ["wait-repo", sidetag]- return sidetag- else error' "'fedpkg request-side-tag' failed"- [tag] -> return tag- _ -> error' $ "More than one user side-tag found for " ++ show br
src/Cmd/PkgReview.hs view
@@ -25,6 +25,7 @@ deriving Eq -- FIXME add --dependent pkgreview+-- FIXME verify tarball is same as upstream createReview :: ScratchOption -> Bool -> [FilePath] -> IO () createReview scratchOpt mock pkgs = withPackagesByBranches HeaderMust False Nothing Zero createPkgReview (Branches [], pkgs)
src/Cmd/Prep.hs view
@@ -18,7 +18,7 @@ prepCmd mpre verbose (mbr,pkgs) = do when (mpre == Just PrepClone) $ cloneCmd (ClonePkgs (mbr, pkgs))- withPackagesMaybeBranchNoHeadergit ZeroOrOne prepPackage (mbr,pkgs)+ withPackagesMaybeBranchNoHeadergit prepPackage (mbr,pkgs) where prepPackage :: Package -> AnyBranch -> IO () prepPackage pkg br = do
src/Cmd/PullPush.hs view
@@ -1,6 +1,7 @@ module Cmd.PullPush ( pullPkgs, PullOpts(..),+ fetchPkgs, pushPkgs) where @@ -44,11 +45,24 @@ gitSwitchBranch br gitMergeOrigin current +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 :: (BranchesReq, [String]) -> IO () pushPkgs = withPackagesByBranches HeaderMay False cleanGitFetch AnyNumber pushPkg where pushPkg :: Package -> AnyBranch -> IO () pushPkg _pkg _br = do- gitShortLog1 Nothing >>= putStrLn+ whenJustM (gitShortLog1 Nothing) $ putStrLn . showCommit gitPushSilent Nothing
− src/Cmd/Repoquery.hs
@@ -1,24 +0,0 @@-module Cmd.Repoquery- (repoqueryCmd)-where--import Branches-import Common.System-import Package--import qualified Data.List as L--repoqueryCmd :: (BranchesReq, [String]) -> IO ()-repoqueryCmd (breq, pkgs) = do- query <- if null pkgs- then pure <$> getDirectoryName- else return pkgs- brs <- listOfBranches True False breq- sysbr <- systemBranch- mapM_ (repoquery_ sysbr query) brs- where- repoquery_ :: Branch -> [String] -> Branch -> IO ()- repoquery_ sysbr query br = do- let qf = ["--queryformat=%{repoid}: %{name}-%{version}-%{release}.%{arch}"- | not (any ("--qf" `L.isPrefixOf`) query)]- repoquery sysbr br (qf ++ query) >>= putStrLn
src/Cmd/RequestBranch.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE CPP, OverloadedStrings #-} module Cmd.RequestBranch (- requestBranches,+ requestBranchesCmd, requestPkgBranches ) where @@ -18,69 +18,96 @@ import Branches import Bugzilla+import Cmd.SrcDeps (srcDeps) import Git import Krb import ListReviews import Package import Pagure+import Prompt (prompt_) -- FIXME option to do koji scratch build instead of mock-requestBranches :: Bool -> (BranchesReq,[String]) -> IO ()-requestBranches mock (breq, ps) = do+requestBranchesCmd :: Bool -> Maybe Branch -> Bool -> (BranchesReq,[String]) -> IO ()+requestBranchesCmd quiet mrecursebr mock (breq, ps) = do if null ps then do+ when (isJust mrecursebr) $+ error' "please specify a package dir when using --recurse-deps" isPkgGit <- isPkgGitSshRepo if isPkgGit- then getDirectoryName >>= requestPkgBranches False mock breq . Package+ then+ getDirectoryName >>= requestPkgBranches quiet False mock breq . Package else do pkgs <- map reviewBugToPackage <$> listReviews ReviewUnbranched- mapM_ (\ p -> withExistingDirectory p $ requestPkgBranches (length pkgs > 1) mock breq (Package p)) pkgs- else- forM_ ps $ \ p ->- withExistingDirectory p $ do- pkg <- getDirectoryName- requestPkgBranches (length ps > 1) mock breq (Package pkg)+ mapM_ (\ p -> withExistingDirectory p $ requestPkgBranches quiet (length pkgs > 1) mock breq (Package p)) pkgs+ else do+ pkgs <-+ case mrecursebr of+ Just br -> do+ deps <- concat <$> srcDeps False (br,ps)+ putStrLn $ unwords deps+ unless quiet $+ prompt_ "\nPress Enter to check these packages for branches"+ return deps+ Nothing -> return ps+ forM_ pkgs $ \ p ->+ withExistingDirectory p $ do+ pkg <- getDirectoryName+ requestPkgBranches quiet (length pkgs > 1) mock breq (Package pkg) -requestPkgBranches :: Bool -> Bool -> BranchesReq -> Package -> IO ()-requestPkgBranches multiple mock breq pkg = do- -- check have access- fasid <- fasIdFromKrb- epkginfo <- pagureProjectInfo srcfpo ("rpms" </> unPackage pkg)- case epkginfo of- Left err -> error' err- Right pkginfo ->- -- FIXME exclude unprivileged roles- unless (fasid `elem` concat- (lookupKeyElems "access_users" pkginfo)) $- error' $ fasid ++ " does not have access to " ++ unPackage pkg+requestPkgBranches :: Bool -> Bool -> Bool -> BranchesReq -> Package -> IO ()+requestPkgBranches quiet multiple mock breq pkg = do when (breq == Branches []) $ putPkgHdr pkg- git_ "fetch" [] brs <- localBranches False branches <- getRequestedBranches brs breq- newbranches <- filterExistingBranchRequests branches- unless (null newbranches) $ do- mbidsession <- bzReviewSession- urls <- forM newbranches $ \ br -> do- when mock $ fedpkg_ "mockbuild" ["--root", mockRoot br]- when multiple $ putStr (unPackage pkg ++ " ")- when (length branches > 1) $ putStr (show br)- -- Can timeout like this:- -- Could not execute request_branch: HTTPSConnectionPool(host='pagure.io', port=443): Read timed out. (read timeout=60)- -- fbrnch: readCreateProcess: fedpkg "request-branch" "epel9" (exit 1): failed- u <- fedpkg "request-branch" [show br]- putStrLn $ ' ' : u- return u- whenJust mbidsession $ \(bid,session) ->- commentBug session bid $ unlines urls+ if null branches+ then+ unless quiet $ do+ when multiple $ putStr $ unPackage pkg ++ " "+ case breq of+ Branches [_] -> putStrLn "exists"+ _ -> putStrLn "branches exist"+ else do+ when multiple $ putStr $ unPackage pkg ++ " "+ gitFetchSilent True+ brs' <- localBranches False+ branches' <- getRequestedBranches brs' (Branches branches)+ whenM (havePkgAccess pkg) $ do+ newbranches <- filterExistingBranchRequests branches'+ unless (null newbranches) $ do+ mbidsession <- bzReviewSession+ urls <- forM newbranches $ \ br -> do+ when mock $ fedpkg_ "mockbuild" ["--root", mockRoot br]+ when (length branches' > 1) $ putStr $ show br ++ " "+ -- 1. Can timeout like this:+ -- Could not execute request_branch: HTTPSConnectionPool(host='pagure.io', port=443): Read timed out. (read timeout=60)+ -- fbrnch: readCreateProcess: fedpkg "request-branch" "epel9" (exit 1): failed+ -- &+ -- 2. Can fail like this:+ -- Could not execute request_branch: The following error occurred while trying to get the active release branches in PDC: <!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">+ -- <title>500 Internal Server Error</title>+ -- <p>The server encountered an internal error or+ -- misconfiguration and was unable to complete+ -- your request.</p> [...]+ -- fbrnch: readCreateProcess: fedpkg "request-branch" "epel9" (exit 1): failed+ u <- fedpkg "request-branch" [show br]+ putStrLn u+ return u+ whenJust mbidsession $ \(bid,session) ->+ commentBug session bid $ unlines urls where- lookupKeyElems k o =- lookupKey' k o ::-#if MIN_VERSION_aeson(2,0,0)- M.KeyMap [String]-#else- M.HashMap Text [String]-#endif+ -- doRequestBr :: Bool -> Branch -> IO String+ -- doRequestBr multibr br = do+ -- when mock $ fedpkg_ "mockbuild" ["--root", mockRoot br]+ -- when multiple $ putStr (unPackage pkg ++ " ")+ -- when multibr $ putStr (show br)+ -- -- Can timeout like this:+ -- -- Could not execute request_branch: HTTPSConnectionPool(host='pagure.io', port=443): Read timed out. (read timeout=60)+ -- -- fbrnch: readCreateProcess: fedpkg "request-branch" "epel9" (exit 1): failed+ -- u <- fedpkg "request-branch" [show br]+ -- putStrLn $ ' ' : u+ -- return $ show br +-+ u filterExistingBranchRequests :: [Branch] -> IO [Branch] filterExistingBranchRequests branches = do@@ -101,8 +128,11 @@ if null newbranches then return [] else do fasid <- fasIdFromKrb- erecent <- pagureListProjectIssueTitlesStatus "pagure.io" "releng/fedora-scm-requests"- [makeItem "author" fasid, makeItem "status" "all"]+ -- FIXME retry on HttpExceptionRequest ... ConnectionTimeout+ erecent <- pagureListProjectIssueTitlesStatus "pagure.io"+ "releng/fedora-scm-requests"+ [makeItem "author" fasid, makeItem "status" "all",+ makeItem "per_page" "100"] case erecent of Left err -> error' err Right recent -> filterM (notExistingRequest recent) newbranches@@ -112,6 +142,28 @@ notExistingRequest requests br = do let pending = filter ((("New Branch \"" ++ show br ++ "\" for \"rpms/" ++ unPackage pkg ++ "\"") ==) . pagureIssueTitle) requests unless (null pending) $ do- putStrLn $ "Branch request already open for " ++ unPackage pkg ++ ":" ++ show br+ putStrLn $ "Branch request already exists for " ++ unPackage pkg ++ ":" ++ show br mapM_ printScmIssue pending return $ null pending++havePkgAccess :: Package -> IO Bool+havePkgAccess pkg = do+ -- check have access+ fasid <- fasIdFromKrb+ epkginfo <- pagureProjectInfo srcfpo ("rpms" </> unPackage pkg)+ case epkginfo of+ Left err -> error' err+ Right pkginfo -> do+ -- FIXME exclude unprivileged roles+ let access = fasid `elem` concat (lookupKeyElems "access_users" pkginfo)+ unless access $+ warning $ "-" +-+ fasid +-+ "does not have access"+ return access+ where+ lookupKeyElems k o =+ lookupKey' k o ::+#if MIN_VERSION_aeson(2,0,0)+ M.KeyMap [String]+#else+ M.HashMap Text [String]+#endif
src/Cmd/RequestRepo.hs view
@@ -49,10 +49,10 @@ error' "The last repo request was already successfully Processed" when (null requests || retry) $ do checkNoPagureRepo- putStrLn ""+ putNewLn comments <- getComments session bid mapM_ showComment comments- putStrLn ""+ putNewLn prompt_ "Press Enter to continue" -- FIXME check api key is still valid or open pagure ticket directly url <- fedpkg "request-repo" [pkg, show bid]@@ -65,18 +65,22 @@ input <- prompt "Press Enter to post above comment, or input now" let comment = (if null input then draft else input) ++ "\n\n" <> url commentBug session bid comment- putStrLn ""+ putNewLn branches <- getRequestedBranches [] breq forM_ branches $ \ br -> do when mock $ fedpkg_ "mockbuild" ["--root", mockRoot br] putStr (show br ++ " ") fedpkg_ "request-branch" ["--repo", pkg, show br]- putStrLn ""+ putNewLn where existingRepoRequests :: IO [IssueTitleStatus] existingRepoRequests = do fasid <- fasIdFromKrb- erecent <- pagureListProjectIssueTitlesStatus pagureio "releng/fedora-scm-requests" [makeItem "author" fasid, makeItem "status" "all"]+ erecent <-+ pagureListProjectIssueTitlesStatus pagureio+ "releng/fedora-scm-requests"+ [makeItem "author" fasid, makeItem "status" "all",+ makeItem "per_page" "100"] case erecent of Left err -> error' err Right recent ->
src/Cmd/Reviews.hs view
@@ -14,7 +14,7 @@ reviewsCmd short allstates assignee muser mpat status = do listReviewsFull assignee muser mpat allstates status >>= mapM_ (putReviewBug short) . sortBugsByStatus . sortBugsByID- when short $ putStrLn ""+ when short putNewLn findReview :: String -> IO () findReview pkg = do
src/Cmd/Scratch.hs view
@@ -13,14 +13,15 @@ import Git import Koji import Package-import Types (Archs(..))+import Types (Archs(..),SideTagTarget) --- FIXME allow multiple --target's (parallel too)+-- FIXME allow parallel targets -- FIXME tail build.log for failure -- FIXME append timestamp after %release (to help identify scratch builds)-scratchCmd :: Bool -> Bool -> Bool -> Bool -> Maybe Archs -> Maybe String- -> Maybe String -> (BranchesReq, [String]) -> IO ()-scratchCmd dryrun stagger rebuildSrpm nofailfast marchopts mtarget mref (breq,pkgs) =+scratchCmd :: Bool -> Bool -> Bool -> Bool -> Maybe Archs+ -> [SideTagTarget] -> Maybe String -> (BranchesReq, [String])+ -> IO ()+scratchCmd dryrun stagger rebuildSrpm nofailfast marchopts sidetagTargets mref (breq,pkgs) = withPackagesByBranches HeaderMust False Nothing AnyNumber scratchBuild (breq,pkgs) where anyTarget (RelBranch b) = branchTarget b@@ -31,35 +32,39 @@ when (isJust mref && length pkgs > 1) $ error' "--ref is not supported for multiple packages" pkggit <- isPkgGitRepo- when (not pkggit && breq == Branches [] && isNothing mtarget) $+ when (not pkggit && breq == Branches [] && null sidetagTargets) $ error' "please specify a branch or target for non dist-git" spec <- localBranchSpecFile pkg br- let target = fromMaybe (anyTarget br) mtarget- putStrLn $ "Target: " ++ target- archs <-- case marchopts of- Nothing -> return []- Just archopts ->- case archopts of- Archs as -> return as- ExcludedArchs as -> do- Just (buildtag,_desttag) <- kojiBuildTarget fedoraHub target- tagArchs <- kojiTagArchs buildtag- return $ tagArchs \\ as- if stagger- then do- archlist <-- if null archs+ targets <-+ if null sidetagTargets+ then return [anyTarget br]+ else mapM (targetMaybeSidetag dryrun (onlyRelBranch br) . Just) sidetagTargets+ forM_ targets $ \target -> do+ putStrLn $ "Target: " ++ target+ archs <-+ case marchopts of+ Nothing -> return []+ Just archopts ->+ case archopts of+ Archs as -> return as+ ExcludedArchs as -> do+ Just (buildtag,_desttag) <- kojiBuildTarget fedoraHub target+ tagArchs <- kojiTagArchs buildtag+ return $ tagArchs \\ as+ if stagger then do- Just (buildtag,_desttag) <- kojiBuildTarget fedoraHub target- tagArchs <- kojiTagArchs buildtag- -- prioritize preferred archs- return $ nub $ priorityArchs ++ tagArchs- else return $ nub $ filter (`elem` archs) priorityArchs ++ archs- forM_ archlist $ \arch -> do- putStrLn $ arch ++ " scratch build"- doScratchBuild pkggit spec target [arch]- else doScratchBuild pkggit spec target archs+ archlist <-+ if null archs+ then do+ Just (buildtag,_desttag) <- kojiBuildTarget fedoraHub target+ tagArchs <- kojiTagArchs buildtag+ -- prioritize preferred archs+ return $ nub $ priorityArchs ++ tagArchs+ else return $ nub $ filter (`elem` archs) priorityArchs ++ archs+ forM_ archlist $ \arch -> do+ putStrLn $ arch ++ " scratch build"+ doScratchBuild pkggit spec target [arch]+ else doScratchBuild pkggit spec target archs where priorityArchs = ["x86_64", "aarch64", "ppc64le"] @@ -79,7 +84,7 @@ clean <- isGitDirClean if clean && isRelBranch br then- null <$> gitShortLog ("origin/" ++ show br ++ "..HEAD")+ null <$> gitOneLineLog ("origin/" ++ show br ++ "..HEAD") else return False rbr <- anyBranchToRelease br nvr <- pkgNameVerRel' rbr spec@@ -94,12 +99,16 @@ srpmBuild kojiargs = void $ generateSrpm (Just br) spec >>= kojiScratchBuild target kojiargs -scratchCmdX86_64 :: Bool -> Bool -> Maybe String -> Maybe String- -> (BranchesReq, [String]) -> IO ()-scratchCmdX86_64 dryrun rebuildSrpm =- scratchCmd dryrun False rebuildSrpm False (Just (Archs ["x86_64"]))+-- FIXME default -X to --no-fastfail?+scratchCmdX86_64 :: Bool -> Bool -> Bool -> [SideTagTarget]+ -> Maybe String -> (BranchesReq, [String]) -> IO ()+scratchCmdX86_64 dryrun rebuildSrpm excludeArch =+ scratchCmd dryrun False rebuildSrpm False (Just (excludeArchs excludeArch ["x86_64"])) -scratchCmdAarch64 :: Bool -> Bool -> Maybe String -> Maybe String- -> (BranchesReq, [String]) -> IO ()-scratchCmdAarch64 dryrun rebuildSrpm =- scratchCmd dryrun False rebuildSrpm False (Just (Archs ["aarch64"]))+scratchCmdAarch64 :: Bool -> Bool -> Bool -> [SideTagTarget]+ -> Maybe String -> (BranchesReq, [String]) -> IO ()+scratchCmdAarch64 dryrun rebuildSrpm excludeArch =+ scratchCmd dryrun False rebuildSrpm False (Just (excludeArchs excludeArch ["aarch64"]))++excludeArchs :: Bool -> [String] -> Archs+excludeArchs excl = if excl then ExcludedArchs else Archs
src/Cmd/SideTags.hs view
@@ -1,14 +1,21 @@ module Cmd.SideTags (sideTagsCmd) where +import Control.Monad.Extra (whenM)+import SimpleCmd (cmd_)+ import Branches import Koji+import Prompt (yesno) -sideTagsCmd :: [Branch] -> IO ()-sideTagsCmd brs = do- if null brs- then kojiUserSideTags Nothing >>= mapM_ putStrLn- else mapM_ sideTagsBranch brs+sideTagsCmd :: Bool -> [Branch] -> IO ()+sideTagsCmd remove brs = do+ sidetags <-+ if null brs+ then kojiUserSideTags Nothing+ else concat <$> mapM (kojiUserSideTags . Just) brs+ mapM_ (if remove then removeSideTag else putStrLn) sidetags where- sideTagsBranch :: Branch -> IO ()- sideTagsBranch br =- kojiUserSideTags (Just br) >>= mapM_ putStrLn+ removeSideTag :: String -> IO ()+ removeSideTag tag =+ whenM (yesno $ "Remove " ++ tag) $+ cmd_ "fedpkg" ["remove-side-tag", tag]
src/Cmd/Sort.hs view
@@ -21,10 +21,11 @@ data SortDisplay = SortParallel | SortChain | SortLayers | SortPlain -sortCmd :: SortDisplay -> Maybe RpmWith -> (Maybe Branch,[String]) -> IO ()+-- FIXME ghc-attempt f37 branch does not exist! (coming from f29)+sortCmd :: SortDisplay -> Maybe RpmWith -> (Branch,[String]) -> IO () sortCmd _ _ (_,[]) = return ()-sortCmd displaymode mrpmwith (mbr, pkgs) = do- withPackagesMaybeBranchNoHeadergit ExactlyOne noop (mbr, pkgs)+sortCmd displaymode mrpmwith (br, pkgs) = do+ withPackagesBranch HeaderNone False Nothing noop (br, pkgs) let rpmopts = maybe [] toRpmOption mrpmwith case displaymode of -- reverse because rpmbuild-order reverses the order of independent pkgs?@@ -49,7 +50,7 @@ graphCmd :: Bool -> Maybe RpmWith -> (Maybe Branch,[FilePath]) -> IO () graphCmd dot mrpmwith (mbr, pkgs) = do- withPackagesMaybeBranchNoHeadergit ZeroOrOne noop (mbr, pkgs)+ withPackagesMaybeBranchNoHeadergit noop (mbr, pkgs) let rpmopts = maybe [] toRpmOption mrpmwith createGraph4 False [] rpmopts False False True Nothing pkgs >>= if dot then printGraph else renderGraph
+ src/Cmd/SrcDeps.hs view
@@ -0,0 +1,38 @@+module Cmd.SrcDeps (+ srcDepsCmd,+ srcDeps+ )+where++import Distribution.RPM.Build.Graph++import Branches+import Common+import Common.System+import Git+import Package++srcDepsCmd :: Bool -> (Branch,[String]) -> IO ()+srcDepsCmd rev (rbr,pkgs) =+ srcDeps rev (rbr,pkgs) >>=+ mapM_ (putStrLn . unwords)++srcDeps :: Bool -> (Branch,[String]) -> IO [[String]]+srcDeps rev (rbr,pkgs) = do+ when (null pkgs) $+ error' "please specify one or more package dirs"+ whenM isPkgGitRepo $+ error' "please run from the directory containing the dependency package set"+ listDirectory "." >>=+ filterM checkPackage . filter ((/= '.') . head) >>=+ fmap (topsortGraph Combine) . depsGraphDeps rev [] False [] [] False Nothing pkgs+ where+ checkPackage :: FilePath -> IO Bool+ checkPackage p = do+ withExistingDirectory p $ do+ exists <- checkIfRemoteBranchExists (RelBranch rbr)+ if exists+ then do+ gitSwitchBranch (RelBranch rbr)+ isJust <$> maybeFindSpecfile+ else return False
src/Cmd/Status.hs view
@@ -53,18 +53,19 @@ Nothing -> do putStrLn "undefined NVR!\n" putStr "HEAD "- gitShortLog1 Nothing >>= putStrLn+ 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 <- gitShortLog $ "HEAD..origin/" ++ show newerBr+ -- unmerged <- gitOneLineLog $ "HEAD..origin/" ++ show newerBr -- unless (null unmerged) $ do -- putStrLn $ "Newer commits in " ++ show newerBr ++ ":" -- mapM_ putStrLn unmerged unpushed <- gitShortLog1 $ Just $ "origin/" ++ show br ++ "..HEAD"- if null unpushed then do+ if null unpushed+ then do mbuild <- kojiGetBuildID fedoraHub nvr case mbuild of Nothing -> do@@ -101,8 +102,8 @@ let diff = diffUTCTime current since putAge diff _ -> putStrLn "More than one update found!"- putStrLn ""- else putStrLn $ show br ++ ": " ++ unpushed+ putNewLn+ else whenJust unpushed $ putStrLn . ((show br ++ ": ") ++) . showCommit where isStable :: [String] -> Bool isStable = not . all ("-testing" `isSuffixOf`)
src/Cmd/Update.hs view
@@ -13,6 +13,7 @@ import Data.RPM.VerCmp +-- FIXME don't bump release if already bumped -- FIXME check EVR increased -- FIXME if multiple sources might need to bump release -- FIXME Haskell subpackages require release bump even with version bump@@ -35,10 +36,12 @@ in if pkgGit then dirty else if null pkgs then Nothing else dirty- withPackagesMaybeBranch HeaderMay False mgitops ZeroOrOne (updatePkg mver) (mbr, pkgs)+ withPackagesMaybeBranch HeaderMay False mgitops (updatePkg mver) (mbr, pkgs) where updatePkg :: Maybe String -> Package -> AnyBranch -> IO () updatePkg mver pkg br = do+ when (br /= RelBranch Rawhide) $+ warning $ "Are you sure you want to update " ++ show br ++ "?\n" spec <- if allowHEAD then findSpecfile else localBranchSpecFile pkg br@@ -92,6 +95,10 @@ unless force $ -- FIXME only if not all exist cmd_ "spectool" ["-g", "-S", spec]+ patches <- cmdLines "spectool" ["-P", spec]+ forM_ patches $ \patch ->+ unlessM (doesFileExist patch) $+ cmd_ "spectool" ["-g", "-P", spec] when force $ do let archives = filter isArchiveFile existing forM_ archives removeFile
src/Cmd/WaitRepo.hs view
@@ -5,19 +5,19 @@ where import Common.System-import Data.Maybe import Branches import Git import Koji import Package+import Types data WaitFetch = WaitNoFetch | WaitDirty | WaitFetch -- FIXME first check/wait for build to actually exist-waitrepoCmd :: Bool -> WaitFetch -> Maybe String -> (BranchesReq, [String])- -> IO ()-waitrepoCmd dryrun fetch mtarget = do+waitrepoCmd :: Bool -> WaitFetch -> Maybe SideTagTarget+ -> (BranchesReq, [String]) -> IO ()+waitrepoCmd dryrun fetch msidetagTarget = do withPackagesByBranches HeaderMay False (case fetch of WaitFetch -> cleanGitFetchActive@@ -32,5 +32,7 @@ gitSwitchBranch rbr let spec = packageSpec pkg nvr <- pkgNameVerRel' br spec+ target <- targetMaybeSidetag dryrun br msidetagTarget+ putStrLn $ "waiting for " ++ nvr ++ " to appear in " ++ target timeIO $- kojiWaitRepo dryrun True (fromMaybe (branchTarget br) mtarget) nvr+ kojiWaitRepo dryrun True target nvr
src/Common.hs view
@@ -9,7 +9,8 @@ #endif (+/+), plural,- pluralException+ pluralException,+ putNewLn ) where import Control.Monad.Extra -- hiding (loop)@@ -34,3 +35,6 @@ " ", if i == 1 then ns else ps ]++putNewLn :: IO ()+putNewLn = putChar '\n'
src/Git.hs view
@@ -12,7 +12,10 @@ gitFetchSilent, gitPushSilent, gitRepoName,- gitShortLog,+ Commit(commitRef,commitLog),+ showCommit,+ displayCommits,+ gitOneLineLog, gitShortLogN, gitShortLog1, gitSwitchBranch,@@ -25,9 +28,12 @@ isGitDirClean, checkIfRemoteBranchExists, CommitOpt (..),+ refPrompt,+ conflictPrompt, module SimpleCmd.Git ) where +import Data.Char (isSpace) import SimpleCmd.Git import Branches@@ -44,81 +50,102 @@ cmdBool "git" (c:args) #endif -gitMergeable :: Bool -> Branch -> IO (Bool,[String])+gitMergeable :: Bool -> Branch -> IO (Bool,[Commit]) gitMergeable origin br = do let ref = (if origin then "origin/" else "") ++ show br ancestor <- gitBool "merge-base" ["--is-ancestor", "HEAD", ref]- commits <- gitShortLog ("HEAD.." ++ ref)- -- warn if branch is ahead- when (not origin && null commits && not ancestor) $ do- rcommits <- gitShortLog (ref ++ "..HEAD")- unless (null rcommits) $ do- putStrLn $ "current branch is ahead of newer " ++ show br ++ " !!"- prompt_ "Press Enter if you want to continue"+ commits <- gitOneLineLog ("HEAD.." ++ ref)+ when (not origin && null commits && not ancestor) $+ whenM (gitBool "merge-base" ["--is-ancestor", "HEAD", "origin/" ++ show br]) $ do+ rancestor <- gitBool "merge-base" ["--is-ancestor", ref, "HEAD"]+ if rancestor+ then do+ diff <- git "diff" [ref]+ unless (null diff) $ do+ putStrLn $ "current branch is ahead of newer" +-+ show br +-+ "!!"+ prompt_ "Press Enter if you want to continue"+ else putStrLn $ "current branch" +-+ "is diverged from" +-+ show br return (ancestor, commits) -getNewerBranch :: Branch -> IO Branch-getNewerBranch Rawhide = return Rawhide+getNewerBranch :: Branch -> IO (Maybe Branch)+getNewerBranch Rawhide = return Nothing getNewerBranch br = do branches <- fedoraBranches (localBranches False) let newer = newerBranch br branches return $- if newer > br then newer- -- FIXME? this can be dropped with next fedora-dists- else case elemIndex br branches of- Just i -> branches !! (i - 1)- Nothing -> error' $ show br ++ ": branch not found"+ if newer > br+ then Just newer+ else+ case elemIndex br branches of+ Just i -> Just $ branches !! (i - 1)+ Nothing -> Nothing gitMergeOrigin :: Branch -> IO () gitMergeOrigin br = do (ancestor,commits) <- gitMergeable True br- if ancestor then+ when ancestor $ unless (null commits) $ do- rebase <- git "rebase" []- unless ("Already up to date." `isPrefixOf` rebase) $- putStr rebase- else git_ "rebase" []+ pull <- git "pull" []+ unless ("Already up to date." `isPrefixOf` pull) $+ putStr pull -- FIXME maybe require local branch already here-newerMergeable :: Branch -> IO (Bool,[String])+newerMergeable :: Branch -> IO (Bool,[Commit]) newerMergeable br = if br == Rawhide then return (False,[]) else do- newer <- getNewerBranch br+ mnewer <- getNewerBranch br locals <- localBranches True- gitMergeable (show newer `notElem` locals) newer--gitShortLog :: String -> IO [String]-gitShortLog range =- map simplifyCommitLog <$> gitLines "log" ["--pretty=reference", range]+ case mnewer of+ Just newer -> gitMergeable (show newer `notElem` locals) newer+ Nothing -> return (False,[]) -gitShortLogN :: Int -> Maybe String -> IO [String]-gitShortLogN num mrange =- map simplifyCommitLog <$> gitLines "log" (["--max-count=" ++ show num, "--pretty=reference"] ++ maybeToList mrange)+data Commit = Commit+ { commitRef :: String,+ commitLog :: String,+ commitDate :: String } -gitShortLog1 :: Maybe String -> IO String-gitShortLog1 mrange =- simplifyCommitLog <$> git "log" (["--max-count=1", "--pretty=reference"] ++ maybeToList mrange)+showCommit :: Commit -> String+showCommit c =+ take 7 (commitRef c) +-+ commitLog c +-+ "(" ++ commitDate c ++ ")" --- FIXME currently no-op with --format=reference-simplifyCommitLog :: String -> String-simplifyCommitLog = unwords . shortenHash . words+displayCommits :: Bool -> [Commit] -> IO ()+displayCommits showall =+ mapM_ putStrLn . showAll showall . map showCommit where- shortenHash :: [String] -> [String]- shortenHash [] = []- shortenHash (h:cs) = take 8 h : simplifyLog cs+ showAll :: Bool -> [String] -> [String]+ showAll False cs =+ if length cs > 20 then take 20 cs ++ [":"] else cs+ showAll True cs = cs - simplifyLog [] = []- -- remove leading '('- simplifyLog (w:ws) =- case ws of- [] -> error "malformed changelog"- [_] -> init (tail w) : map ('(' :) ws- _ ->- let (mid,end) = splitAt (length ws - 2) ws- in tail w : mid ++ [init (head end),'(' : last end]+gitOneLineLog :: String -> IO [Commit]+gitOneLineLog range =+ map mkCommit <$> gitLines "log" ["--pretty=format:%H (%s, %cs)", range] +gitShortLogN :: Int -> Maybe String -> IO [Commit]+gitShortLogN num mrange =+ map mkCommit <$> gitLines "log" (["--max-count=" ++ show num, "--pretty=reference"] ++ maybeToList mrange)++gitShortLog1 :: Maybe String -> IO (Maybe Commit)+gitShortLog1 mrange = do+ cs <- git "log" (["--max-count=1", "--pretty=reference"] ++ maybeToList mrange)+ return $+ if null cs+ then Nothing+ else Just $ mkCommit cs++-- assumes reference style pretty format: "hash (title, date)"+mkCommit :: String -> Commit+mkCommit cs =+ case word1 cs of+ ("",_) -> error' "empty commit log line!"+ (hash,rest) ->+ case breakEnd isSpace rest of+ -- "(msg txt, date)"+ (plogcs,datep) ->+ Commit hash (init $ tail $ trim plogcs) (init datep)+ gitPushSilent :: Maybe String -> IO () gitPushSilent mref = do checkOnBranch@@ -131,11 +158,11 @@ gitRepoName = dropSuffix ".git" . takeFileName <$> git "remote" ["get-url", "origin"] --- FIXME flag for really silent?-gitFetchSilent :: IO ()-gitFetchSilent = do+gitFetchSilent :: Bool -> IO ()+gitFetchSilent quiet = do name <- gitRepoName- putStr $ "git fetching " ++ name ++ "... "+ unless quiet $+ putStr $ "git fetching " ++ name ++ "... " (ok, out, err) <- cmdFull "git" ["fetch"] "" unless (null out) $ putStrLn out unless ok $ error' err@@ -143,9 +170,9 @@ [] -> [] (hd:tl) -> filter (/= "Already up to date.") $ if "From " `isPrefixOf` hd then tl else hd:tl- putStrLn $ if null filtered- then "done"- else "\n" ++ intercalate "\n" filtered+ if null filtered+ then unless quiet $ putStrLn "done"+ else putStrLn $ intercalate "\n" filtered checkWorkingDirClean :: IO () checkWorkingDirClean = do@@ -212,7 +239,7 @@ exists <- checkIfRemoteBranchExists br if exists then return True- else gitFetchSilent >> checkIfRemoteBranchExists br+ else gitFetchSilent False >> checkIfRemoteBranchExists br if not remotebranch then do name <- getDirectoryName@@ -221,8 +248,8 @@ git_ "checkout" ["-q", "-b", show br, "--track", "origin/" ++ show br] -- similar to gitSwitchBranch but does not error-gitSwitchBranch' :: Branch -> IO Bool-gitSwitchBranch' br = do+gitSwitchBranch' :: Bool -> Branch -> IO Bool+gitSwitchBranch' quiet br = do localbranches <- gitLines "branch" ["--format=%(refname:short)"] if show br `elem` localbranches then do@@ -237,11 +264,12 @@ if exists then return True -- FIXME this is redundant if we already fetched (eg for merge cmd)- else gitFetchSilent >> checkIfRemoteBranchExists (RelBranch br)+ else gitFetchSilent quiet >> checkIfRemoteBranchExists (RelBranch br) if not remotebranch then do name <- getDirectoryName- warning $ name ++ " " ++ show br ++ " branch does not exist!"+ unless quiet $+ warning $ name ++ " " ++ show br ++ " branch does not exist!" return False else do git_ "checkout" ["-q", "-b", show br, "--track", "origin/" ++ show br]@@ -252,3 +280,36 @@ gitBool "show-ref" ["--verify", "--quiet", "refs/remotes/origin/" ++ show br] data CommitOpt = CommitMsg String | CommitAmend++-- FIXME select ref by number+refPrompt :: [Commit] -> String -> IO (Maybe String)+refPrompt commits txt = do+ case map commitRef commits of+ [] -> error' "empty commits list"+ (c:cs) -> do+ ref <- prompt txt+ case lower ref of+ "" -> return $ Just c+ "no" -> return Nothing+ "n" -> return Nothing+ _ ->+ case find (ref `isPrefixOf`) cs of+ Just cref -> return $ Just cref+ Nothing -> refPrompt commits txt++-- FIXME also include branch+conflictPrompt :: [Commit] -> String -> IO (Maybe String)+conflictPrompt commits txt = do+ case map commitRef commits of+ [] -> error' "empty commits list"+ commitrefs@(c:_) -> do+ ref <- prompt txt+ if null ref+ then return Nothing+ else+ if ref `elem` commitrefs+ then return $ Just ref+ else+ if lower ref == "head"+ then return $ Just c+ else conflictPrompt commits txt
src/InterleaveOutput.hs view
@@ -17,6 +17,6 @@ (ret, out) <- readProcessInterleaved (proc c args) let ok = ret == ExitSuccess unless ok $ do- putStrLn ""+ putNewLn putStrLn (B.toString out) return ok
src/Koji.hs view
@@ -21,7 +21,8 @@ TaskID, displayID, fedoraHub,- maybeTimeout+ maybeTimeout,+ targetMaybeSidetag ) where import Data.Char (isDigit)@@ -44,6 +45,7 @@ import Package import Pagure import Prompt+import Types fedoraHub :: String fedoraHub = fedoraKojiHub@@ -105,10 +107,11 @@ -- [ERROR] koji: AuthError: unable to obtain a session -- readCreateProcess: koji "build" "--nowait" "f33-build-side-25385" "--fail-fast" "--background" ... (exit 1): failed (ret,out) <- readProcessStdout $ proc "koji" $ ["build", "--nowait", target] ++ args- -- for srpm: drop uploading line until doing tee- -- for git: drop "Created task: "- -- init to drop final newline- logMsg $ (B.unpack . B.init . B.unlines . tail . B.lines) out+ -- for srpm: drop uploading line until doing tee+ -- for git: drop "Created task: "+ -- init to drop final newline+ unless (B.null out) $+ logMsg $ (B.unpack . B.init . B.unlines . tail . B.lines) out if ret == ExitSuccess then do let kojiurl = B.unpack $ last $ B.words out task = (TaskId . read) $ takeWhileEnd isDigit kojiurl@@ -243,3 +246,30 @@ warning "Connection timed out: retrying" maybeTimeout (secs + 5) act Just res -> return res++targetMaybeSidetag :: Bool -> Branch -> Maybe SideTagTarget -> IO String+targetMaybeSidetag dryrun br msidetagTarget =+ case msidetagTarget of+ Nothing -> return $ branchTarget br+ Just (Target t) -> return t+ Just SideTag -> do+ tags <- map (head . words) <$> kojiUserSideTags (Just br)+ case tags of+ [] -> do+ Just (buildtag,_desttag) <- kojiBuildTarget fedoraHub (show br)+ out <-+ if dryrun+ then return $ "Side tag '" ++ buildtag ++ "-dryrun'"+ else head . lines <$> fedpkg "request-side-tag" ["--base-tag", buildtag]+ if "Side tag '" `isPrefixOf` out+ then do+ putStrLn out+ let sidetag =+ init . dropWhileEnd (/= '\'') $ dropPrefix "Side tag '" out+ putStrLn $ "waiting for " ++ sidetag ++ " repo"+ unless dryrun $+ cmd_ "koji" ["wait-repo", sidetag]+ return sidetag+ else error' "'fedpkg request-side-tag' failed"+ [tag] -> return tag+ _ -> error' $ "More than one user side-tag found for " ++ show br
src/Krb.hs view
@@ -17,7 +17,7 @@ when (last krb == "(Expired)") $ do putStrLn $ unwords krb cmd_ "fkinit" []- putStrLn ""+ putNewLn maybeFasIdFromKrb :: IO (Maybe String) maybeFasIdFromKrb =
src/Main.hs view
@@ -2,6 +2,7 @@ module Main (main) where +import Data.Maybe (fromMaybe) import Distribution.Fedora.Branch #if !MIN_VERSION_simple_cmd_args(0,1,7) import Options.Applicative (maybeReader, ReadM)@@ -26,6 +27,7 @@ import Cmd.Merge import Cmd.Mock import Cmd.Override+import Cmd.Owner import Cmd.Parallel import Cmd.PkgReview import Cmd.Prep@@ -37,6 +39,7 @@ import Cmd.Scratch import Cmd.SideTags import Cmd.Sort+import Cmd.SrcDeps import Cmd.Status import Cmd.Switch import Cmd.Update@@ -73,7 +76,10 @@ <*> branchesPackages , Subcommand "merge" "Merge from newer branch" $ mergeCmd- <$> nopromptOpt+ <$> dryrunOpt+ <*> nopromptOpt+ <*> optional (optionWith auto 's' "skip-bumps" "NUM" "Max num of rebuild commits to ignore [default 0]")+ <*> switchWith 'a' "show-all" "List all commits [default first 20]" <*> optional (optionWith branchM 'f' "from" "BRANCH" "Branch to merge from [default newer]") <*> branchesPackages , Subcommand "build" "Build package(s) in Koji" $@@ -85,6 +91,9 @@ <$> switchWith 'c' "count" "Print number of packages" <*> optional packagerOpt <*> many (pkgArg "PKGPAT...")+ , Subcommand "list-local" "List packages in branch" $+ listLocalCmd+ <$> maybeBranchPackages True , Subcommand "branches" "List package branches" $ branchesCmd <$> switchWith 'd' "skip-dead" "Skip if dead.package exists"@@ -97,12 +106,13 @@ <$> dryrunOpt <*> mergeOpt <*> optionalWith auto 'l' "skip-to-layer" "LAYERNO" "Skip the first N layers [default 0]" 0- <*> optional sidetagTargetOpt- <*> updateOpt 'S'+ <*> optional (sidetagTargetOpt $ Just "or creates one for you (with 'fedpkg request-side-tag --base-tag')")+ <*> updateOpt <*> branchesPackages , Subcommand "sidetags" "List user's side-tags" $ sideTagsCmd- <$> many branchArg+ <$> switchLongWith "remove" "Remove one or more sidetags"+ <*> many branchArg , Subcommand "override" "Tag builds into buildroot override in Koji" $ overrideCmd <$> dryrunOpt@@ -113,33 +123,35 @@ waitrepoCmd <$> dryrunOpt <*> waitfetchOpt- <*> mtargetOpt+ <*> optional (sidetagTargetOpt Nothing) <*> branchesPackages , Subcommand "scratch" "Scratch build package in Koji" $ scratchCmd <$> dryrunOpt- <*> switchWith 'S' "stagger" "Stagger archs"+ <*> switchLongWith "stagger" "Stagger archs" <*> rebuildSrpmOpt <*> noFailFastOpt <*> optional archesOpt- <*> mtargetOpt+ <*> many (sidetagTargetOpt Nothing) <*> optional (strOptionWith 'r' "ref" "COMMITHASH" "git commit to build") <*> branchesPackages , Subcommand "scratch-aarch64" "Koji aarch64 scratch build of package" $ scratchCmdAarch64 <$> dryrunOpt <*> rebuildSrpmOpt- <*> mtargetOpt+ <*> switchWith 'X' "exclude-arch" "Exclude aarch64"+ <*> many (sidetagTargetOpt Nothing) <*> optional (strOptionWith 'r' "ref" "COMMITHASH" "git commit to build") <*> branchesPackages , Subcommand "scratch-x86_64" "Koji x86_64 scratch build of package" $ scratchCmdX86_64 <$> dryrunOpt <*> rebuildSrpmOpt- <*> mtargetOpt+ <*> switchWith 'X' "exclude-arch" "Exclude x86_64"+ <*> many (sidetagTargetOpt Nothing) <*> optional (strOptionWith 'r' "ref" "COMMITHASH" "git commit to build") <*> branchesPackages- , Subcommand "update" "Update package in dist-git to newer version" $+ , 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"@@ -149,7 +161,7 @@ sortCmd <$> sortDisplayOpt <*> optional rpmWithOpt- <*> maybeBranchPackages True+ <*> branchPackages , Subcommand "prep" "Prep sources" $ prepCmd <$> optional prepPreOpts@@ -158,6 +170,7 @@ , Subcommand "local" "Build locally" $ localCmd <$> switchWith 'q' "quiet" "Hide the build.log until it errors"+ <*> switchWith 'd' "debug" "show the rpmbuild command" <*> optional forceshortOpt <*> many bcondOpt <*> branchesPackages@@ -170,16 +183,21 @@ <$> switchWith 'o' "spec-only" "Only diff spec file" <*> diffWorkOpt <*> diffFormatOpt- <*> switchWith 'q' "quiet" "Just output package name"+ <*> switchWith 'i' "ignore-bumps" "Ignore pure release bumps" <*> optional diffFilterOpt <*> optional (optionWith anyBranchM 'w' "with-branch" "BRANCH" "branch") <*> maybeBranchPackages False , Subcommand "compare" "Show commits between branches" $ compareCmd <$> switchWith 'l' "long" "show full commit log"+ <*> optional (strOptionWith 'i' "ignore" "SUBSTRING" "Matching substring to ignore") <*> anyBranchArg <*> anyBranchArg <*> manyPackages+ , Subcommand "src-deps" "List source package dependencies" $+ srcDepsCmd+ <$> switchWith 'r' "reverse" "Reverse dependencies"+ <*> branchPackages , Subcommand "mock" "Local mock build" $ mockCmd <$> switchWith 'n' "dry-run" "Do not build (but creates srpm)"@@ -196,9 +214,11 @@ installCmd <$> switchWith 'v' "verbose" "verbose rpmbuild output" <*> switchWith 'R' "recurse" "build and install missing deps packages"+ <*> optional (optionLongWith branchM "from" "BRANCH" "Merge branch first") <*> optional forceshortOpt <*> many bcondOpt <*> switchWith 'r' "reinstall" "reinstall rpms"+ <*> switchWith 'a' "all-subpackages" "install all subpackages (default if none currently installed)" <*> maybeBranchPackages False , Subcommand "not-installed" "Packages not installed locally" $ notInstalledCmd@@ -222,9 +242,15 @@ pullPkgs <$> pullOpts <*> branchesPackages+ , Subcommand "fetch" "Git fetch packages" $+ fetchPkgs+ <$> manyPackages , Subcommand "push" "Git push packages" $ pushPkgs <$> branchesPackages+ , Subcommand "owner" "List package owner(s)" $+ ownerCmd+ <$> manyPackages , Subcommand "create-review" "Create a Package Review request" $ createReview <$> scratchOpt@@ -257,8 +283,10 @@ <$> mockOpt True <*> branchesPackages , Subcommand "request-branches" "Request branches for approved created packages" $- requestBranches- <$> mockOpt False+ requestBranchesCmd+ <$> switchWith 'q' "quiet" "Quieter output"+ <*> optional (optionWith branchM 'r' "recurse-from" "BRANCH" "Add neighboring dependencies from branch")+ <*> mockOpt False <*> branchesPackages , Subcommand "find-review" "Find package review bug" $ findReview@@ -366,6 +394,18 @@ -- flagWith' AllBranches 'B' "all-branches" "Request branches for all current releases [default latest 2]" <|> -- ExcludeBranches <$> some excludeBranchOpt + branchPackages :: Parser (Branch,[String])+ branchPackages =+ branchPkgs <$> some (pkgArg "[BRANCH] PKGPATH...")+ where+ branchPkgs :: [String] -> (Branch,[String])+ branchPkgs args =+ let (brs,pkgs) = partitionBranches args+ in case brs of+ [] -> error' "specify one branch"+ [br] -> (br,pkgs)+ _ -> error' $ "cannot have more than one branch: " ++ unwords (map show brs)+ maybeBranchPackages :: Bool -> Parser (Maybe Branch,[String]) maybeBranchPackages oneplus = maybeBranchesPkgs <$>@@ -381,6 +421,7 @@ [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...")@@ -408,7 +449,7 @@ archOpt :: Parser String archOpt = strOptionWith 'a' "arch" "ARCH[,ARCH].." "build for arch(s)" - rebuildSrpmOpt = switchWith 's' "rebuild-srpm" "rebuild srpm in Koji"+ rebuildSrpmOpt = switchWith 'S' "rebuild-srpm" "rebuild srpm in Koji" mergeOpt = optional (flagWith' True 'm' "merge" "Merge without prompt" <|>@@ -418,12 +459,12 @@ BuildOpts <$> mergeOpt <*> noFailFastOpt- <*> mtargetOpt+ <*> optional (sidetagTargetOpt Nothing) <*> overrideOpt <*> waitrepoOpt <*> dryrunOpt <*> skipFetchOpt- <*> updateOpt 's'+ <*> updateOpt <*> useChangelogOpt <*> switchWith 'p' "by-package" "Build by each package across brs" <*> switchWith 'k' "allow-dirty" "Allow building from unclean git dir"@@ -449,30 +490,19 @@ archesOpt :: Parser Archs archesOpt = Archs <$> some archOpt <|> ExcludedArchs <$> some excludeArch - mtargetOpt :: Parser (Maybe String)- mtargetOpt = optional targetOpt-- targetOpt :: Parser String- targetOpt =- checkNotRawhide <$> strOptionWith 't' "target" "TARGET" "Koji target"- where- checkNotRawhide "rawhide" = error' "'rawhide' is not a valid target!"- checkNotRawhide t = t-- dryrunOpt = switchWith 'n' "dry-run" "Do not write (push, build, post, override)" skipFetchOpt = switchWith 'S' "skip-fetch" "Do not git fetch" - updateOpt :: Char -> Parser (Maybe UpdateType, UpdateSeverity)- updateOpt s = updatePair <$> updatetypeOpt <*> updateSeverityOpt+ updateOpt :: Parser (Maybe UpdateType, UpdateSeverity)+ updateOpt = updatePair <$> updatetypeOpt <*> updateSeverityOpt where updatetypeOpt = flagWith' Nothing 'U' "no-update" "Do not generate a Bodhi update" <|> Just <$> optionalWith auto 'u' "update-type" "TYPE" "security, bugfix, enhancement (default), newpackage, or template" EnhancementUpdate updateSeverityOpt =- optionalWith auto s "severity" "SEVERITY" "low, medium, high, urgent, (default: unspecified)" SeverityUnspecified+ optionalLongWith auto "severity" "SEVERITY" "low, medium, high, urgent, (default: unspecified)" SeverityUnspecified updatePair :: Maybe UpdateType -> UpdateSeverity -> (Maybe UpdateType, UpdateSeverity)@@ -486,14 +516,16 @@ forceshortOpt = flagWith' ForceBuild 'f' "rebuild" "Rebuild even if already built" <|>- flagWith' ShortCircuit 's' "short-circuit" "Do --short-circuit rpmbuild"+ flagLongWith' ShortCompile "short-compile" "Do rpmbuild --short-circuit -bc" <|>+ flagWith' ShortInstall 's' "short-install" "Do rpmbuild --short-circuit -bi" diffFormatOpt :: Parser DiffFormat diffFormatOpt = DiffContext <$> optionWith auto 'u' "unified" "CONTEXT" "Lines of context" <|> flagWith' DiffMinimal 'm' "minimal" "Minimize diff noise" <|> flagWith' DiffStatus 'n' "status" "Show diff --name-status" <|>- flagWith DiffDefault DiffStats 's' "stats" "Show diff --stat"+ flagWith' DiffStats 's' "stats" "Show diff --stat" <|>+ flagWith DiffDefault DiffQuiet 'q' "quiet" "Just output package name" diffFilterOpt :: Parser DiffFilter diffFilterOpt =@@ -520,10 +552,18 @@ commandOpt = strOptionWith 'c' "cmd" "SHELLCOMMAND" "Shell command to run in $p" - sidetagTargetOpt :: Parser SideTagTarget- sidetagTargetOpt =+ targetOpt :: Parser String+ targetOpt =+ checkNotRawhide <$> strOptionWith 't' "target" "TARGET" "Koji target"+ where+ checkNotRawhide "rawhide" = error' "'rawhide' is not a valid target!"+ checkNotRawhide t = t++ sidetagTargetOpt :: Maybe String -> Parser SideTagTarget+ sidetagTargetOpt mdesc = Target <$> targetOpt <|>- flagWith' SideTag 's' "sidetag" "Use the existing branch side-tag to build or creates one for you (with 'fedpkg request-side-tag --base-tag')"+ flagWith' SideTag 's' "sidetag"+ ("Use existing branch side-tag to build" +-+ fromMaybe "" mdesc) packagerOpt = Owner <$> strOptionWith 'o' "owner" "OWNER" "Package owner" <|> Committer <$> strOptionWith 'u' "username" "USERNAME" "Packages user can commit to" @@ -545,6 +585,7 @@ flagWith' NoCleanBefore 'c' "no-clean" "Do not clean chroot before building" <|> flagWith' NoCleanAfter 'C' "no-clean-after" "Do not clean chroot after building" <|> flagWith' NoCleanAll 'A' "no-clean-all" "Do not clean chroot before or after building"+ <|> flagWith' MockShortCircuit 'S' "short-circuit" "Short circuit to install phase" sortDisplayOpt :: Parser SortDisplay sortDisplayOpt =
src/Package.hs view
@@ -20,6 +20,7 @@ generateSrpm', BCond(..), ForceShort(..),+ isShortCircuit, buildRPMs, installDeps, installMissingMacros,@@ -31,6 +32,7 @@ withExistingDirectory, initialPkgRepo, withPackagesByBranches,+ withPackagesBranch, withPackagesMaybeBranch, withPackagesMaybeBranchNoHeadergit, HeaderShow(..),@@ -50,9 +52,8 @@ pkgNameVerRel', buildRequires, notInstalled,+ nvraInstalled, pkgInstalled,- rpmInstalled,- repoquery, equivNVR, nameOfNVR ) where@@ -90,7 +91,7 @@ changeLogPrompt :: Maybe String -> FilePath -> IO String changeLogPrompt mcontext spec = do clog <- cleanChangelog spec- putStrLn ""+ putNewLn putStrLn "```" putStrLn clog putStrLn "```"@@ -125,7 +126,7 @@ getSummaryURL :: FilePath -> IO String getSummaryURL spec = do notes <- cmd "rpmspec" ["-q", "--srpm", "--qf", "%{summary}\n\n- %{url}", spec]- putStrLn ""+ putNewLn putStrLn "```" putStrLn notes putStrLn "```"@@ -225,9 +226,15 @@ putStrLn $ "Created " ++ takeFileName srpm return srpm -data ForceShort = ForceBuild | ShortCircuit+data ForceShort = ForceBuild | ShortCompile | ShortInstall deriving Eq +isShortCircuit :: Maybe ForceShort -> Bool+isShortCircuit ms =+ case ms of+ Just s -> s /= ForceBuild+ Nothing -> False+ data BCond = BuildWith String | BuildWithout String instance Show BCond where@@ -237,9 +244,9 @@ -- FIXME create build.log -- Note does not check if bcond changed -- FIXME check tarball timestamp-buildRPMs :: Bool -> Maybe ForceShort -> [BCond] -> [FilePath] -> AnyBranch- -> FilePath -> IO Bool-buildRPMs quiet mforceshort bconds rpms br spec = do+buildRPMs :: Bool -> Bool -> Bool -> Maybe ForceShort -> [BCond] -> [FilePath]+ -> AnyBranch -> FilePath -> IO Bool+buildRPMs quiet debug noclean mforceshort bconds rpms br spec = do needBuild <- if isJust mforceshort then return True@@ -256,30 +263,36 @@ void $ getSources spec dist <- getBranchDist br cwd <- getCurrentDirectory- let shortcircuit = mforceshort == Just ShortCircuit- let buildopt = if shortcircuit then ["-bi", "--short-circuit"] else ["-bb"]+ let buildopt =+ case mforceshort of+ Just ShortCompile -> ["-bc", "--short-circuit"]+ Just ShortInstall -> ["-bi", "--short-circuit"]+ _ -> "-bb" : ["--noclean" | noclean] sourcediropt = ["--define", "_sourcedir " ++ cwd] args = sourcediropt ++ ["--define", "dist " ++ rpmDistTag dist] ++ buildopt ++ map show bconds ++ [spec] date <- cmd "date" ["+%T"] putStr $ date ++ " Building " ++ takeBaseName spec ++ " locally... "- ok <-+ ok <- do+ rbr <- anyBranchToRelease br+ nvr <- pkgNameVerRel' rbr spec+ let buildlog = ".build-" ++ showNVRVerRel (readNVR nvr) <.> "log" timeIO $- if not quiet || shortcircuit- then do- rbr <- anyBranchToRelease br- nvr <- pkgNameVerRel' rbr spec- -- FIXME would like to have pipeOutErr- shellBool $ unwords $ "rpmbuild" : map quoteArg args ++ "|&" : "tee" : [".build-" ++ showNVRVerRel (readNVR nvr) <.> "log"]- else do- rbr <- anyBranchToRelease br- nvr <- pkgNameVerRel' rbr spec- let buildlog = ".build-" ++ showNVRVerRel (readNVR nvr) <.> "log"- res <- shellBool $ unwords $ "rpmbuild" : map quoteArg args ++ [">&", buildlog]- if res- then putStrLn "done"- else cmd_ "tail" ["-n 100", buildlog]- return res+ if not quiet || isShortCircuit mforceshort+ then do+ putNewLn+ -- FIXME would like to have pipeOutErr+ let buildcmd = unwords $ "rpmbuild" : map quoteArg args ++ "|&" : "tee" : [buildlog ++ " && exit ${PIPESTATUS[0]}"]+ when debug $ putStrLn buildcmd+ shellBool buildcmd+ else do+ let buildcmd = unwords $ "rpmbuild" : map quoteArg args ++ [">&", buildlog]+ when debug $ putStrLn buildcmd+ res <- shellBool buildcmd+ if res+ then putStrLn "done"+ else cmd_ "tail" ["-n 100", buildlog]+ return res unless ok $ error' $ takeBaseName spec ++ " failed to build" return needBuild@@ -636,7 +649,7 @@ _ -> when (fetch || header /= HeaderNone) $ putPkgHdr pkg when haveGit $ when (have gitOptClean) checkWorkingDirClean- when fetch gitFetchSilent+ when fetch $ gitFetchSilent False -- FIXME!! no branch restriction when (breq `elem` map BranchOpt [AllBranches,AllFedora,AllEPEL]) $ putStrLn $ "Branches: " ++ unwords (map show brs) ++ "\n"@@ -651,20 +664,27 @@ have :: (GitOpts -> Bool) -> Bool have opt = maybe False opt mgitopts +withPackagesBranch :: HeaderShow+ -> Bool+ -> Maybe GitOpts+ -> (Package -> AnyBranch -> IO ())+ -> (Branch,[String])+ -> IO ()+withPackagesBranch header count mgitopts action (br, pkgs) =+ withPackagesByBranches header count mgitopts ExactlyOne action (Branches [br],pkgs)+ withPackagesMaybeBranch :: HeaderShow -> Bool -> Maybe GitOpts- -> LimitBranches -> (Package -> AnyBranch -> IO ()) -> (Maybe Branch,[String]) -> IO ()-withPackagesMaybeBranch header count mgitopts limitBranches action (mbr, pkgs) =- withPackagesByBranches header count mgitopts limitBranches action (Branches (maybeToList mbr),pkgs)+withPackagesMaybeBranch header count mgitopts action (mbr, pkgs) =+ withPackagesByBranches header count mgitopts ZeroOrOne action (Branches (maybeToList mbr),pkgs) -withPackagesMaybeBranchNoHeadergit :: LimitBranches- -> (Package -> AnyBranch -> IO ())- -> (Maybe Branch,[String])- -> IO ()+withPackagesMaybeBranchNoHeadergit :: (Package -> AnyBranch -> IO ())+ -> (Maybe Branch,[String])+ -> IO () withPackagesMaybeBranchNoHeadergit = withPackagesMaybeBranch HeaderNone False Nothing @@ -698,7 +718,7 @@ hostdist <- cmd "rpm" ["--eval", "%{dist}"] -- FIXME more precise regexp with "Release:" autorelease <- grep_ " %autorelease" spec- fmap (replace hostdist disttag) . listToMaybe <$>+ nvrs <- if autorelease then do mautospec <- findExecutable "rpmautospec"@@ -707,6 +727,12 @@ autorel <- last . words <$> cmd "rpmautospec" ["calculate-release", spec] rpmspec ["--srpm"] (Just ("%{name}-%{version}-" ++ autorel ++ disttag)) spec else rpmspec ["--srpm"] (Just "%{name}-%{version}-%{release}") spec+ seq disttag $+ return $+ case nvrs of+ [] -> Nothing+ [nvr] -> Just (replace hostdist disttag nvr)+ _ -> error' "could not determine unique nvr" pkgNameVerRel' :: Branch -> FilePath -> IO String pkgNameVerRel' br spec = do@@ -761,30 +787,13 @@ notInstalled pkg = not <$> cmdBool "rpm" ["--quiet", "-q", "--whatprovides", pkg] -rpmInstalled :: NVRA -> IO Bool-rpmInstalled rpm =+nvraInstalled :: NVRA -> IO Bool+nvraInstalled rpm = cmdBool "rpm" ["--quiet", "-q", showNVRA rpm] pkgInstalled :: String -> IO Bool pkgInstalled pkg = cmdBool "rpm" ["--quiet", "-q", pkg]--repoquery :: Branch -> Branch -> [String] -> IO String-repoquery sysbr br args = do- let brOpts =- if sysbr == br- then []- else- case br of- Rawhide -> ["--disablerepo=*", "--enablerepo=rawhide"]- Fedora _ -> ["--disablerepo=*", "--enablerepo=fedora",- "--enablerepo=updates",- "--releasever=" ++ branchVersion br]- EPEL _ -> ["--disablerepo=*", "--enablerepo=epel",- "--releasever=" ++ branchVersion br]- EPELNext _ -> ["--disablerepo=*", "--enablerepo=epel-next",- "--releasever=" ++ branchVersion br]- cmd "dnf" (["repoquery", "--quiet"] ++ brOpts ++ args) -- FIXME should be more strict about dist tag (eg .fcNN only) equivNVR :: String -> String -> Bool
+ src/Patch.hs view
@@ -0,0 +1,53 @@+module Patch (+ simplifyMinimalDiff,+ dropChangelog,+ isTrivialRebuildCommit,+ removeDiffContext+ )+where++import Common++simplifyMinimalDiff :: [String] -> [String]+simplifyMinimalDiff =+ maybeRemoveDiffGit . filterCommon+ where+ filterCommon =+ filter (not .+ -- FIXME a/ and b/+ matchPreds (map isPrefixOf ["--- ", "+++ ", "index ", "@@ -"]))++ maybeRemoveDiffGit ls =+ let gitDiffs = filter ("diff --git " `isPrefixOf`) ls in+ if length gitDiffs == 1+ then ls \\ gitDiffs+ else ls++-- adapted from flist in swish+matchPreds :: [a -> Bool] -> a -> Bool+matchPreds fs a = any ($ a) fs++-- adapted from cabal-rpm PackageUtils+dropChangelog :: [String] -> [String]+dropChangelog ls =+ if " %changelog" `elem` ls+ then+ let rest = (dropWhileEnd ("@@ " `isPrefixOf`) . dropWhileEnd (== " ") . takeWhile (/= " %changelog")) ls in+ if length rest > 2 then rest else []+ else ls++isTrivialRebuildCommit :: [String] -> Bool+isTrivialRebuildCommit ls =+ let nontrivial =+ (simplifyMinimalDiff . removeDiffContext . dropChangelog) ls+ in+ length nontrivial `elem` [0,2] &&+ all (matchPreds (map isPrefixOf ["-Release:", "+Release:"])) nontrivial++ -- not+ -- (any+ -- (not . matchPreds (map isPrefixOf ["-Release:", "+Release:"])) ls)+-- (all . matchPreds (map isPrefixOf ["-Release:", "+Release:"])) ls++removeDiffContext :: [String] -> [String]+removeDiffContext = filter ((/= ' ') . head)
src/Prompt.hs view
@@ -1,8 +1,7 @@ module Prompt ( prompt, prompt_,- refPrompt,- conflictPrompt+ yesno ) where import Data.Char (isPrint)@@ -38,25 +37,13 @@ prompt_ :: String -> IO () prompt_ = void <$> prompt --- FIXME select ref by number-refPrompt :: [String] -> String -> IO (Maybe (Maybe String))-refPrompt commits txt = do- let commitrefs = tail $ map (head . words) commits- ref <- prompt txt- if null ref then return (Just Nothing) else- if lower ref == "no" then return Nothing- else if ref `elem` commitrefs- then return $ Just (Just ref)- else refPrompt commits txt---- FIXME also include branch-conflictPrompt :: [String] -> String -> IO (Maybe String)-conflictPrompt commits txt = do- let commitrefs = map (head . words) commits- ref <- prompt txt- if null ref then return Nothing- else if ref `elem` commitrefs- then return $ Just ref- else if lower ref == "head"- then return $ Just $ head commitrefs- else conflictPrompt commits txt+-- from dnf-repo Sudo.hs+yesno :: String -> IO Bool+yesno desc = do+ inp <- prompt $ desc ++ "? [y/n]"+ case lower inp of+ "y" -> return True+ "yes" -> return True+ "n" -> return False+ "no" -> return False+ _ -> yesno desc
+ src/Repoquery.hs view
@@ -0,0 +1,28 @@+module Repoquery (+ repoquery+ )+where++import Data.Maybe (isJust)+import SimpleCmd++import Bodhi (bodhiTestingRepo)+import Branches++repoquery :: Branch -> Branch -> [String] -> IO String+repoquery sysbr br args = do+ mtesting <- bodhiTestingRepo br+ let brOpts =+ if sysbr == br+ then []+ else do+ case br of+ Rawhide -> ["--disablerepo=*", "--enablerepo=rawhide"]+ Fedora _ -> ["--disablerepo=*", "--enablerepo=fedora"] +++ ["--enablerepo=updates"| isJust mtesting] +++ ["--releasever=" ++ branchVersion br]+ EPEL _ -> ["--disablerepo=*", "--enablerepo=epel",+ "--releasever=" ++ branchVersion br]+ EPELNext _ -> ["--disablerepo=*", "--enablerepo=epel-next",+ "--releasever=" ++ branchVersion br]+ cmd "dnf" (["repoquery", "--quiet"] ++ brOpts ++ args)
src/Types.hs view
@@ -1,6 +1,14 @@ module Types (- Archs(..)+ Archs(..),+ SideTagTarget(..),+ maybeTarget ) where data Archs = Archs [String] | ExcludedArchs [String]++data SideTagTarget = SideTag | Target String++maybeTarget :: Maybe SideTagTarget -> Maybe String+maybeTarget (Just (Target t)) = Just t+maybeTarget _ = Nothing