fbrnch 1.5 → 1.6
raw patch · 45 files changed
+937/−594 lines, 45 filesdep +safedep ~fedora-releasesdep ~select-rpms
Dependencies added: safe
Dependency ranges changed: fedora-releases, select-rpms
Files
- CHANGELOG.md +33/−2
- README.md +11/−11
- fbrnch.cabal +7/−4
- src/Bodhi.hs +28/−42
- src/Branches.hs +18/−16
- src/Bugzilla.hs +14/−5
- src/Cmd/Autospec.hs +1/−1
- src/Cmd/Build.hs +45/−36
- src/Cmd/Bump.hs +6/−6
- src/Cmd/Commit.hs +4/−3
- src/Cmd/Copr.hs +48/−43
- src/Cmd/CreateReview.hs +82/−0
- src/Cmd/Import.hs +29/−11
- src/Cmd/Install.hs +11/−6
- src/Cmd/ListBranches.hs +6/−5
- src/Cmd/Local.hs +10/−5
- src/Cmd/Merge.hs +20/−19
- src/Cmd/Override.hs +1/−1
- src/Cmd/Parallel.hs +29/−24
- src/Cmd/PkgReview.hs +0/−146
- src/Cmd/Prep.hs +1/−0
- src/Cmd/RequestBranch.hs +6/−6
- src/Cmd/RequestRepo.hs +29/−13
- src/Cmd/ReviewPackage.hs +46/−11
- src/Cmd/Scratch.hs +5/−6
- src/Cmd/SideTags.hs +39/−9
- src/Cmd/SrcDeps.hs +2/−1
- src/Cmd/Status.hs +7/−5
- src/Cmd/Unpushed.hs +3/−3
- src/Cmd/Update.hs +14/−6
- src/Cmd/UpdateReview.hs +37/−0
- src/Cmd/WaitRepo.hs +1/−0
- src/Common.hs +15/−1
- src/Common/System.hs +14/−8
- src/Git.hs +61/−37
- src/Koji.hs +55/−37
- src/Krb.hs +2/−2
- src/ListReviews.hs +1/−1
- src/Main.hs +28/−17
- src/Package.hs +30/−14
- src/Patch.hs +3/−1
- src/PkgReview.hs +79/−0
- src/Repoquery.hs +3/−3
- src/RpmBuild.hs +52/−27
- src/Types.hs +1/−0
CHANGELOG.md view
@@ -1,5 +1,36 @@ # Changelog +## 1.6 (2024-12-13)+* update to fedora-releases-0.2.0 (showBranch and branchDestTag)+* kojiWaitRepo: now uses request-repo to trigger newrepo+- 'build': use --notes to set Bodhi update notes text (#59)+- 'clone' now uses fedpkg for better compatibility (#62)+* 'copr' refactoring and fix existingChrootBuilds to prevent rebuilds+- 'create-review': --force to create a new "duplicate" review (#53)+* 'create-review': include FAS id if can be determined (#42)+* 'import': prompt whether to build or only push+- 'install': add --existing-only, --skip-existing, --no-reinstall options from select-rpms-0.2 (ported from koji-tool --install)+- 'parallel': koji-tool tail of failed build.log if < 3 packages in layer+* 'request-repo': now offers to import the new repo immediately+- 'request-repo': only post comment if prompt input+* 'review-package': allow --interactive also for local review+- 'review-package': summarize long rpmlint error output+- 'reviews --created': now uses REL_PREP state+- 'scratch-x86_64','scratch-aarch64': --exclude-arch no longer fast fails+- 'sidetag': add --create+- 'update': remove %autorelease -b bump when updating version+- Common.System: override cmdFull to avoid weird lazy IO crash+- Merge: gitMergeable now returns Maybe Bool for reverse ancestry+- Package pkgNameVerRelDist: add autorelease strict parameter for rpmBuild+- RpmBuild buildRequires: improve dyn BRs handling+- dropped all head and tail functions usage+- fix merging from new unfetched branch+- fixup "Push and build" prompt text, which is no longer promptEnter (#47)+- gitPush: say message and drop "done"+- sentence-case commit and changelog messages (#38)+- split CreateReview and UpdateReview out of PkgReview+- targetMaybeSidetag: now maps "rawhide" to its dist_tag+ ## 1.5 (2024-08-17) * fedora-releases (using bodhi) replaces fedora-dists (pdc): explicit imports - 'bugs': also include product in prefix@@ -39,9 +70,9 @@ * 'sort': default to chain-build output - 'sort': skip getDynSourcesMacros for dead.package - 'status': add --latest-commit-- 'unpush --bump': now uses 'bump' code+- 'unpushed --bump': now uses 'bump' code - 'unpushed': add --check-nvr and do not print every "dead package"-* 'update': git add patches+* 'update-sources': git add patches - 'update-review': end with bug url - '--dryrun' is now an alias for '--dry-run' - Package pkgNameVerRelDist: use fedpkg verrel if autorelease
README.md view
@@ -33,7 +33,7 @@ ### Cloning and switching branch Clone one or more packages: ```-$ fbrnch clone package ...+$ fbrnch clone [package] ... ``` There are also options to clone all one's packages or another user's packages. @@ -97,13 +97,13 @@ You can merge branches with: ```-$ fbrnch merge f40 package+$ fbrnch merge f40 [package] ``` which will offer to merge f41 (or up to a git hash you choose) into f40. Merging can also be done together with building: ```-$ fbrnch build f41 package+$ fbrnch build f41 [package] ``` will ask if you want to merge newer commits from a newer branch, then push and build it.@@ -114,15 +114,15 @@ You can also build all active branches: ```-$ fbrnch build -B package+$ fbrnch build -B [package] ``` or only all fedora branches: ```-$ fbrnch build -F package+$ fbrnch build -F [package] ``` or only all epel branches: ```-$ fbrnch build -E package+$ fbrnch build -E [package] ``` Scratch builds can also be done:@@ -135,12 +135,12 @@ You can sort packages by build dependency order: ```-$ fbrnch sort rawhide package1 package2 package3 package4 ...+$ fbrnch sort rawhide <package1> <package2> <package3> <package4> ... ``` ### Local commands ```-$ fbrnch prep rawhide package+$ fbrnch prep rawhide [package] ``` Build locally:@@ -155,7 +155,7 @@ Locally build and install: ```-$ fbrnch install package1 package2/ package3 ...+$ fbrnch install <package1> <package2>/ <package3> ... ``` You can use:@@ -229,7 +229,7 @@ One can also search for the review(s) of a specific package with: ```-$ fbrnch find-review package-name+$ fbrnch find-review <package-name> ``` Package reviews can be performed with `fbrnch review-package`.@@ -270,7 +270,7 @@ `$ fbrnch --version` ```-1.5+1.6 ``` `$ fbrnch --help`
fbrnch.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: fbrnch-version: 1.5+version: 1.6 synopsis: Fedora packager tool to build package branches description: fbrnch (fedora branch or "f-branch" for short) is@@ -55,6 +55,7 @@ Cmd.Commit Cmd.Compare Cmd.Copr+ Cmd.CreateReview Cmd.Diff Cmd.Fetch Cmd.FTBFS@@ -68,7 +69,6 @@ Cmd.Override Cmd.Owner Cmd.Parallel- Cmd.PkgReview Cmd.Prep Cmd.Pull Cmd.Push@@ -85,6 +85,7 @@ Cmd.Switch Cmd.Unpushed Cmd.Update+ Cmd.UpdateReview Cmd.WaitRepo Common Common.System@@ -98,6 +99,7 @@ Pagure Patch Paths_fbrnch+ PkgReview Repoquery RpmBuild Types@@ -118,7 +120,7 @@ either, email-validate, extra,- fedora-releases,+ fedora-releases >= 0.2, filepath, http-conduit, http-directory >= 0.1.5,@@ -131,8 +133,9 @@ -- regex-tdfa, rpmbuild-order >= 0.4.12, rpm-nvr >= 0.1.2,+ safe, say,- select-rpms,+ select-rpms >= 0.2, simple-cmd >= 0.2.3, simple-cmd-args >= 0.1.8, simple-prompt >= 0.2.3,
src/Bodhi.hs view
@@ -1,22 +1,21 @@-{-# LANGUAGE CPP, OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-} module Bodhi ( bodhiCreateOverride,- bodhiTestingRepo,+ bodhiTestingRepoTag, checkAutoBodhiUpdate, UpdateType(..), UpdateSeverity(..),+ UpdateNotes(..), bodhiUpdate, bodhiBuildExists ) where -#if MIN_VERSION_aeson(2,0,0)-import Data.Aeson.Key (fromText)-#endif-import Data.Aeson.Types (Object, (.:), parseEither) import Data.Char (isDigit) import Data.RPM.NVR (NVR)+import Distribution.Fedora.Branch (branchRelease)+import Distribution.Fedora.Release (Release(..)) import Fedora.Bodhi hiding (bodhiUpdate) import SimplePrompt (promptEnter, promptNonEmpty) import Text.Read@@ -27,30 +26,13 @@ import Bugzilla (BugId) import Common import Common.System-import qualified Common.Text as T import Package import Types (ChangeType(ChangeBodhi)) checkAutoBodhiUpdate :: Branch -> IO Bool checkAutoBodhiUpdate Rawhide = return True--- epel7 returns 'create_automatic_updates: null' !-checkAutoBodhiUpdate (EPEL 7) = return False--- not sure how to best handle next-checkAutoBodhiUpdate (EPELNext _) = return False checkAutoBodhiUpdate br =- lookupKey'' "create_automatic_updates" <$> bodhiRelease (show br)- where- -- Error in $: key "create_automatic_updates" not found- lookupKey'' :: T.Text -> Object -> Bool- lookupKey'' k obj =- let errMsg e = error $ e +-+ show obj in- -- bodhi-hs has lookupKeyEither- either errMsg id $ parseEither (.: fromText k) obj--#if !MIN_VERSION_aeson(2,0,0)- fromText :: T.Text -> T.Text- fromText = id-#endif+ releaseAutomaticUpdates <$> branchRelease br -- FIXME should determine 3 days for branched devel release -- FIXME handle expired override?@@ -116,21 +98,22 @@ "urgent" -> RP.lift (R.string s) >> return SeverityUrgent _ -> error' "unknown bodhi update severity" >> RP.pfail -bodhiTestingRepo :: Branch -> IO (Maybe String)-bodhiTestingRepo Rawhide = return Nothing-bodhiTestingRepo br = do- obj <- bodhiRelease (show br)- return $- case lookupKey "testing_repository" obj :: Maybe String of- Nothing -> Nothing- Just _ -> lookupKey' "testing_tag" obj+bodhiTestingRepoTag :: Branch -> IO (Maybe String)+bodhiTestingRepoTag Rawhide = return Nothing+bodhiTestingRepoTag br = do+ rel <- branchRelease br+ return $ do+ _ <- releaseTestingRepo rel+ pure $ releaseTestingTag rel +data UpdateNotes = NotesChangelog | NotesText String+ -- FIXME support --no-close-bugs -- push comma separated list of builds for a package to bodhi bodhiUpdate :: Bool -> (Maybe UpdateType, UpdateSeverity) -> Maybe BugId- -> Bool -> FilePath -> String -> IO ()+ -> Maybe UpdateNotes -> FilePath -> String -> IO () bodhiUpdate _ _ _ _ _ [] = putStrLn "no package to push"-bodhiUpdate dryrun (mupdate,severity) mreview usechangelog spec nvrs = do+bodhiUpdate dryrun (mupdate,severity) mreview mnotes spec nvrs = do case mupdate of Nothing -> return () Just updateType ->@@ -147,11 +130,14 @@ changelog <- if isJust mreview then getSummaryURL spec else- if usechangelog- then cleanChangelog True spec- else- -- FIXME list open bugs- changeLogPrompt ChangeBodhi spec+ case mnotes of+ Just NotesChangelog ->+ cleanChangelog True spec+ Just (NotesText notes) ->+ return notes+ Nothing ->+ -- FIXME list open bugs+ changeLogPrompt ChangeBodhi spec if trim (lower changelog) `elem` ["no","n"] then return False else do@@ -179,7 +165,7 @@ then do putStrLn $ "bodhi submission failed for" +-+ nvrs promptEnter "Press Enter to resubmit to Bodhi"- bodhiUpdate dryrun (mupdate,severity) mreview usechangelog spec nvrs+ bodhiUpdate dryrun (mupdate,severity) mreview mnotes spec nvrs else forM_ updates $ \update -> case lookupKey "url" update of@@ -190,8 +176,8 @@ extractBugReferences clog = case dropWhile (/= '#') clog of "" -> []- rest ->- case span isDigit (tail rest) of+ (_:rest) ->+ case span isDigit rest of (ds,more) -> -- make sure is contemporary 7-digit bug (if length ds > 6 then (ds :) else id) $
src/Branches.hs view
@@ -10,6 +10,7 @@ pagurePkgBranches, mockRoot, Branch(..),+ showBranch, AnyBranch(..), anyBranch, isRelBranch,@@ -31,10 +32,10 @@ ) where import Data.Either (partitionEithers)-import Distribution.Fedora.Branch (Branch(..), eitherBranch, getFedoraBranched,- getFedoraBranches, getLatestFedoraBranch,+import Distribution.Fedora.Branch (Branch(..), eitherBranch, getActiveBranched,+ getActiveBranches, getLatestFedoraBranch, readActiveBranch, eitherActiveBranch,- readBranch)+ readBranch, showBranch) import SimpleCmd.Git import SimplePrompt (promptEnter, promptInitial) import qualified System.Info (arch)@@ -57,7 +58,7 @@ isRelBranch _ = False instance Show AnyBranch where- show (RelBranch br) = show br+ show (RelBranch br) = showBranch br show (OtherBranch obr) = obr activeBranches :: [Branch] -> [String] -> [Branch]@@ -67,12 +68,12 @@ fedoraBranches :: IO [String] -> IO [Branch] fedoraBranches mthd = do- active <- getFedoraBranches+ active <- getActiveBranches activeBranches active <$> mthd fedoraBranchesNoRawhide :: IO [String] -> IO [Branch] fedoraBranchesNoRawhide mthd = do- active <- getFedoraBranched+ active <- getActiveBranched activeBranches active <$> mthd isFedoraBranch :: Branch -> Bool@@ -96,6 +97,7 @@ gitLines "branch" ["--remote", "--list", "--format=%(refname:lstrip=-2)"] return $ map (removePrefix "origin/") origins \\ ["HEAD", "master"] +-- FIXME use Package? pagurePkgBranches :: String -> IO [String] pagurePkgBranches pkg = do let project = "rpms/" ++ pkg@@ -142,21 +144,21 @@ listOfBranches distgit _active (BranchOpt AllBranches) = if distgit then fedoraBranches (localBranches False)- else getFedoraBranches+ else getActiveBranches listOfBranches distgit _active (BranchOpt AllFedora) = filter isFedoraBranch <$> if distgit then fedoraBranches (localBranches False)- else getFedoraBranches+ else getActiveBranches listOfBranches distgit _active (BranchOpt AllEPEL) = filter isEPELBranch <$> if distgit then fedoraBranches (localBranches False)- else getFedoraBranches+ else getActiveBranches listOfBranches distgit _ (BranchOpt (ExcludeBranches brs)) = do branches <- if distgit then fedoraBranches (localBranches False)- else getFedoraBranches+ else getActiveBranches return $ branches \\ brs listOfBranches distgit active (Branches brs) = if null brs@@ -165,17 +167,17 @@ then getReleaseBranch else systemBranch else do- activeBrs <- getFedoraBranches+ activeBrs <- getActiveBranches forM_ brs $ \ br -> if active then unless (br `elem` activeBrs) $- error' $ show br +-+ "is not an active branch"+ error' $ showBranch br +-+ "is not an active branch" else case br of Fedora _ -> do let latest = maximum (delete Rawhide activeBrs) when (br > latest) $- error' $ show br +-+ "is newer than latest branch"+ error' $ showBranch br +-+ "is newer than latest branch" -- FIXME also check for too new EPEL _ -> return () return brs@@ -234,7 +236,7 @@ getRequestedBranches :: [String] -> BranchesReq -> IO [Branch] getRequestedBranches existing breq = do- activenew <- filter (\b -> show b `notElem` existing) <$> getFedoraBranched+ activenew <- filter (\b -> showBranch b `notElem` existing) <$> getActiveBranched case breq of Branches brs -> if null brs then branchingPrompt activenew@@ -250,7 +252,7 @@ branchingPrompt :: [Branch] -> IO [Branch] branchingPrompt active = do inp <- promptInitial "Enter required branches" $- unwords $ map show $ take 2 active+ unwords $ map showBranch $ take 2 active let abrs = map anyBranch $ words inp in if all isRelBranch abrs then return $ map onlyRelBranch abrs@@ -258,7 +260,7 @@ confirmBranches :: [Branch] -> [Branch] -> IO [Branch] confirmBranches activenew requested = do- inp <- promptInitial "Confirm branches to request" $ unwords (map show requested)+ inp <- promptInitial "Confirm branches to request" $ unwords (map showBranch requested) let (errs,oks) = partitionEithers $ map (eitherActiveBranch activenew) $ words inp if null errs
src/Bugzilla.hs view
@@ -38,6 +38,7 @@ statusNewPost, statusNewModified, statusOpen,+ statusRelPrep, summaryContains, versionIs, ftbfsFedoraBugs,@@ -278,6 +279,10 @@ statusNewModified = StatusField `equalsAny` ["NEW", "ASSIGNED", "POST", "MODIFIED"] +statusRelPrep :: SearchExpression+statusRelPrep =+ StatusField .==. "RELEASE_PENDING"+ reviewApproved :: SearchExpression reviewApproved = FlagsField `contains` "fedora-review+"@@ -357,8 +362,10 @@ _ -> error' "more than one review bug found!" reviewBugToPackage :: Bug -> String-reviewBugToPackage =- head . dropOne ["Request:"] . dropOne ["Review", "Re-Review", "Rename"] . words . T.unpack . bugSummary+reviewBugToPackage bug =+ case (dropOne ["Request:"] . dropOne ["Review", "Re-Review", "Rename"] . words . T.unpack . bugSummary) bug of+ [] -> error' $ "failed to determine review package for" +-+ show (bugId bug)+ (p:_) -> p where dropOne _ [] = [] dropOne ks as@(w:ws) = if w `elem` ks then ws else as@@ -433,13 +440,15 @@ where pref = T.unwords (bugProduct bug : bugVersion bug) +bzUrl :: BugId -> String+bzUrl bid = "https://" <> T.unpack brc <> "/show_bug.cgi?id=" <> show bid+ putBugId :: BugId -> IO ()-putBugId bid =- putStrLn $ "https://" <> T.unpack brc <> "/show_bug.cgi?id=" <> show bid+putBugId = putStrLn . bzUrl putBugURLStatus :: Bug -> IO () putBugURLStatus bug = do- putStr $ "https://" <> T.unpack brc <> "/show_bug.cgi?id=" <> show (bugId bug)+ putStr $ bzUrl $ bugId bug T.putStrLn $ " (" <> bugStatus bug <> ")" -- uniq for lists
src/Cmd/Autospec.hs view
@@ -29,6 +29,6 @@ writeFile changelogfile unlessM (null <$> git "status" ["--porcelain", "--untracked=no"]) $ do git_ "add" [changelogfile]- git_ "commit" ["-m", "refresh changelog"]+ git_ "commit" ["-m", "Refresh changelog"] else putStrLn "'changelog' file already exists" else cmd_ "rpmautospec" ["convert"]
src/Cmd/Build.hs view
@@ -5,7 +5,7 @@ BuildOpts(..) ) where -import Distribution.Fedora.Branch (branchDestTag, branchTarget)+import Distribution.Fedora.Branch (branchDestTag) import SimplePrompt (promptEnter, yesNo) import Bodhi@@ -30,7 +30,7 @@ , buildoptDryrun :: Bool , buildoptSkipFetch :: Bool , buildoptUpdate :: (Maybe UpdateType, UpdateSeverity)- , buildoptUseChangelog :: Bool+ , buildoptNotes :: Maybe UpdateNotes , buildoptByPackage :: Bool , buildoptStash :: Bool }@@ -49,6 +49,7 @@ -- FIXME -B fails to find new branches (fixed?) -- FIXME disallow override for autoupdate? -- FIXME --scratch build first+-- FIXME --skip-bumps NUM buildCmd :: BuildOpts -> (BranchesReq, [String]) -> IO () buildCmd opts (breq, pkgs) = do let singleBrnch = if isJust (buildoptSidetagTarget opts)@@ -69,6 +70,7 @@ else withPackagesByBranches HeaderMay True gitopts singleBrnch (buildBranch mlastOfPkgs opts) (breq, pkgs) +-- FIXME display existing sidetag early -- FIXME what if untracked files -- FIXME --merge instead of --yes confusing buildBranch :: Maybe Package -> BuildOpts -> Package -> AnyBranch -> IO ()@@ -82,45 +84,46 @@ gitMergeOrigin br newrepo <- initialPkgRepo tty <- isTty- (ancestor,unmerged,mnewer) <- newerMergeable br+ (ancestor,unmerged,mnewer) <- newerMergeable (unPackage pkg) br -- FIXME if already built or failed, also offer merge merged <- case buildoptMerge opts of Just False -> return False Just True -> do whenJust mnewer $ \newer ->- mergeBranch (buildoptDryrun opts) True True False Nothing (ancestor,unmerged) newer br+ mergeBranch (buildoptDryrun opts) True True False pkg (ancestor,unmerged) newer br return True Nothing -> if ancestor && (newrepo || tty) then do whenJust mnewer $ \newer ->- mergeBranch (buildoptDryrun opts) True False True Nothing (ancestor,unmerged) newer br+ mergeBranch (buildoptDryrun opts) True False True pkg (ancestor,unmerged) newer br return $ isJust mnewer else do unless (br == Rawhide) $ whenJust mnewer $ \newer ->- putStrLn $ show newer +-+ "branch not mergeable"+ putStrLn $ showBranch newer +-+ "branch not mergeable" return False let spec = packageSpec pkg checkForSpecFile spec checkSourcesMatch pkg (RelBranch br) spec- unpushed <- gitOneLineLog $ "origin/" ++ show br ++ "..HEAD"+ unpushed <- gitOneLineLog $ "origin/" ++ showBranch br ++ "..HEAD" nvr <- pkgNameVerRel' br spec putNewLn mpush <-- if null unpushed- then return Nothing- else do- when (not merged || br == Rawhide) $ do- putStrLn $ showNVR nvr ++ "\n"- putStrLn "Local commits:"- displayCommits True unpushed- putNewLn- -- see mergeBranch for: unmerged == 1 (774b5890)- if tty && (not merged || (newrepo && ancestor && length unmerged == 1))- then refPrompt unpushed $ "Press Enter to push and build" ++ (if length unpushed > 1 then "; or give ref to push" else "") ++ (if not newrepo then "; or 'no' to skip pushing" else "")- else return $ Just $ commitRef $ head unpushed+ case unpushed of+ [] -> return Nothing+ (unpd:_) -> do+ when (not merged || br == Rawhide) $ do+ -- FIXME should be printed for new package branch+ putStrLn $ showNVR nvr ++ "\n"+ putStrLn "Local commits:"+ displayCommits True unpushed+ putNewLn+ -- see mergeBranch for: unmerged == 1 (774b5890)+ if tty && (not merged || (newrepo && ancestor && length unmerged == 1))+ then refPrompt unpushed $ "Press Enter to push and build" ++ (if length unpushed > 1 then "; or give ref to push" else "") ++ (if not newrepo then "; or 'no' to skip pushing" else "")+ else return $ Just $ commitRef unpd let msidetagTarget = buildoptSidetagTarget opts target <- targetMaybeSidetag dryrun True br msidetagTarget buildRun spec nvr merged mpush unpushed target msidetagTarget moverride@@ -135,24 +138,28 @@ putStrLn $ showNVR nvr +-+ "is built" when (isJust mpush) $ error' "Please bump the spec file"- when (br /= Rawhide && isNothing msidetagTarget) $ do+ autoupdate <- checkAutoBodhiUpdate br+ if not autoupdate && isNothing msidetagTarget+ then do updateExists <- maybeTimeout 30 $ bodhiBuildExists nvr- autoupdate <- checkAutoBodhiUpdate br -- FIXME update referenced bugs for autoupdate branch unless autoupdate $ do if updateExists then putStrLn "update exists" else do mbug <- bzReviewAnon- bodhiUpdate dryrun (buildoptUpdate opts) mbug (buildoptUseChangelog opts) spec $ showNVR nvr+ bodhiUpdate dryrun (buildoptUpdate opts) mbug (buildoptNotes opts) spec $ showNVR nvr whenJust moverride $ \days -> do tags <- maybeTimeout 30 $ kojiNVRTags nvr- unless (any (`elem` tags) [show br, show br ++ "-updates", show br ++ "-override"]) $+ unless (any (`elem` tags) [showBranch br, showBranch br ++ "-updates", showBranch br ++ "-override"]) $ bodhiCreateOverride dryrun (Just days) nvr when (isJust mlastpkg && mlastpkg /= Just pkg || mwaitrepo == Just True) $ when ((isJust moverride && mwaitrepo /= Just False) || (autoupdate && mwaitrepo == Just True)) $- kojiWaitRepo dryrun True True target nvr+ kojiWaitRepo dryrun False True target nvr+ else+ when (mwaitrepo == Just True) $+ kojiWaitRepo dryrun False True target nvr Just BuildBuilding -> do putStrLn $ showNVR nvr +-+ "is already building" when (isJust mpush) $@@ -162,7 +169,7 @@ _ -> do mbuildref <- case mpush of- Nothing -> Just <$> git "show-ref" ["--hash", "origin/" ++ show br]+ Nothing -> Just <$> git "show-ref" ["--hash", "origin/" ++ showBranch br] _ -> return mpush opentasks <- kojiOpenTasks pkg mbuildref target case opentasks of@@ -173,8 +180,10 @@ kojiWatchTask task (_:_) -> error' $ show (length opentasks) +-+ "open" +-+ unPackage pkg +-+ "tasks already!" [] -> do- let tag =- if target == branchTarget br then branchDestTag br else target+ tag <-+ if target == showBranch br+ then branchDestTag br+ else return target mlatest <- kojiLatestNVR tag $ unPackage pkg if equivNVR nvr mlatest then putStrLn $ showNVR nvr +-+ "is already latest" +-+ if Just nvr /= mlatest then "(modulo disttag)" else ""@@ -182,16 +191,16 @@ when (null unpushed || merged && br /= Rawhide) $ do putStrLn $ showNVR nvr ++ "\n" firstBuild <- do- mtestingRepo <- bodhiTestingRepo br- case mtestingRepo of+ mtestingtag <- bodhiTestingRepoTag br+ case mtestingtag of Nothing -> return $ isNothing mlatest- Just testing -> do- mnewest <- kojiLatestNVR testing $ unPackage pkg+ Just testingtag -> do+ mnewest <- kojiLatestNVR testingtag $ unPackage pkg case mnewest of Nothing -> return $ isNothing mlatest Just newest -> do newestTags <- kojiNVRTags newest- unless (any (`elem` newestTags) [show br, show br ++ "-updates", show br ++ "-updates-pending"]) $ do+ unless (any (`elem` newestTags) [showBranch br, showBranch br ++ "-updates", showBranch br ++ "-updates-pending"]) $ do -- FIXME print how many days left putStrLn $ "Warning:" +-+ showNVR newest +-+ "still in testing?" promptEnter "Press Enter to continue"@@ -202,8 +211,8 @@ unless dryrun krbTicket whenJust mpush $ \ref -> unless dryrun $- gitPush False $ Just $ ref ++ ":" ++ show br- unlessM (null <$> gitOneLineLog ("origin/" ++ show br ++ "..HEAD")) $+ gitPush False $ Just $ ref ++ ":" ++ showBranch br+ unlessM (null <$> gitOneLineLog ("origin/" ++ showBranch br ++ "..HEAD")) $ unless dryrun $ do ok <- yesNo "Unpushed changes remain, continue" unless ok $ error' "aborted"@@ -223,11 +232,11 @@ whenJust (fmap fst mBugSess) $ \bid -> putStr "review bug: " >> putBugId bid -- FIXME diff previous changelog?- bodhiUpdate dryrun (buildoptUpdate opts) (fmap fst mBugSess) (buildoptUseChangelog opts) spec $ showNVR nvr+ bodhiUpdate dryrun (buildoptUpdate opts) (fmap fst mBugSess) (buildoptNotes opts) spec $ showNVR nvr -- FIXME prompt for override note whenJust moverride $ \days -> bodhiCreateOverride dryrun (Just days) nvr when (isJust mlastpkg && mlastpkg /= Just pkg || mwaitrepo == Just True) $ when ((isJust moverride && mwaitrepo /= Just False) || (autoupdate && mwaitrepo == Just True)) $- kojiWaitRepo dryrun True True target nvr+ kojiWaitRepo dryrun False True target nvr
src/Cmd/Bump.hs view
@@ -52,7 +52,7 @@ Nothing -> case mclog of Just cl -> [cl]- Nothing -> ["bump release"]+ Nothing -> ["Bump release"] git_ "commit" $ "-a" : "--allow-empty" : copts else do rbr <-@@ -77,9 +77,9 @@ pkgNameVerRel rbr spec else case br of- RelBranch rbr' ->- let tag = branchDestTag rbr'- in kojiLatestNVR tag $ unPackage pkg+ RelBranch rbr' -> do+ tag <- branchDestTag rbr'+ kojiLatestNVR tag $ unPackage pkg -- FIXME fallback to local? _ -> return Nothing whenJust moldnvr $ \o -> putStrLn $ showNVR o +-+ "->"@@ -93,12 +93,12 @@ Nothing -> case mcmsg of Just msg -> msg- _ -> "rebuild"+ _ -> "Rebuild" unless (autorelease || dryrun) $ cmd_ "rpmdev-bumpspec" ["-c", clog, spec] let copts = case mcmsg of- Nothing -> ["-m", "bump release"]+ Nothing -> ["-m", "Bump release"] Just msg -> ["-m", msg] -- FIXME quiet commit? if dryrun
src/Cmd/Commit.hs view
@@ -15,6 +15,7 @@ -- FIXME handle multiline changelog entries with "-m description" -- FIXME --undo last change: eg undo accidential --amend -- FIXME --empty+-- FIXME include only (used) changelog if not staged commitCmd :: Bool -> Maybe CommitOpt -> Bool -> Bool -> [String] -> IO () commitCmd dryrun mopt firstLine unstaged paths = do when (isJust mopt && firstLine) $@@ -50,16 +51,16 @@ case clog of [] -> readCommitMsg [msg] -> return msg- msgs ->+ (msg:_) -> if firstLine- then return $ removePrefix "- " $ head msgs+ then return $ removePrefix "- " msg else do diff <- git "diff" ["-U0", if addall then "HEAD" else "--cached"] let newlogs = filter (\c -> ('+' : c) `elem` lines (unquoteMacros diff)) clog case newlogs of [] -> putStrLn diff >> readCommitMsg- [msg] -> return (removePrefix "- " msg)+ [m] -> return (removePrefix "- " m) [m,m'] -> mapM_ putStrLn newlogs >> return (unlines $ map (removePrefix "- ") [m,"",m']) (m:ms) -> mapM_ putStrLn newlogs >>
src/Cmd/Copr.hs view
@@ -22,8 +22,9 @@ import Data.RPM.NVR (nvrVerRel) import Data.RPM.VerRel (showVerRel) import Data.Tuple.Extra (first)-import Distribution.Fedora.Branch (getFedoraBranches, getFedoraBranched)+import Distribution.Fedora.Branch (getActiveBranches, getActiveBranched) import Network.HTTP.Query (lookupKey, lookupKey')+import Safe (headDef) import System.Environment.XDG.BaseDir (getUserConfigDir) import System.Time.Extra (sleep) import Web.Fedora.Copr (coprChroots, fedoraCopr)@@ -111,10 +112,11 @@ -- FIXME interact with copr dist-git -- FIXME parallel copr builds -- FIXME time builds?-coprCmd :: Bool -> CoprMode -> Bool -> BuildBy -> Maybe Archs -> String+coprCmd :: Bool -> CoprMode -> Bool -> Maybe BuildBy -> Maybe Archs -> String -> (BranchesReq,[String]) -> IO ()-coprCmd dryrun mode force buildBy marchs project (breq, pkgs) = do+coprCmd dryrun mode force mbuildBy marchs project (breq, pkgs) = do user <- getUsername+ let buildBy = fromMaybe ValidateByRelease mbuildBy case mode of ListChroots -> coprGetChroots user >>= mapM_ (putStrLn . showChroot) CoprMonitor -> coprMonitorPackages user project >>= mapM_ printPkgRes@@ -122,9 +124,9 @@ CoprBuild -> do chroots <- coprGetChroots user if null pkgs- then coprBuildPkg user chroots False+ then coprBuildPkg user buildBy chroots False else- mapM_ (\(n,p) -> withExistingDirectory p $ coprBuildPkg user chroots (n>0)) $ zip (reverse [0..length pkgs - 1]) pkgs+ mapM_ (\(n,p) -> withExistingDirectory p $ coprBuildPkg user buildBy chroots (n>0)) $ zip (reverse [0..length pkgs - 1]) pkgs where coprGetChroots :: String -> IO [Chroot] coprGetChroots user = do@@ -137,8 +139,8 @@ if null brs then return $ (nub . map chrootBranch) chroots else listOfBranches False False breq- BranchOpt AllFedora -> filter isFedoraBranch <$> getFedoraBranches- BranchOpt AllEPEL -> filter isEPELBranch <$> getFedoraBranched+ BranchOpt AllFedora -> filter isFedoraBranch <$> getActiveBranches+ BranchOpt AllEPEL -> filter isEPELBranch <$> getActiveBranched _ -> listOfBranches False False breq let buildroots = -- FIXME sort archs appropriately@@ -155,8 +157,8 @@ then error' "No valid chroots" else return buildroots - coprBuildPkg :: String -> [Chroot] -> Bool -> IO ()- coprBuildPkg user buildroots morepkgs = do+ coprBuildPkg :: String -> BuildBy -> [Chroot] -> Bool -> IO ()+ coprBuildPkg user buildBy chroots morepkgs = do -- FIXME check is pkg.spec -- was: localBranchSpecFile pkg (RelBranch Rawhide) spec <- findSpecfile@@ -166,29 +168,29 @@ else return spec -- hack to avoid generating srpm for dryrun verrel <- showVerRel . nvrVerRel <$> pkgNameVerRelNodist spec actualpkg <- cmd "rpmspec" ["-q", "--srpm", "--qf", "%{name}", spec]- builtChroots <- existingChrootBuilds user project (Package actualpkg) verrel buildroots- let finalChroots = buildroots \\ if force then [] else map taskChroot builtChroots- if null finalChroots- then putStrLn $ actualpkg ++ '-' : verrel +-+ "built"- else- case buildBy of- SingleBuild -> coprBuild dryrun user project srpm spec finalChroots- -- FIXME or default to secondary parallel to previous primary- ValidateByRelease -> do- let initialChroots =- let primaryArch = chrootArch $ head finalChroots- in map pure $ filter (isArch primaryArch) finalChroots- remainingChroots = finalChroots \\ concat initialChroots- staggerBuilds srpm spec initialChroots remainingChroots- ValidateByArch -> do- let initialChroots =- let newestRelease = chrootBranch $ head finalChroots- in map pure $ filter ((== newestRelease) . chrootBranch) finalChroots- remainingChroots = finalChroots \\ concat initialChroots- staggerBuilds srpm spec initialChroots remainingChroots- BuildByRelease -> do- let releaseChroots = groupBy sameRelease finalChroots- staggerBuilds srpm spec releaseChroots []+ builtChroots <- existingChrootBuilds dryrun user project (Package actualpkg) verrel chroots+ let finalChroots = chroots \\ if force then [] else map taskChroot builtChroots+ case finalChroots of+ [] -> putStrLn $ actualpkg ++ '-' : verrel +-+ "built"+ (final:_) ->+ case buildBy of+ SingleBuild -> coprBuild dryrun user project srpm spec finalChroots+ -- FIXME or default to secondary parallel to previous primary+ ValidateByRelease -> do+ let initialChroots =+ let primaryArch = chrootArch final+ in map pure $ filter (isArch primaryArch) finalChroots+ remainingChroots = finalChroots \\ concat initialChroots+ staggerBuilds srpm spec initialChroots remainingChroots+ ValidateByArch -> do+ let initialChroots =+ let newestRelease = chrootBranch final+ in map pure $ filter ((== newestRelease) . chrootBranch) finalChroots+ remainingChroots = finalChroots \\ concat initialChroots+ staggerBuilds srpm spec initialChroots remainingChroots+ BuildByRelease -> do+ let releaseChroots = groupBy sameRelease finalChroots+ staggerBuilds srpm spec releaseChroots [] when morepkgs putNewLn where staggerBuilds :: FilePath -> FilePath -> [[Chroot]] -> [Chroot] -> IO ()@@ -233,23 +235,25 @@ -- ["canceled", "failed", "skipped", "succeeded"] -- FIXME restrict to requested chroots?-existingChrootBuilds :: String -> String -> Package -> String -> [Chroot]- -> IO [CoprTask]-existingChrootBuilds user project actualpkg verrel chroots = do+existingChrootBuilds :: Bool -> String -> String -> Package -> String+ -> [Chroot] -> IO [CoprTask]+existingChrootBuilds dryrun user project actualpkg verrel chroots = do monitorPkgs <- coprMonitorPackages user project let pkgmonitor = fromMaybe [] $ lookup actualpkg monitorPkgs let buildingChroots = filterTasks verrel (`elem` coprProcessingStates) pkgmonitor+ builds = filterTasks verrel (`notElem` ["failed","skipped"]) pkgmonitor if null buildingChroots- then return $ filterTasks verrel (`notElem` ["failed","skipped"]) pkgmonitor+ then return builds else do mapM_ printCoprTask buildingChroots putNewLn- forM_ buildingChroots $ \building ->+ unless dryrun $+ forM_ buildingChroots $ \building -> when (taskChroot building `elem` chroots) $ -- FIXME check failure void $ coprWatchBuild Nothing $ Left building- return buildingChroots+ return builds filterTasks :: String -> (String -> Bool) -> [CoprTask] -> [CoprTask] filterTasks verrel statustest =@@ -257,15 +261,16 @@ coprBuild :: Bool -> String -> String -> FilePath -> FilePath -> [Chroot] -> IO () coprBuild _ _ _ _ _ [] = error' "No chroots chosen"-coprBuild dryrun user project srpm spec buildroots = do- let chrootargs = mconcat [["-r", showChroot bldrt] | bldrt <- buildroots]+coprBuild dryrun user project srpm spec chroots = do+ let chrootargs = mconcat [["-r", showChroot bldrt] | bldrt <- chroots] buildargs = ["build", "--nowait"] ++ chrootargs ++ [project, srpm] putNewLn- putStrLn $ unwords $ map showChroot buildroots+ putStrLn $ unwords $ map showChroot chroots unless dryrun $ do output <- cmd "copr" buildargs putStrLn output let bid = read $ last $ words $ last $ lines output+ -- FIXME get the actual build time ok <- timeIO $ coprWatchBuild Nothing $ Right bid unless ok $ do putStrLn $ "Failed: copr" +-+ unwords buildargs@@ -277,7 +282,7 @@ actualpkg <- cmd "rpmspec" ["-q", "--srpm", "--qf", "%{name}", spec] -- FIXME which chroot? -- FIXME print buildlog size- error' $ "https://download.copr.fedorainfracloud.org/results" +/+ user +/+ project +/+ showChroot (head buildroots) +/+ zbid ++ "-" ++ actualpkg +/+ "builder-live.log.gz"+ error' $ "https://download.copr.fedorainfracloud.org/results" +/+ user +/+ project +/+ showChroot (headDef (error' " nochroot!") chroots) +/+ zbid ++ "-" ++ actualpkg +/+ "builder-live.log.gz" -- FIXME idea: Maybe Seconds to increment FIXME -- sleep should have all chroots in pending CoprTask build@@ -392,4 +397,4 @@ let chroots = [ Chroot b a | b <- branches, a <- archs] (if dryrun then cmdN else cmd_) "copr" $ "create" : concatMap (\ch -> ["--chroot", showChroot ch]) chroots ++ [project] unless (null pkgs) $- coprCmd False CoprBuild False ValidateByRelease Nothing project (breq, pkgs)+ coprCmd False CoprBuild False Nothing Nothing project (breq, pkgs)
+ src/Cmd/CreateReview.hs view
@@ -0,0 +1,82 @@+module Cmd.CreateReview (+ createReviewCmd+ )+where++import Data.Char (isAscii)+import SimpleCmd (cmd, error')+import SimplePrompt (promptEnter)+import System.Directory (doesFileExist)++import Branches+import Bugzilla+import Common+import Krb+import Package+import PkgReview+import RpmBuild++-- FIXME add --dependent pkgreview+-- FIXME verify tarball is same as upstream+-- FIXME post URL field too+createReviewCmd :: Bool -> Maybe ScratchOption -> Bool -> [FilePath] -> IO ()+createReviewCmd force mscratchOpt mock pkgs =+ withPackagesByBranches HeaderMust False Nothing Zero createPkgReview (Branches [], pkgs)+ where+ createPkgReview :: Package -> AnyBranch -> IO ()+ createPkgReview package _br = do+ let spec = packageSpec package+ pkg = unPackage package+ unlessM (doesFileExist spec) $+ error' $ "This does not look like a pkg dir:" +-+ spec +-+ "not found"+ unless (all isAscii pkg) $+ putStrLn "Warning: package name is not ASCII!"+ putStrLn "checking for existing reviews..."+ (bugs,session) <- bugsSession $ pkgReviews pkg+ unless (null bugs) $ do+ let nobugs = length bugs+ putStrLn $ plural nobugs "Existing review" ++ ":"+ mapM_ putBug bugs+ putNewLn+ unless force $+ error' $ plural nobugs "package review" +-+ "already" +-+ singularVerb (nobugs == 1) "exist"+ promptEnter "Press Enter to create a new review"+ srpm <- generateSrpm Nothing spec+ mockRpmLint mock pkg spec srpm+ (mkojiurl,specSrpmUrls) <- buildAndUpload mscratchOpt srpm pkg spec+ bugid <- postReviewReq session spec specSrpmUrls mkojiurl pkg+ putStrLn "Review request posted:"+ putBugId bugid+ where+ postReviewReq :: BugzillaSession -> FilePath -> String -> Maybe String -> String -> IO BugId+ postReviewReq session spec specSrpmUrls mkojiurl pkg = do+ summary <- cmd "rpmspec" ["-q", "--srpm", "--qf", "%{summary}", spec]+ description <- cmd "rpmspec" ["-q", "--srpm", "--qf", "%{description}", spec]+ url <- cmd "rpmspec" ["-q", "--srpm", "--qf", "%{url}", spec]+ mfas <- maybeFasIdFromKrb+ createBug session+ [ ("product", "Fedora")+ , ("component", "Package Review")+ , ("version", "rawhide")+ , ("summary", "Review Request: " <> pkg <> " - " <> summary)+ , ("url", url)+ , ("description",+ unlines $+ [specSrpmUrls,+ "",+ "Description:",+ description]+ +++ case mfas of+ Just fasid ->+ ["",+ "Fedora Account System Username:" +-+ fasid]+ Nothing -> []+ +++ case mkojiurl of+ Just kojiurl ->+ ["",+ "",+ "Koji scratch build:" +-+ kojiurl]+ Nothing -> []+ )]
src/Cmd/Import.hs view
@@ -12,7 +12,8 @@ import qualified Common.Text as T import Network.URI-import SimplePrompt (promptEnter, yesNoDefault)+import SimplePrompt (promptEnter)+import SimplePrompt.Internal (runPrompt, mapInput, getPromptLine) import Branches import Bugzilla@@ -25,8 +26,8 @@ -- FIXME separate pre-checked listReviews and direct pkg call, which needs checks -- FIXME add --dryrun-importCmd :: Bool -> Bool -> (BranchesReq,[String]) -> IO ()-importCmd existingrepo mock (breq, ps) = do+importCmd :: Bool -> Bool -> Bool -> (BranchesReq,[String]) -> IO ()+importCmd reporequest existingrepo mock (breq, ps) = do pkgs <- if null ps then map reviewBugToPackage <$> listReviews ReviewRepoCreated else return ps@@ -41,7 +42,6 @@ exists <- doesDirectoryExist pkg unless exists $ do clonePkg True UserClone Nothing pkg- putNewLn setCurrentDirectory pkg -- FIXME: check branch is rawhide unlessM isGitRepo $ error' "Not a git repo"@@ -54,24 +54,42 @@ (bid,session) <- approvedReviewBugIdSession pkg putBugId bid srpmfile <- downloadReviewSRPM False True pkg bid session+ putNewLn promptEnter $ "Press Enter to import" +-+ srpmfile krbTicket fedpkg_ "import" [srpmfile]- git_ "commit" ["--message", "import rhbz#" ++ show bid]+ git_ "commit" ["--message", "Import rhbz#" ++ show bid] nvr <- pkgNameVerRel' Rawhide (pkg <.> "spec")- ok <- yesNoDefault True $ "Press Enter to push and build" +-+ showNVR nvr- when ok $ do+ mbuild <- promptPushBuild $ "Press Enter to Push & B[uild]" +-+ showNVR nvr ++ ", or just P[ush], or N[o] to skip? [Y/n/b/p]"+ when (mbuild /= Just False) $ do gitPush True Nothing- -- FIXME build more branches- kojiBuildBranch "rawhide" (Package pkg) Nothing ["--fail-fast"]- putBugBuild False session bid nvr+ when (mbuild == Just True) $ do+ -- FIXME check package exists in koji (for instant import)+ -- FIXME build more branches+ kojiBuildBranch "rawhide" (Package pkg) Nothing ["--fail-fast"]+ putBugBuild False session bid nvr existing <- fedoraBranchesNoRawhide (localBranches False) when (null existing) $ do brs <- getRequestedBranches [] breq- unless (null brs) $+ unless (reporequest || null brs) $ requestPkgBranches False False mock (Branches brs) (Package pkg) when (pkg /= takeFileName dir) $ setCurrentDirectory dir++ promptPushBuild = runPrompt . mapInput maybePush . getPromptLine+ where+ maybePush inp =+ case lower inp of+ "" -> Just (Just True)+ "y" -> Just (Just True)+ "yes" -> Just (Just True)+ "b" -> Just (Just True)+ "build" -> Just (Just True)+ "p" -> Just Nothing+ "push" -> Just Nothing+ "n" -> Just (Just False)+ "no" -> Just (Just False)+ _ -> Nothing downloadReviewSRPM :: Bool -> Bool -> String -> Int -> BugzillaSession -> IO FilePath
src/Cmd/Install.hs view
@@ -7,6 +7,7 @@ ) where import Data.RPM+import Safe (headMay) import SelectRPMs import Branches@@ -26,10 +27,13 @@ -- FIXME --skip-unavailable -- FIXME --check any/all of package installed -- FIXME add --debug or respect --verbose for dnf commands+-- FIXME handle subpackage renames (eg ghc-rpm-macros-no-prof to ghc-rpm-macros-quick)+-- FIXME allow building an srpm+-- FIXME ExistingStrategy option installCmd :: Bool -> Bool -> Maybe Branch -> Maybe ForceShort -> [BCond]- -> Bool -> Bool -> Bool -> Select -> (Maybe Branch,[String])- -> IO ()-installCmd quiet recurse mfrom mforceshort bconds reinstall nobuild nobuilddeps select (mbr, pkgs) = do+ -> Bool -> Bool -> Bool -> Select -> Maybe ExistingStrategy+ -> (Maybe Branch,[String]) -> IO ()+installCmd quiet recurse mfrom mforceshort bconds reinstall nobuild nobuilddeps select mexisting (mbr, pkgs) = do when (recurse && isShortCircuit mforceshort) $ error' "cannot use --recurse and --shortcircuit" withPackagesMaybeBranch (boolHeader (recurse || length pkgs > 1)) True Nothing installPkg (mbr, pkgs)@@ -58,7 +62,8 @@ where doInstallPkg mforceshort' spec rpms = do -- FIXME show source NVR (eg not pandoc-common)- putStrLn $ (showNVR . dropArch . readNVRA) (head rpms)+ whenJust (headMay rpms) $+ putStrLn . showNVR . dropArch . readNVRA unless (nobuilddeps || nobuild) $ do missingdeps <- nub <$> (buildRequires spec >>= filterM notInstalled) unless (null missingdeps) $@@ -71,7 +76,7 @@ mpkgdir <- lookForPkgDir rbr ".." dep case mpkgdir of Nothing -> putStrLn $ dep +-+ "not known"- Just pkgdir -> installCmd quiet recurse mfrom mforceshort bconds reinstall nobuild nobuilddeps select (mbr, [pkgdir]) >> putNewLn+ Just pkgdir -> installCmd quiet recurse mfrom mforceshort bconds reinstall nobuild nobuilddeps select mexisting (mbr, [pkgdir]) >> putNewLn -- FIXME option to enable/disable installing missing deps -- FIXME --skip-missing-deps or prompt else installDeps True spec@@ -83,7 +88,7 @@ unless (isShortCircuit mforceshort') $ do let nvras = rpmsToNVRAs rpms -- FIXME: prefix = fromMaybe (nvrName nvr) mprefix- decided <- decideRPMs No False Nothing select (unPackage pkg) nvras+ decided <- decideRPMs No False mexisting select (unPackage pkg) nvras -- FIXME dryrun and debug -- FIXME return Bool? installRPMs False False Nothing No $ groupOnArch "RPMS" decided
src/Cmd/ListBranches.hs view
@@ -4,7 +4,7 @@ ) where -import Distribution.Fedora.Branch (getFedoraBranches, readBranch)+import Distribution.Fedora.Branch (getActiveBranches, readBranch) import Branches import Common@@ -74,19 +74,20 @@ if allbrs then do putStrLn $ unPackage pkg ++ ":" +-+ unwords brs else do- if breq == Branches [] then do+ if breq == Branches []+ then do -- FIXME better to filter inactive instead- active <- getFedoraBranches+ active <- getActiveBranches let result = if missing then active \\ mapMaybe readBranch brs else activeBranches active brs putStr $ unPackage pkg ++ ": "- putStrLn $ (unwords . map show) result+ putStrLn $ (unwords . map showBranch) result else do branches <- listOfBranches True False breq let havebrs = filter (`elem` branches) $ mapMaybe readBranch brs result = if missing then branches \\ havebrs else havebrs unless (null result) $ do putStr $ unPackage pkg ++ ": "- putStrLn $ (unwords . map show) result+ putStrLn $ (unwords . map showBranch) result
src/Cmd/Local.hs view
@@ -12,6 +12,7 @@ import qualified Data.ByteString.Lazy.Char8 as B import Data.Char (isDigit)+import Safe (headMay) import System.Environment (getEnvironment) import qualified System.Process as P import qualified System.Process.Typed as TP@@ -36,7 +37,9 @@ rpms <- if isJust mforceshort then return [] else builtRpms br spec+ -- FIXME backup BUILD tree to .prev void $ buildRPMs quiet debug True mforceshort bconds rpms br spec+ -- FIXME mark BUILD dir complete installDepsCmd :: (Maybe Branch,[String]) -> IO () installDepsCmd =@@ -166,8 +169,10 @@ ok <- pipeBool ("rpm2cpio", [srpm]) ("cpio", ["--extract", "--quiet", "--make-directories", "-D", dir , "--preserve-modification-time", "*.spec"]) if ok then do- spec <- head <$> listDirectory dir- return $ subdir </> spec+ mspec <- headMay <$> listDirectory dir+ case mspec of+ Nothing -> error' $ "no spec in" +-+ dir+ Just spec -> return $ subdir </> spec else error' "failed to extract spec file" else error' $ "no such file:" +-+ srpm @@ -202,9 +207,9 @@ spec <- localBranchSpecFile pkg br srcs <- map (takeWhile (not . isDigit) . takeBaseName) <$> cmdLines "spectool" ["-S", spec] let srctrees =- if null srcs- then []- else filter (head srcs `isPrefixOf`) dirs+ case srcs of+ [] -> []+ (src:_) -> filter (src `isPrefixOf`) dirs createDirectoryIfMissing False builddir forM_ srctrees $ \tree -> do exists <- doesDirectoryExist $ builddir </> tree
src/Cmd/Merge.hs view
@@ -5,16 +5,15 @@ where import Numeric.Natural (Natural)+import Safe (tailSafe) import Common import Common.System- import Branches import Git import Package import Patch --- FIXME should rawhide default to no-op mergeCmd :: Bool -> Bool -> Bool -> Maybe Natural -> Bool -> Maybe Branch -> (BranchesReq,[String]) -> IO () mergeCmd dryrun nofetch noprompt mnotrivial showall mfrom =@@ -23,12 +22,13 @@ runMergeBranch :: Package -> AnyBranch -> IO () runMergeBranch _ (OtherBranch _) = error' "merge only defined for release branches"+ -- FIXME should rawhide default to no-op runMergeBranch pkg (RelBranch br) = do exists <- gitSwitchBranch' False br when exists $ do mfrom' <- if isJust mfrom then return mfrom- else getNewerBranch br+ else getNewerBranch (unPackage pkg) br whenJust mfrom' $ \from -> do when (from == br) $ error' "cannot merge branch to itself"@@ -36,7 +36,7 @@ gitMergeOrigin br (ancestor,unmerged) <- mergeable from br unmerged' <- filterOutTrivial mnotrivial unmerged- mergeBranch dryrun False noprompt showall (if nofetch then Just pkg else Nothing) (ancestor,unmerged') from br+ mergeBranch dryrun False noprompt showall pkg (ancestor,unmerged') from br where filterOutTrivial :: Maybe Natural -> [Commit] -> IO [Commit] filterOutTrivial Nothing cs = return cs@@ -46,7 +46,7 @@ then return css else do -- drop oneline- ls <- tail <$> gitLines "show" ["-U1", "--pretty=oneline", commitRef c]+ ls <- tailSafe <$> gitLines "show" ["-U1", "--pretty=oneline", commitRef c] if isTrivialRebuildCommit ls then filterOutTrivial (Just (no -1)) cs else return css@@ -56,29 +56,30 @@ mergeable _ Rawhide = return (False,[]) mergeable from _ = do locals <- localBranches True- gitMergeable (show from `notElem` locals) from+ (mancestor, unmerged) <- gitMergeable (showBranch from `notElem` locals) from+ return (mancestor == Just True, unmerged) -- FIXME return merged ref-mergeBranch :: Bool -> Bool -> Bool -> Bool -> Maybe Package+mergeBranch :: Bool -> Bool -> Bool -> Bool -> Package -> (Bool,[Commit]) -- (ancestor,unmerged) -> Branch -> Branch -> IO () mergeBranch _ _ _ _ _ _ _ Rawhide = return () mergeBranch _ _ _ _ _ (_,[]) _ _ = return ()-mergeBranch dryrun build noprompt showall mpkg (True, unmerged) from br = do- whenJust mpkg $ flip putPkgBrnchHdr br+mergeBranch dryrun build noprompt showall pkg (True, unmerged@(unmgd:_)) from br = do+ unless build $ putPkgBrnchHdr pkg br isnewrepo <- initialPkgRepo- putStrLn $ (if isnewrepo || noprompt then "Merging from" else "New commits in") +-+ show from ++ ":"+ putStrLn $ (if isnewrepo || noprompt then "Merging from" else "New commits in") +-+ showBranch from ++ ":" displayCommits showall unmerged putNewLn- unpushed <- gitOneLineLog $ "origin/" ++ show br ++ "..HEAD"+ unpushed <- gitOneLineLog $ "origin/" ++ showBranch br ++ "..HEAD" unless (null unpushed) $ do putStrLn "Local commits:" displayCommits showall unpushed putNewLn mmerge <- if isnewrepo && length unmerged == 1 || noprompt- then return $ Just $ commitRef (head unmerged)- else refPrompt unmerged ("Press Enter to merge" +-+ show from +++ then return $ Just $ commitRef unmgd+ else refPrompt unmerged ("Press Enter to merge" +-+ showBranch from ++ (if build then " and build" else "") ++ (if length unmerged > 1 then "; or give ref to merge" else "") ++ "; or 'no' to skip merge")@@ -86,17 +87,17 @@ gitSwitchBranch (RelBranch br) whenJust mmerge $ \ ref -> do locals <- localBranches True- unless (show from `elem` locals) $- git_ "fetch" ["origin", show from ++ ":" ++ show from]+ unless (showBranch from `elem` locals) $+ git_ "fetch" ["origin", showBranch from ++ ":" ++ showBranch from] unless dryrun $ -- FIXME merge from origin by default not local branch git_ "merge" ["--quiet", ref]-mergeBranch dryrun build noprompt showall mpkg (False,unmerged) from br = do- unless build $ whenJust mpkg $ flip putPkgBrnchHdr br- putStrLn $ show from +-+ "branch is not directly mergeable:"+mergeBranch dryrun build noprompt showall pkg (False,unmerged) from br = do+ unless build $ putPkgBrnchHdr pkg br+ putStrLn $ showBranch from +-+ "branch is not directly mergeable:" displayCommits False unmerged putNewLn- unpushed <- gitOneLineLog $ "origin/" ++ show br ++ "..HEAD"+ unpushed <- gitOneLineLog $ "origin/" ++ showBranch br ++ "..HEAD" unless (null unpushed) $ do putStrLn "Local commits:" displayCommits showall unpushed
src/Cmd/Override.hs view
@@ -46,7 +46,7 @@ nvr <- pkgNameVerRel' br spec putStrLn $ showNVR nvr tags <- kojiNVRTags nvr- unless (any (`elem` tags) [show br, show br ++ "-updates", show br ++ "-override"]) $+ unless (any (`elem` tags) [showBranch br, showBranch br ++ "-updates", showBranch br ++ "-override"]) $ unlessM (checkAutoBodhiUpdate br) $ bodhiCreateOverride dryrun mduration nvr overrideCmd _dryrun OverrideList _mduration _nowait (_breq,pkgs) =
src/Cmd/Parallel.hs view
@@ -10,7 +10,7 @@ import Control.Concurrent.Async import Control.Exception.Extra (retry) import Data.RPM.NVR (NVR)-import Distribution.Fedora.Branch (branchDestTag, branchTarget)+import Distribution.Fedora.Branch (branchDestTag) import Distribution.RPM.Build.Order (dependencyLayersRpmOpts) import Fedora.Bodhi hiding (bodhiUpdate) import Say@@ -45,9 +45,10 @@ -- FIXME time builds -- FIXME copy bodhi notes from another branch update -- FIXME support non-sidetag update for parallel packages--- FIXME print layers if few packages?+-- FIXME print all layers if few packages? -- FIXME push update -- FIXME use more say+-- FIXME --skip-bumps NUM parallelBuildCmd :: Bool -> Maybe Bool -> Int -> Maybe SideTagTarget -> Bool -> Double -> (Maybe UpdateType, UpdateSeverity) -> (BranchesReq, [String]) -> IO ()@@ -78,7 +79,7 @@ mtargetSidetag <- if msidetagTarget == Just SideTag then do- tags <- map (head . words) <$> kojiUserSideTags (Just rbr)+ tags <- kojiUserSideTags (Just rbr) case tags of [] -> do putStrLn "will use new sidetag"@@ -92,7 +93,7 @@ when (mmerge /= Just False) $ withExistingDirectory p $ do pkg <- getPackageName p- mergeNewerBranch (Just pkg) rbr+ mergeNewerBranch pkg rbr getDynSourcesMacros $ packageSpec pkg distopts <- distRpmOptions rbr allLayers <- getLayers distopts pkgs@@ -101,7 +102,7 @@ unlessM (checkAutoBodhiUpdate rbr) $ error' "You must use --target/--sidetag to build package layers for this branch" when (length branches > 1) $- putStrLn $ "#" +-+ show rbr+ putStrLn $ "#" +-+ showBranch rbr target <- targetMaybeSidetag dryrun True rbr mtargetSidetag nvrclogs <- concatMapM (timeIO . parallelBuild target rbr) (zip [firstlayer..length allLayers] $@@ -109,7 +110,7 @@ unless (isNothing (fst mupdate)) $ unless (isNothing msidetagTarget) $ -- FIXME check for an existing sidetag update- when (target /= branchTarget rbr) $ do+ when (target /= showBranch rbr) $ do let changelog = intercalate "" $ renderChangelogs $ reverse nvrclogs putNewLn putStrLn changelog@@ -126,7 +127,7 @@ krbTicket currentbranch <- gitCurrentBranch putStrLn $ "= Building" +-+ pluralException (length brs) Nothing "branch" "branches" +-+ "in parallel:"- putStrLn $ unwords $ map show brs+ putStrLn $ unwords $ map showBranch brs jobs <- mapM setupBranch brs (failures,nvrclogs) <- timeIO $ watchJobs (length jobs == 1) Nothing [] [] jobs -- switch back to the original branch@@ -138,7 +139,7 @@ unless okay $ error' "Quitting" when (isNothing msidetagTarget) $ do let spec = packageSpec pkg- bodhiUpdate dryrun mupdate Nothing False spec $+ bodhiUpdate dryrun mupdate Nothing Nothing spec $ intercalate "," . map (showNVR . jobNvr) $ filter ((/= Rawhide) . jobBranch) nvrclogs where@@ -147,20 +148,21 @@ setupBranch br = do putPkgBrnchHdr pkg br target <- targetMaybeSidetag dryrun True br msidetagTarget- when (mmerge /= Just False) $ mergeNewerBranch Nothing br+ when (mmerge /= Just False) $ mergeNewerBranch pkg br job <- startBuild Nothing 0 False (length brs) target pkg br "." >>= async unless dryrun $ sleep delay- return (show br,job)+ return (showBranch br,job) - mergeNewerBranch :: Maybe Package -> Branch -> IO ()- mergeNewerBranch mpkg br = do+ mergeNewerBranch :: Package -> Branch -> IO ()+ mergeNewerBranch pkg br = do gitSwitchBranch (RelBranch br)- (ancestor,unmerged,mnewer) <- newerMergeable br+ (ancestor,unmerged,mnewer) <- newerMergeable (unPackage pkg) br unless dryrun $ whenJust mnewer $ \newer ->- mergeBranch dryrun False (mmerge == Just True) False mpkg (ancestor,unmerged) newer br+ mergeBranch dryrun False (mmerge == Just True) False pkg (ancestor,unmerged) newer br -- FIXME time builds or layers+ -- FIXME return Either parallelBuild :: String -> Branch -> (Int,[[String]]) -> IO [JobDone] parallelBuild _ _ (_,[]) = return [] -- should not reach here@@ -201,10 +203,11 @@ if okay then return nvrs else error' $- plural pending "pending package" ++ if pending > 0- then ":\n" ++ unwords (map unwords nextLayers)- else ""+ then+ plural pending "pending package" +++ ":\n" ++ unwords (map unwords nextLayers)+ else "failed" where nopkgs = length layer layersleft = length nextLayers@@ -248,7 +251,7 @@ let spec = packageSpec pkg checkForSpecFile spec nvr <- pkgNameVerRel' br spec- unpushed <- gitOneLineLog $ "origin/" ++ show br ++ "..HEAD"+ unpushed <- gitOneLineLog $ "origin/" ++ showBranch br ++ "..HEAD" if null unpushed then when mustpush $ do@@ -272,15 +275,17 @@ -- FIXME should compare git refs -- FIXME check for target buildstatus <- kojiBuildStatus nvr- let tag = if target == branchTarget br then branchDestTag br else target+ tag <- if target == showBranch br+ then branchDestTag br+ else return target mlatest <- kojiLatestNVR tag $ unPackage pkg case buildstatus of Just BuildComplete -> do -- FIXME detect old stable existing build sayString $ color Green (showNVR nvr) +-+ "is already" +-+ color Green "built"- when (br /= Rawhide && morelayers && target == branchTarget br) $ do+ when (br /= Rawhide && morelayers && target == showBranch br) $ do tags <- kojiNVRTags nvr- unless (any (`elem` tags) [show br, show br ++ "-updates", show br ++ "-override"]) $+ unless (any (`elem` tags) [showBranch br, showBranch br ++ "-updates", showBranch br ++ "-override"]) $ unlessM (checkAutoBodhiUpdate br) $ bodhiCreateOverride dryrun Nothing nvr return $ do@@ -302,7 +307,7 @@ maybe "" (\l -> "in layer" +-+ show l) mlayer putNewLn putStrLn changelog- buildref <- git "show-ref" ["--hash", "origin/" ++ show br]+ buildref <- git "show-ref" ["--hash", "origin/" ++ showBranch br] opentasks <- kojiOpenTasks pkg (Just buildref) target case opentasks of [task] -> do@@ -337,7 +342,7 @@ else do whenJustM (findExecutable "koji-tool") $ \kojitool -> -- FIXME cmdLog deprecated- cmdLog kojitool ["tasks", "--children", displayID task, "-s", "fail"]+ cmdLog kojitool $ ["tasks", "--children", displayID task, "-s", "fail"] ++ ["--tail" | nopkgs < 3] error' $ color Red $ showNVR nvr +-+ "build failed" autoupdate <- checkAutoBodhiUpdate br if autoupdate then@@ -346,7 +351,7 @@ whenJust mBugSess $ \(bid,session) -> putBugBuild dryrun session bid nvr else do- when (target == branchTarget br && morelayers) $+ when (target == showBranch br && morelayers) $ -- -- FIXME: avoid prompt in -- changelog <- changeLogPrompt False spec -- bodhiUpdate (fmap fst mBugSess) changelog nvr
− src/Cmd/PkgReview.hs
@@ -1,146 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Cmd.PkgReview (- createReview,- updateReview,- ScratchOption(..)- ) where--import Common-import Common.System-import qualified Common.Text as T--import Data.Char-import Network.HTTP.Directory (httpExists, httpManager)-import SimplePrompt (promptEnter, yesNoDefault)--import Branches-import Bugzilla-import Koji-import Krb-import Package-import RpmBuild-import Types (ChangeType(ChangeReview))--data ScratchOption = ScratchBuild | ScratchTask Int | SkipScratch- deriving Eq---- FIXME add --dependent pkgreview--- FIXME verify tarball is same as upstream--- FIXME post URL field too-createReview :: Maybe ScratchOption -> Bool -> [FilePath] -> IO ()-createReview mscratchOpt mock pkgs =- withPackagesByBranches HeaderMust False Nothing Zero createPkgReview (Branches [], pkgs)- where- createPkgReview :: Package -> AnyBranch -> IO ()- createPkgReview package _br = do- let spec = packageSpec package- pkg = unPackage package- unlessM (doesFileExist spec) $- error' $ "This does not look like a pkg dir:" +-+ spec +-+ "not found"- unless (all isAscii pkg) $- putStrLn "Warning: package name is not ASCII!"- putStrLn "checking for existing reviews..."- (bugs,session) <- bugsSession $ pkgReviews pkg- unless (null bugs) $ do- putStrLn "Existing review(s):"- mapM_ putBug bugs- -- FIXME abort if open review (unless --force?)- promptEnter "Press Enter to continue"- srpm <- generateSrpm Nothing spec- mockRpmLint mock pkg spec srpm- (mkojiurl,specSrpmUrls) <- buildAndUpload mscratchOpt srpm pkg spec- bugid <- postReviewReq session spec specSrpmUrls mkojiurl pkg- putStrLn "Review request posted:"- putBugId bugid- where- postReviewReq :: BugzillaSession -> FilePath -> String -> Maybe String -> String -> IO BugId- postReviewReq session spec specSrpmUrls mkojiurl pkg = do- summary <- cmd "rpmspec" ["-q", "--srpm", "--qf", "%{summary}", spec]- description <- cmd "rpmspec" ["-q", "--srpm", "--qf", "%{description}", spec]- url <- cmd "rpmspec" ["-q", "--srpm", "--qf", "%{url}", spec]- createBug session- [ ("product", "Fedora")- , ("component", "Package Review")- , ("version", "rawhide")- , ("summary", "Review Request: " <> pkg <> " - " <> summary)- , ("url", url)- , ("description", specSrpmUrls <> "\n\nDescription:\n" <> description <> maybe "" ("\n\n\nKoji scratch build: " <>) mkojiurl)]--buildAndUpload :: Maybe ScratchOption -> String -> String -> FilePath- -> IO (Maybe String, String)-buildAndUpload mscratchOpt srpm pkg spec = do- scratch <-- if isNothing mscratchOpt- then yesNoDefault False "Would you like to do a koji scratch build before submitting"- else do- let doscratch = mscratchOpt == Just ScratchBuild- promptEnter $ "Press Enter to" +-+ if doscratch- then "submit"- else "upload"- return doscratch- mkojiurl <- case mscratchOpt of- Just (ScratchTask tid) -> return $ Just ("https://koji.fedoraproject.org/koji/taskinfo?taskID=" ++ show tid)- _ ->- if scratch- then Just <$> kojiScratchBuild "rawhide" [] srpm- else return Nothing- specSrpmUrls <- uploadPkgFiles pkg spec srpm- return (mkojiurl, specSrpmUrls)--updateReview :: Maybe ScratchOption -> Bool -> Maybe FilePath -> IO ()-updateReview mscratchOpt mock mspec = do- spec <- maybe findSpecfile checkLocalFile mspec- pkg <- cmd "rpmspec" ["-q", "--srpm", "--qf", "%{name}", spec]- (bid,session) <- reviewBugIdSession pkg- putBugId bid- srpm <- generateSrpm Nothing spec- submitted <- checkForComment session bid (T.pack srpm)- when submitted $- error' "This NVR was already posted on the review bug: please bump"- mockRpmLint mock pkg spec srpm- (mkojiurl,specSrpmUrls) <- buildAndUpload mscratchOpt srpm pkg spec- changelog <- changeLogPrompt ChangeReview spec- commentBug session bid (specSrpmUrls <> (if null changelog then "" else "\n\n" <> changelog) <> maybe "" ("\n\nKoji scratch build: " <>) mkojiurl)- putBugId bid- where- checkLocalFile :: FilePath -> IO FilePath- checkLocalFile f =- if takeFileName f == f then return f- else error' "Please run in the directory of the spec file"--uploadPkgFiles :: String -> FilePath -> FilePath -> IO String-uploadPkgFiles pkg spec srpm = do- fasid <- fasIdFromKrb- -- read ~/.config/fedora-create-review- let sshhost = "fedorapeople.org"- sshpath = "public_html/reviews/" ++ pkg- cmd_ "ssh" [fasid ++ "@" ++ sshhost, "mkdir", "-p", sshpath]- cmd_ "scp" [spec, srpm, fasid ++ "@" ++ sshhost ++ ":" ++ sshpath]- getCheckedFileUrls $ "https://" <> fasid <> ".fedorapeople.org" +/+ removePrefix "public_html/" sshpath- where- getCheckedFileUrls :: String -> IO String- getCheckedFileUrls uploadurl = do- let specUrl = uploadurl +/+ takeFileName spec- srpmUrl = uploadurl +/+ takeFileName srpm- mgr <- httpManager- checkUrlOk mgr specUrl- checkUrlOk mgr srpmUrl- return $ "Spec URL: " <> specUrl <> "\nSRPM URL: " <> srpmUrl- where- checkUrlOk mgr url = do- okay <- httpExists mgr url- unless okay $ error' $ "Could not access:" +-+ url--mockRpmLint :: Bool -> String -> FilePath -> FilePath -> IO ()-mockRpmLint mock pkg spec srpm = do- rpms <-- if mock then do- -- FIXME check that mock is installed- let resultsdir = "results_" ++ pkg- cmd_ "mock" ["--root", mockRoot Rawhide Nothing, "--resultdir=" ++ resultsdir, srpm]- map (resultsdir </>) . filter ((== ".rpm") . takeExtension) <$> listDirectory resultsdir- else- builtRpms (RelBranch Rawhide) spec >>= filterM doesFileExist- -- FIXME parse # of errors/warnings- void $ cmdBool "rpmlint" $ spec:srpm:rpms
src/Cmd/Prep.hs view
@@ -16,6 +16,7 @@ deriving Eq -- FIXME prompt for cloning+-- FIXME to skip prep or deps (eg in broken toolbox when deps can't install;) prepCmd :: Maybe PrepPre -> Bool -> Bool -> Bool -> (Maybe Branch,[String]) -> IO () prepCmd mpre verbose deps allowhead (mbr,pkgs) = do
src/Cmd/RequestBranch.hs view
@@ -78,7 +78,7 @@ mbidsession <- bzReviewSession urls <- forM newbranches $ \ br -> do when mock $ fedpkg_ "mockbuild" ["--root", mockRoot br Nothing]- when (length branches' > 1) $ putStr $ show br ++ " "+ when (length branches' > 1) $ putStr $ showBranch br ++ " " -- 1. Can timeout like this: -- Could not execute request_branch: HTTPSConnectionPool(host='pagure.io', port=443): Read timed out. (read timeout=60) -- fbrnch: readCreateProcess: fedpkg "request-branch" "epel9" (exit 1): failed@@ -90,7 +90,7 @@ -- misconfiguration and was unable to complete -- your request.</p> [...] -- fbrnch: readCreateProcess: fedpkg "request-branch" "epel9" (exit 1): failed- u <- fedpkg "request-branch" [show br]+ u <- fedpkg "request-branch" [showBranch br] putStrLn u return u whenJust mbidsession $ \(bid,session) ->@@ -114,7 +114,7 @@ let pkgPrefix = if multiple then unPackage pkg ++ ": " else "" forM_ branches $ \ br -> when (br `elem` existing) $- putStrLn $ pkgPrefix ++ show br +-+ "branch already exists"+ putStrLn $ pkgPrefix ++ showBranch br +-+ "branch already exists" let brs' = branches \\ existing if null brs' then return []@@ -122,7 +122,7 @@ current <- fedoraBranchesNoRawhide $ pagurePkgBranches (unPackage pkg) forM_ brs' $ \ br -> when (br `elem` current) $- putStrLn $ pkgPrefix ++ show br +-+ "remote branch already exists"+ putStrLn $ pkgPrefix ++ showBranch br +-+ "remote branch already exists" let newbranches = brs' \\ current if null newbranches then return []@@ -142,12 +142,12 @@ notExistingRequest requests br = do let processed = filter processedIssueFilter requests unless (null processed) $ do- putStrLn $ "Branch request already exists for" +-+ unPackage pkg ++ ":" ++ show br+ putStrLn $ "Branch request already exists for" +-+ unPackage pkg ++ ":" ++ showBranch br mapM_ printScmIssue processed return $ null processed where processedIssueFilter issue =- pagureIssueTitle issue == ("New Branch \"" ++ show br ++ "\" for \"rpms/" ++ unPackage pkg ++ "\"")+ pagureIssueTitle issue == ("New Branch \"" ++ showBranch br ++ "\" for \"rpms/" ++ unPackage pkg ++ "\"") && pagureIssueCloseStatus issue == Just "Processed"
src/Cmd/RequestRepo.hs view
@@ -4,12 +4,15 @@ import Control.Exception.Extra (retry) import Network.HTTP.Directory (httpExists, httpManager)-import SimpleCmd-import SimplePrompt (promptEnter, promptInitial)+import Safe (headMay)+import SimplePrompt (promptEnter, promptInitial, yesNo)+import System.Time.Extra (sleep) import Branches import Bugzilla+import Cmd.Import (importCmd) import Common+import Common.System (error') import qualified Common.Text as T import Krb import ListReviews@@ -43,16 +46,15 @@ else do requests <- if skipcheck then return [] else existingRepoRequests- unless (null requests) $ do+ whenJust (headMay requests) $ \request -> do putStrLn "Request exists:" mapM_ printScmIssue requests -- don't resubmit if succeeded- -- FIXME head- when (resubmit && pagureIssueCloseStatus (head requests) == Just "Processed") $+ when (resubmit && pagureIssueCloseStatus request == Just "Processed") $ error' "The last repo request was already successfully Processed" when (null requests || resubmit) $ do checkNoPagureRepo- putNewLn+ -- may be truncated with "<rest of output cut here>" comments <- getComments session bid mapM_ showComment comments putNewLn@@ -61,20 +63,22 @@ promptEnter "Press Enter to continue" -- FIXME check api key is still valid or open pagure ticket directly fedpkg_ "request-repo" [pkg, show bid]+ putNewLn let draft = "Thank you for the review" ++ maybe "" ("," +-+) (assigneeFirstname $ bugAssignedToDetail bug)- putStrLn "```"- putStrLn draft- putStrLn "```" input <- promptInitial "Enter comment" draft- let comment = (if null input then draft else input)- commentBug session bid comment+ unless (null input) $+ commentBug session bid input putNewLn branches <- getRequestedBranches [] breq forM_ branches $ \ br -> do when mock $ fedpkg_ "mockbuild" ["--root", mockRoot br Nothing]- putStr $ show br ++ " "- fedpkg_ "request-branch" ["--repo", pkg, show br]+ putStr $ showBranch br ++ " "+ fedpkg_ "request-branch" ["--repo", pkg, showBranch br] putNewLn+ ok <- yesNo $ "Import" +-+ pkg+ when ok $ do+ waitForPagureRepo+ importCmd True False False (Branches [],[pkg]) where existingRepoRequests :: IO [IssueTitleStatus] existingRepoRequests = do@@ -107,3 +111,15 @@ if "@" `T.isInfixOf` first then Nothing else Just (T.unpack first)++ waitForPagureRepo :: IO ()+ waitForPagureRepo = do+ ebrs <- pagureListGitBranches srcfpo $ "rpms/" ++ pkg+ case ebrs of+ Left _err -> do+ putChar '.'+ sleep 10+ waitForPagureRepo+ Right brs ->+ when (null brs) $+ error' $ "no branches in dist-git for" +-+ pkg
src/Cmd/ReviewPackage.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings #-} module Cmd.ReviewPackage ( reviewPackage@@ -8,6 +8,8 @@ import Common.System import Data.Char+import Data.Tuple.Extra (second)+import Safe (headDef, headMay, tailSafe) import SelectRPMs (selectDefault) import SimplePrompt (promptEnter, yesNoDefault) @@ -23,11 +25,14 @@ -- FIXME does not work with pkg dir/spec: 'fbrnch: No spec file found' -- FIXME --user to download all user's review requests reviewPackage :: Bool -> Maybe String -> IO ()-reviewPackage _ Nothing = do+reviewPackage interactive Nothing = do -- FIXME catch no spec file spec <- findSpecfile srpm <- generateSrpm Nothing spec- cmd_ "fedora-review" ["-rn", srpm]+ if interactive+ then doInteractiveReview False (Just spec) srpm+ else do+ cmd_ "fedora-review" ["-rn", srpm] reviewPackage interactive (Just pkgbug) = do let epkgbid = if all isDigit pkgbug@@ -70,13 +75,23 @@ -- FIXME default to no if nvr unchanged? yesNoDefault True "Press Enter to install/prep srpm" else return True- let spec = pkg <.> "spec"+ -- review and package name may be different (eg ramalama)+ doInteractiveReview importsrpm Nothing srpm+ putNewLn+ putReviewBug False bug+ putNewLn+ putStrLn $ "Review dir is" +-+ dir++doInteractiveReview :: Bool -> Maybe FilePath -> FilePath -> IO ()+doInteractiveReview importsrpm mspec srpm = do when importsrpm $ do isgit <- isGitRepo unless isgit $ git_ "init" [] -- FIXME override %_sourcedir so it doesn't put elsewhere? sourcediropt <- sourceDirCwdOpt- cmd_ "rpm" $ ["-ivh", srpm] ++ sourcediropt+ putStrLn "installing srpm:"+ cmd_ "rpm" $ ["-i", srpm] ++ sourcediropt+ spec <- maybe findSpecfile return mspec git_ "add" [spec] allsrcs <- map sourceFieldFile <$> cmdLines "spectool" [spec] forM_ allsrcs $ \src ->@@ -93,24 +108,31 @@ else mapM_ putStrLn filterdiff unlessM (gitBool "diff" ["--quiet", "--cached"]) $ git_ "commit" ["-m", srpm]+ putNewLn putStrLn "# Build" -- FIXME or download rpms build <- yesNoDefault importsrpm "Build package locally" when build $ localCmd False False Nothing [] (Branches [],[])+ putNewLn putStrLn "# RpmLint" void $ cmdBool "rpmlint" ["."] -- FIXME $ spec:srpm:rpms+ spec <- maybe findSpecfile return mspec whenM (yesNoDefault importsrpm "Install packages locally") $ do- installCmd False False Nothing Nothing [] False True True selectDefault (Nothing,[])+ installCmd False False Nothing Nothing [] False True True selectDefault Nothing (Nothing,[]) rpms <- cmdLines "rpmspec" ["-q", "--rpms", "--qf", "%{name}\n", spec] whenM (yesNoDefault importsrpm "Rpmlint installed packages") $ do (_ok, out, err) <- cmdFull "rpmlint" ("-i" : rpms) "" let rpmlintout = "rpmlint.output" writeFile rpmlintout out- let nolines = length $ lines out+ let ls = lines out+ nolines = length ls if nolines > 20 then do- cmd_ "tail" [rpmlintout]+ mapM_ putStrLn $ takeEnd 10 ls+ putNewLn+ putStrLn "RpmLint summary:"+ mapM_ (putStrLn . renderLintSummary) $ summarizeErrors ls putStrLn $ show nolines +-+ "lines saved to" +-+ rpmlintout else putStrLn out unless (null err) $ warning $ "rpmlint stderr:\n" ++ err@@ -122,6 +144,19 @@ -- handle "FILEPATH: *No copyright* UNKNOWN [generated file]" mapM_ putStrLn . filter (not . (" UNKNOWN" `isInfixOf`)) cmd_ "rpmspec" ["-q", "--srpm", "--qf", "Spec license: %{license}\n", spec]- putNewLn- putReviewBug False bug- putStrLn $ "Review dir is" +-+ dir++summarizeErrors :: [String] -> [(String,Int)]+summarizeErrors =+ sortOn fst . map (second length) . groupOnKey (headDef "''") . map tailSafe . filter ((Just "E:" ==) . headMay) . map (tailSafe . words)++renderLintSummary :: (String,Int) -> String+renderLintSummary (err,n) = err ++ ":" +-+ show n++#if !MIN_VERSION_extra(1,7,11)+groupOnKey :: Eq k => (a -> k) -> [a] -> [(k, [a])]+groupOnKey _ [] = []+groupOnKey f (x:xs) = (fx, x:yes) : groupOnKey f no+ where+ fx = f x+ (yes, no) = span (\y -> fx == f y) xs+#endif
src/Cmd/Scratch.hs view
@@ -9,7 +9,7 @@ ) where import Data.RPM.NVR (NVR)-import Distribution.Fedora.Branch (branchTarget)+import Safe (tailSafe) import Branches import Common@@ -39,7 +39,7 @@ scratchCmd dryrun stagger rebuildSrpm nofailfast allowHEAD marchopts sidetagTargets msource (breq,pkgs) = withPackagesByBranches HeaderMust False Nothing AnyNumber scratchBuild (breq,pkgs) where- anyTarget (RelBranch b) = branchTarget b+ anyTarget (RelBranch b) = showBranch b anyTarget _ = "rawhide" scratchBuild :: Package -> AnyBranch -> IO ()@@ -69,7 +69,7 @@ return $ if null excluded then return []- else concatMap tail excluded+ else concatMap tailSafe excluded return $ tagArchs \\ (as ++ excludedarchs) if stagger then do@@ -127,16 +127,15 @@ putStrLn $ "Target:" +-+ target void $ generateSrpm (Just br) spec >>= kojiScratchBuild target kojiargs --- FIXME default -X to --no-fastfail? scratchCmdX86_64 :: Bool -> Bool -> Bool -> Bool -> [SideTagTarget] -> Maybe ScratchSource -> (BranchesReq, [String]) -> IO () scratchCmdX86_64 dryrun rebuildSrpm allowHEAD excludeArch =- scratchCmd dryrun False rebuildSrpm False allowHEAD (Just (excludeArchs excludeArch ["x86_64"]))+ scratchCmd dryrun False rebuildSrpm True allowHEAD (Just (excludeArchs excludeArch ["x86_64"])) scratchCmdAarch64 :: Bool -> Bool -> Bool -> Bool -> [SideTagTarget] -> Maybe ScratchSource -> (BranchesReq, [String]) -> IO () scratchCmdAarch64 dryrun rebuildSrpm allowHEAD excludeArch =- scratchCmd dryrun False rebuildSrpm False allowHEAD (Just (excludeArchs excludeArch ["aarch64"]))+ scratchCmd dryrun False rebuildSrpm True allowHEAD (Just (excludeArchs excludeArch ["aarch64"])) excludeArchs :: Bool -> [String] -> Archs excludeArchs excl = if excl then ExcludedArchs else Archs
src/Cmd/SideTags.hs view
@@ -1,23 +1,53 @@-module Cmd.SideTags (sideTagsCmd) where+module Cmd.SideTags (+ sideTagsCmd,+ SidetagMode(..))+where -import SimpleCmd (cmd_)+import SimpleCmd (cmd_, cmdN, error') import SimplePrompt (yesNo) import Branches import Common+import Git (isPkgGitRepo) import Koji import Krb (krbTicket) -sideTagsCmd :: Bool -> [Branch] -> IO ()-sideTagsCmd remove brs = do+data SidetagMode = SidetagAdd | SidetagRemove+ deriving Eq++sideTagsCmd :: Bool -> Maybe SidetagMode -> [Branch] -> IO ()+sideTagsCmd dryrun mmode brs = do+ branches <-+ if null brs && isJust mmode+ then do+ pkggit <- isPkgGitRepo+ if pkggit+ then do+ br <- getReleaseBranch+ return [br]+ else error' "please specify a branch"+ else return brs sidetags <-- if null brs+ if null branches then kojiUserSideTags Nothing- else concat <$> mapM (kojiUserSideTags . Just) brs- when remove krbTicket- mapM_ (if remove then removeSideTag else putStrLn) sidetags+ else concat <$> mapM (kojiUserSideTags . Just) branches+ unless (isNothing mmode)+ krbTicket+ case mmode of+ Nothing -> mapM_ putStrLn sidetags+ Just SidetagRemove -> mapM_ removeSideTag sidetags+ Just SidetagAdd -> do+ putStrLn "existing tags:"+ mapM_ putStrLn sidetags+ putNewLn+ mapM_ addSideTag branches where removeSideTag :: String -> IO () removeSideTag tag = whenM (yesNo $ "Remove" +-+ tag) $- cmd_ "fedpkg" ["remove-side-tag", tag]+ (if dryrun then cmdN else cmd_) "fedpkg" ["remove-side-tag", tag]++ addSideTag :: Branch -> IO ()+ addSideTag br =+ whenM (yesNo $ "Create" +-+ indefinite (showBranch br) +-+ "user sidetag") $+ void $ createKojiSidetag dryrun br
src/Cmd/SrcDeps.hs view
@@ -5,6 +5,7 @@ where import Distribution.RPM.Build.Graph+import Safe (headMay) import Branches import Common@@ -24,7 +25,7 @@ whenM isPkgGitRepo $ error' "please run from the directory containing the dependency package set" listDirectory "." >>=- filterM checkPackage . filter ((/= '.') . head) >>=+ filterM checkPackage . filter ((/= Just '.') . headMay) >>= fmap (topsortGraph Combine) . depsGraphDeps rev (map ("-D" +-+) macros) False [] [] False Nothing pkgs where checkPackage :: FilePath -> IO Bool
src/Cmd/Status.hs view
@@ -49,7 +49,7 @@ if not brExists then do name <- getDirectoryName- putStrLn $ name +-+ "has no branch" +-+ show br+ putStrLn $ name +-+ "has no branch" +-+ showBranch br else do gitSwitchBranch rbr let spec = packageSpec pkg@@ -57,7 +57,7 @@ if not exists then ifM initialPkgRepo- (putStrLn $ show br ++ ": initial repo")+ (putStrLn $ showBranch br ++ ": initial repo") (putStrLn $ "missing" +-+ spec) else do mnvr <- pkgNameVerRel br spec@@ -75,13 +75,14 @@ -- unless (null unmerged) $ do -- putStrLn $ "Newer commits in" +-+ show newerBr ++ ":" -- mapM_ putStrLn unmerged- munpushed <- gitShortLog1 $ Just $ "origin/" ++ show br ++ "..HEAD"+ munpushed <- gitShortLog1 $ Just $ "origin/" ++ showBranch br ++ "..HEAD" case munpushed of Nothing -> do mbuild <- kojiGetBuildID fedoraHub (showNVR nvr) case mbuild of Nothing -> do- mlatest <- kojiLatestNVR (branchDestTag br) (unPackage pkg)+ destTag <- branchDestTag br+ mlatest <- kojiLatestNVR destTag (unPackage pkg) case mlatest of Nothing -> putStrLn $ "new" +-+ showNVR nvr Just latest ->@@ -98,6 +99,7 @@ else do -- FIXME hide testing if ga/stable putStr $ showNVR nvr +-+ "(" ++ unwords tags ++ ")"+ -- FIXME use stable_tag unless (isStable tags) $ do updates <- bodhiUpdates [makeItem "display_user" "0",@@ -122,7 +124,7 @@ (if length pkgs > 1 then unPackage pkg else "") +-+ case breq of Branches brs | length brs <= 1 -> ""- _ -> show br+ _ -> showBranch br in if null pref then "" else pref ++ ":" in putStrLn $ prefix +-+ showCommit unpushed where
src/Cmd/Unpushed.hs view
@@ -28,7 +28,7 @@ if not brExists then do name <- getDirectoryName- putStrLn $ name +-+ "has no branch" +-+ show br+ putStrLn $ name +-+ "has no branch" +-+ showBranch br else do gitSwitchBranch rbr let spec = packageSpec pkg@@ -38,7 +38,7 @@ then unPackage pkg else "") +-+ case breq of Branches brs | length brs <= 1 -> ""- _ -> show br+ _ -> showBranch br in if null pref then "" else pref ++ ":" haveSpec <- doesFileExist spec if not haveSpec@@ -53,7 +53,7 @@ putStrLn "undefined NVR!\n" putStr "HEAD " unpushed <- gitShortLogN (if latest then Just 1 else Nothing) $- Just $ "origin/" ++ show br ++ "..HEAD"+ Just $ "origin/" ++ showBranch br ++ "..HEAD" if null unpushed then when bump $ bumpPkg False False Nothing Nothing pkg rbr
src/Cmd/Update.hs view
@@ -15,7 +15,6 @@ import Krb import Package --- FIXME if autorelease, drop -b baserelease -- FIXME --no-prep to avoid overwriting ongoing build -- FIXME don't bump release if already bumped -- FIXME check EVR increased@@ -51,6 +50,7 @@ spec <- if allowHEAD then findSpecfile else localBranchSpecFile pkg br+ -- FIXME detect uncommitted version bump, ie old committed version (curver,_) <- pkgVerRel spec vdiff <- filter ("Version:" `isInfixOf`) . filter (not . ("@@ " `isPrefixOf`)) <$> gitLines "diff" ["-U0", "HEAD", spec] unless (length vdiff `elem` [0,2]) $@@ -82,8 +82,13 @@ putStrLn $ oldver +-+ "->\n" ++ newver when (curver /= newver) $ do editSpecField "Version" newver spec- -- FIXME do not touch %autorelease- editSpecField "Release" "0%{?dist}" spec+ autorelease <- isAutoRelease spec+ if autorelease+ then do+ autobump <- autoReleaseBump spec+ when autobump $+ editSpecField "Release" "%autorelease" spec+ else editSpecField "Release" "0%{?dist}" spec -- FIXME should be sure sources exists for distgit whenM (doesFileExist "sources") $ cmd_ "sed" ["-i", "/" ++ unPackage pkg ++ "-" ++ oldver ++ "./d", "sources"]@@ -109,10 +114,13 @@ cmd_ "fedpkg" $ "new-sources" : filter isArchiveFile sources whenJust moldnewver $ \(_old,newver) -> do versions <- changelogVersions spec- let missing = null versions || not ((newver ++ "-") `isPrefixOf` head versions)+ let missing =+ case versions of+ [] -> True+ (h:_) -> not $ (newver ++ "-") `isPrefixOf` h when missing $ do- cmd_ "rpmdev-bumpspec" ["-c", "update to" +-+ newver, spec]- git_ "commit" ["-a", "-m", "update to" +-+ newver]+ cmd_ "rpmdev-bumpspec" ["-c", "Update to" +-+ newver, spec]+ git_ "commit" ["-a", "-m", "Update to" +-+ newver] putStr "Prepping... " sourcediropt <- sourceDirCwdOpt cmdSilent' "rpmbuild" $ "-bp" : sourcediropt ++ ["--nodeps", spec]
+ src/Cmd/UpdateReview.hs view
@@ -0,0 +1,37 @@+module Cmd.UpdateReview (+ updateReviewCmd+ )+where++import Control.Monad (when)+import SimpleCmd (cmd, error')+import System.FilePath (takeFileName)++import Bugzilla+--import Common+import qualified Common.Text as T+import Package+import PkgReview+import RpmBuild+import Types (ChangeType(ChangeReview))++updateReviewCmd :: Maybe ScratchOption -> Bool -> Maybe FilePath -> IO ()+updateReviewCmd mscratchOpt mock mspec = do+ spec <- maybe findSpecfile checkLocalFile mspec+ pkg <- cmd "rpmspec" ["-q", "--srpm", "--qf", "%{name}", spec]+ (bid,session) <- reviewBugIdSession pkg+ putBugId bid+ srpm <- generateSrpm Nothing spec+ submitted <- checkForComment session bid (T.pack srpm)+ when submitted $+ error' "This NVR was already posted on the review bug: please bump"+ mockRpmLint mock pkg spec srpm+ (mkojiurl,specSrpmUrls) <- buildAndUpload mscratchOpt srpm pkg spec+ changelog <- changeLogPrompt ChangeReview spec+ commentBug session bid (specSrpmUrls <> (if null changelog then "" else "\n\n" <> changelog) <> maybe "" ("\n\nKoji scratch build: " <>) mkojiurl)+ putBugId bid+ where+ checkLocalFile :: FilePath -> IO FilePath+ checkLocalFile f =+ if takeFileName f == f then return f+ else error' "Please run in the directory of the spec file"
src/Cmd/WaitRepo.hs view
@@ -35,4 +35,5 @@ nvr <- pkgNameVerRel' br spec target <- targetMaybeSidetag dryrun False br msidetagTarget logMsg $ "Waiting for" +-+ showNVR nvr +-+ "to appear in" +-+ target+ -- FIXME can we get time from koji waitrepo task? timeIO $ kojiWaitRepo dryrun True knowntag target nvr
src/Common.hs view
@@ -9,15 +9,21 @@ #endif (+/+), (+-+),+ indefinite, plural, pluralException,+ singularVerb, putNewLn, reverseSort, showNVR ) where import Control.Monad.Extra -- hiding (loop)-import Data.List.Extra hiding (list, merge)+import Data.List.Extra hiding (list, merge,+#if MIN_VERSION_extra(1,6,19)+ headDef+#endif+ ) import Data.Maybe import Data.Ord (comparing, Down(Down)) import Data.RPM.NVR (showNVR)@@ -42,6 +48,14 @@ " ", if i == 1 then ns else ps ]++singularVerb :: Bool -> String -> String+singularVerb singular v = v ++ if singular then "s" else ""++indefinite :: String -> String+indefinite "" = ""+indefinite w@(c:_) =+ (if c `elem` "aeiou" then "an" else "a") +-+ w putNewLn :: IO () putNewLn = putChar '\n'
src/Common/System.hs view
@@ -10,7 +10,7 @@ #if !MIN_VERSION_filepath(1,4,2) isExtensionOf, #endif-#if !MIN_VERSION_simple_cmd(0,2,3)+#if !MIN_VERSION_simple_cmd(0,2,8) cmdFull, #endif #if !MIN_VERSION_simple_cmd(0,2,5)@@ -21,11 +21,16 @@ #if !MIN_VERSION_filepath(1,4,2) import Data.List #endif-import SimpleCmd+import Safe+import SimpleCmd hiding (+#if !MIN_VERSION_simple_cmd(0,2,8)+ cmdFull,+#endif #if MIN_VERSION_simple_cmd(0,2,1)- hiding (ifM,whenM)+ ifM,whenM #endif-#if !MIN_VERSION_simple_cmd(0,2,3)+ )+#if !MIN_VERSION_simple_cmd(0,2,8) import System.Exit import System.Process #endif@@ -52,23 +57,24 @@ isTty = hIsTerminalDevice stdin setNoBuffering :: IO ()-setNoBuffering =+setNoBuffering = do hSetBuffering stdout NoBuffering+ hSetBuffering stderr NoBuffering getDirectoryName :: IO String getDirectoryName = takeFileName <$> getCurrentDirectory -#if !MIN_VERSION_simple_cmd(0,2,3)+-- bugfix for lazy stderr+#if !MIN_VERSION_simple_cmd(0,2,8) cmdFull :: String -> [String] -> String -> IO (Bool, String, String) cmdFull c args input = do (ret, out, err) <- readProcessWithExitCode c args input return (ret == ExitSuccess, removeTrailingNewline out, removeTrailingNewline err) where removeTrailingNewline :: String -> String- removeTrailingNewline "" = "" removeTrailingNewline str =- if last str == '\n'+ if lastMay str == Just '\n' then init str else str #endif
src/Git.hs view
@@ -37,6 +37,8 @@ import Data.Char (isSpace) import Distribution.Fedora.Branch (newerBranch)+import Safe (tailSafe)+import Say (sayString) import SimpleCmd.Git import SimplePrompt @@ -53,57 +55,78 @@ cmdBool "git" (c:args) #endif -gitMergeable :: Bool -> Branch -> IO (Bool,[Commit])+-- Just True => ancestor+-- Nothing => neither ancestor+-- Just False => reverse ancestor+gitMergeable :: Bool -> Branch -> IO (Maybe Bool,[Commit]) gitMergeable origin br = do- let ref = (if origin then "origin/" else "") ++ show br- ancestor <- gitBool "merge-base" ["--is-ancestor", "HEAD", ref]+ let ref = (if origin then "origin/" else "") ++ showBranch br+ mancestor <- do+ ancestor <- gitBool "merge-base" ["--is-ancestor", "HEAD", ref]+ if ancestor+ then return $ Just True+ else do+ revancestor <- gitBool "merge-base" ["--is-ancestor", ref, "HEAD"]+ if revancestor+ then return $ Just False+ else+ if not origin+ then do+ origancestor <- gitBool "merge-base" ["--is-ancestor", "HEAD", "origin/" ++ showBranch br]+ if origancestor+ then error $ "origin/" ++ showBranch br +-+ "is ancestor but not" +-+ showBranch br+ else return Nothing+ else return Nothing commits <- gitOneLineLog ("HEAD.." ++ ref)- when (not origin && null commits && not ancestor) $- whenM (gitBool "merge-base" ["--is-ancestor", "HEAD", "origin/" ++ show br]) $ do- rancestor <- gitBool "merge-base" ["--is-ancestor", ref, "HEAD"]- if rancestor+ when (not origin && null commits && mancestor /= Just True) $+ if mancestor == Just False then do diff <- git "diff" [ref] unless (null diff) $ do- putStrLn $ "current branch is ahead of newer" +-+ show br +-+ "!!"+ putStrLn $ "current branch is ahead of newer" +-+ showBranch br +-+ "!!" promptEnter "Press Enter if you want to continue"- else putStrLn $ "current branch" +-+ "is diverged from" +-+ show br- return (ancestor, commits)+ else putStrLn $ "current branch" +-+ "is diverged from" +-+ showBranch br+ return (mancestor, commits) -getNewerBranch :: Branch -> IO (Maybe Branch)-getNewerBranch Rawhide = return Nothing-getNewerBranch br = do- branches <- fedoraBranches (localBranches False)- let newer = newerBranch br branches- return $- if newer > br- then Just newer- else- case elemIndex br branches of- Just i -> Just $ branches !! (i - 1)- Nothing -> Nothing+-- FIXME use Package+getNewerBranch :: String -> Branch -> IO (Maybe Branch)+getNewerBranch _ Rawhide = return Nothing+getNewerBranch pkg br = do+ localbrs <- fedoraBranches (localBranches False)+ case newerBranch br localbrs of+ Just newer ->+ if newer `elem` localbrs+ then return $ Just newer+ else do+ remotebrs <- fedoraBranches (pagurePkgBranches pkg)+ if newer `elem` remotebrs+ then do+ gitFetchSilent False+ return $ Just newer+ else return $ newerBranch br remotebrs+ Nothing -> return Nothing gitMergeOrigin :: Branch -> IO () gitMergeOrigin br = do- (ancestor,commits) <- gitMergeable True br- when ancestor $+ (mancestor,commits) <- gitMergeable True br+ when (mancestor == Just True) $ unless (null commits) $ do pull <- git "pull" [] unless ("Already up to date." `isPrefixOf` pull) $ putStr pull -- FIXME maybe require local branch already here-newerMergeable :: Branch -> IO (Bool,[Commit],Maybe Branch)-newerMergeable br =+newerMergeable :: String -> Branch -> IO (Bool,[Commit],Maybe Branch)+newerMergeable pkg br = if br == Rawhide then return (False,[],Nothing) else do- mnewer <- getNewerBranch br+ mnewer <- getNewerBranch pkg br locals <- localBranches True case mnewer of Just newer -> do- (ancestor,commits) <- gitMergeable (show newer `notElem` locals) newer- return (ancestor, commits, Just newer)+ (mancestor,commits) <- gitMergeable (showBranch newer `notElem` locals) newer+ return (mancestor == Just True, commits, Just newer) Nothing -> return (False,[],Nothing) data Commit = Commit@@ -149,14 +172,14 @@ case breakEnd isSpace rest of -- "(msg txt, date)" (plogcs,datep) ->- Commit hash (init $ tail $ trim plogcs) (init datep)+ Commit hash (init $ tailSafe $ trim plogcs) (init datep) gitPush :: Bool -> Maybe String -> IO () gitPush quiet mref = do -- FIXME also check ref on branch checkOnBranch when quiet $- putStr "git pushing... "+ sayString "git pushing" -- Can error like this: -- kex_exchange_identification: Connection closed by remote host -- Connection closed by 38.145.60.17 port 22@@ -164,7 +187,8 @@ let args = ["push"] ++ ["--quiet" | quiet] ++ ["origin"] ++ maybeToList mref (ok, _out, err) <- cmdFull "git" args "" if ok- then putStrLn $ if quiet then "done" else last (lines err)+ then unless quiet $+ putStrLn $ last (lines err) else do when quiet putNewLn putStrLn $ unwords ("git" : args) +-+ "failed with\n" ++ err@@ -194,7 +218,7 @@ else putStrLn $ '\r' : intercalate "\n" filtered stashedWithFbrnch :: String-stashedWithFbrnch = "saved by fbrnch"+stashedWithFbrnch = "Saved by fbrnch" checkWorkingDirClean :: Bool -> IO () checkWorkingDirClean stash = do@@ -281,11 +305,11 @@ gitSwitchBranch' :: Bool -> Branch -> IO Bool gitSwitchBranch' quiet br = do localbranches <- gitLines "branch" ["--format=%(refname:short)"]- if show br `elem` localbranches+ if showBranch br `elem` localbranches then do current <- gitCurrentBranch when (current /= RelBranch br) $- git_ "switch" ["-q", show br]+ git_ "switch" ["-q", showBranch br] return True else do -- check remote branch exists@@ -299,10 +323,10 @@ then do name <- getDirectoryName unless quiet $- warning $ name +-+ show br +-+ "branch does not exist!"+ warning $ name +-+ showBranch br +-+ "branch does not exist!" return False else do- git_ "checkout" ["-q", "-b", show br, "--track", "origin/" ++ show br]+ git_ "checkout" ["-q", "-b", showBranch br, "--track", "origin/" ++ showBranch br] return True checkIfRemoteBranchExists :: AnyBranch -> IO Bool
src/Koji.hs view
@@ -22,6 +22,7 @@ displayID, fedoraHub, maybeTimeout,+ createKojiSidetag, targetMaybeSidetag ) where @@ -34,9 +35,11 @@ import Data.Time.Clock import Data.Time.Format import Data.Time.LocalTime-import Distribution.Fedora.Branch (branchTarget) import Distribution.Koji import qualified Distribution.Koji.API as Koji+import Distribution.Fedora.Branch (branchRelease)+import Distribution.Fedora.Release (releaseDistTag)+import Safe (headMay, tailSafe) import Say (sayString) import SimplePrompt (promptEnter) import System.Exit@@ -117,12 +120,14 @@ -- for git: drop "Created task: " -- init to drop final newline unless (B.null out) $- logMsg $ (dropPrefix "Task info: " . B.unpack . B.init . B.unlines . tail . B.lines) out+ -- FIXME include output example here+ logMsg $ (dropPrefix "Task info: " . B.unpack . B.init . B.unlines . tailSafe . B.lines) out if ret == ExitSuccess then do let kojiurl = B.unpack $ last $ B.words out task = (TaskId . read) $ takeWhileEnd isDigit kojiurl when wait $ do+ -- FIXME get actual build time timeIO $ kojiWatchTask task cmd_ "date" ["+%T"] return $ if wait then Right kojiurl else Left task@@ -227,7 +232,7 @@ where waitRepo :: String -> Maybe Struct -> IO () waitRepo buildtag moldrepo = do- when (isJust moldrepo) $ do+ when (isJust moldrepo) $ threadDelay (fromEnum (50 :: Micro)) -- 50s mrepo <- kojiGetRepo fedoraHub buildtag Nothing Nothing case mrepo of@@ -250,6 +255,7 @@ else do when (isNothing moldrepo && not quiet) $ logSay tz $ "Waiting for" +-+ buildtag +-+ "to have" +-+ showNVR nvr+ cmdSilent "koji" ["request-repo", "--nowait", "--quiet", buildtag] waitRepo buildtag mrepo kojiTagArchs :: String -> IO [String]@@ -260,15 +266,16 @@ kojiUserSideTags :: Maybe Branch -> IO [String] kojiUserSideTags mbr = do user <- fasIdFromKrb- case mbr of- Nothing -> do- maybeTimeout 55 $ kojiListSideTags fedoraKojiHub Nothing (Just user)- Just br -> do- mtags <- kojiBuildTarget fedoraHub (branchTarget br)- case mtags of- Nothing -> return []- Just (buildtag,_desttag) -> do- kojiListSideTags fedoraKojiHub (Just buildtag) (Just user)+ mapMaybe (headMay . words) <$>+ case mbr of+ Nothing -> do+ maybeTimeout 55 $ kojiListSideTags fedoraKojiHub Nothing (Just user)+ Just br -> do+ mtags <- kojiBuildTarget fedoraHub (showBranch br)+ case mtags of+ Nothing -> return []+ Just (buildtag,_desttag) -> do+ kojiListSideTags fedoraKojiHub (Just buildtag) (Just user) maybeTimeout :: Micro -> IO a -> IO a maybeTimeout secs act = do@@ -279,38 +286,49 @@ maybeTimeout (secs + 5) act Just res -> return res +createKojiSidetag :: Bool -> Branch -> IO String+createKojiSidetag dryrun br = do+ Just (buildtag,_desttag) <- kojiBuildTarget fedoraHub (showBranch br)+ out <-+ if dryrun+ then return $ "Side tag '" ++ buildtag ++ "'"+ else do+ ls <- lines <$> fedpkg "request-side-tag" ["--base-tag", buildtag]+ case ls of+ [] -> error' "no output from request-side-tag"+ (l:_) -> return l+ if "Side tag '" `isPrefixOf` out+ then do+ putNewLn+ let sidetag =+ init . dropWhileEnd (/= '\'') $ dropPrefix "Side tag '" out+ putStrLn $ "Sidetag" +-+ sidetag +-+ "created"+ -- logMsg $ "Waiting for" +-+ sidetag +-+ "repo"+ -- unless dryrun $+ -- cmd_ "koji" ["wait-repo", sidetag]+ return sidetag+ else error' "'fedpkg request-side-tag' failed"+ -- FIXME check/warn for target/branch mismatch targetMaybeSidetag :: Bool -> Bool -> Branch -> Maybe SideTagTarget -> IO String targetMaybeSidetag dryrun create br msidetagTarget = case msidetagTarget of- Nothing -> return $ branchTarget br- Just (Target t) -> return t+ Nothing -> return $ showBranch br+ -- FIXME map "rawhide" to valid target+ Just (Target t) ->+ if t == "rawhide"+ then releaseDistTag <$> branchRelease Rawhide+ else return t Just SideTag -> do- sidetags <- map (head . words) <$> kojiUserSideTags (Just br)- case sidetags of- [] -> do- Just (buildtag,_desttag) <- kojiBuildTarget fedoraHub (show br)- out <-- if dryrun- then return $ "Side tag '" ++ buildtag ++ "'"- else- if create- then head . lines <$> fedpkg "request-side-tag" ["--base-tag", buildtag]- else error' "incorrect side-tag create request"- if "Side tag '" `isPrefixOf` out- then do- putNewLn- putStrLn out- let sidetag =- init . dropWhileEnd (/= '\'') $ dropPrefix "Side tag '" out- logMsg $ "Waiting for" +-+ sidetag +-+ "repo"- unless dryrun $- cmd_ "koji" ["wait-repo", sidetag]- return sidetag- else error' "'fedpkg request-side-tag' failed"+ tags <- kojiUserSideTags (Just br)+ case tags of+ [] ->+ if create+ then createKojiSidetag dryrun br+ else error' "incorrect side-tag create request" [tag] -> return tag- _ -> error' $ "More than one user side-tag found for" +-+ show br+ _ -> error' $ "More than one user side-tag found for" +-+ showBranch br logSay :: TimeZone -> String -> IO () logSay tz str = do
src/Krb.hs view
@@ -6,7 +6,7 @@ import Common -import SimpleCmd+import SimpleCmd (error', cmdBool, cmdMaybe) krbTicket :: IO () krbTicket = do@@ -25,7 +25,7 @@ maybeFasIdFromKrb :: IO (Maybe String) maybeFasIdFromKrb =- fmap (removeSuffix "@FEDORAPROJECT.ORG") . find ("@FEDORAPROJECT.ORG" `isSuffixOf`) <$> klistEntryFedora+ fmap (dropSuffix "@FEDORAPROJECT.ORG") . find ("@FEDORAPROJECT.ORG" `isSuffixOf`) <$> klistEntryFedora fasIdFromKrb :: IO String fasIdFromKrb = do
src/ListReviews.hs view
@@ -55,7 +55,7 @@ ReviewAllOpen -> statusOpen ReviewUnApproved -> statusOpen ReviewApproved -> statusNewPost- ReviewRepoCreated -> statusNewPost+ ReviewRepoCreated -> statusRelPrep ReviewUnbranched -> statusNewModified ReviewBranched -> statusNewModified _ -> statusNewPost
src/Main.hs view
@@ -2,12 +2,13 @@ module Main (main) where +import Data.List.Extra (dropSuffix) import Data.Maybe (fromMaybe) import Distribution.Fedora.Branch (partitionBranches, readBranch) #if !MIN_VERSION_simple_cmd_args(0,1,7) import Options.Applicative (maybeReader, ReadM) #endif-import SelectRPMs (selectRpmsOption)+import SelectRPMs (existingStrategyOption, selectRpmsOptions) import SimpleCmdArgs -- commands@@ -18,6 +19,7 @@ import Cmd.Clone import Cmd.Commit import Cmd.Compare+import Cmd.CreateReview import Cmd.Copr import Cmd.Diff import Cmd.Fetch@@ -32,7 +34,6 @@ import Cmd.Override import Cmd.Owner import Cmd.Parallel-import Cmd.PkgReview import Cmd.Prep import Cmd.Pull import Cmd.Push@@ -49,13 +50,15 @@ import Cmd.Switch import Cmd.Unpushed import Cmd.Update+import Cmd.UpdateReview import Cmd.WaitRepo -import Bodhi (UpdateType(..),UpdateSeverity(..))+import Bodhi (UpdateType(..), UpdateSeverity(..), UpdateNotes(..)) import Branches import Common.System import Git (CommitOpt(..)) import ListReviews+import PkgReview import RpmBuild (ForceShort(..), BCond(..)) import Paths_fbrnch (version) import Types (SideTagTarget(..))@@ -131,7 +134,9 @@ <*> branchesPackagesDesc "BRANCH... PKG1... [:] PKG2..." , Subcommand "sidetags" "List user's side-tags" $ sideTagsCmd- <$> switchLongWith "remove" "Remove one or more sidetags"+ <$> dryrunOpt "Dry-run: no sidetag actions"+ <*> optional (flagLongWith' SidetagAdd "create" "Create one or more sidetags" <|>+ flagLongWith' SidetagRemove "remove" "Remove one or more sidetags") <*> many branchArg , Subcommand "override" "Tag builds into buildroot override in Koji" $ overrideCmd@@ -261,7 +266,8 @@ <*> switchWith 'r' "reinstall" "reinstall rpms" <*> switchLongWith "no-build" "do not (re-)build (install built rpms)" <*> switchLongWith "ignore-builddeps" "do not install builddeps"- <*> selectRpmsOption+ <*> selectRpmsOptions+ <*> optional existingStrategyOption <*> maybeBranchPackages False , Subcommand "not-installed" "Packages not installed locally" $ notInstalledCmd@@ -306,12 +312,13 @@ bzusersCmd <$> strArg "NAME" , Subcommand "create-review" "Create a Package Review request" $- createReview- <$> optional scratchOpt+ createReviewCmd+ <$> forceOpt "create a review even if one exists already"+ <*> optional scratchOpt <*> mockOpt False <*> manyPackages , Subcommand "update-review" "Update a Package Review" $- updateReview+ updateReviewCmd <$> optional scratchOpt <*> mockOpt False <*> optional (strArg "SPECFILE")@@ -339,7 +346,7 @@ <*> switchWith 'r' "resubmit" "Re-request repo" <*> branchesPackages , Subcommand "import" "Import new approved created packages from bugzilla review" $- importCmd+ importCmd False <$> switchLongWith "existing" "Use an existing repo" <*> mockOpt True <*> branchesPackages@@ -369,7 +376,7 @@ flagLongWith' CoprNew "new" "Create new copr repo" <|> flagWith CoprBuild CoprMonitor 'm' "monitor" "Show project chroots") <*> forceOpt "build even if existing n-v-r"- <*> buildByOpt+ <*> optional buildByOpt <*> optional archesOpt <*> pkgArg "PROJECT" <*> branchesPackages@@ -445,7 +452,7 @@ anyBranchM = anyBranch <$> str pkgArg :: String -> Parser String- pkgArg lbl = removeSuffix "/" <$> strArg lbl+ pkgArg lbl = dropSuffix "/" <$> strArg lbl manyPackages :: Parser [String] manyPackages = many (pkgArg "PKGPATH...")@@ -478,7 +485,7 @@ in case brs of [] -> error' "specify one branch" [br] -> (br,pkgs)- _ -> error' $ "cannot have more than one branch:" +-+ unwords (map show brs)+ _ -> error' $ "cannot have more than one branch:" +-+ unwords (map showBranch brs) maybeBranchPackages :: Bool -> Parser (Maybe Branch,[String]) maybeBranchPackages oneplus =@@ -493,7 +500,7 @@ in case brs of [] -> (Nothing, pkgs) [br] -> (Just br,pkgs)- _ -> error' $ "cannot have more than one branch:" +-+ unwords (map show brs)+ _ -> error' $ "cannot have more than one branch:" +-+ unwords (map showBranch brs) branchesPackages :: Parser (BranchesReq, [String]) branchesPackages = branchesPackagesDesc "BRANCH... PKGPATH..."@@ -542,7 +549,7 @@ <*> dryrunOpt "Dry run: do not merge/push/build" <*> skipFetchOpt <*> updateOpt- <*> useChangelogOpt+ <*> optional notesOpt <*> switchWith 'p' "by-package" "Build by each package across brs" <*> switchLongWith "stash" "git stash before fetching and building" where@@ -551,8 +558,9 @@ 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"+ notesOpt =+ flagWith' NotesChangelog 'c' "changelog-notes" "Use spec changelog for Bodhi notes" <|>+ NotesText <$> strOptionLongWith "notes" "NOTES" "Bodhi update notes" -- yesOpt = switchWith 'y' "yes" "Assume yes for questions" @@ -629,7 +637,10 @@ flagWith' PullStash 's' "stash" "Stash local changes" <|> flagWith' PullRebase 'r' "rebase" "Git pull instead of fetch" - buildByOpt = flagWith' SingleBuild 'S' "single" "Non-progressive normal single build" <|> flagWith' BuildByRelease 'R' "by-release" "Builds by release" <|> flagWith ValidateByRelease ValidateByArch 'A' "by-arch" "Build across latest release archs first (default is across releases for primary arch)"+ buildByOpt =+ flagWith' SingleBuild 'S' "single" "Non-progressive normal single build" <|>+ flagWith' BuildByRelease 'R' "by-release" "Builds by release" <|>+ flagWith' ValidateByArch 'A' "by-arch" "Build across latest release archs first (default is across releases for primary arch)" commandOpt = strOptionWith 'c' "cmd" "SHELLCOMMAND" "Shell command to run in $p"
src/Package.hs view
@@ -41,10 +41,12 @@ pkgNameVerRel, pkgNameVerRel', pkgNameVerRelNodist,+ pkgNameVerRelDist, equivNVR, editSpecField, isAutoChangelog, isAutoRelease,+ autoReleaseBump, sourceFieldFile, isArchiveFile, sourceDirCwdOpt@@ -52,7 +54,8 @@ import Data.RPM (NV(..), VerRel(..)) import Data.RPM.NVR (maybeNVR, NVR(..))-import Distribution.Fedora.Branch+import Distribution.Fedora.Branch (branchDistTag)+import Safe (tailSafe) import SimpleCmd.Rpm import SimplePrompt (prompt, promptInitial) @@ -60,7 +63,6 @@ import Common import Common.System import Git-import Krb import Types (ChangeType(..)) fedpkg :: String -> [String] -> IO String@@ -198,7 +200,7 @@ putPkgBrnchHdr :: Package -> Branch -> IO () putPkgBrnchHdr pkg br =- putStrLn $ "\n==" +-+ unPackage pkg +-+ show br +-+ "=="+ putStrLn $ "\n==" +-+ unPackage pkg +-+ showBranch br +-+ "==" putPkgAnyBrnchHdr :: Package -> AnyBranch -> IO () putPkgAnyBrnchHdr pkg br =@@ -207,6 +209,7 @@ packageSpec :: Package -> FilePath packageSpec pkg = unPackage pkg <.> "spec" +-- FIXME rebase data GitOpts = GitOpts { gitOptClean :: Bool@@ -238,6 +241,7 @@ boolHeader b = if b then HeaderMust else HeaderMay -- FIXME option to filter out dead.packages+-- FIXME option to pause between packages? withPackagesByBranches :: HeaderShow -> Bool -> Maybe GitOpts@@ -361,15 +365,13 @@ else do let mbranch = case mbr of Nothing -> []- Just br -> ["--branch", show br]+ Just br -> ["--branch", showBranch br] case cloneuser of AnonClone -> do msgout git_ "clone" $ ["--quiet"] ++ mbranch ++ ["https://src.fedoraproject.org/rpms/" ++ pkg <.> "git"] UserClone -> do- fasid <- fasIdFromKrb- msgout- git_ "clone" $ ["--quiet"] ++ mbranch ++ ["ssh://" ++ fasid ++ "@pkgs.fedoraproject.org/rpms/" ++ pkg <.> "git"]+ fedpkg_ "clone" $ mbranch ++ [pkg] where msgout = putStrLn $ if quiet then "cloning..." else "Cloning:" +-+ pkg@@ -379,21 +381,33 @@ matches <- filter ("Release:" `isPrefixOf`) <$> grep "%autorelease" spec return $ not (null matches) +autoReleaseBump :: FilePath -> IO Bool+autoReleaseBump spec = do+ matches <- filter ("Release:" `isPrefixOf`) <$> grep "%autorelease" spec+ return $+ case matches of+ [] -> False+ [release] ->+ case words release of+ ("Release:":"%autorelease":"-b":_) -> True+ _ -> False+ _ -> error' $ "multiple autorelease fields in" +-+ spec+ isAutoChangelog :: FilePath -> IO Bool isAutoChangelog = grep_ "^%autochangelog" pkgNameVerRel :: Branch -> FilePath -> IO (Maybe NVR)-pkgNameVerRel = pkgNameVerRelDist . Just+pkgNameVerRel = pkgNameVerRelDist True . Just -pkgNameVerRelDist :: Maybe Branch -> FilePath -> IO (Maybe NVR)-pkgNameVerRelDist Nothing spec = do+pkgNameVerRelDist :: Bool -> Maybe Branch -> FilePath -> IO (Maybe NVR)+pkgNameVerRelDist _strict Nothing spec = do nvrs <- rpmspec ["--srpm", "--undefine=dist"] (Just "%{name}-%{version}-%{release}") spec return $ case nvrs of [] -> Nothing [nvr] -> maybeNVR nvr _ -> error' "could not determine unique nvr"-pkgNameVerRelDist (Just br) spec = do+pkgNameVerRelDist strict (Just br) spec = do disttag <- branchDistTag br -- workaround dist with bootstrap hostdist <- cmd "rpm" ["--eval", "%{dist}"]@@ -410,7 +424,9 @@ error' "requires fedpkg.." cmdLines "fedpkg" ["verrel"] else- error' "cannot determine NVR accurately for autorelease outside dist-git"+ if strict+ then error' "cannot determine NVR accurately for autorelease outside dist-git"+ else return [] else rpmspec ["--srpm"] (Just "%{name}-%{version}-%{release}") spec seq disttag $ return $@@ -428,7 +444,7 @@ pkgNameVerRelNodist :: FilePath -> IO NVR pkgNameVerRelNodist spec = do- mnvr <- pkgNameVerRelDist Nothing spec+ mnvr <- pkgNameVerRelDist True Nothing spec case mnvr of Nothing -> error' $ "rpmspec failed to parse" +-+ spec Just nvr -> return nvr@@ -463,7 +479,7 @@ ("fc","fc") -> True _ -> r1' == r2' && length drs1 == length drs2 &&- compareReleases (tail drs1) (tail drs2)+ compareReleases (tailSafe drs1) (tailSafe drs2) _ -> False -- data BrPkg = IsBr AnyBranch | Unknown String | IsPkg String
src/Patch.hs view
@@ -8,6 +8,8 @@ import Common +import Safe (headMay)+ simplifyMinimalDiff :: [String] -> [String] simplifyMinimalDiff = maybeRemoveDiffGit . filterCommon@@ -50,4 +52,4 @@ -- (all . matchPreds (map isPrefixOf ["-Release:", "+Release:"])) ls removeDiffContext :: [String] -> [String]-removeDiffContext = filter ((/= ' ') . head)+removeDiffContext = filter ((/= Just ' ') . headMay)
+ src/PkgReview.hs view
@@ -0,0 +1,79 @@+module PkgReview (+ ScratchOption(..),+ buildAndUpload,+ mockRpmLint,+ uploadPkgFiles+ )+where++import Common+import Common.System++import Network.HTTP.Directory (httpExists, httpManager)+import SimplePrompt (promptEnter, yesNoDefault)++import Branches+import Koji+import Krb+import RpmBuild++data ScratchOption = ScratchBuild | ScratchTask Int | SkipScratch+ deriving Eq++buildAndUpload :: Maybe ScratchOption -> String -> String -> FilePath+ -> IO (Maybe String, String)+buildAndUpload mscratchOpt srpm pkg spec = do+ scratch <-+ if isNothing mscratchOpt+ then yesNoDefault False "Would you like to do a koji scratch build before submitting"+ else do+ let doscratch = mscratchOpt == Just ScratchBuild+ promptEnter $ "Press Enter to" +-+ if doscratch+ then "submit"+ else "upload"+ return doscratch+ mkojiurl <- case mscratchOpt of+ Just (ScratchTask tid) -> return $ Just ("https://koji.fedoraproject.org/koji/taskinfo?taskID=" ++ show tid)+ _ ->+ if scratch+ then Just <$> kojiScratchBuild "rawhide" [] srpm+ else return Nothing+ specSrpmUrls <- uploadPkgFiles pkg spec srpm+ return (mkojiurl, specSrpmUrls)++uploadPkgFiles :: String -> FilePath -> FilePath -> IO String+uploadPkgFiles pkg spec srpm = do+ fasid <- fasIdFromKrb+ -- read ~/.config/fedora-create-review+ let sshhost = "fedorapeople.org"+ sshpath = "public_html/reviews/" ++ pkg+ cmd_ "ssh" [fasid ++ "@" ++ sshhost, "mkdir", "-p", sshpath]+ cmd_ "scp" [spec, srpm, fasid ++ "@" ++ sshhost ++ ":" ++ sshpath]+ getCheckedFileUrls $ "https://" <> fasid <> ".fedorapeople.org" +/+ removePrefix "public_html/" sshpath+ where+ getCheckedFileUrls :: String -> IO String+ getCheckedFileUrls uploadurl = do+ let specUrl = uploadurl +/+ takeFileName spec+ srpmUrl = uploadurl +/+ takeFileName srpm+ mgr <- httpManager+ checkUrlOk mgr specUrl+ checkUrlOk mgr srpmUrl+ return $ "Spec URL: " <> specUrl <> "\nSRPM URL: " <> srpmUrl+ where+ checkUrlOk mgr url = do+ okay <- httpExists mgr url+ unless okay $ error' $ "Could not access:" +-+ url++mockRpmLint :: Bool -> String -> FilePath -> FilePath -> IO ()+mockRpmLint mock pkg spec srpm = do+ rpms <-+ if mock then do+ -- FIXME check that mock is installed+ let resultsdir = "results_" ++ pkg+ cmd_ "mock" ["--root", mockRoot Rawhide Nothing, "--resultdir=" ++ resultsdir, srpm]+ map (resultsdir </>) . filter ((== ".rpm") . takeExtension) <$> listDirectory resultsdir+ else+ builtRpms (RelBranch Rawhide) spec >>= filterM doesFileExist+-- print rpms+ -- FIXME parse # of errors/warnings+ void $ cmdBool "rpmlint" $ spec:srpm:rpms
src/Repoquery.hs view
@@ -4,16 +4,16 @@ where import Data.Maybe (isJust)-import SimpleCmd+import SimpleCmd (cmd) -import Bodhi (bodhiTestingRepo)+import Bodhi (bodhiTestingRepoTag) import Branches -- FIXME use fedora-repoquery library -- FIXME default to package repoquery :: Branch -> Branch -> [String] -> IO String repoquery sysbr br args = do- mtesting <- bodhiTestingRepo br+ mtesting <- bodhiTestingRepoTag br let brOpts = if sysbr == br then []
src/RpmBuild.hs view
@@ -20,17 +20,20 @@ where import Control.Exception (uninterruptibleMask_)+import qualified Data.ByteString.Lazy.Char8 as B import Data.Char (isDigit) import Data.Either (partitionEithers) import Data.RPM import Distribution.Fedora.Branch (branchDistTag, branchRelease)-import Distribution.Fedora.Release (Release(releaseVersion))+import Distribution.Fedora.Release (releaseVersion) import Network.HTTP.Directory (Manager, httpExists, httpManager)+import Safe (lastMay) import SimpleCmd.Rpm import SimplePrompt (promptEnter, yesNo) import System.Console.Pretty import System.IO.Extra (withTempDir) import System.Posix.Files+import System.Process.Typed (proc, readProcessInterleaved) import Branches import Cmd.Update (updatePkg)@@ -52,17 +55,21 @@ distRpmOptions :: Branch -> IO [String] distRpmOptions br = map ("--define=" ++) <$> do- release <- branchRelease br- return $- case br of- Rawhide ->- let ver = releaseVersion release- in ["fedora" +-+ ver, "fc" ++ ver +-+ "1"]- Fedora n ->- ["fedora" +-+ show n, "fc" ++ show n +-+ "1"]- EPEL n -> ["rhel" +-+ show n, "el" ++ show n +-+ "1"]- EPELNext n -> ["rhel" +-+ show n, "el" ++ show n +-+ "1"]+ case br of+ Rawhide -> do+ ver <- releaseVersion <$> branchRelease br+ return ["fedora" +-+ ver, "fc" ++ ver +-+ "1"]+ Fedora n ->+ return ["fedora" +-+ show n, "fc" ++ show n +-+ "1"]+ EPEL n ->+ return ["rhel" +-+ show n, "el" ++ show n +-+ "1"]+ EPELNext n ->+ return ["rhel" +-+ show n, "el" ++ show n +-+ "1"] +-- branchToRelease :: AnyBranch -> IO Release+-- branchToRelease (RelBranch br) = branchRelease br+-- branchToRelease (OtherBranch b) = error' $ "no release for branch" +-+ b+ builtRpms :: AnyBranch -> FilePath -> IO [FilePath] builtRpms br spec = do distopt <- distOptAny br@@ -113,8 +120,8 @@ uploaded <- if isPkgGit then do have_sources <- doesFileExist "sources"- if have_sources then- grep_ src "sources"+ if have_sources+ then grep_ src "sources" else return False else return False mfedpkg <- findExecutable "fedpkg"@@ -269,6 +276,7 @@ -- FIXME create build.log -- Note does not check if bcond changed -- FIXME check tarball timestamp+-- FIXME handle prep (-bp) too? buildRPMs :: Bool -> Bool -> Bool -> Maybe ForceShort -> [BCond] -> [FilePath] -> AnyBranch -> FilePath -> IO Bool buildRPMs quiet debug noclean mforceshort bconds rpms br spec = do@@ -282,7 +290,9 @@ else do specTime <- getModificationTime spec rpmTimes <- sort <$> mapM getModificationTime rpms- return $ specTime > head rpmTimes+ case rpmTimes of+ [] -> return True -- corner case+ (rpmtime:_) -> return $ specTime > rpmtime if not needBuild then putStrLn "Existing rpms are newer than spec file (use --force to rebuild)" else do@@ -300,7 +310,11 @@ buildopt ++ map show bconds ++ autoreleaseOpt ++ [spec] date <- cmd "date" ["+%T"] rbr <- anyBranchToRelease br- nvr <- pkgNameVerRel' rbr spec+ nvr <- do+ mnvr <- pkgNameVerRelDist False (Just rbr) spec+ case mnvr of+ Just nvr' -> return nvr'+ Nothing -> pkgNameVerRelNodist spec putStr $ date +-+ "Building" +-+ showNVR nvr +-+ "locally... " ok <- do let buildlog = ".build-" ++ (showVerRel . nvrVerRel) nvr <.> "log"@@ -312,6 +326,7 @@ when (prevsize > currsize) $ copyFile backup (backup <.> "prev") copyFile buildlog (buildlog <.> "prev")+ -- FIXME also backup successful buildtree (if log ends in "+ exit 0") timeIO $ if not quiet || isShortCircuit mforceshort then do@@ -373,26 +388,32 @@ installMissingMacros spec void $ getSources spec withTempDir $ \tmpdir -> do- let srpmdiropt = ["--define", "_srcrpmdir" +-+ tmpdir]- (_ok, out, err) <- cmdFull "rpmbuild" (["-br", "--nodeps", spec] ++ srpmdiropt) ""+ let rpmbuildArgs = ["-br", "--nodeps", spec] +++ ["--define", "_srcrpmdir" +-+ tmpdir]+ -- errors for missing deps+ (_ret, out) <- readProcessInterleaved $ proc "rpmbuild" rpmbuildArgs -- Wrote: /current/dir/SRPMS/name-version-release.buildreqs.nosrc.rpm- case words out of- [] -> error' $ spec +-+ "could not generate source rpm for dynamic buildrequires"- ws -> do- let srpm = last ws+ case lastMay (B.words out) of+ Nothing -> error' $ spec +-+ "could not generate source rpm for dynamic buildrequires"+ Just srpmbs -> do+ let srpm = B.unpack srpmbs+ unless ("buildreqs.nosrc.rpm" `isSuffixOf` srpm) $ do+ B.putStrLn out+ error' $ "failed to generated buildreqs.nosrc.rpm for" +-+ spec exists <- doesFileExist srpm if exists- then cmdLines "rpm" ["-qp", "--requires", last ws]- else error' err+ then cmdLines "rpm" ["-qp", "--requires", srpm]+ else error' $ srpm +-+ "does not exist!" else -- FIXME should resolve meta rpmspec ["--buildrequires"] Nothing spec return $ brs ++ ["rpmautospec" | autorelease] where primary dep =- case (head . words) dep of- '(':rest -> Just rest- d -> if "rpmlib(" `isPrefixOf` d+ case words dep of+ [] -> error' "empty dep" -- corner case+ (('(':h):_) -> Just h+ (d:_) -> if "rpmlib(" `isPrefixOf` d then Nothing else Just d @@ -400,7 +421,11 @@ checkSourcesMatch pkg br spec = do -- "^[Ss]ource[0-9]*:" sourcefiles <- map (takeFileName . last . words) <$> cmdLines "spectool" [spec]- sources <- lines <$> readFile "sources"+ sources <- do+ exists <- doesFileExist "sources"+ if exists+ then lines <$> readFile "sources"+ else return [] gitfiles <- gitLines "ls-files" [] let missing = filter (\src -> isNothing (find (src `isInfixOf`) sources) && src `notElem` gitfiles)
src/Types.hs view
@@ -8,6 +8,7 @@ data Archs = Archs [String] | ExcludedArchs [String] +-- FIXME: --new-sidetag ? data SideTagTarget = SideTag | Target String deriving Eq