fbrnch 1.0.0 → 1.1
raw patch · 35 files changed
+768/−363 lines, 35 files
Files
- CHANGELOG.md +42/−0
- README.md +19/−5
- fbrnch.cabal +3/−1
- src/Bodhi.hs +30/−4
- src/Branches.hs +9/−6
- src/Bugzilla.hs +51/−2
- src/Cmd/Bugs.hs +1/−0
- src/Cmd/Build.hs +58/−35
- src/Cmd/Clone.hs +10/−8
- src/Cmd/Commit.hs +2/−0
- src/Cmd/Copr.hs +3/−2
- src/Cmd/FTBFS.hs +99/−0
- src/Cmd/Local.hs +4/−4
- src/Cmd/Merge.hs +12/−5
- src/Cmd/Mock.hs +4/−4
- src/Cmd/Override.hs +3/−3
- src/Cmd/Parallel.hs +76/−60
- src/Cmd/PkgReview.hs +1/−0
- src/Cmd/Prep.hs +3/−27
- src/Cmd/RequestBranch.hs +15/−8
- src/Cmd/RequestRepo.hs +3/−3
- src/Cmd/Scratch.hs +5/−4
- src/Cmd/Sort.hs +20/−7
- src/Cmd/Status.hs +68/−62
- src/Cmd/Switch.hs +1/−1
- src/Cmd/Update.hs +1/−0
- src/Cmd/WaitRepo.hs +3/−3
- src/Common.hs +8/−4
- src/Common/System.hs +19/−1
- src/Git.hs +15/−8
- src/Koji.hs +2/−2
- src/ListReviews.hs +1/−16
- src/Main.hs +80/−31
- src/Package.hs +74/−42
- src/Prompt.hs +23/−5
CHANGELOG.md view
@@ -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
README.md view
@@ -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+<https://bugzilla.redhat.com/userprefs.cgi?tab=apikey>. ## Known issues - parallel builds will push local package commits without asking
fbrnch.cabal view
@@ -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,
src/Bodhi.hs view
@@ -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
src/Branches.hs view
@@ -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)
src/Bugzilla.hs view
@@ -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)
src/Cmd/Bugs.hs view
@@ -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
src/Cmd/Build.hs view
@@ -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
src/Cmd/Clone.hs view
@@ -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
src/Cmd/Commit.hs view
@@ -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) $
src/Cmd/Copr.hs view
@@ -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
+ src/Cmd/FTBFS.hs view
@@ -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 ()
src/Cmd/Local.hs view
@@ -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 =
src/Cmd/Merge.hs view
@@ -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
src/Cmd/Mock.hs view
@@ -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
src/Cmd/Override.hs view
@@ -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
src/Cmd/Parallel.hs view
@@ -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
src/Cmd/PkgReview.hs view
@@ -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
src/Cmd/Prep.hs view
@@ -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
src/Cmd/RequestBranch.hs view
@@ -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 ->
src/Cmd/RequestRepo.hs view
@@ -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)
src/Cmd/Scratch.hs view
@@ -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
src/Cmd/Sort.hs view
@@ -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 =
src/Cmd/Status.hs view
@@ -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`)
src/Cmd/Switch.hs view
@@ -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
src/Cmd/Update.hs view
@@ -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
src/Cmd/WaitRepo.hs view
@@ -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 _) =
src/Common.hs view
@@ -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 ]
src/Common/System.hs view
@@ -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
src/Git.hs view
@@ -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
src/Koji.hs view
@@ -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::<PreparedRequest [POST]> -- [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
src/ListReviews.hs view
@@ -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
src/Main.hs view
@@ -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"
src/Package.hs view
@@ -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
src/Prompt.hs view
@@ -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