fbrnch 1.2.1 → 1.3
raw patch · 34 files changed
+806/−423 lines, 34 filesdep +simple-prompt
Dependencies added: simple-prompt
Files
- CHANGELOG.md +41/−0
- README.md +13/−5
- fbrnch.cabal +5/−4
- src/Bodhi.hs +8/−2
- src/Branches.hs +11/−9
- src/Bugzilla.hs +5/−3
- src/Cmd/Bugs.hs +22/−1
- src/Cmd/Build.hs +16/−13
- src/Cmd/Bump.hs +13/−9
- src/Cmd/Commit.hs +4/−4
- src/Cmd/Copr.hs +5/−4
- src/Cmd/Diff.hs +64/−52
- src/Cmd/Import.hs +2/−2
- src/Cmd/Install.hs +63/−32
- src/Cmd/Local.hs +124/−1
- src/Cmd/Merge.hs +5/−5
- src/Cmd/Mock.hs +17/−9
- src/Cmd/Override.hs +4/−4
- src/Cmd/Parallel.hs +72/−55
- src/Cmd/PkgReview.hs +2/−2
- src/Cmd/PullPush.hs +9/−4
- src/Cmd/RequestBranch.hs +2/−2
- src/Cmd/RequestRepo.hs +2/−2
- src/Cmd/Scratch.hs +29/−13
- src/Cmd/SideTags.hs +2/−2
- src/Cmd/Status.hs +145/−88
- src/Cmd/Update.hs +1/−5
- src/Cmd/WaitRepo.hs +4/−5
- src/Git.hs +22/−10
- src/Koji.hs +34/−9
- src/Main.hs +43/−8
- src/Package.hs +9/−4
- src/Prompt.hs +0/−50
- src/RpmBuild.hs +8/−5
CHANGELOG.md view
@@ -1,5 +1,46 @@ # Changelog +## 1.3 (2023-04-08)+- new 'autospec' command converts packages to use rpmautospec+- new 'move-artifacts' command moves rpmbuild artifacts into dirs (--delete)+- new 'srpm-spec' command shows or diffs srpm specfiles+- new 'unpushed' command shows unpushed commits; and --latest option+- new 'bzusers' command searches users in bugzilla+- 'build': check for Bodhi update before koji tags+- 'build': do not repeat header when merging+- 'build': improve logic and prompt for unpushed check+- 'bump': add --changelog override and handle %autorelease+- 'copr': intersperse newlines between packages+- 'diff': --debug option to print package header+- 'diff': handle missing and non-release branches+- 'install': add --ignore-builddeps (for existing built rpms)+- 'install': ignore dead.package's+- 'install': show dnf commands with sudoLog and cmdN sudo+- 'merge': --no-fetch option+- 'mock': add --arch option+- 'mock': new --shell-only option which skips build+- 'override': default to ./ when no pkg path given+- 'parallel': if single layer, don't output layer #+- 'parallel': improve sidetag update transition messages, now waits 90s+- 'parallel': output tweaks for more packages/layers and existing nvr+- 'parallel': prompt whether to continue after failure+- 'parallel': reverse the package order for update changelog+- 'parallel': be quieter when many parallel packages+- 'push': --no-fetch option and also print header+- 'push': allow specifying a ref+- 'rename-rawhide': now pulls to get latest+- 'scratch': add --srpm option to build existing srpm+- 'status': add pkg/branch prefix before latest log+- Bugzilla: update checkRepoCreatedComment for fedora-admin automation+- Copr branchRelease: do not error for EPELNext!+- buildRPMs: backup the build.log file to build.log.prev+- buildRPMs: print NVR instead of package name+- changeLogPrompt: no trailing newline after showing changelog+- gitPush replaces gitPushSilent+- kojiWaitRepo: knowntag assurance parameter for build and parallel+- kojiWatchTask: use koji-tool to get build.log tail on failure+- use simple-prompt+ ## 1.2.1 (2022-11-23) - 'install': if dnf install fails, include command in error message - 'override': check for kerberos ticket
README.md view
@@ -39,7 +39,7 @@ One can change the branch of one or more packages: ```-$ fbrnch switch f37 [package] ...+$ fbrnch switch f38 [package] ... ``` You can also git pull over packages:@@ -97,13 +97,13 @@ You can merge branches with: ```-$ fbrnch merge f36 package+$ fbrnch merge f37 package ```-which will offer to merge f37 (or up to a git hash you choose) into f36.+which will offer to merge f38 (or up to a git hash you choose) into f37. Merging can also be done together with building: ```-$ fbrnch build f37 package+$ fbrnch build f38 package ``` will ask if you want to merge newer commits from a newer branch, then push and build it.@@ -255,13 +255,16 @@ ### Other commands There are a lot more commands, like eg `copr` and `graph`: +Here is an "extreme" [example](https://github.com/fedora-haskell/haskell-language-server/blob/main/build.sh) of a script using `fbrnch copr` to do multiple staggered builds.+ ``` $ fbrnch --version-1.2.1+1.3 $ fbrnch --help Fedora branch building tool Usage: fbrnch [--version] COMMAND+ A tool to help with updating and building package branches https://github.com/juhp/fbrnch#readme @@ -275,6 +278,7 @@ nvr Print name-version-release status Status package/branch status merge Merge from newer branch+ unpushed Show unpushed commits build Build package(s) in Koji list List packages in pagure list-local List packages in branch@@ -291,6 +295,7 @@ prep Prep sources local Build locally srpm Build srpm+ srpm-spec Show the spec file in an srpm diff Diff local changes compare Show commits between branches src-deps List source package dependencies@@ -305,6 +310,7 @@ fetch Git fetch packages push Git push packages owner List package owner(s)+ bzusers Search bugzilla users create-review Create a Package Review request update-review Update a Package Review review-package Run fedora-review on a package Review Request bug@@ -320,6 +326,8 @@ count Count number of living packages graph Output dependency graph ftbfs Check FTBFS status+ autospec Convert package to use rpmautospec+ move-artifacts Move old rpm artifacts into rpmbuild dirs ``` ## Installation
fbrnch.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: fbrnch-version: 1.2.1+version: 1.3 synopsis: Fedora packager tool to build package branches description: fbrnch (fedora branch) is a convenient packaging tool for@@ -27,13 +27,14 @@ license-file: LICENSE author: Jens Petersen <petersen@redhat.com> maintainer: Jens Petersen <petersen@fedoraproject.org>-copyright: 2019-2022 Jens Petersen+copyright: 2019-2023 Jens Petersen category: Distribution build-type: Simple extra-doc-files: CHANGELOG.md README.md tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5,- GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.5+ GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.7,+ GHC == 9.4.4 source-repository head type: git@@ -91,7 +92,6 @@ Pagure Patch Paths_fbrnch- Prompt Repoquery RpmBuild Types@@ -127,6 +127,7 @@ rpm-nvr >= 0.1.2, simple-cmd >= 0.2.3, simple-cmd-args >= 0.1.8,+ simple-prompt, text, time, typed-process >= 0.2.4.0,
src/Bodhi.hs view
@@ -6,7 +6,8 @@ checkAutoBodhiUpdate, UpdateType(..), UpdateSeverity(..),- bodhiUpdate+ bodhiUpdate,+ bodhiBuildExists ) where @@ -16,6 +17,7 @@ import Data.Aeson.Types (Object, (.:), parseEither) import Data.Char (isDigit) import Fedora.Bodhi hiding (bodhiUpdate)+import SimplePrompt import Text.Read import qualified Text.ParserCombinators.ReadP as R import qualified Text.ParserCombinators.ReadPrec as RP@@ -26,7 +28,6 @@ import Common.System import qualified Common.Text as T import Package-import Prompt checkAutoBodhiUpdate :: Branch -> IO Bool checkAutoBodhiUpdate Rawhide = return True@@ -201,3 +202,8 @@ putStrLn ("no such file: " ++ file) maybeTemplate TemplateUpdate maybeTemplate _ = return Nothing++bodhiBuildExists :: String -> IO Bool+bodhiBuildExists nvr = do+ obj <- bodhiBuild nvr+ return $ isNothing (lookupKey "status" obj :: Maybe String)
src/Branches.hs view
@@ -35,10 +35,10 @@ import Data.Tuple import Distribution.Fedora.Branch import SimpleCmd.Git-import System.Info (arch)+import SimplePrompt+import qualified System.Info (arch) import Pagure-import Prompt data AnyBranch = RelBranch Branch | OtherBranch String deriving Eq@@ -104,13 +104,15 @@ where include p e = e ++ ": " ++ p -mockRoot :: Branch -> String-mockRoot br = do- case br of- Rawhide -> "fedora-rawhide-" ++ arch- Fedora n -> "fedora-" ++ show n ++ "-" ++ arch- EPEL n -> "epel-" ++ show n ++ "-" ++ arch- EPELNext n -> "centos-stream+epel-next-" ++ show n ++ "-" ++ arch+mockRoot :: Branch -> Maybe String -> String+mockRoot br march =+ let arch = fromMaybe System.Info.arch march+ in+ case br of+ Rawhide -> "fedora-rawhide-" ++ arch+ Fedora n -> "fedora-" ++ show n ++ "-" ++ arch+ EPEL n -> "epel-" ++ show n ++ "-" ++ arch+ EPELNext n -> "centos-stream+epel-next-" ++ show n ++ "-" ++ arch ------
src/Bugzilla.hs view
@@ -66,13 +66,14 @@ putBugURLStatus, -- request newBzRequest,- makeTextItem+ makeTextItem,+ searchUsers ) where import Common import Common.System import qualified Common.Text as T-import Prompt+import SimplePrompt import Data.Aeson.Types (Array, Object) import qualified Data.ByteString.Char8 as B@@ -399,10 +400,11 @@ mapM_ (T.putStrLn . (" " <>)) $ dropDuplicates . removeLeadingNewline . T.lines $ commentText cmt putNewLn +-- FIXME check for Fedora Admin user for bugzilla script actions <fedora-admin-xmlrpc@fedoraproject.org> checkRepoCreatedComment :: BugzillaSession -> BugId -> IO Bool checkRepoCreatedComment session bid = checkForComment session bid- "(fedscm-admin): The Pagure repository was created at"+ "The Pagure repository was created at https://src.fedoraproject.org/" checkForComment :: BugzillaSession -> BugId -> T.Text -> IO Bool checkForComment session bid text = do
src/Cmd/Bugs.hs view
@@ -1,6 +1,14 @@-module Cmd.Bugs (bugsCmd) where+{-# LANGUAGE OverloadedStrings, RecordWildCards #-} +module Cmd.Bugs+ (bugsCmd,+ bzusersCmd)+where+ import Bugzilla+import Common+import Common.System (error')+import qualified Common.Text as T import Package bugsCmd :: Maybe String -> [String] -> IO ()@@ -20,3 +28,16 @@ Just key -> statusOpen .&&. summaryContains key bugs <- bugsAnon $ pkgBugs (unPackage pkg) .&&. query mapM_ putBugVer $ sortBugsByProduct bugs++bzusersCmd :: String -> IO ()+bzusersCmd name = do+ if length (trim name) < 3+ then error' "use more than 2 characters"+ else do+ session <- bzApiKeySession+ users <- searchUsers session (T.pack name)+ mapM_ printUser users+ where+ printUser :: User -> IO ()+ printUser User{..} =+ T.putStrLn $ userRealName <> " " <> "<" <> userName <> ">"
src/Cmd/Build.hs view
@@ -16,7 +16,7 @@ import Krb import Koji import Package-import Prompt+import SimplePrompt import RpmBuild (checkSourcesMatch) import Types @@ -86,14 +86,14 @@ Just False -> return False Just True -> do whenJust mnewer $ \newer ->- mergeBranch (buildoptDryrun opts) True True False (Just pkg) (ancestor,unmerged) newer br+ mergeBranch (buildoptDryrun opts) True True False Nothing (ancestor,unmerged) newer br return True Nothing -> if ancestor && (newrepo || tty) then do whenJust mnewer $ \newer ->- mergeBranch (buildoptDryrun opts) True False True (Just pkg) (ancestor,unmerged) newer br- return True+ mergeBranch (buildoptDryrun opts) True False True Nothing (ancestor,unmerged) newer br+ return $ isJust mnewer else do unless (br == Rawhide) $ whenJust mnewer $ \newer ->@@ -116,8 +116,7 @@ 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 ref to push" else "") ++ (if not newrepo then "; or 'no' to skip pushing" else "")+ then refPrompt unpushed $ "Press Enter to push and build" ++ (if length unpushed > 1 then "; or give ref to push" else "") ++ (if not newrepo then "; or 'no' to skip pushing" else "") else return $ Just $ commitRef $ head unpushed let dryrun = buildoptDryrun opts buildstatus <- maybeTimeout 30 $ kojiBuildStatus nvr@@ -130,20 +129,23 @@ when (isJust mpush) $ error' "Please bump the spec file" when (br /= Rawhide && isNothing msidetagTarget) $ do- tags <- maybeTimeout 30 $ kojiNVRTags nvr+ updateExists <- maybeTimeout 30 $ bodhiBuildExists 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+ if updateExists+ then putStrLn "update exists"+ else do mbug <- bzReviewAnon bodhiUpdate dryrun (buildoptUpdate opts) mbug (buildoptUseChangelog opts) spec nvr+ tags <- maybeTimeout 30 $ kojiNVRTags nvr unless (any (`elem` tags) [show br, show br ++ "-updates", show br ++ "-override"]) $ whenJust moverride $ \days -> bodhiCreateOverride dryrun (Just days) nvr when (isJust mlastpkg && mlastpkg /= Just pkg || mwaitrepo == Just True) $ when ((isJust moverride && mwaitrepo /= Just False) || (autoupdate && mwaitrepo == Just True)) $- kojiWaitRepo dryrun True target nvr+ kojiWaitRepo dryrun True True target nvr Just BuildBuilding -> do putStrLn $ nvr ++ " is already building" when (isJust mpush) $@@ -189,10 +191,11 @@ unless dryrun krbTicket whenJust mpush $ \ref -> unless dryrun $- gitPushSilent $ Just $ ref ++ ":" ++ show br+ gitPush False $ Just $ ref ++ ":" ++ show br unlessM (null <$> gitOneLineLog ("origin/" ++ show br ++ "..HEAD")) $- when (isJust mpush && not dryrun) $- error' "Unpushed changes remain"+ unless dryrun $ do+ ok <- yesno Nothing "Unpushed changes remain, continue"+ unless ok $ error' "aborted" unless (buildoptAllowDirty opts) $ unlessM isGitDirClean $ error' "local changes remain (dirty)"@@ -219,4 +222,4 @@ when (isJust mlastpkg && mlastpkg /= Just pkg || mwaitrepo == Just True) $ when ((isJust moverride && mwaitrepo /= Just False) || (autoupdate && mwaitrepo == Just True)) $- kojiWaitRepo dryrun True target nvr+ kojiWaitRepo dryrun True True target nvr
src/Cmd/Bump.hs view
@@ -15,8 +15,8 @@ -- FIXME --force -- FIXME --target -- FIXME detect rpmautospec and add empty commit-bumpPkgs :: Bool -> Maybe CommitOpt -> (BranchesReq,[String]) -> IO ()-bumpPkgs local mopt =+bumpPkgs :: Bool -> Maybe CommitOpt -> Maybe String -> (BranchesReq,[String]) -> IO ()+bumpPkgs local mopt mclog = withPackagesByBranches (boolHeader local) False (if local then cleanGit else cleanGitFetchActive) AnyNumber bumpPkg where@@ -49,19 +49,23 @@ then do git_ "log" ["origin..HEAD", "--pretty=oneline"] let clmsg =- case mopt of- Just (CommitMsg msg) -> msg- _ -> "rebuild"- -- FIXME check for rpmautospec first- cmd_ "rpmdev-bumpspec" ["-c", clmsg, spec]+ case mclog of+ Just clog -> clog+ Nothing ->+ case mopt of+ Just (CommitMsg msg) -> msg+ _ -> "rebuild"+ autorelease <- grep_ " %autorelease" spec+ unless autorelease $+ cmd_ "rpmdev-bumpspec" ["-c", clmsg, spec] let copts = case mopt of- Nothing -> ["-m", "bump release"]+ Nothing -> ["-m", if autorelease then "rebuild" else "bump release"] Just opt -> case opt of CommitMsg msg -> ["-m", msg] -- FIXME reject amend if already pushed CommitAmend -> ["--amend", "--no-edit"] -- FIXME quiet commit?- git_ "commit" $ "-a" : copts+ git_ "commit" $ "-a" : (if autorelease then ("--allow-empty" :) else id) copts else putStrLn "already bumped"
src/Cmd/Commit.hs view
@@ -7,7 +7,7 @@ import Common.System import Git import Package-import Prompt+import SimplePrompt -- FIXME reject if nvr ahead of newer branch -- FIXME use branches after all?@@ -23,10 +23,10 @@ else mapM_ commitPkg paths where commitPkg :: FilePath -> IO ()- commitPkg path =- withExistingDirectory path $+ commitPkg dir =+ withExistingDirectory dir $ unlessM isGitDirClean $ do- getPackageName path >>= putPkgHdr+ getPackageName dir >>= putPkgHdr addall <- if null paths then null <$> git "diff" ["--cached"]
src/Cmd/Copr.hs view
@@ -45,9 +45,9 @@ then mapM_ putStrLn chroots else if null pkgs then- getPackageName "." >>= coprBuildPkg chroots+ getPackageName "." >>= coprBuildPkg chroots False else- mapM_ (\ p -> withExistingDirectory p $ coprBuildPkg chroots (Package p)) pkgs+ mapM_ (\(n,p) -> withExistingDirectory p $ coprBuildPkg chroots (n>0) (Package p)) $ zip (reverse [0,length pkgs - 1]) pkgs where coprGetChroots = do username <- getUsername@@ -76,7 +76,7 @@ then error' "No valid chroots" else return buildroots - coprBuildPkg buildroots pkg = do+ coprBuildPkg buildroots morepkgs pkg = do -- FIXME check is pkg.spec spec <- localBranchSpecFile pkg (RelBranch Rawhide) -- pkg <- takeFileName <$> getCurrentDirectory@@ -103,6 +103,7 @@ let initialChroots = groupBy sameRelease buildroots remainingChroots = buildroots \\ concat initialChroots staggerBuilds srpm initialChroots remainingChroots+ when morepkgs putNewLn removeArch relarch = init $ dropWhileEnd (/= '-') relarch takeArch = takeWhileEnd (/= '-')@@ -124,7 +125,7 @@ branchRelease Rawhide = "fedora-rawhide" branchRelease (Fedora n) = "fedora-" ++ show n branchRelease (EPEL n) = "epel-" ++ show n-branchRelease (EPELNext n) = error' $ show (EPELNext n) ++ " is unsupported"+branchRelease (EPELNext n) = "epel-" ++ show n ++ "-next" --data Chroot = Chroot Release Arch
src/Cmd/Diff.hs view
@@ -28,63 +28,75 @@ -- FIXME diff other branches without switching -- FIXME --older/--newer branch-diffCmd :: Bool -> DiffWork -> DiffFormat -> Bool -> Maybe DiffFilter+diffCmd :: Bool -> Bool -> DiffWork -> DiffFormat -> Bool -> Maybe DiffFilter -> Maybe AnyBranch -> (Maybe Branch,[String]) -> IO ()-diffCmd speconly work fmt ignorebumps mpatt mwbr =- withPackagesMaybeBranch HeaderNone False dirtyGit diffPkg+diffCmd debug speconly work fmt ignorebumps mpatt mwbr =+ withPackagesMaybeBranch (if debug then HeaderMust else HeaderNone) False dirtyGit diffPkg where diffPkg :: Package -> AnyBranch -> IO () diffPkg pkg br = do- gitSwitchBranch br- speconlyNone <-- if speconly- then notM $ doesFileExist $ packageSpec pkg- else return False- if speconlyNone- then do- dead <- doesFileExist "dead.package"- unless dead $ putStrLn $ "no " ++ packageSpec pkg- else do- let contxt = case fmt of- DiffContext n -> ["--unified=" ++ show n]- DiffMinimal -> ["--unified=0"]- DiffStatus -> ["--name-status"]- -- FIXME hide "files changed" and "insertions" summary- DiffStats -> ["--compact-summary"]- _ -> []- (workOpts,workArgs) =- case work of- DiffWorkAll -> ([],["HEAD" | isNothing mwbr])- DiffWorkUnstage -> ([],[])- DiffWorkStaged -> (["--cached"],[])- file = [packageSpec pkg | speconly]- withBranch <-- case mwbr of- Nothing -> return []- Just wbr ->- let brn = show wbr in- if '/' `elem` brn- then return [brn]- else do- localbrs <- gitLines "branch" ["--format=%(refname:short)"]- if brn `elem` localbrs- then return [brn]- else return ["origin/" ++ brn]- let revdiff = case mwbr of- Nothing -> []- Just wbr -> case (wbr,br) of- (RelBranch rwbr, RelBranch rbr) -> ["-R" | rwbr > rbr]- _ -> []- diff <- gitLines "diff" $ contxt ++ workOpts ++ revdiff ++ withBranch ++ workArgs ++ file- let diffout = (maybe id filterPattern mpatt . simplifyDiff fmt) diff- -- FIXME: sometimes we may want to list even if diff but no diffout- unless (null diffout) $- unless (ignorebumps && isTrivialRebuildCommit diffout) $- if fmt == DiffQuiet- then putStrLn $ unPackage pkg+ ok <-+ case br of+ OtherBranch _ -> gitSwitchBranch br >> return True+ RelBranch rbr -> gitSwitchBranch' False rbr+ when ok $ do+ speconlyNone <-+ if speconly+ then notM $ doesFileExist $ packageSpec pkg+ else return False+ if speconlyNone+ then do+ dead <- doesFileExist "dead.package"+ unless dead $ putStrLn $ "no " ++ packageSpec pkg else do- putPkgAnyBrnchHdr pkg br- mapM_ putStrLn diffout+ let contxt = case fmt of+ DiffContext n -> ["--unified=" ++ show n]+ DiffMinimal -> ["--unified=0"]+ DiffStatus -> ["--name-status"]+ -- FIXME hide "files changed" and "insertions" summary+ DiffStats -> ["--compact-summary"]+ _ -> []+ (workOpts,workArgs) =+ case work of+ DiffWorkAll -> ([],["HEAD" | isNothing mwbr])+ DiffWorkUnstage -> ([],[])+ DiffWorkStaged -> (["--cached"],[])+ file = [packageSpec pkg | speconly]+ mwithBranch <-+ case mwbr of+ Nothing -> return $ Just []+ Just wbr ->+ let brn = show wbr in+ if '/' `elem` brn+ then return $ Just [brn]+ else do+ localbrs <- gitLines "branch" ["--format=%(refname:short)"]+ if brn `elem` localbrs+ then return $ Just [brn]+ else do+ wbexists <- checkIfRemoteBranchExists wbr+ if wbexists+ then return $ Just ["origin/" ++ brn]+ else do+ putStrLn $ "no" +-+ show wbr +-+ "for" +-+ unPackage pkg+ return Nothing+ whenJust mwithBranch $ \withBranch -> do+ let revdiff =+ case mwbr of+ Nothing -> []+ Just wbr -> case (wbr,br) of+ (RelBranch rwbr, RelBranch rbr) -> ["-R" | rwbr > rbr]+ _ -> []+ diff <- gitLines "diff" $ contxt ++ workOpts ++ revdiff ++ withBranch ++ workArgs ++ file+ let diffout = (maybe id filterPattern mpatt . simplifyDiff fmt) diff+ -- FIXME: sometimes we may want to list even if diff but no diffout+ unless (null diffout) $+ 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 = simplifyMinimalDiff ds
src/Cmd/Import.hs view
@@ -16,7 +16,7 @@ import Krb import ListReviews import Package-import Prompt+import SimplePrompt -- FIXME separate pre-checked listReviews and direct pkg call, which needs checks -- FIXME add --dryrun@@ -70,7 +70,7 @@ git_ "commit" ["--message", "import #" ++ show bid] nvr <- pkgNameVerRel' Rawhide (pkg <.> "spec") prompt_ $ "Press Enter to push and build " ++ nvr- gitPushSilent Nothing+ gitPush True Nothing -- FIXME build more branches kojiBuildBranch "rawhide" (Package pkg) Nothing ["--fail-fast"] putBugBuild False session bid nvr
src/Cmd/Install.hs view
@@ -1,9 +1,15 @@+{-# LANGUAGE CPP #-}+ module Cmd.Install ( installCmd, notInstalledCmd ) where import Data.RPM+#if !MIN_VERSION_simple_cmd(0,2,7)+import System.Posix.User (getEffectiveUserID)+#endif+import SimplePrompt import Branches import Cmd.Merge@@ -11,10 +17,11 @@ import Common.System import Git import Package-import Prompt import Repoquery import RpmBuild +-- FIXME --nobuild+-- FIXME --rpm to avoid dnf -- FIXME --force removal of existing incompatible dependent packages -- FIXME --subpackage to specify subpackage(s) to install/add -- FIXME --ignore-uninstalled subpackages@@ -22,8 +29,8 @@ -- FIXME --check any/all of package installed -- FIXME add --debug or respect --verbose for dnf commands installCmd :: Bool -> Bool -> Maybe Branch -> Maybe ForceShort -> [BCond]- -> Bool -> Bool -> (Maybe Branch,[String]) -> IO ()-installCmd verbose recurse mfrom mforceshort bconds reinstall allsubpkgs (mbr, pkgs) = do+ -> Bool -> Bool -> Bool -> (Maybe Branch,[String]) -> IO ()+installCmd verbose recurse mfrom mforceshort bconds reinstall nobuilddeps allsubpkgs (mbr, pkgs) = do when (recurse && isShortCircuit mforceshort) $ error' "cannot use --recurse and --shortcircuit" withPackagesMaybeBranch (boolHeader (recurse || length pkgs > 1)) True Nothing installPkg (mbr, pkgs)@@ -31,37 +38,42 @@ installPkg :: Package -> AnyBranch -> IO () installPkg pkg br = do whenJust mbr $ gitSwitchBranch . RelBranch- spec <-- if isNothing mfrom- then localBranchSpecFile pkg br+ dead <- doesFileExist "dead.package"+ if dead+ then putStrLn "dead package" else do- mergeCmd False True Nothing False mfrom (Branches [onlyRelBranch br], ["."])- localBranchSpecFile pkg br- rpms <- builtRpms br spec- -- removing arch- 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"+ spec <-+ if isNothing mfrom+ then localBranchSpecFile pkg br+ else do+ mergeCmd False False True Nothing False mfrom (Branches [onlyRelBranch br], ["."])+ localBranchSpecFile pkg br+ rpms <- builtRpms br spec+ -- removing arch+ 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 already = do putStrLn $ (showNVR . dropArch . readNVRA) (head rpms)- missingdeps <- nub <$> (buildRequires spec >>= filterM notInstalled)- unless (null missingdeps) $- if recurse- then do- -- srcs <- nub <$> mapM (derefSrcPkg topdir dist True) hmissing- rbr <- anyBranchToRelease br- forM_ missingdeps $ \ dep -> do- -- FIXME check not metadep with parens- mpkgdir <- lookForPkgDir rbr ".." dep- case mpkgdir of- Nothing -> putStrLn $ dep ++ " not known"- 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+ unless nobuilddeps $ do+ missingdeps <- nub <$> (buildRequires spec >>= filterM notInstalled)+ unless (null missingdeps) $+ if recurse+ then do+ -- srcs <- nub <$> mapM (derefSrcPkg topdir dist True) hmissing+ rbr <- anyBranchToRelease br+ forM_ missingdeps $ \ dep -> do+ -- FIXME check not metadep with parens+ mpkgdir <- lookForPkgDir rbr ".." dep+ case mpkgdir of+ Nothing -> putStrLn $ dep ++ " not known"+ Just pkgdir -> installCmd verbose recurse mfrom mforceshort bconds reinstall nobuilddeps allsubpkgs (mbr, [pkgdir]) >> putNewLn+ -- FIXME option to enable/disable installing missing deps+ else installDeps True spec wasbuilt <- buildRPMs (not verbose) False False mforceshort' bconds rpms br spec unless (isShortCircuit mforceshort') $ do toinstalls <-@@ -75,12 +87,13 @@ let reinstalls = filter (\ f -> readNVRA f `elem` already) toinstalls unless (null reinstalls) $- sudo_ "/usr/bin/dnf" $ "reinstall" : "-q" : "-y" : reinstalls+ sudoLog "/usr/bin/dnf" $ "reinstall" : "-q" : "-y" : reinstalls let remaining = filterDebug $ toinstalls \\ reinstalls unless (null remaining) $- sudo_ "/usr/bin/dnf" $ "install" : "-q" : "-y" : remaining+ sudoLog "/usr/bin/dnf" $ "install" : "-q" : "-y" : remaining else do let command = "/usr/bin/dnf" : "install" : "-q" : "-y" : filterDebug toinstalls+ cmdN "sudo" command ok <- cmdBool "sudo" command unless ok $ if wasbuilt@@ -144,3 +157,21 @@ pkgInstalled :: String -> IO Bool pkgInstalled pkg = cmdBool "rpm" ["--quiet", "-q", pkg]++#if !MIN_VERSION_simple_cmd(0,2,7)+sudoLog :: String -- ^ command+ -> [String] -- ^ arguments+ -> IO ()+sudoLog = sudoInternal cmdLog+ where+ sudoInternal :: (String -> [String] -> IO a) -> String -> [String] -> IO a+ sudoInternal exc c args = do+ uid <- getEffectiveUserID+ sd <- if uid == 0+ then return Nothing+ else findExecutable "sudo"+ let noSudo = isNothing sd+ when (uid /= 0 && noSudo) $+ warning "'sudo' not found"+ exc (fromMaybe c sd) (if noSudo then args else c:args)+#endif
src/Cmd/Local.hs view
@@ -1,18 +1,23 @@ module Cmd.Local (+ autospecCmd, commandCmd, countCmd, installDepsCmd, localCmd,+ moveArtifactsCmd, nvrCmd,+ renameMasterCmd, srpmCmd,- renameMasterCmd+ srpmSpecCmd ) where import qualified Data.ByteString.Lazy.Char8 as B+import Data.Char (isDigit) import System.Environment import qualified System.Process as P import qualified System.Process.Typed as TP import System.Exit+import System.IO.Extra (withTempDir) import Branches import Common@@ -112,6 +117,7 @@ git_ "branch" ["--move", "master", "rawhide"] git_ "remote" ["set-head", "origin", "rawhide"] git_ "branch" ["--set-upstream-to", "origin/rawhide", "rawhide"]+ git_ "pull" [] countCmd :: (Maybe Branch,[String]) -> IO () countCmd (mbr,pkgs) =@@ -130,3 +136,120 @@ exists <- doesFileExist spec return $ n + if exists then 1 else 0 Nothing -> return n++srpmSpecCmd :: Bool -> [FilePath] -> IO ()+srpmSpecCmd diff srpms =+ if diff then+ case srpms of+ [] -> error' "impossible happened: no srpms given"+ [srpm] -> do+ withTempDir $ \tempdir -> do+ spec <- getSrpmSpecfile False srpm tempdir+ cmd_ "diff" ["-u", tempdir </> spec, spec]+ [srpm1, srpm2] ->+ withTempDir $ \tempdir -> do+ spec1 <- getSrpmSpecfile True srpm1 tempdir+ spec2 <- getSrpmSpecfile True srpm2 tempdir+ withCurrentDirectory tempdir $+ void $ cmdBool "diff" ["-u", spec1, spec2]+ _ -> error' "too many srpm files"+ else+ forM_ srpms $ \srpm ->+ pipe_ ("rpm2cpio", [srpm]) ("cpio",["--extract", "--quiet", "--to-stdout", "*.spec"])+ where+ getSrpmSpecfile :: Bool -> FilePath -> FilePath -> IO FilePath+ getSrpmSpecfile sub srpm tempdir = do+ exists <- doesFileExist srpm+ if exists+ then do+ let subdir = if sub then takeBaseName srpm else ""+ dir = tempdir </> subdir+ ok <- pipeBool ("rpm2cpio", [srpm]) ("cpio", ["--extract", "--quiet", "--make-directories", "-D", dir , "--preserve-modification-time", "*.spec"])+ if ok+ then do+ spec <- head <$> listDirectory dir+ return $ subdir </> spec+ else error' "failed to extract spec file"+ else error' $ "no such file:" +-+ srpm++autospecCmd :: Bool -> [String] -> IO ()+autospecCmd force pkgs =+ withPackagesByBranches HeaderMay False cleanGitFetchActive ExactlyOne autospecPkg (Branches [Rawhide], pkgs)+ where+ autospecPkg :: Package -> AnyBranch -> IO ()+ autospecPkg _pkg br = do+ gitSwitchBranch br+ let changelogfile = "changelog"+ exists <- doesFileExist changelogfile+ if exists+ then+ if force+ then do+ cmd "rpmautospec" ["generate-changelog"] >>=+ writeFile changelogfile+ unlessM (null <$> git "status" ["--porcelain", "--untracked=no"]) $ do+ git_ "add" [changelogfile]+ git_ "commit" ["-m", "refresh changelog"]+ else putStrLn "'changelog' file already exists"+ else cmd_ "rpmautospec" ["convert"]++moveArtifactsCmd :: Bool -> [String] -> IO ()+moveArtifactsCmd remove pkgs =+ withPackagesByBranches HeaderMay False dirtyGit Zero moveArtifactsPkg (Branches [], pkgs)+ where+ moveArtifactsPkg :: Package -> AnyBranch -> IO ()+ moveArtifactsPkg pkg br = do+ cwd <- getCurrentDirectory+ whenJustM (rpmEval "%_rpmdir") $ \rpmdir ->+ unless (rpmdir == cwd) $ do+ moveRPMS rpmdir "x86_64"+ moveRPMS rpmdir "noarch"+ ls <- listDirectory "."+ whenJustM (rpmEval "%_srcrpmdir") $ \srcrpmdir ->+ unless (srcrpmdir == cwd) $ do+ let srpms = filter ("src.rpm" `isExtensionOf`) ls+ forM_ srpms $ \srpm -> do+ exists <- doesFileExist $ srcrpmdir </> srpm+ if exists+ then if remove+ then removeFile srpm+ else putStrLn $ "duplicate:" +-+ srpm+ else do+ createDirectoryIfMissing False srcrpmdir+ renameFile srpm $ srcrpmdir </> srpm+ whenJustM (rpmEval "%_builddir") $ \builddir ->+ unless (builddir == cwd) $ do+ dirs <- filterM doesDirectoryExist ls+ spec <- localBranchSpecFile pkg br+ srcs <- map (takeWhile (not . isDigit) . takeBaseName) <$> cmdLines "spectool" ["-S", spec]+ let srctrees =+ if null srcs+ then []+ else filter (head srcs `isPrefixOf`) dirs+ createDirectoryIfMissing False builddir+ forM_ srctrees $ \tree -> do+ exists <- doesDirectoryExist $ builddir </> tree+ if exists+ then if remove+ then removeDirectoryRecursive tree+ else putStrLn $ "duplicate:" +-+ tree+ else renameDirectory tree $ builddir </> tree++ moveRPMS :: FilePath -> FilePath -> IO ()+ moveRPMS rpmdir dir =+ whenM (doesDirectoryExist dir) $+ whenM (doesDirectoryExist (rpmdir </> dir)) $ do+ rpms <- listDirectory dir+ forM_ rpms $ \rpm -> do+ let file = dir </> rpm+ exists <- doesFileExist $ rpmdir </> file+ if exists+ then if remove+ then removeFile file+ else putStrLn $ "duplicate:" +-+ file+ else do+ createDirectoryIfMissing False rpmdir+ renameFile file $ rpmdir </> file+ left <- listDirectory dir+ when (null left) $+ removeDirectory dir
src/Cmd/Merge.hs view
@@ -14,10 +14,10 @@ import Package import Patch -mergeCmd :: Bool -> Bool -> Maybe Natural -> Bool -> Maybe Branch+mergeCmd :: Bool -> Bool -> Bool -> Maybe Natural -> Bool -> Maybe Branch -> (BranchesReq,[String]) -> IO ()-mergeCmd dryrun noprompt mnotrivial showall mfrom =- withPackagesByBranches HeaderMay False cleanGitFetchActive AnyNumber runMergeBranch+mergeCmd dryrun nofetch noprompt mnotrivial showall mfrom =+ withPackagesByBranches HeaderMay False (if nofetch then cleanGitActive else cleanGitFetchActive) AnyNumber runMergeBranch where runMergeBranch :: Package -> AnyBranch -> IO () runMergeBranch _ (OtherBranch _) =@@ -35,7 +35,7 @@ gitMergeOrigin br (ancestor,unmerged) <- mergeable from br unmerged' <- filterOutTrivial mnotrivial unmerged- mergeBranch dryrun False noprompt showall (Just pkg) (ancestor,unmerged') from br+ mergeBranch dryrun False noprompt showall (if nofetch then Just pkg else Nothing) (ancestor,unmerged') from br where filterOutTrivial :: Maybe Natural -> [Commit] -> IO [Commit] filterOutTrivial Nothing cs = return cs@@ -88,7 +88,7 @@ unless dryrun $ git_ "merge" ["--quiet", ref] mergeBranch dryrun build noprompt showall mpkg (False,unmerged) from br = do- whenJust mpkg $ flip putPkgBrnchHdr br+ unless build $ whenJust mpkg $ flip putPkgBrnchHdr br putStrLn $ show from ++ " branch is not directly mergeable:" displayCommits False unmerged putNewLn
src/Cmd/Mock.hs view
@@ -1,6 +1,7 @@ module Cmd.Mock ( mockCmd,- NoClean(..)+ NoClean(..),+ MockShell(..) ) where @@ -16,12 +17,15 @@ data NoClean = NoCleanBefore | NoCleanAfter | NoCleanAll | MockShortCircuit deriving Eq +data MockShell = ShellOnly | BuildShell+ deriving Eq+ -- FIXME add repo/copr for build -- FIXME handle non-release branches (on-branch works) -- FIXME option for --shell without rebuild-mockCmd :: Bool -> Maybe NoClean -> Bool -> Bool -> Maybe Branch- -> (BranchesReq, [String]) -> IO ()-mockCmd dryrun mnoclean network mockshell mroot (breq, ps) = do+mockCmd :: Bool -> Maybe NoClean -> Bool-> Maybe MockShell -> Maybe Branch+ -> Maybe String -> (BranchesReq, [String]) -> IO ()+mockCmd dryrun mnoclean network mockshell mroot march (breq, ps) = do branches <- case breq of Branches [] ->@@ -53,16 +57,20 @@ 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]+ mockopts_common c = [c, "--root", mockRoot rootBr march] ++ 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] if dryrun then do- cmdN "mock" mockbuild_opts- when mockshell $ cmdN "mock" mockshell_opts+ unless (mockshell == Just ShellOnly) $+ cmdN "mock" mockbuild_opts+ when (isJust mockshell) $ cmdN "mock" mockshell_opts else do- ok <- cmdBool "mock" mockbuild_opts- when mockshell $ cmd_ "mock" mockshell_opts+ ok <-+ if mockshell == Just ShellOnly+ then return True+ else cmdBool "mock" mockbuild_opts+ when (isJust mockshell) $ cmd_ "mock" mockshell_opts unless ok $ error' "mockbuild failed" where prepSrpm :: AnyBranch -> FilePath -> IO FilePath
src/Cmd/Override.hs view
@@ -20,7 +20,7 @@ import Koji import Krb (krbTicket) import Package-import Prompt (yesno)+import SimplePrompt (yesno) data OverrideMode = OverrideCreate | OverrideList | OverrideExpire deriving Eq@@ -34,7 +34,7 @@ putStrLn "Overriding" withPackagesByBranches HeaderMay False cleanGitFetchActive AnyNumber overrideBranch breqpkgs unless nowait $- waitrepoCmd dryrun WaitNoFetch Nothing breqpkgs+ waitrepoCmd dryrun False WaitNoFetch Nothing breqpkgs where overrideBranch :: Package -> AnyBranch -> IO () overrideBranch _ (OtherBranch _) =@@ -69,13 +69,13 @@ Just _expired -> return () Nothing -> do whenJust (lookupKey "nvr" override) $ \nvr -> do- ok <- yesno $ "Expire override" +-+ nvr+ ok <- yesno Nothing $ "Expire override" +-+ nvr when ok $ cmd_ "bodhi" ["overrides", "edit", "--expire", nvr] withPackages :: [FilePath] -> (Package -> IO ()) -> IO () withPackages pkgs act =- forM_ pkgs $ \pkgdir ->+ forM_ (if null pkgs then ["."] else pkgs) $ \pkgdir -> withExistingDirectory pkgdir $ getPackageName "." >>= act
src/Cmd/Parallel.hs view
@@ -25,13 +25,13 @@ import Koji import Package import RpmBuild (checkSourcesMatch)-import Prompt+import SimplePrompt import Types -data JobDone = JobDone {jobNvr :: String,- jobBranch :: Branch,- _jobClog :: String- }+data JobDone = Done {jobNvr :: String,+ jobBranch :: Branch,+ _jobClog :: String}+ type JobAsync = (String, Async JobDone) -- FIXME offer to untag overrides afterwards@@ -91,7 +91,7 @@ unless (isNothing msidetagTarget) $ -- FIXME check for an existing sidetag update when (target /= branchTarget rbr) $ do- let changelog = intercalate "" $ renderChangelogs nvrclogs+ let changelog = intercalate "" $ renderChangelogs $ reverse nvrclogs putNewLn putStrLn changelog input <- prompt "Press Enter to use above or input update summary now; or 'no' to skip update"@@ -106,12 +106,14 @@ putStrLn $ "= Building " ++ pluralException (length brs) "branch" "branches" ++ " in parallel:" putStrLn $ unwords $ map show brs jobs <- mapM setupBranch brs- (failures,nvrclogs) <- timeIO $ watchJobs Nothing [] [] jobs+ (failures,nvrclogs) <- timeIO $ watchJobs (length jobs == 1) Nothing [] [] jobs -- switch back to the original branch when (length brs /= 1) $ gitSwitchBranch currentbranch- unless (null failures) $- error' $ "Build failures: " ++ unwords failures+ unless (null failures) $ do+ putStrLn $ "Build failures:" +-+ unwords failures+ okay <- yesno Nothing "Do you want to continue nevertheless"+ unless okay $ error' "Quitting" when (isNothing msidetagTarget) $ do let spec = packageSpec pkg bodhiUpdate dryrun mupdate Nothing False spec $@@ -124,7 +126,7 @@ putPkgBrnchHdr pkg br target <- targetMaybeSidetag dryrun br msidetagTarget when (mmerge /= Just False) $ mergeNewerBranch Nothing br- job <- startBuild Nothing 0 False False target pkg br "." >>= async+ job <- startBuild Nothing 0 False (length brs) target pkg br "." >>= async unless dryrun $ sleep 3 return (show br,job) @@ -142,71 +144,78 @@ parallelBuild _ _ (_,[]) = return [] -- should not reach here parallelBuild target br (layernum, layer:nextLayers) = do krbTicket- putStrLn $ "\n= Building parallel layer #" ++ show layernum +++ let singlelayer = layernum == 0 && null nextLayers+ putStrLn $ "\n= Building" +-++ (if singlelayer+ then "in parallel"+ else "parallel layer #" ++ show layernum) ++ if nopkgs > 1 then " (" ++ show nopkgs +-+ "packages):" else ":" putStrLn $ unwords layer -- maybe print total pending packages unless (null nextLayers) $- putStrLn $ plural layersleft "more layer" ++ " left with " +++ putStrLn $ let layerspkgs = map length nextLayers in case layerspkgs of- [l] -> plural l "package"- _ -> show layerspkgs +-+ "packages"- jobs <- zipWithM setupBuild (reverse [0..(length layer - 1)]) layer+ [n] -> plural n "more package" +-+ "left in next final layer"+ _ -> "more package layers left:" +-+ show layerspkgs+ jobs <- zipWithM (setupBuild singlelayer) (reverse [0..(length layer - 1)]) layer when (null jobs) $ error' "No jobs run"- (failures,nvrs) <- watchJobs (Just layernum) [] [] jobs- -- FIXME prompt to continue?+ (failures,nvrs) <- watchJobs (length jobs == 1) (if singlelayer then Nothing else Just layernum) [] [] jobs if null failures then return nvrs else do let pending = sum $ map length nextLayers- error' $ "Build failures in layer" +-+ show layernum ++ ": " ++- unwords failures ++ "\n\n" +++ putStrLn $ "\nBuild failures" +-++ (if singlelayer then ":" else "in layer" +-+ show layernum ++ ":")+ +-+ unwords failures+ okay <- yesno Nothing "Do you want to continue nevertheless"+ if okay+ then return nvrs+ else error' $ plural pending "pending package" ++ if pending > 0- then- ":\n" ++ unwords (map unwords nextLayers)+ then ":\n" ++ unwords (map unwords nextLayers) else "" where nopkgs = length layer layersleft = length nextLayers - setupBuild :: Int -> String -> IO JobAsync- setupBuild n dir = do+ setupBuild :: Bool -> Int -> String -> IO JobAsync+ setupBuild singlelayer n dir = do pkg <- getPackageName dir putPkgBrnchHdr pkg br- job <- startBuild (Just layernum) n (layersleft > 0) (nopkgs > 5) target pkg br dir+ job <- startBuild (if singlelayer then Nothing else Just layernum) n (layersleft > 0) nopkgs target pkg br dir >>= async unless dryrun $ sleep 4 return (unPackage pkg,job) - watchJobs :: Maybe Int -> [String] -> [JobDone] -> [JobAsync]+ watchJobs :: Bool -> Maybe Int -> [String] -> [JobDone] -> [JobAsync] -> IO ([String],[JobDone]) -- (failures,successes)- watchJobs _ fails results [] = return (fails,results)- watchJobs mlayer fails results (job:jobs) = do+ watchJobs _ _ fails dones [] = return (fails,dones)+ watchJobs singlejob mlayer fails dones (job:jobs) = do status <- poll (snd job) case status of- Nothing -> sleep 1 >> watchJobs mlayer fails results (jobs ++ [job])+ Nothing -> sleep 1 >> watchJobs singlejob mlayer fails dones (jobs ++ [job]) -- (nvr,changelog)- Just (Right result) -> do- putStrLn $- if null jobs- then "ending layer" +-+ maybe "" show mlayer- else plural (length jobs) "job" +-+ "left" +-+ maybe "" (\l -> "in layer" +-+ show l) mlayer- watchJobs mlayer fails (result:results) jobs+ Just (Right done) -> do+ unless singlejob $+ when (null jobs) $+ putStrLn $ "ending" +-+ maybe "" (\l -> "layer" +-+ show l) mlayer+ -- else plural (length jobs) "job" +-+ "left" +-+ maybe "" (\l -> "in layer" +-+ show l) mlayer+ watchJobs singlejob mlayer fails (done:dones) jobs Just (Left except) -> do print except let pkg = fst job- 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+ putStrLn $ "** " ++ color Magenta pkg +-+ "job" +-+ color Magenta "failed" ++ " **" +-+ if singlejob then "" else "(" ++ plural (length jobs) "job" +-+ "left" +-+ maybe "" (\l -> "in layer" +-+ show l) mlayer ++ ")"+ watchJobs singlejob mlayer (pkg : fails) dones jobs -- FIXME prefix output with package name- startBuild :: Maybe Int -> Int -> Bool -> Bool -> String -> Package+ startBuild :: Maybe Int -> Int -> Bool -> Int -> String -> Package -> Branch -> String -> IO (IO JobDone)- startBuild mlayer n morelayers background target pkg br dir =+ startBuild mlayer n morelayers nopkgs target pkg br dir = withExistingDirectory dir $ do gitSwitchBranch (RelBranch br) let spec = packageSpec pkg@@ -214,14 +223,16 @@ 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+ putStrLn $ nvr +-+ "(" ++ target ++ ")" +-++ if nopkgs > 1+ then pluralException n "more" "more" +-+ maybe "" (\l -> "in layer" +-+ show l) mlayer+ else "" putNewLn displayCommits True unpushed unless (null unpushed) $ do checkSourcesMatch spec unless dryrun $- gitPushSilent Nothing+ gitPush True Nothing changelog <- unlines <$> getChangelog spec -- FIXME should compare git refs -- FIXME check for target@@ -239,8 +250,8 @@ bodhiCreateOverride dryrun Nothing nvr return $ do when morelayers $- kojiWaitRepo dryrun background target nvr- return $ JobDone nvr br changelog+ kojiWaitRepo dryrun (nopkgs > 5) True target nvr+ return $ Done nvr br changelog Just BuildBuilding -> do putStrLn $ color Yellow nvr +-+ "is already" +-+ color Yellow "building" mtask <- kojiGetBuildTaskID fedoraHub nvr@@ -249,7 +260,7 @@ Just task -> return $ do kojiWaitTaskAndRepo (isNothing mlatest) nvr task- return $ JobDone nvr br changelog+ return $ Done nvr br changelog _ -> do when (null unpushed) $ do putStrLn $ nvr ++ " (" ++ target ++ ")" +-+ show n +-+ "more" +-+@@ -263,21 +274,23 @@ putStrLn $ nvr ++ " task is already open" return $ do kojiWaitTaskAndRepo (isNothing mlatest) nvr task- return $ JobDone nvr br changelog+ return $ Done nvr br changelog (_:_) -> error' $ show (length opentasks) ++ " open " ++ unPackage pkg ++ " tasks already" [] -> do if equivNVR nvr (fromMaybe "" mlatest)- then return $ error' $- color Red $ nvr ++ " is already latest (modulo disttag)"+ then do+ -- FIXME add a retry prompt+ putStrLn $ color Red $ nvr ++ " is already latest (modulo disttag)"+ return $ error' $ nvr +-+ "failed" else do -- FIXME parse build output if dryrun- then return $ return $ JobDone nvr br "<changelog>"+ then return $ return $ Done nvr br "<changelog>" else do- task <- kojiBuildBranchNoWait target pkg Nothing $ "--fail-fast" : ["--background" | background]+ task <- kojiBuildBranchNoWait target pkg Nothing $ "--fail-fast" : ["--background" | nopkgs > 5] return $ do kojiWaitTaskAndRepo (isNothing mlatest) nvr task- return $ JobDone nvr br changelog+ return $ Done nvr br changelog where kojiWaitTaskAndRepo :: Bool -> String -> TaskID -> IO () kojiWaitTaskAndRepo newpkg nvr task = do@@ -299,12 +312,12 @@ -- bodhiUpdate (fmap fst mBugSess) changelog nvr bodhiCreateOverride dryrun Nothing nvr when morelayers $- kojiWaitRepo dryrun background target nvr+ kojiWaitRepo dryrun (nopkgs > 5) True target nvr -- FIXME map nvr to package? renderChangelogs :: [JobDone] -> [String] renderChangelogs [] = []- renderChangelogs ((JobDone nvr _ clog):jobs) =+ renderChangelogs ((Done nvr _ clog):jobs) = unlines [nvr, "", clog] : renderChangelogs jobs -- FIXME how to catch authentication errors?@@ -336,8 +349,9 @@ case lookupKey "updateid" update of Nothing -> error' "could not determine Update id" Just updateid -> do- putStr "Waiting for sidetag update to transition to 'request testing'"- sleep 80+ putStr "Waiting ~90s for sidetag update to transition to 'request testing'.."+ -- FIXME countdown timer+ sleep 90 bodhiUpdateTestingRequesting 1 updateid update _ -> error' $ "impossible happened: more than one update found for " ++ last nvrs @@ -348,7 +362,10 @@ else case lookupKey "request" update of Just (String request) ->- putStrLn $ "\nrequest:" +-+ T.unpack request+ putStrLn $+ if request == "testing"+ then " done"+ else "\nrequest:" +-+ T.unpack request _ -> do mupdate' <- FedoraBodhi.bodhiUpdate updateid case mupdate' of
src/Cmd/PkgReview.hs view
@@ -19,7 +19,7 @@ import Koji import Krb import Package-import Prompt+import SimplePrompt import RpmBuild data ScratchOption = ScratchBuild | ScratchTask Int | SkipScratch@@ -122,7 +122,7 @@ if mock then do -- FIXME check that mock is installed let resultsdir = "results_" ++ pkg- cmd_ "mock" ["--root", mockRoot Rawhide, "--resultdir=" ++ resultsdir, srpm]+ cmd_ "mock" ["--root", mockRoot Rawhide Nothing, "--resultdir=" ++ resultsdir, srpm] map (resultsdir </>) . filter ((== ".rpm") . takeExtension) <$> listDirectory resultsdir else builtRpms (RelBranch Rawhide) spec >>= filterM doesFileExist
src/Cmd/PullPush.hs view
@@ -7,6 +7,7 @@ import Branches import Common+import Common.System (error') import Git import Package @@ -58,11 +59,15 @@ fetchPkg _pkg _br = gitFetchSilent False -pushPkgs :: (BranchesReq, [String]) -> IO ()-pushPkgs =- withPackagesByBranches HeaderMay False cleanGitFetch AnyNumber pushPkg+pushPkgs :: Bool -> Bool -> Maybe String -> (BranchesReq, [String]) -> IO ()+pushPkgs dryrun nofetch mref (breq, pkgs) = do+ when (isJust mref && length pkgs > 1) $+ error' "can only specify ref for single package"+ withPackagesByBranches HeaderMust False (if nofetch then cleanGit else cleanGitFetch) AnyNumber pushPkg (breq, pkgs) where pushPkg :: Package -> AnyBranch -> IO () pushPkg _pkg _br = do whenJustM (gitShortLog1 Nothing) $ putStrLn . showCommit- gitPushSilent Nothing+ if dryrun+ then checkOnBranch+ else gitPush False mref
src/Cmd/RequestBranch.hs view
@@ -18,7 +18,7 @@ import ListReviews import Package import Pagure-import Prompt (prompt_)+import SimplePrompt (prompt_) -- FIXME option to do koji scratch build instead of mock requestBranchesCmd :: Bool -> Maybe Branch -> Bool -> (BranchesReq,[String]) -> IO ()@@ -72,7 +72,7 @@ unless (null newbranches) $ do mbidsession <- bzReviewSession urls <- forM newbranches $ \ br -> do- when mock $ fedpkg_ "mockbuild" ["--root", mockRoot br]+ when mock $ fedpkg_ "mockbuild" ["--root", mockRoot br Nothing] 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)
src/Cmd/RequestRepo.hs view
@@ -14,7 +14,7 @@ import ListReviews import Package import Pagure-import Prompt+import SimplePrompt -- FIXME separate pre-checked listReviews and direct pkg call, which needs checks requestRepos :: Bool -> Bool -> Bool -> (BranchesReq, [String]) -> IO ()@@ -68,7 +68,7 @@ putNewLn branches <- getRequestedBranches [] breq forM_ branches $ \ br -> do- when mock $ fedpkg_ "mockbuild" ["--root", mockRoot br]+ when mock $ fedpkg_ "mockbuild" ["--root", mockRoot br Nothing] putStr (show br ++ " ") fedpkg_ "request-branch" ["--repo", pkg, show br] putNewLn
src/Cmd/Scratch.hs view
@@ -5,6 +5,7 @@ scratchCmdAarch64, scratchCmdX86_64, Archs(..),+ ScratchSource(..) ) where import Branches@@ -16,13 +17,21 @@ import RpmBuild (generateSrpm) import Types (Archs(..),SideTagTarget) +data ScratchSource = ScratchRef String | ScratchSRPM String++showScratchSource :: Bool -> String -> Maybe ScratchSource -> String+showScratchSource pushed nvr Nothing = nvr ++ (if pushed then "" else ".src.rpm")+showScratchSource _ _ (Just (ScratchRef ref)) = ref+showScratchSource _ _ (Just (ScratchSRPM srpm)) = srpm++-- FIXME --with --without ? -- 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- -> [SideTagTarget] -> Maybe String -> (BranchesReq, [String])+ -> [SideTagTarget] -> Maybe ScratchSource -> (BranchesReq, [String]) -> IO ()-scratchCmd dryrun stagger rebuildSrpm nofailfast marchopts sidetagTargets mref (breq,pkgs) =+scratchCmd dryrun stagger rebuildSrpm nofailfast marchopts sidetagTargets msource (breq,pkgs) = withPackagesByBranches HeaderMust False Nothing AnyNumber scratchBuild (breq,pkgs) where anyTarget (RelBranch b) = branchTarget b@@ -30,8 +39,8 @@ scratchBuild :: Package -> AnyBranch -> IO () scratchBuild pkg br = do- when (isJust mref && length pkgs > 1) $- error' "--ref is not supported for multiple packages"+ when (isJust msource && length pkgs > 1) $+ error' "source override is not supported for multiple packages" pkggit <- isPkgGitRepo when (not pkggit && breq == Branches [] && null sidetagTargets) $ error' "please specify a branch or target for non dist-git"@@ -75,12 +84,13 @@ then do gitSwitchBranch br pushed <- do- case mref of- Just ref ->+ case msource of+ Just (ScratchRef ref) -> if length ref < 6 then error' $ "please use a longer ref: " ++ ref -- FIXME print commit log else return True+ Just (ScratchSRPM _) -> return False Nothing -> do clean <- isGitDirClean if clean && isRelBranch br@@ -89,11 +99,17 @@ else return False rbr <- anyBranchToRelease br nvr <- pkgNameVerRel' rbr spec- putStrLn $ target ++ " scratch build of " ++ fromMaybe nvr mref ++ (if pushed then "" else ".src.rpm")- unless dryrun $ do- if pushed- then kojiBuildBranch target pkg mref $ "--scratch" : kojiargs- else srpmBuild kojiargs+ putStrLn $ target ++ " scratch build of " ++ showScratchSource pushed nvr msource+ unless dryrun $+ case msource of+ Just (ScratchSRPM srpm) ->+ void $ kojiScratchBuild target kojiargs srpm+ Nothing ->+ if pushed+ then kojiBuildBranch target pkg Nothing $ "--scratch" : kojiargs+ else srpmBuild kojiargs+ Just (ScratchRef ref) ->+ kojiBuildBranch target pkg (Just ref) $ "--scratch" : kojiargs else srpmBuild kojiargs where srpmBuild :: [String] -> IO ()@@ -102,12 +118,12 @@ -- FIXME default -X to --no-fastfail? scratchCmdX86_64 :: Bool -> Bool -> Bool -> [SideTagTarget]- -> Maybe String -> (BranchesReq, [String]) -> IO ()+ -> Maybe ScratchSource -> (BranchesReq, [String]) -> IO () scratchCmdX86_64 dryrun rebuildSrpm excludeArch = scratchCmd dryrun False rebuildSrpm False (Just (excludeArchs excludeArch ["x86_64"])) scratchCmdAarch64 :: Bool -> Bool -> Bool -> [SideTagTarget]- -> Maybe String -> (BranchesReq, [String]) -> IO ()+ -> Maybe ScratchSource -> (BranchesReq, [String]) -> IO () scratchCmdAarch64 dryrun rebuildSrpm excludeArch = scratchCmd dryrun False rebuildSrpm False (Just (excludeArchs excludeArch ["aarch64"]))
src/Cmd/SideTags.hs view
@@ -6,7 +6,7 @@ import Common import Koji import Krb (krbTicket)-import Prompt (yesno)+import SimplePrompt (yesno) sideTagsCmd :: Bool -> [Branch] -> IO () sideTagsCmd remove brs = do@@ -19,5 +19,5 @@ where removeSideTag :: String -> IO () removeSideTag tag =- whenM (yesno $ "Remove " ++ tag) $+ whenM (yesno Nothing $ "Remove " ++ tag) $ cmd_ "fedpkg" ["remove-side-tag", tag]
src/Cmd/Status.hs view
@@ -1,7 +1,11 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -module Cmd.Status (statusCmd) where+module Cmd.Status (+ statusCmd,+ unpushedCmd+ )+where import Common import Common.System@@ -24,98 +28,151 @@ -- FIXME silence fetching of new branches? (for --reviews etc) statusCmd :: Bool -> Bool -> (BranchesReq,[String]) -> IO () statusCmd nofetch reviews (breq, pkgs) = do- reviewpkgs <- if reviews then- map reviewBugToPackage <$> listReviewsAll True ReviewRepoCreated+ reviewpkgs <-+ if reviews+ then map reviewBugToPackage <$> listReviewsAll True ReviewRepoCreated else return [] -- FIXME dirty not okay for multiple branches? withPackagesByBranches HeaderMay False (if nofetch then dirtyGit else dirtyGitFetch) AnyNumber statusBranch (breq, pkgs ++ reviewpkgs)---- FIXME note dirty when local changes-statusBranch :: Package -> AnyBranch -> IO ()-statusBranch _ (OtherBranch _) =- error' "status currently only defined for release branches"-statusBranch pkg rbr@(RelBranch br) = do- brExists <- checkIfRemoteBranchExists rbr- if not brExists- then do- name <- getDirectoryName- putStrLn $ name ++ " has no branch " ++ show br- else do- gitSwitchBranch rbr- let spec = packageSpec pkg- ifM (notM (doesFileExist spec))- (ifM initialPkgRepo- (putStrLn $ show br ++ ": initial repo")- (putStrLn $ "missing " ++ spec)) $- do- mnvr <- pkgNameVerRel br spec- case mnvr of- Nothing -> do- putStrLn "undefined NVR!\n"- putStr "HEAD "- whenJustM (gitShortLog1 Nothing) $ putStrLn . showCommit- Just nvr -> do- -- unless (br == Rawhide) $ do- -- newerBr <- newerBranch br <$> getFedoraBranches- -- ancestor <- gitBool "merge-base" ["--is-ancestor", "HEAD", show newerBr]- -- when ancestor $ do- -- unmerged <- gitOneLineLog $ "HEAD..origin/" ++ show newerBr- -- unless (null unmerged) $ do- -- putStrLn $ "Newer commits in " ++ show newerBr ++ ":"- -- mapM_ putStrLn unmerged- unpushed <- gitShortLog1 $ Just $ "origin/" ++ show br ++ "..HEAD"- if null unpushed- then do- mbuild <- kojiGetBuildID fedoraHub nvr- case mbuild of- Nothing -> do- mlatest <- kojiLatestNVR (branchDestTag br) (unPackage pkg)- case mlatest of- Nothing -> putStrLn $ "new " ++ nvr- Just latest ->- putStrLn $ if equivNVR nvr latest then latest ++ " is latest modulo disttag" else (if null latest then "new " else (head . words) latest ++ " ->\n") ++ nvr- Just buildid -> do- tags <- kojiBuildTags fedoraHub (buildIDInfo buildid)- if null tags then do- mstatus <- kojiBuildStatus nvr- -- FIXME show pending archs building- whenJust mstatus $ \ status ->- -- FIXME better Show BuildStatus- putStr $ nvr ++ " (" ++ show status ++ ")"- else do- -- FIXME hide testing if ga/stable- putStr $ nvr ++ " (" ++ unwords tags ++ ")"- unless (isStable tags) $ do- updates <- bodhiUpdates- [makeItem "display_user" "0",- makeItem "builds" nvr]- case updates of- [] -> putStrLn "No update found"- [update] -> do- -- FIXME could show minus time left using stable_days?- let msince = lookupKey "date_testing" update :: Maybe LocalTime- case msince of- Nothing -> return ()- Just date -> do- let since = localTimeToUTC utc date- current <- getCurrentTime- let diff = diffUTCTime current since- putAge diff- _ -> putStrLn "More than one update found!"- putNewLn- else whenJust unpushed $ putStrLn . ((show br ++ ": ") ++) . showCommit where- isStable :: [String] -> Bool- isStable = not . all ("-testing" `isSuffixOf`)+ -- FIXME note dirty when local changes+ statusBranch :: Package -> AnyBranch -> IO ()+ statusBranch _ (OtherBranch _) =+ error' "status currently only defined for release branches"+ statusBranch pkg rbr@(RelBranch br) = do+ brExists <- checkIfRemoteBranchExists rbr+ if not brExists+ then do+ name <- getDirectoryName+ putStrLn $ name ++ " has no branch " ++ show br+ else do+ gitSwitchBranch rbr+ let spec = packageSpec pkg+ ifM (notM (doesFileExist spec))+ (ifM initialPkgRepo+ (putStrLn $ show br ++ ": initial repo")+ (putStrLn $ "missing " ++ spec)) $+ do+ mnvr <- pkgNameVerRel br spec+ case mnvr of+ Nothing -> do+ putStrLn "undefined NVR!\n"+ putStr "HEAD "+ whenJustM (gitShortLog1 Nothing) $ putStrLn . showCommit+ Just nvr -> do+ -- unless (br == Rawhide) $ do+ -- newerBr <- newerBranch br <$> getFedoraBranches+ -- ancestor <- gitBool "merge-base" ["--is-ancestor", "HEAD", show newerBr]+ -- when ancestor $ do+ -- unmerged <- gitOneLineLog $ "HEAD..origin/" ++ show newerBr+ -- unless (null unmerged) $ do+ -- putStrLn $ "Newer commits in " ++ show newerBr ++ ":"+ -- mapM_ putStrLn unmerged+ munpushed <- gitShortLog1 $ Just $ "origin/" ++ show br ++ "..HEAD"+ case munpushed of+ Nothing -> do+ mbuild <- kojiGetBuildID fedoraHub nvr+ case mbuild of+ Nothing -> do+ mlatest <- kojiLatestNVR (branchDestTag br) (unPackage pkg)+ case mlatest of+ Nothing -> putStrLn $ "new " ++ nvr+ Just latest ->+ putStrLn $ if equivNVR nvr latest then latest ++ " is latest modulo disttag" else (if null latest then "new " else (head . words) latest ++ " ->\n") ++ nvr+ Just buildid -> do+ tags <- kojiBuildTags fedoraHub (buildIDInfo buildid)+ if null tags+ then do+ mstatus <- kojiBuildStatus nvr+ -- FIXME show pending archs building+ whenJust mstatus $ \ status ->+ -- FIXME better Show BuildStatus+ putStr $ nvr ++ " (" ++ show status ++ ")"+ else do+ -- FIXME hide testing if ga/stable+ putStr $ nvr ++ " (" ++ unwords tags ++ ")"+ unless (isStable tags) $ do+ updates <- bodhiUpdates+ [makeItem "display_user" "0",+ makeItem "builds" nvr]+ case updates of+ [] -> putStrLn "No update found"+ [update] -> do+ -- FIXME could show minus time left using stable_days?+ let msince = lookupKey "date_testing" update :: Maybe LocalTime+ case msince of+ Nothing -> return ()+ Just date -> do+ let since = localTimeToUTC utc date+ current <- getCurrentTime+ let diff = diffUTCTime current since+ putAge diff+ _ -> putStrLn "More than one update found!"+ putNewLn+ Just unpushed ->+ let prefix =+ let pref =+ (if length pkgs > 1 then unPackage pkg else "") +-++ case breq of+ Branches brs | length brs <= 1 -> ""+ _ -> show br+ in if null pref then "" else pref ++ ":"+ in putStrLn $ prefix +-+ showCommit unpushed+ where+ isStable :: [String] -> Bool+ isStable = not . all ("-testing" `isSuffixOf`) - putAge :: NominalDiffTime -> IO ()- putAge diff = do- -- FIXME time-1.10 has formatTime of NominalDiffTime- let (days,nomRest) = diff `divMod'` nominalDay :: (Int,NominalDiffTime)- nominalHour = 3600 :: NominalDiffTime- hours = nomRest `div'` nominalHour :: Int- putStr $ " " ++ plural days "day" +-+ plural hours "hour"+ putAge :: NominalDiffTime -> IO ()+ putAge diff = do+ -- FIXME time-1.10 has formatTime of NominalDiffTime+ let (days,nomRest) = diff `divMod'` nominalDay :: (Int,NominalDiffTime)+ nominalHour = 3600 :: NominalDiffTime+ hours = nomRest `div'` nominalHour :: Int+ putStr $ " " ++ plural days "day" +-+ plural hours "hour" #if !MIN_VERSION_time(1,8,0)- nominalDay = 3600 * 24 :: NominalDiffTime+ nominalDay = 3600 * 24 :: NominalDiffTime #endif+++unpushedCmd :: Bool -> (BranchesReq,[String]) -> IO ()+unpushedCmd latest (breq, pkgs) =+ -- FIXME dirty not okay for multiple branches?+ withPackagesByBranches (if latest then HeaderMay else HeaderMust) False dirtyGit AnyNumber unpushedBranch (breq, pkgs)+ where+ -- FIXME note dirty when local changes+ unpushedBranch :: Package -> AnyBranch -> IO ()+ unpushedBranch _ (OtherBranch _) =+ error' "status currently only defined for release branches"+ unpushedBranch pkg rbr@(RelBranch br) = do+ brExists <- checkIfRemoteBranchExists rbr+ if not brExists+ then do+ name <- getDirectoryName+ putStrLn $ name ++ " has no branch " ++ show br+ else do+ gitSwitchBranch rbr+ let spec = packageSpec pkg+ prefix =+ let pref =+ (if length pkgs > 1 then unPackage pkg else "") +-++ case breq of+ Branches brs | length brs <= 1 -> ""+ _ -> show br+ in if null pref then "" else pref ++ ":"+ ifM (notM (doesFileExist spec))+ (ifM initialPkgRepo+ (putStrLn $ prefix +-+ "initial repo")+ (unlessM (doesFileExist "dead.package") $+ putStrLn $ "missing " ++ spec)) $+ do+ whenM (isNothing <$> pkgNameVerRel br spec) $ do+ putStrLn "undefined NVR!\n"+ putStr "HEAD "+ unpushed <- gitShortLogN (if latest then Just 1 else Nothing) $+ Just $ "origin/" ++ show br ++ "..HEAD"+ if latest+ then whenJust (listToMaybe unpushed) $ putCommit prefix+ else mapM_ (putCommit prefix) unpushed++ putCommit prefix = putStrLn . (prefix +-+) . showCommit
src/Cmd/Update.hs view
@@ -10,9 +10,9 @@ import InterleaveOutput (cmdSilent') import Krb import Package-import Prompt (prompt_) import Data.RPM.VerCmp+import SimplePrompt (prompt_) -- FIXME don't bump release if already bumped -- FIXME check EVR increased@@ -138,10 +138,6 @@ case ws of [f,v] -> (f,v) _ -> error $ "inconsistent field: " ++ xs--editSpecField :: String -> String -> FilePath -> IO ()-editSpecField field new spec =- cmd_ "sed" ["-i", "-e s/^\\(" ++ field ++ ":\\s\\+\\).*/\\1" ++ new ++ "/", spec] changelogVersions :: FilePath -> IO [String] changelogVersions spec = do
src/Cmd/WaitRepo.hs view
@@ -15,9 +15,9 @@ data WaitFetch = WaitNoFetch | WaitDirty | WaitFetch -- FIXME first check/wait for build to actually exist-waitrepoCmd :: Bool -> WaitFetch -> Maybe SideTagTarget+waitrepoCmd :: Bool -> Bool -> WaitFetch -> Maybe SideTagTarget -> (BranchesReq, [String]) -> IO ()-waitrepoCmd dryrun fetch msidetagTarget = do+waitrepoCmd dryrun knowntag fetch msidetagTarget = do withPackagesByBranches HeaderMay False (case fetch of WaitFetch -> cleanGitFetchActive@@ -33,6 +33,5 @@ let spec = packageSpec pkg nvr <- pkgNameVerRel' br spec target <- targetMaybeSidetag dryrun br msidetagTarget- logMsg $ "waiting for " ++ nvr ++ " to appear in " ++ target- timeIO $- kojiWaitRepo dryrun True target nvr+ logMsg $ "Waiting for " ++ nvr ++ " to appear in " ++ target+ timeIO $ kojiWaitRepo dryrun True knowntag target nvr
src/Git.hs view
@@ -10,7 +10,7 @@ getNewerBranch, newerMergeable, gitFetchSilent,- gitPushSilent,+ gitPush, gitRepoName, Commit(commitRef,commitLog), showCommit,@@ -35,11 +35,11 @@ import Data.Char (isSpace) import SimpleCmd.Git+import SimplePrompt import Branches import Common import Common.System-import Prompt #if !MIN_VERSION_simple_cmd(0,2,2) -- | 'gitBool c args' runs git command and return result@@ -125,9 +125,9 @@ 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)+gitShortLogN :: Maybe Int -> Maybe String -> IO [Commit]+gitShortLogN mnum mrange =+ map mkCommit <$> gitLines "log" (["--max-count=" ++ show num | num <- maybeToList mnum] ++ "--pretty=reference": maybeToList mrange) gitShortLog1 :: Maybe String -> IO (Maybe Commit) gitShortLog1 mrange = do@@ -148,12 +148,24 @@ (plogcs,datep) -> Commit hash (init $ tail $ trim plogcs) (init datep) -gitPushSilent :: Maybe String -> IO ()-gitPushSilent mref = do+gitPush :: Bool -> Maybe String -> IO ()+gitPush quiet mref = do checkOnBranch- putStr "git pushing... "- out <- cmdQuiet "git" $ ["push", "--quiet", "origin"] ++ maybeToList mref- putStrLn $ if null out then "done" else "\n" ++ out+ when quiet $+ putStr "git pushing... "+ -- Can error like this:+ -- kex_exchange_identification: Connection closed by remote host+ -- Connection closed by 38.145.60.17 port 22+ -- fatal: Could not read from remote repository.+ let args = ["push"] ++ ["--quiet" | quiet] ++ ["origin"] ++ maybeToList mref+ (ok, _out, err) <- cmdFull "git" args ""+ if ok+ then putStrLn $ if quiet then "done" else last (lines err)+ else do+ when quiet $ putStrLn ""+ putStrLn $ unwords ("git" : args) +-+ "failed with\n" ++ err+ yes <- yesno Nothing "Retry git push"+ when yes $ gitPush quiet mref -- FIXME use this in more places gitRepoName :: IO String
src/Koji.hs view
@@ -32,6 +32,7 @@ import Data.Fixed (Micro) import Distribution.Koji import qualified Distribution.Koji.API as Koji+import SimplePrompt import System.Exit import System.Process.Typed import System.Timeout (timeout)@@ -44,7 +45,6 @@ import Krb import Package (fedpkg, Package, unPackage) import Pagure-import Prompt import Types fedoraHub :: String@@ -112,7 +112,8 @@ -- 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+ if ret == ExitSuccess+ then do let kojiurl = B.unpack $ last $ B.words out task = (TaskId . read) $ takeWhileEnd isDigit kojiurl when wait $ do@@ -141,7 +142,11 @@ mst <- kojiGetTaskState fedoraHub task case mst of Just TaskClosed -> return ()- Just TaskFailed -> error' "Task failed!"+ Just TaskFailed -> do+ let kojitool = "/usr/bin/koji-tool"+ whenM (doesFileExist kojitool) $+ cmd_ kojitool ["tasks", displayID task, "--tail", "-s", "fail"]+ error' "Task failed!" Just TaskCanceled -> return () _ -> kojiWatchTask task @@ -188,11 +193,31 @@ Left task <- kojiBuildBranch' False target pkg mref args return task -kojiWaitRepo :: Bool -> Bool -> String -> String -> IO ()-kojiWaitRepo dryrun quiet target nvr = do- Just (buildtag,_desttag) <- kojiBuildTarget fedoraHub target- unless dryrun $- waitRepo buildtag Nothing+kojiWaitRepo :: Bool -> Bool -> Bool -> String -> String -> IO ()+kojiWaitRepo dryrun quiet knowntag target nvr = do+ Just (buildtag,desttag) <- kojiBuildTarget fedoraHub target+ unless dryrun $ do+ mlatest <- kojiLatestNVR buildtag (nameOfNVR nvr)+ if Just nvr == mlatest+ then waitRepo buildtag Nothing+ else do+ tags <- cmdLines "koji" ["list-tags", "--build=" ++ nvr]+ if knowntag+ then do+ putStrLn $ "current tags:" +-+ unwords tags+ waitRepo buildtag Nothing+ else do+ mbuilt <- kojiLatestNVR desttag (nameOfNVR nvr)+ if mbuilt == Just nvr+ then do+ sleep 40+ kojiWaitRepo dryrun quiet knowntag target nvr+ else do+ putStrLn $ "current tags:" +-+ unwords tags+ unless (buildtag `elem` tags) $ do+ putStrLn $ "no" +-+ nvr +-+ "tagged" +-+ buildtag+ prompt_ "Press Enter to continue anyway"+ waitRepo buildtag Nothing where waitRepo :: String -> Maybe Struct -> IO () waitRepo buildtag moldrepo = do@@ -273,7 +298,7 @@ putStrLn out let sidetag = init . dropWhileEnd (/= '\'') $ dropPrefix "Side tag '" out- logMsg $ "waiting for " ++ sidetag ++ " repo"+ logMsg $ "Waiting for " ++ sidetag ++ " repo" unless dryrun $ cmd_ "koji" ["wait-repo", sidetag] return sidetag
src/Main.hs view
@@ -78,11 +78,16 @@ , Subcommand "merge" "Merge from newer branch" $ mergeCmd <$> dryrunOpt+ <*> switchLongWith "no-fetch" "Skip git fetch" <*> 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 "unpushed" "Show unpushed commits" $+ unpushedCmd+ <$> switchWith 'l' "latest" "Only show latest unpushed commit"+ <*> branchesPackages , Subcommand "build" "Build package(s) in Koji" $ buildCmd <$> buildOpts@@ -124,6 +129,7 @@ , Subcommand "waitrepo" "Wait for build to appear in Koji buildroot" $ waitrepoCmd <$> dryrunOpt+ <*> pure False <*> waitfetchOpt <*> optional (sidetagTargetOpt Nothing) <*> branchesPackages@@ -135,7 +141,7 @@ <*> noFailFastOpt <*> optional archesOpt <*> many (sidetagTargetOpt Nothing)- <*> optional (strOptionWith 'r' "ref" "COMMITHASH" "git commit to build")+ <*> optional scratchSourceOpt <*> branchesPackages , Subcommand "scratch-aarch64" "Koji aarch64 scratch build of package" $ scratchCmdAarch64@@ -143,7 +149,7 @@ <*> rebuildSrpmOpt <*> switchWith 'X' "exclude-arch" "Exclude aarch64" <*> many (sidetagTargetOpt Nothing)- <*> optional (strOptionWith 'r' "ref" "COMMITHASH" "git commit to build")+ <*> optional scratchSourceOpt <*> branchesPackages , Subcommand "scratch-x86_64" "Koji x86_64 scratch build of package" $ scratchCmdX86_64@@ -151,7 +157,7 @@ <*> rebuildSrpmOpt <*> switchWith 'X' "exclude-arch" "Exclude x86_64" <*> many (sidetagTargetOpt Nothing)- <*> optional (strOptionWith 'r' "ref" "COMMITHASH" "git commit to build")+ <*> optional scratchSourceOpt <*> branchesPackages , Subcommand "update-version" "Update package in dist-git to newer version" $ updateCmd@@ -180,9 +186,14 @@ srpmCmd <$> switchWith 'f' "force" "regenerate even if spec older than existing srpm" <*> maybeBranchPackages False+ , Subcommand "srpm-spec" "Show the spec file in an srpm" $+ srpmSpecCmd+ <$> switchWith 'd' "diff" "Compare with current spec file"+ <*> some (strArg "SRPM") , Subcommand "diff" "Diff local changes" $ diffCmd- <$> switchWith 'o' "spec-only" "Only diff spec file"+ <$> switchWith 'd' "debug" "use package headers"+ <*> switchWith 'o' "spec-only" "Only diff spec file" <*> diffWorkOpt <*> diffFormatOpt <*> switchWith 'i' "ignore-bumps" "Ignore pure release bumps"@@ -204,9 +215,11 @@ mockCmd <$> switchWith 'n' "dry-run" "Do not build (but creates srpm)" <*> optional nocleanOpt- <*> switchWith 'w' "network" "Use network during build"- <*> switchWith 's' "shell" "Enter chroot shell after building"+ <*> switchWith 'N' "network" "Use network during build"+ <*> optional (flagLongWith' ShellOnly "shell-only" "Skip mock build" <|>+ flagWith' BuildShell 's' "shell" "Enter chroot shell after building") <*> optional (optionWith branchM 'r' "root" "BRANCH" "Mock config to use")+ <*> optional archOpt <*> branchesPackages , Subcommand "install-deps" "Install package build dependencies" $ installDepsCmd@@ -220,6 +233,7 @@ <*> optional forceshortOpt <*> many bcondOpt <*> switchWith 'r' "reinstall" "reinstall rpms"+ <*> switchWith 'B' "ignore-builddeps" "do not install builddeps" <*> switchWith 'a' "all-subpackages" "install all subpackages (default if none currently installed)" <*> maybeBranchPackages False , Subcommand "not-installed" "Packages not installed locally" $@@ -233,6 +247,8 @@ bumpPkgs <$> switchWith 'l' "local" "Use local origin rather than checking latest koji" <*> optional commitOpts+ <*> optional (strOptionWith 'c' "changelog" "CLOGENTRY"+ "Override changelog entry [default: rebuild]") <*> branchesPackages , Subcommand "commit" "Git commit packages" $ commitPkgs@@ -249,10 +265,16 @@ <$> manyPackages , Subcommand "push" "Git push packages" $ pushPkgs- <$> branchesPackages+ <$> dryrunOpt+ <*> switchLongWith "no-fetch" "Skip git fetch"+ <*> optional (strOptionWith 'r' "ref" "COMMITHASH" "git commit to push")+ <*> branchesPackages , Subcommand "owner" "List package owner(s)" $ ownerCmd <$> manyPackages+ , Subcommand "bzusers" "Search bugzilla users" $+ bzusersCmd+ <$> strArg "NAME" , Subcommand "create-review" "Create a Package Review request" $ createReview <$> scratchOpt@@ -333,6 +355,14 @@ <|> FtbfsSubstring <$> strOptionWith 's' "substring" "STRING" "Component substring") <*> maybeBranchPackages False+ , Subcommand "autospec" "Convert package to use rpmautospec" $+ autospecCmd+ <$> switchWith 'f' "force" "Refresh changelog file to current"+ <*> manyPackages+ , Subcommand "move-artifacts" "Move old rpm artifacts into rpmbuild dirs" $+ moveArtifactsCmd+ <$> switchWith 'd' "delete" "Remove duplicate artifacts"+ <*> manyPackages ] where cloneRequest :: Parser CloneRequest@@ -449,7 +479,7 @@ mockOpt brs = switchWith 'm' "mock" $ "Do mock build to test" ++ if brs then " branches" else "" archOpt :: Parser String- archOpt = strOptionWith 'a' "arch" "ARCH[,ARCH].." "build for arch(s)"+ archOpt = strOptionWith 'a' "arch" "ARCH" "build for arch(s)" rebuildSrpmOpt = switchWith 'S' "rebuild-srpm" "rebuild srpm in Koji" @@ -581,6 +611,11 @@ scratchOpt = ScratchTask <$> optionWith auto 's' "scratch-build" "TASKID" "Existing scratch build taskid" <|> flagWith ScratchBuild SkipScratch 'S' "no-scratch" "Skip scratch build"++ scratchSourceOpt :: Parser ScratchSource+ scratchSourceOpt =+ ScratchSRPM <$> strOptionLongWith "srpm" "SRPM" "SRPM to use" <|>+ ScratchRef <$> strOptionWith 'r' "ref" "COMMITHASH" "git commit to build" nocleanOpt :: Parser NoClean nocleanOpt =
src/Package.hs view
@@ -39,18 +39,19 @@ packageSpec, pkgNameVerRel, pkgNameVerRel',- equivNVR+ equivNVR,+ editSpecField ) where import Distribution.Fedora hiding (Fedora,EPEL,EPELNext) import SimpleCmd.Rpm+import SimplePrompt import Branches import Common import Common.System import Git import Krb-import Prompt fedpkg :: String -> [String] -> IO String fedpkg c args =@@ -70,7 +71,7 @@ clog <- cleanChangelog spec putNewLn putStrLn "```"- putStrLn clog+ putStr clog putStrLn "```" -- FIXME is this actually useful? tty <- isTty@@ -161,7 +162,7 @@ -- newly created Fedora repos/branches have just one README commit initialPkgRepo :: IO Bool initialPkgRepo = do- commits <- length <$> gitShortLogN 2 Nothing+ commits <- length <$> gitShortLogN (Just 2) Nothing return $ commits <= 1 newtype Package = Package {unPackage :: String}@@ -455,3 +456,7 @@ -- toPackage (IsPkg p) = p -- toPackage (Unknown p) = p -- toPackage (IsBr b) = error' $ "can't map branch to package: " ++ show b++editSpecField :: String -> String -> FilePath -> IO ()+editSpecField field new spec =+ cmd_ "sed" ["-i", "-e s/^\\(" ++ field ++ ":\\s\\+\\).*/\\1" ++ new ++ "/", spec]
− src/Prompt.hs
@@ -1,50 +0,0 @@-module Prompt (- prompt,- prompt_,- yesno- ) where--import Data.Char (isPrint)--import Common-import Common.System---- import System.Console.Haskeline-import System.IO---- FIXME promptNonEmpty-prompt :: String -> IO String-prompt s = do- -- -- doesn't work in emacs-vterm :(- -- runInputT defaultSettings loop- -- where- -- loop :: InputT IO String- -- loop = do- -- minput <- getInputLine $ s ++ ": "- -- case minput of- -- Nothing -> return ""- -- Just input -> return input- putStr $ s ++ ": "- tty <- openFile "/dev/tty" ReadMode- inp <- hGetLine tty- if all isPrint inp- then return inp- else do- warning $- "input rejected because of unprintable character(s): '" ++- show inp ++ "'"- prompt s--prompt_ :: String -> IO ()-prompt_ = void <$> prompt---- 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/RpmBuild.hs view
@@ -12,6 +12,7 @@ isShortCircuit, checkSourcesMatch, notInstalled,+ rpmEval ) where @@ -21,6 +22,7 @@ import Distribution.Fedora hiding (Fedora,EPEL,EPELNext) import Network.HTTP.Directory (Manager, httpExists, httpManager) import SimpleCmd.Rpm+import SimplePrompt (prompt_) import System.Console.Pretty import System.IO.Extra (withTempDir) import System.Posix.Files@@ -30,7 +32,6 @@ import Common.System import Git import Package-import Prompt (prompt_) builtRpms :: AnyBranch -> FilePath -> IO [FilePath] builtRpms br spec = do@@ -233,11 +234,13 @@ args = sourcediropt ++ ["--define", "dist " ++ rpmDistTag dist] ++ buildopt ++ map show bconds ++ [spec] date <- cmd "date" ["+%T"]- putStr $ date ++ " Building " ++ takeBaseName spec ++ " locally... "+ rbr <- anyBranchToRelease br+ nvr <- pkgNameVerRel' rbr spec+ putStr $ date ++ " Building " ++ nvr ++ " locally... " ok <- do- rbr <- anyBranchToRelease br- nvr <- pkgNameVerRel' rbr spec let buildlog = ".build-" ++ (showVerRel . nvrVerRel . readNVR) nvr <.> "log"+ whenM (doesFileExist buildlog) $+ copyFile buildlog (buildlog <.> "prev") timeIO $ if not quiet || isShortCircuit mforceshort then do@@ -255,7 +258,7 @@ else cmd_ "tail" ["-n 100", buildlog] return res unless ok $- error' $ takeBaseName spec ++ " failed to build"+ error' $ nvr ++ " failed to build" return needBuild where quoteArg :: String -> String