diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,48 @@ ## next - 'repoquery': new experimental command +## 1.1 (2022-04-30) +- parallel: show target as early as possible +- status: warn if branch does not exist rather than erroring +- new 'ftbfs' command: lists FTBFS bugs +- build,parallel: add --template to support bodhi update templates +- local: --quiet option to suppress the rpmbuild output +- sort: add --chain (#25) and --layers +- Prompt: reject input with escape sequence chars +- Package checkLookasideCache: accept old md5 hashes in sources too +- merge: fetch newer branch if not local +- merge: accept HEAD in conflict prompt +- parallel: more output improvement tweaks +- Package getSources: canonicalize %_sourcedir +- Package: make sure rpmautospec is installed if needed +- Package: support %autochangelog +- build: fix --no-waitrepo short option to be '-W' +- Bugzilla readIniConfig: include ini filename in parser error +- build: extractBugReference require 7 digits RH bug id +- Package buildRPMs: only override dir macros if not dist-git +- Prompt: only allow printable chars in input (703a575) +- Branches listOfBranches: return branches for non-distgit +- build: --override now takes number of days (#31) +- scratch now requires a target or branch for non dist-git +- build no longer offers to merge unmergeable +- override no longer git fetches again when doing wait-repo +- switch: fix branch handling for multiple packages +- print duration of builds, etc +- parallel package now returns to original branch like build +- override: make sure a spec file exists +- commit: change '-u' to '-a' (all) and '-a' to '-A' (amend) +- request-branch: don't use full path for package name +- prep, srpm, local, scratch, mock: respect _builddir, _rpmdir, _srcrpmdir +- Main: most commands take PKGPATH not PACKAGE name +- build,parallel: add --severity (#32) +- build: changelog lines can contain multiple bzs +- build: simplify update type logic to detect pkgreview again and print +- request-branch: always print urls +- Git: isPkgGitRepo now ignores dist-git fork +- Package buildRequires: use installMissingMacros for dyn BR +- clone: --branch option is now an optional arg +- mock: --no-clean* fix and tweak + ## 1.0.0 (2022-02-21) - rpm's _sourcedir is now acts as a source cache directory: sources are in the package dir, but may be hardlinks to _sourcedir diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -96,7 +96,7 @@ One can change the branch of one or more packages: ``` -$ fbrnch switch f35 [package] ... +$ fbrnch switch f36 [package] ... ``` You can also git pull over packages: @@ -144,13 +144,13 @@ You can merge branches with: ``` -$ fbrnch merge f34 package +$ fbrnch merge f35 package ``` -which will offer to merge f35 (or some of it) into f34. +which will offer to merge f36 (or some of it) into f35. Merging can also be done together with building: ``` -$ fbrnch build f35 package +$ fbrnch build f36 package ``` will ask if you want to merge newer commits from a newer branch, then push and build it. @@ -233,7 +233,7 @@ ``` $ fbrnch --version -1.0.0 +1.1 $ fbrnch --help Fedora branch building tool @@ -288,6 +288,7 @@ rename-rawhide Rename local 'master' branch to 'rawhide' count Count number of living packages graph Output dependency graph + ftbfs Check FTBFS status ``` ## Installation @@ -326,6 +327,19 @@ - git - ssh & scp (for uploading package reviews) - bugzilla API key + +## Bugzilla API key +fbrnch can share the API of the python-bugzilla CLI tool, +placed either in `~/.config/python-bugzilla/bugzillarc` or `~/.bugzillarc`: + +``` +[bugzilla.redhat.com] +api_key = PASTE_YOUR_APIKEY_HERE + +``` + +You can create your key at +. ## Known issues - parallel builds will push local package commits without asking diff --git a/fbrnch.cabal b/fbrnch.cabal --- a/fbrnch.cabal +++ b/fbrnch.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: fbrnch -version: 1.0.0 +version: 1.1 synopsis: Build and create Fedora package repos and branches description: fbrnch (fedora branch) is a convenient packaging tool for @@ -52,6 +52,7 @@ Cmd.Commit Cmd.Copr Cmd.Diff + Cmd.FTBFS Cmd.Import Cmd.Install Cmd.ListBranches @@ -107,6 +108,7 @@ extra, fedora-dists >= 2.0, filepath, + -- haskeline, http-conduit, http-directory >= 0.1.5, http-query, diff --git a/src/Bodhi.hs b/src/Bodhi.hs --- a/src/Bodhi.hs +++ b/src/Bodhi.hs @@ -4,7 +4,8 @@ bodhiCreateOverride, bodhiTestingRepo, checkAutoBodhiUpdate, - UpdateType(..) + UpdateType(..), + UpdateSeverity(..) ) where @@ -12,7 +13,6 @@ import Data.Aeson.Key (fromText) #endif import Data.Aeson.Types (Object, (.:), parseEither) -import Data.Char (toLower) import Fedora.Bodhi hiding (bodhiUpdate) import Text.Read import qualified Text.ParserCombinators.ReadP as R @@ -64,23 +64,49 @@ Just obj -> error' $ show obj data UpdateType = - SecurityUpdate | BugfixUpdate | EnhancementUpdate | NewPackageUpdate + SecurityUpdate | BugfixUpdate | EnhancementUpdate | NewPackageUpdate | + TemplateUpdate + deriving Eq instance Show UpdateType where show SecurityUpdate = "security" show BugfixUpdate = "bugfix" show EnhancementUpdate = "enhancement" show NewPackageUpdate = "newpackage" + show TemplateUpdate = error "template update" instance Read UpdateType where readPrec = do s <- look - case map toLower s of + case lower s of "security" -> RP.lift (R.string s) >> return SecurityUpdate "bugfix" -> RP.lift (R.string s) >> return BugfixUpdate "enhancement" -> RP.lift (R.string s) >> return EnhancementUpdate "newpackage" -> RP.lift (R.string s) >> return NewPackageUpdate + "template" -> RP.lift (R.string s) >> return TemplateUpdate _ -> error' "unknown bodhi update type" >> RP.pfail + +data UpdateSeverity = + SeverityLow | SeverityMedium | SeverityHigh | SeverityUrgent | + SeverityUnspecified + deriving Eq + +instance Show UpdateSeverity where + show SeverityLow = "low" + show SeverityMedium = "medium" + show SeverityHigh = "high" + show SeverityUrgent = "urgent" + show SeverityUnspecified = "unspecified" + +instance Read UpdateSeverity where + readPrec = do + s <- look + case lower s of + "low" -> RP.lift (R.string s) >> return SeverityLow + "medium" -> RP.lift (R.string s) >> return SeverityMedium + "high" -> RP.lift (R.string s) >> return SeverityHigh + "urgent" -> RP.lift (R.string s) >> return SeverityUrgent + _ -> error' "unknown bodhi update severity" >> RP.pfail bodhiTestingRepo :: Branch -> IO (Maybe String) bodhiTestingRepo Rawhide = return Nothing diff --git a/src/Branches.hs b/src/Branches.hs --- a/src/Branches.hs +++ b/src/Branches.hs @@ -92,7 +92,8 @@ locals <- cmdLines "git" ["branch", "--list", "--format=%(refname:lstrip=-1)"] return $ locals \\ ["HEAD", "master"] else do - origins <- filter ("origin/" `isPrefixOf`) <$> cmdLines "git" ["branch", "--remote", "--list", "--format=%(refname:lstrip=-2)"] + origins <- filter ("origin/" `isPrefixOf`) <$> + cmdLines "git" ["branch", "--remote", "--list", "--format=%(refname:lstrip=-2)"] return $ map (removePrefix "origin/") origins \\ ["HEAD", "master"] pagurePkgBranches :: String -> IO [String] @@ -127,15 +128,17 @@ listOfBranches distgit _active (BranchOpt AllBranches) = if distgit then fedoraBranches (localBranches False) - else error' "--all-branches only allowed for dist-git packages" + else getFedoraBranches listOfBranches distgit _active (BranchOpt AllFedora) = + filter isFedoraBranch <$> if distgit - then filter isFedoraBranch <$> fedoraBranches (localBranches False) - else error' "--all-fedora only allowed for dist-git packages" + then fedoraBranches (localBranches False) + else getFedoraBranches listOfBranches distgit _active (BranchOpt AllEPEL) = + filter isEPELBranch <$> if distgit - then filter isEPELBranch <$> fedoraBranches (localBranches False) - else error' "--all-epel only allowed for dist-git packages" + then fedoraBranches (localBranches False) + else getFedoraBranches listOfBranches distgit _ (BranchOpt (ExcludeBranches brs)) = do branches <- if distgit then fedoraBranches (localBranches False) diff --git a/src/Bugzilla.hs b/src/Bugzilla.hs --- a/src/Bugzilla.hs +++ b/src/Bugzilla.hs @@ -10,9 +10,12 @@ bugsAnon, bugIdsAnon, bzAnonSession, + bzApiKeySession, bzReviewSession, bzReviewAnon, + bzBugMaybe, getBzUser, + getBzAccountId, reviewBugIdSession, approvedReviewBugIdSession, approvedReviewBugSession, @@ -36,6 +39,9 @@ statusNewModified, statusOpen, summaryContains, + versionIs, + ftbfsFedoraBugs, + componentSubStr, -- comments Comment, checkForComment, @@ -57,6 +63,7 @@ putBugVer, putReviewBug, putBugId, + putBugURLStatus, -- request newBzRequest, makeTextItem @@ -125,16 +132,25 @@ encodeParams ((k,v):ps) = (B.pack k, fromString v) : encodeParams ps +-- FIXME check original status? putBugBuild :: Bool -> BugzillaSession -> BugId -> String -> IO () putBugBuild dryrun session bid nvr = do unless dryrun $ void $ updateBug session bid [("cf_fixed_in", nvr), ("status", "MODIFIED")] - putStrLn $ "build posted to review bug " ++ show bid + putStrLn $ "bug " ++ show bid ++ (if dryrun then " would be" else "") ++ " moved to MODIFIED with " ++ nvr brc :: T.Text brc = "bugzilla.redhat.com" +bzBugMaybe :: BugzillaSession -> SearchExpression -> IO (Maybe Bug) +bzBugMaybe session query = do + bugs <- searchBugs session query + return $ case bugs of + [] -> Nothing + [bug] -> Just bug + _ -> error' "more that one bug found" + bzReviewAnon :: IO (Maybe BugId) bzReviewAnon = do pkg <- getDirectoryName @@ -282,6 +298,17 @@ summaryContains keywrd = SummaryField `contains` T.pack keywrd +versionIs :: String -> SearchExpression +versionIs v = + VersionField .==. T.pack v + +ftbfsFedoraBugs :: SearchExpression +ftbfsFedoraBugs = summaryContains "FTBFS in Fedora" + +componentSubStr :: String -> SearchExpression +componentSubStr substr = + ComponentField .=~. [T.pack substr] + bugIdsAnon :: SearchExpression -> IO [BugId] bugIdsAnon = searchBugs' bzAnonSession @@ -337,7 +364,10 @@ readIniConfig :: FilePath -> IniParser a -> (a -> b) -> IO b readIniConfig inifile iniparser fn = do ini <- T.readFile inifile - return $ either error fn $ parseIniFile ini iniparser + return $ + case parseIniFile ini iniparser of + Left err -> error' $ err ++ "\nin " ++ inifile + Right res -> fn res sortBugsByID :: [Bug] -> [Bug] sortBugsByID = sortOn bugId @@ -404,6 +434,11 @@ putBugId bid = putStrLn $ "https://" <> T.unpack brc <> "/show_bug.cgi?id=" <> show bid +putBugURLStatus :: Bug -> IO () +putBugURLStatus bug = do + putStr $ "https://" <> T.unpack brc <> "/show_bug.cgi?id=" <> show (bugId bug) + T.putStrLn $ " (" <> bugStatus bug <> ")" + -- uniq for lists dropDuplicates :: Eq a => [a] -> [a] dropDuplicates (x:xs) = @@ -430,3 +465,17 @@ let req = setRequestCheckStatus $ newBzRequest session ["user"] [makeTextItem "match" user] lookupKey' "users" . getResponseBody <$> httpJSON req + +getBzAccountId :: BugzillaSession -> Maybe String -> IO T.Text +getBzAccountId session muser = do + case muser of + Nothing -> getBzUser + Just userid -> + if emailIsValid userid then return $ T.pack userid + else do + users <- listBzUsers session userid + case users of + [] -> error' $ "No user found for " ++ userid + [obj] -> return $ T.pack $ lookupKey' "email" obj + objs -> error' $ "Found multiple user matches: " ++ + unwords (map (lookupKey' "email") objs) diff --git a/src/Cmd/Bugs.hs b/src/Cmd/Bugs.hs --- a/src/Cmd/Bugs.hs +++ b/src/Cmd/Bugs.hs @@ -6,6 +6,7 @@ bugsCmd :: Maybe String -> [String] -> IO () bugsCmd keyword pkgs = do if null pkgs + -- FIXME check for distgit then bugsPkg "." else mapM_ bugsPkg pkgs where diff --git a/src/Cmd/Build.hs b/src/Cmd/Build.hs --- a/src/Cmd/Build.hs +++ b/src/Cmd/Build.hs @@ -3,7 +3,6 @@ module Cmd.Build ( buildCmd, BuildOpts(..), - UpdateType(..), ) where import Common @@ -26,24 +25,26 @@ { buildoptMerge :: Maybe Bool , buildoptNoFailFast :: Bool , buildoptTarget :: Maybe String - , buildoptOverride :: Bool + , buildoptOverride :: Maybe Int , buildoptWaitrepo :: Maybe Bool , buildoptDryrun :: Bool - , buildoptUpdateType :: Maybe UpdateType + , buildoptUpdate :: (Maybe UpdateType, UpdateSeverity) , buildoptUseChangelog :: Bool , buildoptByPackage :: Bool } +-- FIXME check bugs before building? +-- FIXME --sidetag -- FIXME --sort -- FIXME --add-to-update nvr --- FIXME --rpmlint (only run for rawhide?) +-- FIXME --rpmlint (default for rawhide?) -- FIXME support --wait-build=NVR -- FIXME build from ref -- FIXME provide direct link to failed task/build.log -- FIXME --auto-override for deps in testing -- FIXME -B fails to find new branches (fixed?) --- FIXME --ignore-dirty?? -- FIXME disallow override for autoupdate? +-- FIXME count remaining packages buildCmd :: BuildOpts -> (BranchesReq, [String]) -> IO () buildCmd opts (breq, pkgs) = do let singleBrnch = if isJust (buildoptTarget opts) @@ -65,6 +66,9 @@ buildBranch _ _ _ (OtherBranch _) = error' "build only defined for release branches" buildBranch mlastpkg opts pkg rbr@(RelBranch br) = do + let moverride = buildoptOverride opts + whenJust moverride $ \days -> + when (days < 1) $ error "override duration must be positive number of days" gitSwitchBranch rbr gitMergeOrigin br newrepo <- initialPkgRepo @@ -76,9 +80,12 @@ Just False -> return False Just True -> mergeBranch True True (ancestor,unmerged) br >> return True Nothing -> - if newrepo || tty + if ancestor && (newrepo || tty) then mergeBranch True False (ancestor,unmerged) br >> return True - else return False + else do + unless (br == Rawhide) $ + putStrLn "newer branch is not ancestor" + return False let spec = packageSpec pkg checkForSpecFile spec checkSourcesMatch spec @@ -103,7 +110,6 @@ let mtarget = buildoptTarget opts target = fromMaybe (branchTarget br) mtarget mwaitrepo = buildoptWaitrepo opts - override = buildoptOverride opts case buildstatus of Just BuildComplete -> do putStrLn $ nvr ++ " is already built" @@ -112,15 +118,16 @@ when (br /= Rawhide && isNothing mtarget) $ 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 mbug spec nvr unless (any (`elem` tags) [show br, show br ++ "-updates", show br ++ "-override"]) $ - when override $ - bodhiCreateOverride dryrun Nothing nvr + whenJust moverride $ \days -> + bodhiCreateOverride dryrun (Just days) nvr when (isJust mlastpkg && mlastpkg /= Just pkg || mwaitrepo == Just True) $ - when ((override && mwaitrepo /= Just False) || + when ((isJust moverride && mwaitrepo /= Just False) || (autoupdate && mwaitrepo == Just True)) $ kojiWaitRepo dryrun target nvr Just BuildBuilding -> do @@ -176,7 +183,7 @@ unless dryrun $ kojiBuildBranch target pkg mbuildref ["--fail-fast" | not (buildoptNoFailFast opts)] mBugSess <- - if firstBuild + if firstBuild && isJust (fst (buildoptUpdate opts)) then bzReviewSession else return Nothing autoupdate <- checkAutoBodhiUpdate br @@ -185,34 +192,46 @@ \ (bid,session) -> putBugBuild dryrun session bid nvr else do when (isNothing mtarget) $ do + whenJust (fmap fst mBugSess) $ + \bid -> putStr "review bug: " >> putBugId bid -- FIXME diff previous changelog? bodhiUpdate dryrun (fmap fst mBugSess) spec nvr -- FIXME prompt for override note - when override $ - bodhiCreateOverride dryrun Nothing nvr + whenJust moverride $ \days -> + bodhiCreateOverride dryrun (Just days) nvr when (isJust mlastpkg && mlastpkg /= Just pkg || mwaitrepo == Just True) $ - when ((override && mwaitrepo /= Just False) || + when ((isJust moverride && mwaitrepo /= Just False) || (autoupdate && mwaitrepo == Just True)) $ kojiWaitRepo dryrun target nvr where bodhiUpdate :: Bool -> Maybe BugId -> FilePath -> String -> IO () bodhiUpdate dryrun mreview spec nvr = do - changelog <- if isJust mreview - then getSummaryURL spec - else if buildoptUseChangelog opts - then cleanChangelog spec - else changeLogPrompt (Just "update") spec - let cbugs = mapMaybe extractBugReference $ lines changelog - bugs = let bids = [show rev | Just rev <- [mreview]] ++ cbugs in - if null bids then [] else ["--bugs", intercalate "," bids] - -- FIXME also query for open existing bugs - case buildoptUpdateType opts of - Nothing -> return () - Just updateType -> do - putStrLn $ "Creating Bodhi Update for " ++ nvr ++ ":" + case buildoptUpdate opts of + (Nothing, _) -> return () + (Just updateType, severity) -> do unless dryrun $ do -- use cmdLog to debug, but notes are not quoted - cmd_ "bodhi" (["updates", "new", "--type", if isJust mreview then "newpackage" else show updateType, "--request", "testing", "--notes", changelog, "--autokarma", "--autotime", "--close-bugs"] ++ bugs ++ [nvr]) + if updateType == TemplateUpdate + then cmd_ "fedpkg" ["update"] + else do + -- FIXME also query for open existing bugs + changelog <- if isJust mreview + then getSummaryURL spec + else if buildoptUseChangelog opts + then cleanChangelog spec + else + -- FIXME list open bugs + changeLogPrompt (Just "update") spec + 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 " ++ nvr ++ ":" + -- 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 ++ [nvr]) + -- FIXME avoid this if we know the update URL updatequery <- bodhiUpdates [makeItem "display_user" "0", makeItem "builds" nvr] case updatequery of [] -> do @@ -224,9 +243,13 @@ Just uri -> putStrLn uri _ -> error' $ "impossible happened: more than one update found for " ++ nvr - extractBugReference :: String -> Maybe String - extractBugReference clog = - let rest = dropWhile (/= '#') clog in - if null rest then Nothing - else let bid = takeWhile isDigit $ tail rest in - if null bid then Nothing else Just bid + extractBugReferences :: String -> [String] + extractBugReferences clog = + case dropWhile (/= '#') clog of + "" -> [] + rest -> + case span isDigit (tail rest) of + (ds,more) -> + -- make sure is contemporary 7-digit bug + (if length ds > 6 then (ds :) else id) $ + extractBugReferences more diff --git a/src/Cmd/Clone.hs b/src/Cmd/Clone.hs --- a/src/Cmd/Clone.hs +++ b/src/Cmd/Clone.hs @@ -8,18 +8,20 @@ import Package import Pagure -data CloneRequest = CloneUser (Maybe String) | ClonePkgs [String] +data CloneRequest = CloneUser (Maybe String) + | ClonePkgs (Maybe Branch, [String]) -- FIXME allow pagure repo wildcard -- FIXME (detect commit rights or a ssh key?) -cloneCmd :: Maybe Branch -> CloneRequest -> IO () -cloneCmd mbr request = do - pkgs <- case request of +cloneCmd :: CloneRequest -> IO () +cloneCmd request = do + (mbr,pkgs) <- case request of CloneUser mid -> do userid <- maybe fasIdFromKrb return mid - map (takeFileName . T.unpack) <$> pagureUserRepos srcfpo userid + ps <- map (takeFileName . T.unpack) <$> pagureUserRepos srcfpo userid + return (Nothing, ps) -- FIXME detect/prevent "path/dir" - ClonePkgs ps -> return ps + ClonePkgs mbps -> return mbps mfas <- maybeFasIdFromKrb - let cloneuser = maybe AnonClone (const UserClone) mfas - mapM_ (clonePkg False cloneuser mbr) pkgs + let auth = maybe AnonClone (const UserClone) mfas + mapM_ (clonePkg False auth mbr) pkgs diff --git a/src/Cmd/Commit.hs b/src/Cmd/Commit.hs --- a/src/Cmd/Commit.hs +++ b/src/Cmd/Commit.hs @@ -9,8 +9,10 @@ import Package import Prompt +-- FIXME reject if nvr ahead of newer branch -- FIXME use branches after all? -- FIXME handle multiline changelog entries with "-m description" +-- FIXME --undo last change: eg undo accidential --amend commitPkgs :: Maybe CommitOpt -> Bool -> Bool -> [String] -> IO () commitPkgs mopt firstLine notstaged args = do when (isJust mopt && firstLine) $ diff --git a/src/Cmd/Copr.hs b/src/Cmd/Copr.hs --- a/src/Cmd/Copr.hs +++ b/src/Cmd/Copr.hs @@ -34,6 +34,7 @@ -- FIXME --exclude-arch -- FIXME skip existing builds -- FIXME distless srpm +-- FIXME time builds? coprCmd :: Bool -> Bool -> BuildBy -> Maybe Archs -> String -> (BranchesReq,[String]) -> IO () coprCmd dryrun listchroots buildBy marchs project (breq, pkgs) = do @@ -102,14 +103,14 @@ staggerBuilds srpm initialChroots remainingChroots removeArch relarch = init $ dropWhileEnd (/= '-') relarch - takeArch relarch = takeWhileEnd (/= '-') relarch + takeArch = takeWhileEnd (/= '-') staggerBuilds srpm initialChroots remainingChroots = do mapM_ (coprBuild dryrun project srpm) initialChroots unless (null remainingChroots) $ coprBuild dryrun project srpm remainingChroots - releaseArch relarch = takeWhileEnd (/= '-') relarch + releaseArch = takeWhileEnd (/= '-') isArch arch release = releaseArch release == arch diff --git a/src/Cmd/FTBFS.hs b/src/Cmd/FTBFS.hs new file mode 100644 --- /dev/null +++ b/src/Cmd/FTBFS.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Cmd.FTBFS ( + ftbfsCmd, + FTBFSBugs(..) + ) +where + +import Branches +import Bugzilla +import Common +import Common.System +import qualified Common.Text as T +import Koji +import Package + +data FTBFSBugs = FtbfsUser (Maybe String) | FtbfsSubstring String + +-- FIXME option for status filter +-- FIXME check arch +ftbfsCmd :: Bool -> Bool -> Maybe FTBFSBugs -> (Maybe Branch, [FilePath]) + -> IO () +ftbfsCmd dryrun short mbugsopt (mbr,pkgs) = do + case mbugsopt of + Just bugsopt -> do + unless (null pkgs) $ + error' "please use bugs option without listing a package" + session <- bzApiKeySession + bugs <- + case bugsopt of + FtbfsUser muser -> do + accountid <- getBzAccountId session muser + searchBugs session (query .&&. assigneeIs accountid) + FtbfsSubstring substr -> + searchBugs session (query .&&. componentSubStr substr) + mapM_ (ftbfsBugs session) bugs + Nothing -> + mapM_ ftbfsPkg $ if null pkgs then ["."] else pkgs + where + bugComponents :: Bug -> String + bugComponents bug = + case bugComponent bug of + [component] -> T.unpack component + _ -> error' $ "multiple components!\n" ++ show bug + + query = + ftbfsFedoraBugs .&&. + case mbr of + Nothing -> statusNewPost + Just br -> statusNewPost .&&. versionIs (branchVersion br) + + ftbfsBugs :: BugzillaSession -> Bug -> IO () + ftbfsBugs session bug = do + let pkg = bugComponents bug + handleBug session pkg (Package pkg) bug + + ftbfsPkg :: FilePath -> IO () + ftbfsPkg path = do + pkg <- getPackageName path + session <- bzApiKeySession + mbug <- bzBugMaybe session $ pkgBugs (unPackage pkg) .&&. query + whenJust mbug $ handleBug session path pkg + + handleBug :: BugzillaSession -> FilePath -> Package -> Bug -> IO () + handleBug session path pkg bug = do + if short then + putStrLn $ unPackage pkg + else do + putStr $ unPackage pkg ++ ": " + let br = fromMaybe Rawhide mbr + exists <- doesDirectoryExist path + if not exists + then putBug bug + else do + nvr <- withExistingDirectory path $ + localBranchSpecFile pkg (RelBranch br) >>= + -- FIXME handle %autorelease correctly here + pkgNameVerRel' br + mstatus <- kojiBuildStatus nvr + case mstatus of + Nothing -> do + putStrLn $ nvr ++ ": unknown status" + putBug bug + Just status -> do + print status + case status of + BuildFailed -> do + cmdLog "koji-tool" ["tasks", "-T", "-s", "fail", "-b", nvr] + putChar '\n' + BuildComplete -> do + if bugStatus bug `elem` ["NEW", "ASSIGNED", "POST"] + then do + when dryrun $ putBug bug + putBugBuild dryrun session (bugId bug) nvr + putChar '\n' + else do + putBugURLStatus bug + putChar '\n' + _ -> return () diff --git a/src/Cmd/Local.hs b/src/Cmd/Local.hs --- a/src/Cmd/Local.hs +++ b/src/Cmd/Local.hs @@ -20,9 +20,9 @@ import Git import Package --- FIXME generate build.log files -localCmd :: Maybe ForceShort -> [BCond] -> (BranchesReq, [String]) -> IO () -localCmd mforceshort bconds = +localCmd :: Bool -> Maybe ForceShort -> [BCond] -> (BranchesReq, [String]) + -> IO () +localCmd quiet mforceshort bconds = withPackageByBranches Nothing Nothing ZeroOrOne localBuildPkg where localBuildPkg :: Package -> AnyBranch -> IO () @@ -31,7 +31,7 @@ rpms <- if isJust mforceshort then return [] else builtRpms br spec - void $ buildRPMs False mforceshort bconds rpms br spec + void $ buildRPMs quiet mforceshort bconds rpms br spec installDepsCmd :: (Maybe Branch,[String]) -> IO () installDepsCmd = diff --git a/src/Cmd/Merge.hs b/src/Cmd/Merge.hs --- a/src/Cmd/Merge.hs +++ b/src/Cmd/Merge.hs @@ -37,9 +37,9 @@ Just i -> branches !! (i - 1) Nothing -> error' $ show br ++ ": branch not found" --- FIXME newer branch might not exist (eg epel8): - -- restrict to local branches +-- FIXME maybe require local branch already here mergeable :: Branch -> IO (Bool,[String]) +mergeable Rawhide = return (False,[]) mergeable br = do newer <- getNewerBranch br locals <- localBranches True @@ -62,14 +62,21 @@ mapM_ putStrLn unpushed -- FIXME avoid Mass_Rebuild bumps mmerge <- - if isnewrepo && length unmerged == 1 || noprompt then return $ Just Nothing - else refPrompt unmerged $ "Press Enter to merge " ++ show newerBr ++ (if build then " and build" else "") ++ (if length unmerged > 1 then "; or give a ref to merge" else "") ++ "; or 'no' to skip merge" + if isnewrepo && length unmerged == 1 || noprompt + then return $ Just Nothing + else refPrompt unmerged $ "Press Enter to merge " ++ show newerBr ++ + (if build then " and build" else "") ++ + (if length unmerged > 1 then "; or give a ref to merge" else "") ++ + "; or 'no' to skip merge" -- ensure still on same branch! gitSwitchBranch (RelBranch br) whenJust mmerge $ \ mhash -> do let ref = case mhash of Nothing -> show newerBr Just hash -> hash + locals <- localBranches True + unless (show newerBr `elem` locals) $ + git_ "fetch" ["origin", show newerBr ++ ":" ++ show newerBr] git_ "merge" ["--quiet", ref] mergeBranch build noprompt (False,unmerged) br = do newer <- getNewerBranch br @@ -82,7 +89,7 @@ mapM_ putStrLn 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 to attempt merge" + 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 diff --git a/src/Cmd/Mock.hs b/src/Cmd/Mock.hs --- a/src/Cmd/Mock.hs +++ b/src/Cmd/Mock.hs @@ -15,9 +15,9 @@ data NoClean = NoCleanBefore | NoCleanAfter | NoCleanAll deriving Eq +-- FIXME add repo/copr for build -- FIXME handle non-release branches (on-branch works) -- FIXME option for --shell without rebuild --- FIXME add --no-clean-all mockCmd :: Bool -> Maybe NoClean -> Bool -> Bool -> Maybe Branch -> (BranchesReq, [String]) -> IO () mockCmd dryrun mnoclean network mockshell mroot (breq, ps) = do @@ -50,10 +50,10 @@ Nothing -> [] Just NoCleanBefore -> ["--no-clean"] Just NoCleanAfter -> ["--no-cleanup-after"] - Just NoCleanAll -> ["--no-cleanup-all"] + Just NoCleanAll -> ["--no-clean", "--no-cleanup-after"] 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"] + mockshell_opts = mockopts_common "--shell" ++ ["--no-clean" | "--no-clean" `notElem` noclean] if dryrun then do cmdN "mock" mockbuild_opts @@ -77,4 +77,4 @@ else gitSwitchBranch rbr >> return rbr ) spec <- findSpecfile - (pkgdir ) . takeFileName <$> generateSrpm (Just actualBr) spec + generateSrpm (Just actualBr) spec diff --git a/src/Cmd/Override.hs b/src/Cmd/Override.hs --- a/src/Cmd/Override.hs +++ b/src/Cmd/Override.hs @@ -17,9 +17,8 @@ unless nowait $ putStrLn "Overriding" withPackageByBranches (Just False) cleanGitFetchActive AnyNumber overrideBranch breqpkgs - unless nowait $ do - putStrLn "Waiting" - waitrepoCmd dryrun Nothing breqpkgs + unless nowait $ + waitrepoCmd False dryrun Nothing breqpkgs where overrideBranch :: Package -> AnyBranch -> IO () overrideBranch _ (OtherBranch _) = @@ -27,6 +26,7 @@ overrideBranch pkg rbr@(RelBranch br) = do gitSwitchBranch rbr let spec = packageSpec pkg + checkForSpecFile spec nvr <- pkgNameVerRel' br spec putStrLn nvr tags <- kojiNVRTags nvr diff --git a/src/Cmd/Parallel.hs b/src/Cmd/Parallel.hs --- a/src/Cmd/Parallel.hs +++ b/src/Cmd/Parallel.hs @@ -28,17 +28,19 @@ maybeTarget (Just (Target t)) = Just t maybeTarget _ = Nothing --- (pkg, (sidetag, nvr)) -type Job = (String, Async (String, String)) +-- (pkg, nvr) +type Job = (String, Async String) +-- FIXME print koji url of failed process or use koji-tool -- FIXME option to build multiple packages over branches in parallel -- FIXME use --wait-build=NVR -- FIXME check sources as early as possible -- FIXME --single-layer to build packages at once regardless --- FIXME Haskell subpackages require release bump even with version bump -parallelBuildCmd :: Bool -> Int -> Maybe SideTagTarget -> Maybe UpdateType +-- FIXME time builds +parallelBuildCmd :: Bool -> Int -> Maybe SideTagTarget + -> (Maybe UpdateType, UpdateSeverity) -> (BranchesReq, [String]) -> IO () -parallelBuildCmd dryrun firstlayer msidetagTarget mupdatetype (breq, pkgs) = do +parallelBuildCmd dryrun firstlayer msidetagTarget mupdate (breq, pkgs) = do branches <- case pkgs of [] -> do @@ -68,14 +70,11 @@ error' "You must use --target/--sidetag to build package layers for this branch" when (length branches > 1) $ putStrLn $ "# " ++ show rbr - -- FIXME: pass remaining layers for failure error - targets <- mapM (parallelBuild rbr) + target <- targetMaybeSidetag rbr + mapM_ (parallelBuild target rbr) $ zip [firstlayer..length allLayers] $ init $ tails layers -- tails ends in [] - when (isJust msidetagTarget && null targets && not dryrun) $ - error' "No target was returned from jobs!" - unless (isNothing msidetagTarget || null targets || dryrun) $ do - let target = head targets + unless (isNothing msidetagTarget || dryrun) $ do when (target /= branchTarget rbr) $ do notes <- prompt $ "Enter notes to submit Bodhi update for " ++ target bodhiSidetagUpdate target notes @@ -83,22 +82,27 @@ parallelBranches :: [Branch] -> IO () parallelBranches brs = do krbTicket - putStrLn $ "= Building " ++ show (length brs) ++ " branches in parallel:" + currentbranch <- gitCurrentBranch + putStrLn $ "= Building " ++ pluralException (length brs) "branch" "branches" ++ " in parallel:" putStrLn $ unwords $ map show brs jobs <- mapM setupBranch brs - (failures,_mtarget) <- watchJobs Nothing [] jobs + failures <- watchJobs [] jobs + -- switch back to the original branch + when (length brs /= 1) $ + gitSwitchBranch currentbranch unless (null failures) $ error' $ "Build failures: " ++ unwords failures where setupBranch :: Branch -> IO Job setupBranch br = do - job <- startBuild False False br "." >>= async + target <- targetMaybeSidetag br + job <- startBuild False False target br "." >>= async unless dryrun $ sleep 3 return (show br,job) - parallelBuild :: Branch -> (Int,[[String]]) -> IO String - parallelBuild _ (_,[]) = return "" -- should not reach here - parallelBuild br (layernum, layer:nextLayers) = do + parallelBuild :: String -> Branch -> (Int,[[String]]) -> IO () + parallelBuild _ _ (_,[]) = return () -- should not reach here + parallelBuild target br (layernum, layer:nextLayers) = do krbTicket putStrLn $ "\n= Building parallel layer #" ++ show layernum ++ if nopkgs > 1 @@ -113,45 +117,48 @@ [l] -> plural l "package" _ -> show layerspkgs ++ " packages" jobs <- mapM setupBuild layer - (failures,mtarget) <- watchJobs Nothing [] jobs + failures <- watchJobs [] jobs -- FIXME prompt to continue? unless (null failures) $ do let pending = sum $ map length nextLayers error' $ "Build failures in layer " ++ show layernum ++ ": " ++ unwords failures ++ "\n\n" ++ - show pending ++ " pending packages:\n" ++ - unwords (map unwords nextLayers) + show pending ++ " pending packages" ++ + if pending > 0 + then + ":\n" ++ unwords (map unwords nextLayers) + else "" when (null jobs) $ error' "No jobs run" - return $ fromMaybe (error' "No target determined") mtarget where nopkgs = length layer layersleft = length nextLayers setupBuild :: String -> IO Job setupBuild pkg = do - job <- startBuild (layersleft > 0) (nopkgs > 5) br pkg >>= async + job <- startBuild (layersleft > 0) (nopkgs > 5) target br pkg + >>= async unless dryrun $ sleep 3 return (pkg,job) - watchJobs :: Maybe String -> [String] -> [Job] -> IO ([String],Maybe String) - watchJobs mtarget fails [] = return (fails,mtarget) - watchJobs mtarget fails (job:jobs) = do + watchJobs :: [String] -> [Job] -> IO [String] + watchJobs fails [] = return fails + watchJobs fails (job:jobs) = do status <- poll (snd job) case status of - Nothing -> sleep 1 >> watchJobs mtarget fails (jobs ++ [job]) - Just (Right (target,nvr)) -> do - putStrLn $ color Yellow nvr ++ " job completed (" ++ show (length jobs) ++ " jobs left in layer)" - watchJobs (Just target) fails jobs + Nothing -> sleep 1 >> watchJobs fails (jobs ++ [job]) + Just (Right nvr) -> do + putStrLn $ color Yellow nvr ++ " job completed (" ++ show (length jobs) ++ " left in layer)" + watchJobs fails jobs Just (Left except) -> do print except let pkg = fst job - putStrLn $ "** " ++ color Magenta pkg ++ " job " ++ color Magenta "failed" ++ " ** (" ++ show (length jobs) ++ " jobs left in layer)" - watchJobs mtarget (pkg : fails) jobs + putStrLn $ "** " ++ color Magenta pkg ++ " job " ++ color Magenta "failed" ++ " ** (" ++ show (length jobs) ++ " left in layer)" + watchJobs (pkg : fails) jobs -- FIXME prefix output with package name - startBuild :: Bool -> Bool -> Branch -> String -> IO (IO (String,String)) - startBuild morelayers background br pkgdir = + startBuild :: Bool -> Bool -> String -> Branch -> String -> IO (IO String) + startBuild morelayers background target br pkgdir = withExistingDirectory pkgdir $ do gitSwitchBranch (RelBranch br) pkg <- getPackageName pkgdir @@ -166,21 +173,6 @@ unless dryrun $ gitPushSilent Nothing nvr <- pkgNameVerRel' br spec - target <- 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 - out <- head . lines <$> fedpkg "request-side-tag" [] - if "Side tag '" `isPrefixOf` out - then do - putStrLn out - return $ init . dropWhileEnd (/= '\'') $ dropPrefix "Side tag '" out - else error' "'fedpkg request-side-tag' failed" - [tag] -> return tag - _ -> error' $ "More than one user side-tag found for " ++ show br putStrLn $ nvr ++ " (" ++ target ++ ")" -- FIXME should compare git refs -- FIXME check for target @@ -198,20 +190,20 @@ return $ do when morelayers $ kojiWaitRepo dryrun target nvr - return (target,nvr) + return nvr Just BuildBuilding -> do putStrLn $ nvr ++ " is already building" return $ kojiGetBuildTaskID fedoraHub nvr >>= maybe (error' $ "Task for " ++ nvr ++ " not found") - (kojiWaitTaskAndRepo (isNothing mlatest) nvr target) + (kojiWaitTaskAndRepo (isNothing mlatest) nvr) _ -> do buildref <- git "show-ref" ["--hash", "origin/" ++ show br] opentasks <- kojiOpenTasks pkg (Just buildref) target case opentasks of [task] -> do putStrLn $ nvr ++ " task is already open" - return $ kojiWaitTaskAndRepo (isNothing mlatest) nvr target task + return $ kojiWaitTaskAndRepo (isNothing mlatest) nvr task (_:_) -> error' $ show (length opentasks) ++ " open " ++ unPackage pkg ++ " tasks already" [] -> do if equivNVR nvr (fromMaybe "" mlatest) @@ -219,13 +211,13 @@ else do -- FIXME parse build output if dryrun - then return (return (target,nvr)) + then return (return nvr) else do task <- kojiBuildBranchNoWait target pkg Nothing $ "--fail-fast" : ["--background" | background] - return $ kojiWaitTaskAndRepo (isNothing mlatest) nvr target task + return $ kojiWaitTaskAndRepo (isNothing mlatest) nvr task where - kojiWaitTaskAndRepo :: Bool -> String -> String -> TaskID -> IO (String,String) - kojiWaitTaskAndRepo newpkg nvr target task = do + kojiWaitTaskAndRepo :: Bool -> String -> TaskID -> IO String + kojiWaitTaskAndRepo newpkg nvr task = do finish <- kojiWaitTask task if finish then putStrLn $ color Green $ nvr ++ " build success" @@ -245,15 +237,39 @@ bodhiCreateOverride dryrun Nothing nvr when morelayers $ kojiWaitRepo dryrun target nvr - return (target,nvr) + return nvr bodhiSidetagUpdate :: String -> String -> IO () bodhiSidetagUpdate sidetag notes = do - case mupdatetype of - Nothing -> return () - Just updateType -> do + case mupdate of + (Nothing, _) -> return () + (Just updateType, severity) -> do putStrLn $ "Creating Bodhi Update for " ++ sidetag - ok <- cmdBool "bodhi" ["updates", "new", "--type", show updateType , "--request", "testing", "--notes", if null notes then "to be written" else notes, "--autokarma", "--autotime", "--close-bugs", "--from-tag", sidetag] + ok <- + if updateType == TemplateUpdate + then do + putStrLn "Paste update template now:" + template <- getContents + cmdBool "bodhi" ["updates", "new", "--file", template, "--from-tag", sidetag] + 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] when ok $ do prompt_ "After editing update, press Enter to remove sidetag" fedpkg_ "remove-side-tag" [sidetag] + + 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 + out <- head . lines <$> fedpkg "request-side-tag" ["--base-tag", show br ++ "-build"] + if "Side tag '" `isPrefixOf` out + then do + putStrLn out + return $ init . dropWhileEnd (/= '\'') $ dropPrefix "Side tag '" out + else error' "'fedpkg request-side-tag' failed" + [tag] -> return tag + _ -> error' $ "More than one user side-tag found for " ++ show br diff --git a/src/Cmd/PkgReview.hs b/src/Cmd/PkgReview.hs --- a/src/Cmd/PkgReview.hs +++ b/src/Cmd/PkgReview.hs @@ -130,6 +130,7 @@ -- FIXME does not work with pkg dir/spec: -- 'fbrnch: No spec file found' +-- FIXME: option to only download/prep files reviewPackage :: Maybe String -> IO () reviewPackage mpkg = do -- FIXME if spec file exists use it directly diff --git a/src/Cmd/Prep.hs b/src/Cmd/Prep.hs --- a/src/Cmd/Prep.hs +++ b/src/Cmd/Prep.hs @@ -17,7 +17,7 @@ prepCmd :: Maybe PrepPre -> Bool -> (Maybe Branch,[String]) -> IO () prepCmd mpre verbose (mbr,pkgs) = do when (mpre == Just PrepClone) $ - cloneCmd mbr (ClonePkgs pkgs) + cloneCmd (ClonePkgs (mbr, pkgs)) withPackagesMaybeBranchNoHeadergit ZeroOrOne prepPackage (mbr,pkgs) where prepPackage :: Package -> AnyBranch -> IO () @@ -34,38 +34,14 @@ spec <- localBranchSpecFile pkg br unlessM (doesFileExist spec) $ error' $ spec ++ " not found" - cwd <- getCurrentDirectory void $ getSources spec installMissingMacros spec - gitDir <- isGitRepo - let rpmdirs = - [ "--define="++ mcr +-+ cwd | gitDir, - mcr <- ["_builddir", "_sourcedir"]] - args = rpmdirs ++ ["-bp", spec] case br of RelBranch rbr -> do nvr <- pkgNameVerRel' rbr spec -- newline avoids error starting on same line putStr $ "Prepping " ++ nvr ++ ": " _ -> return () - (if verbose then cmdLog else cmdSilent') "rpmbuild" args + timeIO $ + (if verbose then cmdLog else cmdSilent') "rpmbuild" ["-bp", spec] putStrLn "done" - - -srpmMacros :: [(String,String)] -srpmMacros = - [("%gometa", "go-rpm-macros"), - ("fontpkgname", "fonts-rpm-macros"), - ("%cargo_prep", "rust-packaging")] - -needSrpmMacro :: FilePath -> (String,String) -> IO (Maybe String) -needSrpmMacro spec (meta, macros) = do - contents <- readFile spec - return $ if meta `isInfixOf` contents then Just macros else Nothing - -installMissingMacros :: FilePath -> IO () -installMissingMacros spec = do - macros <- mapMaybeM (needSrpmMacro spec) srpmMacros - missing <- filterM notInstalled macros - unless (null missing) $ - cmd_ "/usr/bin/sudo" $ ["/usr/bin/dnf", "install", "--assumeyes"] ++ missing diff --git a/src/Cmd/RequestBranch.hs b/src/Cmd/RequestBranch.hs --- a/src/Cmd/RequestBranch.hs +++ b/src/Cmd/RequestBranch.hs @@ -17,15 +17,19 @@ -- FIXME option to do koji scratch build instead of mock requestBranches :: Bool -> (BranchesReq,[String]) -> IO () requestBranches mock (breq, ps) = do - if null ps then do + if null ps + then do isPkgGit <- isPkgGitSshRepo if isPkgGit then getDirectoryName >>= requestPkgBranches 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 - mapM_ (\ p -> withExistingDirectory p $ requestPkgBranches (length ps > 1) mock breq (Package p)) ps + else + forM_ ps $ \ p -> + withExistingDirectory p $ do + pkg <- getDirectoryName + requestPkgBranches (length ps > 1) mock breq (Package pkg) requestPkgBranches :: Bool -> Bool -> BranchesReq -> Package -> IO () requestPkgBranches multiple mock breq pkg = do @@ -40,11 +44,13 @@ when mock $ fedpkg_ "mockbuild" ["--root", mockRoot br] when multiple $ putStr (unPackage pkg ++ " ") when (length newbranches > 1) $ print 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 fedpkg "request-branch" [show br] - case mbidsession of - Just (bid,session) -> commentBug session bid - Nothing -> putStrLn - $ unlines urls + putStrLn $ unlines urls + whenJust mbidsession $ \(bid,session) -> + commentBug session bid $ unlines urls where filterExistingBranchRequests :: [Branch] -> IO [Branch] filterExistingBranchRequests branches = do @@ -53,7 +59,8 @@ when (br `elem` existing) $ putStrLn $ show br ++ " branch already exists" let brs' = branches \\ existing - if null brs' then return [] + if null brs' + then return [] else do current <- fedoraBranchesNoRawhide $ pagurePkgBranches (unPackage pkg) forM_ brs' $ \ br -> diff --git a/src/Cmd/RequestRepo.hs b/src/Cmd/RequestRepo.hs --- a/src/Cmd/RequestRepo.hs +++ b/src/Cmd/RequestRepo.hs @@ -57,7 +57,7 @@ -- FIXME check api key is still valid or open pagure ticket directly url <- fedpkg "request-repo" [pkg, show bid] let assignee = userRealName (bugAssignedToDetail bug) - let draft = "Thank you for the review" ++ maybe "" ((", " ++) . T.unpack) (getFirstname assignee) + let draft = "Thank you for the review" ++ maybe "" (", " ++) (getFirstname assignee) putStrLn "```" putStrLn draft putStrLn "```" @@ -91,9 +91,9 @@ error' $ "Repo for " ++ pkg ++ " already exists" -- FIXME handle "email name" - getFirstname :: T.Text -> Maybe T.Text + getFirstname :: T.Text -> Maybe String getFirstname t = let first = head (T.words t) in if "@" `T.isInfixOf` first then Nothing - else Just first + else Just (T.unpack first) diff --git a/src/Cmd/Scratch.hs b/src/Cmd/Scratch.hs --- a/src/Cmd/Scratch.hs +++ b/src/Cmd/Scratch.hs @@ -13,8 +13,6 @@ import Package import Types (Archs(..)) --- FIXME default to rawhide/main? --- FIXME build from a specific git ref -- FIXME allow multiple --target's (parallel too) scratchCmd :: Bool -> Bool -> Bool -> Maybe Archs -> Maybe String -> Maybe String -> (BranchesReq, [String]) -> IO () @@ -25,8 +23,12 @@ scratchBuild pkg br = do when (isJust mref && length pkgs > 1) $ error' "--ref is not supported for multiple packages" + pkggit <- isPkgGitRepo + when (not pkggit && breq == Branches [] && isNothing mtarget) $ + 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 @@ -36,7 +38,6 @@ tagArchs <- kojiTagArchs buildtag return $ tagArchs \\ as let kojiargs = ["--arch-override=" ++ intercalate "," archs | notNull archs] ++ ["--fail-fast" | not nofailfast && length archs /= 1] ++ ["--no-rebuild-srpm" | not rebuildSrpm] - pkggit <- isPkgGitRepo if pkggit then do gitSwitchBranch br @@ -54,7 +55,7 @@ else return False rbr <- anyBranchToRelease br nvr <- pkgNameVerRel' rbr spec - putStrLn $ "koji scratch build of " ++ fromMaybe nvr mref ++ (if pushed then "" else ".src.rpm") ++ " for " ++ target + 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 diff --git a/src/Cmd/Sort.hs b/src/Cmd/Sort.hs --- a/src/Cmd/Sort.hs +++ b/src/Cmd/Sort.hs @@ -1,14 +1,17 @@ module Cmd.Sort ( sortCmd, RpmWith(..), - graphCmd + graphCmd, + SortDisplay(..) ) where import Control.Monad.Extra +import Data.List (intercalate) import Distribution.RPM.Build.Graph import Distribution.RPM.Build.Order (dependencySortRpmOpts, - dependencySortParallel) + dependencySortParallel, + dependencyLayers) import Branches import Git @@ -16,15 +19,25 @@ data RpmWith = RpmWith String | RpmWithout String -sortCmd :: Bool -> Maybe RpmWith -> (Maybe Branch,[String]) -> IO () +data SortDisplay = SortParallel | SortChain | SortLayers | SortPlain + +sortCmd :: SortDisplay -> Maybe RpmWith -> (Maybe Branch,[String]) -> IO () sortCmd _ _ (_,[]) = return () -sortCmd parallel mrpmwith (mbr, pkgs) = do +sortCmd displaymode mrpmwith (mbr, pkgs) = do withPackagesMaybeBranchNoHeadergit ExactlyOne noop (mbr, pkgs) let rpmopts = maybe [] toRpmOption mrpmwith - if parallel + case displaymode of -- reverse because rpmbuild-order reverses the order of independent pkgs? - then dependencySortParallel (reverse pkgs) >>= mapM_ (putStrLn . unwords) - else dependencySortRpmOpts rpmopts (reverse pkgs) >>= putStrLn . unwords + SortParallel -> + dependencySortParallel (reverse pkgs) >>= mapM_ (putStrLn . unwords) + SortChain -> + dependencyLayers pkgs >>= + putStrLn . intercalate " : " . map unwords + SortLayers -> + dependencyLayers pkgs >>= + mapM_ (putStrLn . unwords) + SortPlain -> + dependencySortRpmOpts rpmopts (reverse pkgs) >>= putStrLn . unwords noop :: Package -> AnyBranch -> IO () noop _pkg br = diff --git a/src/Cmd/Status.hs b/src/Cmd/Status.hs --- a/src/Cmd/Status.hs +++ b/src/Cmd/Status.hs @@ -35,68 +35,74 @@ statusBranch _ (OtherBranch _) = error' "status currently only defined for release branches" statusBranch pkg rbr@(RelBranch br) = 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 " - gitShortLog1 Nothing >>= putStrLn - 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 - -- 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!" - putStrLn "" - else putStrLn $ show br ++ ": " ++ unpushed + 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 " + gitShortLog1 Nothing >>= putStrLn + 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 + -- 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!" + putStrLn "" + else putStrLn $ show br ++ ": " ++ unpushed where isStable :: [String] -> Bool isStable = not . all ("-testing" `isSuffixOf`) diff --git a/src/Cmd/Switch.hs b/src/Cmd/Switch.hs --- a/src/Cmd/Switch.hs +++ b/src/Cmd/Switch.hs @@ -8,6 +8,6 @@ switchCmd :: AnyBranch -> [String] -> IO () switchCmd br pkgs = -- FIXME use withBranchByPackages ? - withPackageByBranches Nothing dirtyGit ExactlyOne dummy (Branches [],pkgs) + withPackageByBranches Nothing dirtyGit Zero dummy (Branches [],pkgs) where dummy _ _ = gitSwitchBranch br diff --git a/src/Cmd/Update.hs b/src/Cmd/Update.hs --- a/src/Cmd/Update.hs +++ b/src/Cmd/Update.hs @@ -15,6 +15,7 @@ -- FIXME check EVR increased -- FIXME if multiple sources might need to bump release +-- FIXME Haskell subpackages require release bump even with version bump updateCmd :: Bool -> Bool -> Bool -> (Maybe Branch,[String]) -> IO () updateCmd onlysources force allowHEAD (mbr,args) = do pkgGit <- isPkgGitSshRepo diff --git a/src/Cmd/WaitRepo.hs b/src/Cmd/WaitRepo.hs --- a/src/Cmd/WaitRepo.hs +++ b/src/Cmd/WaitRepo.hs @@ -10,9 +10,9 @@ import Package -- FIXME first check/wait for build to actually exist -waitrepoCmd :: Bool -> Maybe String -> (BranchesReq, [String]) -> IO () -waitrepoCmd dryrun mtarget = do - withPackageByBranches (Just False) cleanGitFetchActive AnyNumber waitrepoBranch +waitrepoCmd :: Bool -> Bool -> Maybe String -> (BranchesReq, [String]) -> IO () +waitrepoCmd fetch dryrun mtarget = do + withPackageByBranches (Just False) (if fetch then cleanGitFetchActive else cleanGitActive) AnyNumber waitrepoBranch where waitrepoBranch :: Package -> AnyBranch -> IO () waitrepoBranch _ (OtherBranch _) = diff --git a/src/Common.hs b/src/Common.hs --- a/src/Common.hs +++ b/src/Common.hs @@ -8,10 +8,11 @@ (<>), #endif (+/+), - plural + plural, + pluralException ) where -import Control.Monad.Extra +import Control.Monad.Extra -- hiding (loop) import Data.List.Extra import Data.Maybe @@ -23,10 +24,13 @@ plural :: Int -> String -> String plural i ns = + pluralException i ns (ns ++ "s") + +pluralException :: Int -> String -> String -> String +pluralException i ns ps = mconcat [ show i, " ", - ns, - if i == 1 then "" else "s" + if i == 1 then ns else ps ] diff --git a/src/Common/System.hs b/src/Common/System.hs --- a/src/Common/System.hs +++ b/src/Common/System.hs @@ -11,8 +11,11 @@ isExtensionOf, #endif #if !MIN_VERSION_simple_cmd(0,2,3) - cmdFull + cmdFull, #endif +#if !MIN_VERSION_simple_cmd(0,2,5) + timeIO, +#endif ) where #if !MIN_VERSION_filepath(1,4,2) @@ -29,6 +32,21 @@ import System.Directory import System.FilePath import System.IO + +#if !MIN_VERSION_simple_cmd(0,2,5) +import Control.Exception +import Data.Time.Clock + +timeIO :: IO a -> IO a +timeIO action = do + bracket + getCurrentTime + (\start -> do + end <- getCurrentTime + let duration = diffUTCTime end start + putStrLn $ "took " ++ show duration) + (const action) +#endif isTty :: IO Bool isTty = hIsTerminalDevice stdin diff --git a/src/Git.hs b/src/Git.hs --- a/src/Git.hs +++ b/src/Git.hs @@ -20,6 +20,7 @@ isPkgGitSshRepo, checkWorkingDirClean, isGitDirClean, + checkIfRemoteBranchExists, CommitOpt (..), module SimpleCmd.Git ) where @@ -111,7 +112,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 + putStrLn $ if null filtered + then "done" + else "\n" ++ intercalate "\n" filtered checkWorkingDirClean :: IO () checkWorkingDirClean = do @@ -134,6 +137,8 @@ isPkgGitRepo :: IO Bool isPkgGitRepo = grepGitConfig' "\\(https://\\|@\\)\\(pkgs\\|src\\)\\." + &&^ + (not <$> grepGitConfig' "/forks/") isPkgGitSshRepo :: IO Bool isPkgGitSshRepo = grepGitConfig' "@\\(pkgs\\|src\\)\\." @@ -170,18 +175,20 @@ git_ "switch" ["-q", show br] else do -- check remote branch exists - remotebranch <- - ifM checkIfRemoteBranchExists - (return True) $ - gitFetchSilent >> checkIfRemoteBranchExists + remotebranch <- do + exists <- checkIfRemoteBranchExists br + if exists + then return True + else gitFetchSilent >> checkIfRemoteBranchExists br if not remotebranch then do name <- getDirectoryName error' $ name ++ " " ++ show br ++ " branch does not exist!" else git_ "checkout" ["-q", "-b", show br, "--track", "origin/" ++ show br] - where - checkIfRemoteBranchExists = - gitBool "show-ref" ["--verify", "--quiet", "refs/remotes/origin/" ++ show br] + +checkIfRemoteBranchExists :: AnyBranch -> IO Bool +checkIfRemoteBranchExists br = + gitBool "show-ref" ["--verify", "--quiet", "refs/remotes/origin/" ++ show br] data CommitOpt = CommitMsg String | CommitAmend diff --git a/src/Koji.hs b/src/Koji.hs --- a/src/Koji.hs +++ b/src/Koji.hs @@ -99,7 +99,7 @@ then error' "no args passed to koji build" else ".src.rpm" `isSuffixOf` last args -- FIXME use tee functionality - when srpm $ putStrLn "koji srpm build uploading..." + when srpm $ putStrLn "koji srpm build: uploading..." -- can fail like: -- [ERROR] koji: Request error: POST::https://koji.fedoraproject.org/kojihub/ssllogin:: -- [ERROR] koji: AuthError: unable to obtain a session @@ -113,7 +113,7 @@ let kojiurl = B.unpack $ last $ B.words out task = (TaskId . read) $ takeWhileEnd isDigit kojiurl when wait $ do - kojiWatchTask task + timeIO $ kojiWatchTask task cmd_ "date" ["+%T"] return $ if wait then Right kojiurl else Left task else do diff --git a/src/ListReviews.hs b/src/ListReviews.hs --- a/src/ListReviews.hs +++ b/src/ListReviews.hs @@ -8,9 +8,6 @@ ) where import Common -import Common.System -import qualified Common.Text as T -import Network.HTTP.Query import Branches import Bugzilla @@ -30,23 +27,11 @@ listReviewsAll :: Bool -> ReviewStatus -> IO [Bug] listReviewsAll = listReviewsFull False Nothing Nothing --- FIXME should not require login listReviewsFull :: Bool -> Maybe String -> Maybe String -> Bool -> ReviewStatus-> IO [Bug] listReviewsFull assignee muser mpat allopen status = do let session = bzAnonSession - accountid <- do - case muser of - Nothing -> getBzUser - Just userid -> - if emailIsValid userid then return $ T.pack userid - else do - users <- listBzUsers session userid - case users of - [] -> error' $ "No user found for " ++ userid - [obj] -> return $ T.pack $ lookupKey' "email" obj - objs -> error' $ "Found multiple user matches: " ++ - unwords (map (lookupKey' "email") objs) + accountid <- getBzAccountId session muser let reviews = (if assignee then assigneeIs else reporterIs) accountid .&&. maybe packageReview pkgReviewsPrefix mpat open = if allopen then statusOpen else diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -16,6 +16,7 @@ import Cmd.Commit import Cmd.Copr import Cmd.Diff +import Cmd.FTBFS import Cmd.Import import Cmd.Install import Cmd.ListBranches @@ -41,6 +42,7 @@ import Cmd.Update import Cmd.WaitRepo +import Bodhi (UpdateType(..),UpdateSeverity(..)) import Branches import Common.System import Git (CommitOpt(..)) @@ -56,8 +58,7 @@ subcommands [ Subcommand "clone" "clone packages" $ cloneCmd - <$> optional branchOpt - <*> cloneRequest + <$> cloneRequest , Subcommand "switch" "Switch branch" $ switchCmd <$> anyBranchArg @@ -95,7 +96,7 @@ <$> dryrunOpt <*> optionalWith auto 'l' "skip-to-layer" "LAYERNO" "Skip the first N layers [default 0]" 0 <*> optional sidetagTargetOpt - <*> updatetypeOpt + <*> updateOpt <*> branchesPackages , Subcommand "sidetags" "List user's side-tags" $ sideTagsCmd @@ -107,7 +108,7 @@ <*> switchWith 'w' "no-wait" "Skip waitrepo step" <*> branchesPackages , Subcommand "waitrepo" "Wait for build to appear in Koji buildroot" $ - waitrepoCmd + waitrepoCmd True <$> dryrunOpt <*> mtargetOpt <*> branchesPackages @@ -128,7 +129,7 @@ <*> maybeBranchPackages False , Subcommand "sort" "Sort packages in build dependency order" $ sortCmd - <$> switchWith 'p' "parallel" "Group dependent packages on separate lines" + <$> sortDisplayOpt <*> optional rpmWithOpt <*> maybeBranchPackages True , Subcommand "prep" "Prep sources" $ @@ -138,7 +139,8 @@ <*> maybeBranchPackages False , Subcommand "local" "Build locally" $ localCmd - <$> optional forceshortOpt + <$> switchWith 'q' "quiet" "Hide the build.log until it errors" + <*> optional forceshortOpt <*> many bcondOpt <*> branchesPackages , Subcommand "srpm" "Build srpm" $ @@ -196,7 +198,7 @@ commitPkgs <$> optional commitOpts <*> switchWith '1' "first-line" "use first line of changelog" - <*> switchWith 'u' "unstaged" "include unstaged changes" + <*> switchWith 'a' "unstaged" "include unstaged changes" <*> manyPackages , Subcommand "pull" "Git pull packages" $ pullPkgs @@ -273,16 +275,29 @@ -- , Subcommand "repoquery" "Repoquery branches (put repoquery options after '--')" $ -- repoqueryCmd -- <$> branchesPackages + , Subcommand "ftbfs" "Check FTBFS status" $ + ftbfsCmd + <$> dryrunOpt + <*> switchWith 'l' "short" "Only list packages" + <*> optional (flagWith' (FtbfsUser Nothing) 'M' "mine" "Your packages" + <|> + FtbfsUser . Just <$> strOptionWith 'U' "user" "USER" "Bugzilla userid" + <|> + FtbfsSubstring <$> strOptionWith 's' "substring" "STRING" "Component substring") + <*> maybeBranchPackages False ] where cloneRequest :: Parser CloneRequest - cloneRequest = flagWith' (CloneUser Nothing) 'M' "mine" "Your packages" <|> CloneUser . Just <$> strOptionWith 'u' "user" "USER" "Packages of FAS user" <|> ClonePkgs <$> somePackages + cloneRequest = + flagWith' (CloneUser Nothing) 'M' "mine" "Your packages" <|> + CloneUser . Just <$> strOptionWith 'u' "user" "USER" "Packages of FAS user" <|> + ClonePkgs <$> maybeBranchPackages True reviewShortOpt :: Parser Bool reviewShortOpt = switchWith 's' "short" "Only output the package name" reviewAllStatusOpt :: Parser Bool - reviewAllStatusOpt = switchWith 'A' "all-status" "all open reviews" + reviewAllStatusOpt = switchWith 'A' "all-status" "include all open states" reviewStatusOpt :: Parser ReviewStatus reviewStatusOpt = @@ -294,9 +309,6 @@ flagWith' ReviewUnbranched 'B' "unbranched" "Approved created package reviews not yet branched" <|> flagWith ReviewAllOpen ReviewBranched 'b' "branched" "Approved created package reviews already branched" - branchOpt :: Parser Branch - branchOpt = optionWith branchM 'b' "branch" "BRANCH" "branch" - branchArg :: Parser Branch branchArg = argumentWith branchM "BRANCH" @@ -316,10 +328,10 @@ pkgArg lbl = removeSuffix "/" <$> strArg lbl manyPackages :: Parser [String] - manyPackages = many (pkgArg "PACKAGE...") + manyPackages = many (pkgArg "PKGPATH...") - somePackages :: Parser [String] - somePackages = some (pkgArg "PACKAGE...") + -- somePackages :: Parser [String] + -- somePackages = some (pkgArg "PKGPATH...") branchesOpt :: Parser (Maybe BranchOpts) branchesOpt = @@ -340,8 +352,8 @@ maybeBranchPackages oneplus = maybeBranchesPkgs <$> if oneplus - then some (pkgArg "[BRANCH] PACKAGE...") - else many (pkgArg "[BRANCH] [PACKAGE]...") + then some (pkgArg "[BRANCH] PKGPATH...") + else many (pkgArg "[BRANCH] [PKGPATH]...") where maybeBranchesPkgs :: [String] -> (Maybe Branch,[String]) maybeBranchesPkgs args = @@ -353,7 +365,7 @@ branchesPackages :: Parser (BranchesReq, [String]) branchesPackages = - branchesReqPkgs <$> branchesOpt <*> many (pkgArg "BRANCH... PACKAGE...") + branchesReqPkgs <$> branchesOpt <*> many (pkgArg "BRANCH... PKGPATH...") where branchesReqPkgs :: Maybe BranchOpts -> [String] -> (BranchesReq, [String]) branchesReqPkgs mbrnchopts args = @@ -380,16 +392,33 @@ rebuildSrpmOpt = switchWith 's' "rebuild-srpm" "rebuild srpm in Koji" - buildOpts = BuildOpts <$> mergeOpt <*> noFailFastOpt <*> mtargetOpt <*> overrideOpt <*> waitrepoOpt <*> dryrunOpt <*> updatetypeOpt <*> useChangelogOpt <*> switchWith 'p' "by-package" "Build by each package across brs" - - useChangelogOpt = switchWith 'c' "changelog-notes" "Use spec changelog for Bodhi notes" + buildOpts = + BuildOpts + <$> mergeOpt + <*> noFailFastOpt + <*> mtargetOpt + <*> overrideOpt + <*> waitrepoOpt + <*> dryrunOpt + <*> updateOpt + <*> useChangelogOpt + <*> switchWith 'p' "by-package" "Build by each package across brs" + where + mergeOpt = + optional (flagWith' True 'm' "merge" "Merge without prompt" <|> + flagWith' False 'M' "no-merge" "No merging") + overrideOpt = + optional (optionWith auto 'o' "override" "DAYS" "Create buildroot override for specified days: implies --wait-repo") + waitrepoOpt = + optional (flagWith' True 'w' "waitrepo" "Waitrepo for each build" <|> + flagWith' False 'W' "no-waitrepo" "Do not waitrepo for each build") + useChangelogOpt = + switchWith 'c' "changelog-notes" "Use spec changelog for Bodhi notes" -- yesOpt = switchWith 'y' "yes" "Assume yes for questions" nopromptOpt = switchWith 'm' "no-prompt" "Merge without prompt" - mergeOpt = optional (flagWith' True 'm' "merge" "Merge without prompt" <|> - flagWith' False 'M' "no-merge" "No merging") noFailFastOpt = switchWith 'f' "no-fail-fast" "Do not --fail-fast" @@ -409,16 +438,29 @@ checkNotRawhide "rawhide" = error' "'rawhide' is not a valid target!" checkNotRawhide t = t - overrideOpt = switchWith 'o' "override" "Create a buildroot override: implies --wait-repo" - waitrepoOpt = - optional (flagWith' True 'w' "waitrepo" "Waitrepo for each build" <|> - flagWith' False 'M' "no-waitrepo" "Do not waitrepo for each build") - dryrunOpt = switchWith 'n' "dry-run" "Do not write (push, build, post, override)" - updatetypeOpt = flagWith' Nothing 'U' "no-update" "Do not generate a Bodhi update" <|> Just <$> optionalWith auto 'u' "update-type" "TYPE" "security, bugfix, enhancement (default), or newpackage" EnhancementUpdate + 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 + + updatePair :: Maybe UpdateType -> UpdateSeverity + -> (Maybe UpdateType, UpdateSeverity) + updatePair (Just SecurityUpdate) SeverityUnspecified = + error' "Security update requires specifying Severity" + updatePair Nothing sev | sev /= SeverityUnspecified = + error' "cannot have --severity with --no-update" + updatePair (Just TemplateUpdate) sev | sev /= SeverityUnspecified = + error' "Template update cannot have --severity" + updatePair t s = (t,s) + forceshortOpt = flagWith' ForceBuild 'f' "rebuild" "Rebuild even if already built" <|> flagWith' ShortCircuit 's' "short-circuit" "Do --short-circuit rpmbuild" @@ -441,8 +483,9 @@ commitOpts :: Parser CommitOpt commitOpts = - CommitMsg <$> strOptionWith 'm' "message" "COMMITMSG" "commit message" <|> - flagWith' CommitAmend 'a' "amend" "Amend commit" + CommitMsg <$> + strOptionWith 'm' "message" "COMMITMSG" "commit message" <|> + flagWith' CommitAmend 'A' "amend" "Amend commit" buildByOpt = flagWith' SingleBuild 'S' "single" "Non-progressive normal single build" <|> flagWith' BuildByRelease 'R' "by-release" "Builds by release" <|> flagWith ValidateByRelease ValidateByArch 'A' "by-arch" "Build across latest release archs first (default is across releases for primary arch)" @@ -473,3 +516,9 @@ 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" + + sortDisplayOpt :: Parser SortDisplay + sortDisplayOpt = + flagWith' SortParallel 'p' "parallel" "Group dependent packages on separate lines" + <|> flagWith' SortChain 'c' "chain" "chain-build output" + <|> flagWith SortPlain SortLayers 'l' "layers" "output parallel layers" diff --git a/src/Package.hs b/src/Package.hs --- a/src/Package.hs +++ b/src/Package.hs @@ -21,6 +21,7 @@ ForceShort(..), buildRPMs, installDeps, + installMissingMacros, checkSourcesMatch, getSources, putPkgHdr, @@ -33,6 +34,7 @@ withPackagesMaybeBranchNoHeadergit, LimitBranches(..), cleanGit, + cleanGitActive, cleanGitFetch, cleanGitFetchActive, dirtyGit, @@ -51,9 +53,6 @@ nameOfNVR ) where -import Common -import Common.System - import Data.Char (isDigit) import Data.Either (partitionEithers) import Data.RPM @@ -64,6 +63,8 @@ import System.Posix.Files import Branches +import Common +import Common.System import Git import InterleaveOutput import Krb @@ -104,10 +105,15 @@ cleanChangelog :: FilePath -> IO String cleanChangelog spec = do - cs <- cmd "rpmspec" ["-q", "--srpm", "--qf", "%{changelogtext}", spec] - let ls = lines cs - no = length $ filter ("- " `isPrefixOf`) ls - return $ if no == 1 then removePrefix "- " cs else cs + autochangelog <- grep_ "^%autochangelog" spec + ls <- + if autochangelog + then takeWhile (not . null) . drop 1 <$> + cmdLines "rpmautospec" ["generate-changelog", spec] + else cmdLines "rpmspec" ["-q", "--srpm", "--qf", "%{changelogtext}", spec] + return $ case filter ("- " `isPrefixOf`) ls of + [l] -> removePrefix "- " l + _ -> unlines ls getSummaryURL :: FilePath -> IO String getSummaryURL spec = do @@ -186,21 +192,22 @@ Just br -> do dist <- getBranchDist br return ["--define", "dist " ++ rpmDistTag dist] - srpmfile <- cmd "rpmspec" $ ["-q", "--srpm"] ++ distopt ++ ["--qf", "%{name}-%{version}-%{release}.src.rpm", spec] + msrcrpmdir <- rpmEval "%{_srcrpmdir}" + srpmfile <- cmd "rpmspec" $ ["-q", "--srpm"] ++ distopt ++ ["--qf", fromMaybe "" msrcrpmdir "%{name}-%{version}-%{release}.src.rpm", spec] cwd <- getCurrentDirectory - let srpmdiropt = ["--define", "_srcrpmdir " ++ cwd] - sourcediropt = ["--define", "_sourcedir " ++ cwd] + let sourcediropt = ["--define", "_sourcedir " ++ cwd] + opts = distopt ++ sourcediropt if force then - buildSrpm (distopt ++ srpmdiropt ++ sourcediropt) + buildSrpm opts else do exists <- doesFileExist srpmfile if not exists - then buildSrpm (distopt ++ srpmdiropt ++ sourcediropt) + then buildSrpm opts else do srpmTime <- getModificationTime srpmfile fileTimes <- mapM getModificationTime (spec:srcs) if any (srpmTime <) fileTimes - then buildSrpm (distopt ++ srpmdiropt ++ sourcediropt) + then buildSrpm opts else do -- pretty print with ~/ putStrLn $ srpmfile ++ " is up to date" @@ -242,24 +249,21 @@ void $ getSources spec dist <- getBranchDist br cwd <- getCurrentDirectory - gitDir <- isGitRepo let shortcircuit = mforceshort == Just ShortCircuit let buildopt = if shortcircuit then ["-bi", "--short-circuit"] else ["-bb"] - rpmdirs = - [ "--define="++ mcr +-+ cwd | gitDir, - mcr <- ["_builddir", "_rpmdir", "_srcrpmdir", "_sourcedir"]] - args = rpmdirs ++ ["--define", "dist " ++ rpmDistTag dist] ++ + sourcediropt = ["--define", "_sourcedir " ++ cwd] + args = sourcediropt ++ ["--define", "dist " ++ rpmDistTag dist] ++ buildopt ++ map show bconds ++ [spec] ok <- if not quiet || shortcircuit then do rbr <- anyBranchToRelease br nvr <- pkgNameVerRel' rbr spec - pipeBool ("rpmbuild", args) ("tee", [".build-" ++ showNVRVerRel (readNVR nvr) <.> "log"]) + timeIO $ pipeBool ("rpmbuild", args) ("tee", [".build-" ++ showNVRVerRel (readNVR nvr) <.> "log"]) else do date <- cmd "date" ["+%T"] putStr $ date ++ " Building " ++ takeBaseName spec ++ " locally... " - res <- cmdSilentBool "rpmbuild" args + res <- timeIO $ cmdSilentBool "rpmbuild" args when res $ putStrLn "done" return res unless ok $ @@ -274,6 +278,24 @@ putStrLn $ "Running 'dnf install' " ++ unwords missingdeps cmd_ "/usr/bin/sudo" $ "/usr/bin/dnf":"install": ["--skip-broken" | not strict] ++ ["--assumeyes"] ++ missingdeps +installMissingMacros :: FilePath -> IO () +installMissingMacros spec = do + macros <- mapMaybeM needSrpmMacro srpmMacros + missing <- filterM notInstalled macros + unless (null missing) $ + cmd_ "/usr/bin/sudo" $ ["/usr/bin/dnf", "install", "--assumeyes"] ++ missing + where + srpmMacros :: [(String,String)] + srpmMacros = + [("%gometa", "go-rpm-macros"), + ("fontpkgname", "fonts-rpm-macros"), + ("%cargo_prep", "rust-packaging")] + + needSrpmMacro :: (String,String) -> IO (Maybe String) + needSrpmMacro (meta, macros) = do + contents <- readFile spec + return $ if meta `isInfixOf` contents then Just macros else Nothing + checkSourcesMatch :: FilePath -> IO () checkSourcesMatch spec = do -- "^[Ss]ource[0-9]*:" @@ -293,33 +315,37 @@ where checkLookasideCache :: Manager -> String -> String -> IO () checkLookasideCache mgr pkg source = do - case words source of - ("SHA512":('(':fileparen):"=":[hash]) -> do - let file = dropSuffix ")" fileparen - url = "https://src.fedoraproject.org/lookaside/pkgs" +/+ pkg +/+ file +/+ "sha512" +/+ hash +/+ file - unlessM (httpExists mgr url) $ do - putStrLn $ url ++ " not found" - putStrLn $ "uploading " ++ file ++ " to lookaside source repo" - fedpkg_ "upload" [file] - _ -> error' $ "invalid/unknown source:\n" ++ source + let (file,url) = + case words source of + ("SHA512":('(':fileparen):"=":[hash]) -> + let file' = dropSuffix ")" fileparen + in (file', "https://src.fedoraproject.org/lookaside/pkgs" +/+ pkg +/+ file +/+ "sha512" +/+ hash +/+ file) + [hash,file'] -> + (file', "https://src.fedoraproject.org/lookaside/pkgs" +/+ pkg +/+ file +/+ "md5" +/+ hash +/+ file) + _ -> error' $ "invalid/unknown source:\n" ++ source + unlessM (httpExists mgr url) $ do + putStrLn $ url ++ " not found" + putStrLn $ "uploading " ++ file ++ " to lookaside source repo" + fedpkg_ "upload" [file] getSources :: FilePath -> IO [FilePath] getSources spec = do - gitDir <- isGitRepo - cwd <- getCurrentDirectory -- FIXME fallback to ~/rpmbuild/SOURCES? msrcdir <- do + cwd <- getCurrentDirectory msourcedir <- rpmEval "%{_sourcedir}" case msourcedir of Nothing -> return Nothing - Just srcdir -> - if msourcedir == Just cwd + Just srcdir -> do + canon <- canonicalizePath srcdir + if canon == cwd then return Nothing else do dir <- doesDirectoryExist srcdir if dir then return msourcedir else return Nothing + gitDir <- isGitRepo (patches,srcs) <- partitionEithers . map sourceFieldFile <$> cmdLines "spectool" ["-a", spec] forM_ srcs $ \ src -> do @@ -396,10 +422,11 @@ doesFileExist (srcdir file) withExistingDirectory :: FilePath -> IO a -> IO a -withExistingDirectory dir act = - ifM (doesDirectoryExist dir) - (withCurrentDirectory dir act) - (error' $ "No such directory: " ++ dir) +withExistingDirectory dir act = do + exists <- doesDirectoryExist dir + if exists + then withCurrentDirectory dir act + else error' $ "No such directory: " ++ dir -- newly created Fedora repos/branches have just one README commit initialPkgRepo :: IO Bool @@ -494,9 +521,10 @@ , gitOptHEAD :: Bool -- allow detached head/rebase state } -cleanGit, cleanGitFetch, cleanGitFetchActive, dirtyGit, dirtyGitFetch, dirtyGitHEAD :: Maybe GitOpts +cleanGit, cleanGitActive, cleanGitFetch, cleanGitFetchActive, dirtyGit, dirtyGitFetch, dirtyGitHEAD :: Maybe GitOpts -- clean fetch active HEAD cleanGit = Just $ GitOpts True False False False +cleanGitActive = Just $ GitOpts True False True False cleanGitFetch = Just $ GitOpts True True False False cleanGitFetchActive = Just $ GitOpts True True True False dirtyGit = Just $ GitOpts False False False False @@ -627,10 +655,9 @@ fasid <- fasIdFromKrb msgout git_ "clone" $ ["--quiet"] ++ mbranch ++ ["ssh://" ++ fasid ++ "@pkgs.fedoraproject.org/rpms/" ++ pkg <.> "git"] - putStrLn "" where msgout = - putStr $ if quiet then "cloning..." else "Cloning: " ++ pkg + putStrLn $ if quiet then "cloning..." else "Cloning: " ++ pkg pkgNameVerRel :: Branch -> FilePath -> IO (Maybe String) pkgNameVerRel br spec = do @@ -642,7 +669,9 @@ fmap (replace hostdist disttag) . listToMaybe <$> if autorelease then do - -- FIXME use ? + mautospec <- findExecutable "rpmautospec" + when (isNothing mautospec) $ + error' "requires rpmautospec.." autorel <- last . words <$> cmd "rpmautospec" ["calculate-release", spec] rpmspec ["--srpm"] (Just ("%{name}-%{version}-" ++ autorel ++ disttag)) spec else rpmspec ["--srpm"] (Just "%{name}-%{version}-%{release}") spec @@ -674,16 +703,19 @@ -- from fedora-haskell-tools buildRequires :: FilePath -> IO [String] buildRequires spec = do + autorelease <- grep_ " %autorelease" spec dynbr <- grep_ "^%generate_buildrequires" spec - mapMaybe primary <$> + brs <- mapMaybe primary <$> if dynbr then do + installMissingMacros spec out <- cmdIgnoreErr "rpmbuild" ["-br", "--nodeps", spec] "" -- Wrote: /current/dir/SRPMS/name-version-release.buildreqs.nosrc.rpm cmdLines "rpm" ["-qp", "--requires", last (words out)] else -- FIXME should resolve meta rpmspec ["--buildrequires"] Nothing spec + return $ brs ++ ["rpmautospec" | autorelease] where primary dep = case (head . words) dep of diff --git a/src/Prompt.hs b/src/Prompt.hs --- a/src/Prompt.hs +++ b/src/Prompt.hs @@ -5,19 +5,35 @@ conflictPrompt ) where +import Data.Char (isPrint) + import Common +import Common.System -import Data.Char +-- 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 - putStrLn "" - return inp + if all isPrint inp + then return inp + else do + warning $ "input rejected because of unprintable character(s): " ++ + filter (not . isPrint) inp + prompt s prompt_ :: String -> IO () prompt_ = void <$> prompt @@ -28,7 +44,7 @@ let commitrefs = tail $ map (head . words) commits ref <- prompt txt if null ref then return (Just Nothing) else - if map toLower ref == "no" then return Nothing + if lower ref == "no" then return Nothing else if ref `elem` commitrefs then return $ Just (Just ref) else refPrompt commits txt @@ -41,4 +57,6 @@ if null ref then return Nothing else if ref `elem` commitrefs then return $ Just ref - else conflictPrompt commits txt + else if lower ref == "head" + then return $ Just $ head commitrefs + else conflictPrompt commits txt