fbrnch 1.6.2 → 1.7
raw patch · 39 files changed
+982/−458 lines, 39 filesdep ~fedora-releasesdep ~select-rpms
Dependency ranges changed: fedora-releases, select-rpms
Files
- CHANGELOG.md +61/−0
- README.md +6/−4
- fbrnch.cabal +4/−4
- src/Bodhi.hs +23/−11
- src/Branches.hs +84/−18
- src/Cmd/Autospec.hs +1/−1
- src/Cmd/Build.hs +24/−10
- src/Cmd/Bump.hs +67/−61
- src/Cmd/Clone.hs +16/−6
- src/Cmd/Copr.hs +13/−8
- src/Cmd/FTBFS.hs +1/−1
- src/Cmd/Fetch.hs +6/−4
- src/Cmd/Import.hs +13/−11
- src/Cmd/Install.hs +73/−15
- src/Cmd/ListBranches.hs +31/−20
- src/Cmd/ListPackages.hs +54/−31
- src/Cmd/Local.hs +4/−17
- src/Cmd/Merge.hs +13/−13
- src/Cmd/Mock.hs +61/−12
- src/Cmd/Override.hs +3/−3
- src/Cmd/Parallel.hs +80/−57
- src/Cmd/Prep.hs +1/−1
- src/Cmd/Pull.hs +0/−6
- src/Cmd/Push.hs +11/−6
- src/Cmd/RequestBranch.hs +107/−52
- src/Cmd/RequestRepo.hs +1/−1
- src/Cmd/ReviewPackage.hs +7/−7
- src/Cmd/Scratch.hs +1/−1
- src/Cmd/SideTags.hs +35/−3
- src/Cmd/Switch.hs +12/−3
- src/Cmd/Update.hs +6/−4
- src/Cmd/WaitRepo.hs +26/−12
- src/Git.hs +24/−16
- src/Koji.hs +40/−5
- src/Main.hs +28/−10
- src/Package.hs +17/−13
- src/Pagure.hs +1/−0
- src/Repoquery.hs +4/−0
- src/RpmBuild.hs +23/−11
CHANGELOG.md view
@@ -1,5 +1,66 @@ # Changelog +## 1.7 (2025-06-05)+- support epel10.x minors with fedora-releases-0.3.0+- 'merge': now done from origin for consistency+- targetMaybeSidetag: prompts to choose which sidetag+- 'autospec': no duplicate %changelog line+- 'branches': add --only-dead option+- 'branches': improve the --current error for multiple branches+- 'branches': improve the prefixing for multiple packages+- 'build': newline after git push+- 'build': update latest tagged check to include epel-testing; print all+- 'build': use target branch to determine nvr+- 'bump': complete rework of logic (--strict replaces --local)+- 'clone': add --dryrun+- 'clone': now supports globbing of packages+- 'copr': order chroots by branch (release): so epel10 > epel9+- 'copr': rename i686 to i386+- 'fetch': fix --lenient was no-op+- 'import': better push prompt labeling+- 'import': now also waits for package to be setup in koji+- 'install': add --yes+- 'install': perform also if given a rpm subpackage selection+- 'install': select-rpms-0.3.0 adds --error-existing+- 'install': skip ":" separator+- 'list': refactor with countListPackages+- 'mock': add experimental --install mode (for single package)+- 'parallel': better sidetag setup with warnings+- 'parallel': more color output/tweaks+- 'parallel': offer to retry failures or continue with waitrepo for layer+- 'parallel': print nvr earlier and only latest commits+- 'parallel': reduce default delay to 1s between triggering builds+- 'parallel': skip "koji-tool builds --tail" and always show task url for fail+- 'pull': drop stash pop to avoid making conflicts+- 'push': check local branch exists+- 'repoquest-repo': does not reprint full bug for import+- 'request-branches': long todo comment about catching API key expiry+- 'request-branches': now also checks for commit access via group membership+- 'request-branches': request all branches/pkgs before waiting for koji pkgs+- 'review-package': defaults to interactive, use --full for fedora-review+- 'scratch': do not create a new sidetag!+- 'sidetags': listings are now sorted+- 'switch': add --lenient option to avoid error for non-existent branch+- 'uninstall': new experimental command to remove a package NVR+- 'update-sources': partition sources by isArchiveFile+- 'waitrepo': add --no-nvr option for generic wait-repo+- Bodhi: better error handling with bodhiUpdatesEither refactor+- Branches gitCurrentBranchWarn: offer to rename master to rawhide+- Branches listOfBranches: print branch EOL warning when < 7 days left+- Branches systemBranch: support CPE_NAME+- Package isArchiveFile: ".sig" files are ascii+- RpmBuild getSources: use exists for checkCompression of uncompressed file+- RpmBuild: check/install compression tool before downloading tarball+- buildRPMs: backup build.log's with cp -p+- checkSourcesMatch: match sources filenames wrapped with parens+- mergeBranch: add nofetch switch to avoid refetching+- new 'tag-build-to-sidetag': tags branch's nvr into a sidetag+- recognize .crate as archive file (#70)+- refPrompt: accept "origin" and require ref to over 3 chars+- refPrompt: append newline if prompt less than 1 line+- withPackagesByBranches: git fetch earlier to get any new branches+- withPackagesByBranches: switch back branch before unstash+ ## 1.6.2 (2025-03-05) - 'diff': use git diff's builtin filtering - 'fetch': add --lenient to skip non dist-git directories
README.md view
@@ -270,7 +270,7 @@ `$ fbrnch --version` ```-1.6.2+1.7 ``` `$ fbrnch --help`@@ -295,7 +295,7 @@ merge Merge from newer branch unpushed Show unpushed commits build Build package(s) in Koji- list List packages in pagure+ list List packages in pagure distgit list-local List packages in branch branches List package branches parallel Parallel build packages in Koji@@ -319,6 +319,7 @@ builddeps Install package build dependencies install Build locally and install package(s) not-installed Packages not installed locally+ uninstall Remove installed package(s) bugs List package bugs bump Bump release for package commit Git commit packages@@ -345,6 +346,7 @@ autospec Convert package to use rpmautospec unautospec Unconvert rpmautospec package move-artifacts Move old rpm artifacts into rpmbuild dirs+ tag-build-to-sidetag Tag NVR for current branch to sidetag ``` Use `fbrnch <cmd> --help` to get specific help about each of the above commands@@ -431,8 +433,8 @@ ## Known issues - currently it only checks if already built by NVR not githash-- parallel and sort, etc do not take pkgconfig() and other meta() deps into- account yet (this should be fixed soon in rpmbuild-order)+- parallel and sort, etc do not take cmake() and other meta() deps correctly+ into account yet (this may get fixed soon in rpmbuild-order) ## To do - authentication is not implemented yet natively for Koji, Bodhi, Pagure
fbrnch.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: fbrnch-version: 1.6.2+version: 1.7 synopsis: Fedora packager tool to build package branches description: fbrnch (fedora branch or "f-branch" for short) is@@ -35,7 +35,7 @@ README.md tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.8,- GHC == 9.4.8, GHC == 9.6.6, GHC == 9.8.4, GHC == 9.10.1+ GHC == 9.4.8, GHC == 9.6.7, GHC == 9.8.4, GHC == 9.10.2 source-repository head type: git@@ -120,7 +120,7 @@ email-validate, extra, fedora-krb,- fedora-releases >= 0.2,+ fedora-releases >= 0.3, filepath, http-conduit, http-directory >= 0.1.5,@@ -135,7 +135,7 @@ rpm-nvr >= 0.1.2, safe, say,- select-rpms >= 0.2,+ select-rpms >= 0.3, simple-cmd >= 0.2.3, simple-cmd-args >= 0.1.8, simple-prompt >= 0.2.3,
src/Bodhi.hs view
@@ -12,6 +12,7 @@ ) where +import Data.Aeson.Types (Object) import Data.Char (isDigit) import Data.RPM.NVR (NVR) import Distribution.Fedora.Branch (branchRelease)@@ -160,17 +161,20 @@ return True when updatedone $ do -- FIXME avoid this if we know the update URLs (split update does not seem to return URLs)- updates <- bodhiUpdates [makeItem "display_user" "0", makeItem "builds" nvrs]- if null updates- then do- putStrLn $ "bodhi submission failed for" +-+ nvrs- promptEnter "Press Enter to resubmit to Bodhi"- bodhiUpdate dryrun (mupdate,severity) mreview mnotes spec nvrs- else- forM_ updates $ \update ->- case lookupKey "url" update of- Nothing -> error' "Update created but no url"- Just uri -> putStrLn uri+ eupdates <- bodhiUpdatesEither [makeItem "display_user" "0", makeItem "builds" nvrs]+ case eupdates of+ Left err -> error' err+ Right updates ->+ if null updates+ then do+ putStrLn $ "bodhi submission failed for" +-+ nvrs+ promptEnter "Press Enter to resubmit to Bodhi"+ bodhiUpdate dryrun (mupdate,severity) mreview mnotes spec nvrs+ else+ forM_ updates $ \update ->+ case lookupKey "url" update of+ Nothing -> error' "Update created but no url"+ Just uri -> putStrLn uri where extractBugReferences :: String -> [String] extractBugReferences clog =@@ -198,3 +202,11 @@ bodhiBuildExists nvr = do obj <- bodhiBuild $ showNVR nvr return $ isNothing (lookupKey "status" obj :: Maybe String)++bodhiUpdatesEither :: Query -> IO (Either String [Object])+bodhiUpdatesEither params = do+ res <- queryBodhi params "updates/"+ return $+ case lookupKey "updates" res of+ Just updates -> Right updates+ Nothing -> Left $ "failed to read updates:\n" ++ show res
src/Branches.hs view
@@ -28,14 +28,19 @@ anyBranchToRelease, getRequestedBranches, BranchesReq(..),- gitLines+ gitLines,+ renameMasterToRawhide ) where +import Data.Time.Calendar (diffDays)+import Data.Time.Clock (getCurrentTime, utctDay) import Data.Either (partitionEithers)-import Distribution.Fedora.Branch (Branch(..), eitherBranch, getActiveBranched,+import Distribution.Fedora.Branch (Branch(..), branchRelease,+ eitherBranch, getActiveBranched, getActiveBranches, getLatestFedoraBranch, readActiveBranch, eitherActiveBranch, readBranch, showBranch)+import Distribution.Fedora.Release (Release(releaseEOL)) import SimpleCmd.Git import SimplePrompt (promptEnter, promptInitial) import qualified System.Info (arch)@@ -82,7 +87,9 @@ isFedoraBranch _ = False isEPELBranch :: Branch -> Bool+isEPELBranch (EPELNext _) = True isEPELBranch (EPEL _) = True+isEPELBranch (EPELMinor _ _) = True isEPELBranch _ = False localBranches :: Bool -> IO [String]@@ -113,8 +120,9 @@ case br of Rawhide -> "fedora-rawhide-" ++ arch Fedora n -> "fedora-" ++ show n ++ "-" ++ arch- EPEL n -> "epel-" ++ show n ++ "-" ++ arch+ EPEL n -> "centos-stream+epel-" ++ show n ++ "-" ++ arch EPELNext n -> "centos-stream+epel-next-" ++ show n ++ "-" ++ arch+ EPELMinor n _ -> "rhel+epel-" ++ show n ++ "-" ++ arch ------ @@ -127,18 +135,49 @@ systemBranch :: IO Branch systemBranch = do- platform <- init . removePrefix "PLATFORM_ID=\"platform:" <$> cmd "grep" ["PLATFORM_ID=", "/etc/os-release"]- if platform == "eln"- then return Rawhide- else- case readBranch platform of- Just br -> do- branched <- getLatestFedoraBranch- return $- if br > branched- then Rawhide- else br- Nothing -> error' $ "could not determine system branch from platform" +-+ platform+ mplatform <- listToMaybe <$> grep "PLATFORM_ID=" "/etc/os-release"+ case mplatform of+ Just p -> do+ -- PLATFORM_ID="platform:f42"+ let platform = takeWhileEnd (/= ':') $ dropSuffix "\"" p+ if platform == "eln"+ then return Rawhide+ else+ case readBranch platform of+ Just br -> do+ branched <- getLatestFedoraBranch+ return $+ if br > branched+ then Rawhide+ else br+ Nothing -> error' $ "unknown platform" +-+ platform+ Nothing -> do+ mcpe <- listToMaybe <$> grep "CPE_NAME=" "/etc/os-release"+ case mcpe of+ Just c -> do+ -- CPE_NAME="cpe:/o:redhat:enterprise_linux:9::baseos"+ -- CPE_NAME="cpe:/o:fedoraproject:fedora:43"+ let cpe = takeEnd 2 $ splitOn ":" $ dropPrefix "CPE_NAME=\"cpe:/o:" $ dropSuffix "\"" $ fst $ breakOn "::" c+ case cpe of+ [os,ver] ->+ if ver == "eln"+ then return Rawhide+ else+ case readBranch $ osPrefix os ++ ver of+ Just br -> do+ branched <- getLatestFedoraBranch+ return $+ if br > branched+ then Rawhide+ else br+ Nothing -> error' "could not map CPE_NAME to branch"+ _ -> error' $ "could not parse:" +-+ c+ Nothing -> error' "CPE_NAME not found in /etc/os-release"+ where+ osPrefix "fedora" = "f"+ osPrefix "centos" = "epel"+ osPrefix "enterprise_linux" = "epel"+ osPrefix s = s listOfBranches :: Bool -> Bool -> BranchesReq -> IO [Branch] listOfBranches distgit _active (BranchOpt AllBranches) =@@ -170,8 +209,17 @@ activeBrs <- getActiveBranches forM_ brs $ \ br -> if active- then unless (br `elem` activeBrs) $- error' $ showBranch br +-+ "is not an active branch"+ then do+ unless (br `elem` activeBrs) $+ error' $ showBranch br +-+ "is not an active branch"+ rel <- branchRelease br+ let meol = releaseEOL rel+ whenJust meol $ \eol -> do+ let date = read eol+ today <- utctDay <$> getCurrentTime+ let diff = diffDays date today+ when (diff <= 7) $+ warning $ "EOL for" +-+ showBranch br +-+ "is" +-+ show diff +-+ "days away!" else case br of Fedora _ -> do@@ -216,7 +264,8 @@ if br == OtherBranch "master" then do dir <- getDirectoryName- promptEnter $ dir ++ ":" +-+ show br +-+ "is not a valid branch, please use 'rename-rawhide'"+ promptEnter $ dir +-+ show br +-+ "is not a valid branch: press Enter to rename to rawhide"+ renameMasterToRawhide gitCurrentBranchWarn else return br @@ -233,6 +282,7 @@ branchVersion (Fedora n) = show n branchVersion (EPEL n) = show n branchVersion (EPELNext n) = show n+branchVersion (EPELMinor n _) = show n getRequestedBranches :: [String] -> BranchesReq -> IO [Branch] getRequestedBranches existing breq = do@@ -275,3 +325,19 @@ gitLines :: String -> [String] -> IO [String] gitLines c args = lines <$> git c args++renameMasterToRawhide :: IO ()+renameMasterToRawhide = do+ locals <- gitLines "branch" ["--format=%(refname:short)"]+ -- FIXME dangling warning in current output:+ -- From ssh://pkgs.fedoraproject.org/rpms/hedgewars+ -- - [deleted] (none) -> origin/master+ -- (refs/remotes/origin/HEAD has become dangling)+ -- Branch 'rawhide' set up to track remote branch 'rawhide' from 'origin'.+ -- compare commands with github rename+ unless ("rawhide" `elem` locals) $ do+ git_ "fetch" ["--prune"]+ git_ "branch" ["--move", "master", "rawhide"]+ git_ "remote" ["set-head", "origin", "rawhide"]+ git_ "branch" ["--set-upstream-to", "origin/rawhide", "rawhide"]+ git_ "pull" []
src/Cmd/Autospec.hs view
@@ -46,7 +46,7 @@ when autochange $ do changelog <- cmd "rpmautospec" ["generate-changelog", spec] cmd_ "sed" ["-i", "/%autochangelog/d", spec]- appendFile spec $ "%changelog\n" ++ changelog ++ "\n"+ appendFile spec $ changelog ++ "\n" removeFile "changelog" when autorelease $ do release <- calculateRelease spec
src/Cmd/Build.hs view
@@ -5,7 +5,7 @@ BuildOpts(..) ) where -import Distribution.Fedora.Branch (branchDestTag)+import Distribution.Fedora.Branch (branchDestTag, readBranch) import Fedora.Krb (krbTicket) import SimplePrompt (promptEnter, yesNo) @@ -91,13 +91,13 @@ Just False -> return False Just True -> do whenJust mnewer $ \newer ->- mergeBranch (buildoptDryrun opts) True True False pkg (ancestor,unmerged) newer br+ mergeBranch (buildoptDryrun opts) False 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 pkg (ancestor,unmerged) newer br+ mergeBranch (buildoptDryrun opts) False True False True pkg (ancestor,unmerged) newer br return $ isJust mnewer else do unless (br == Rawhide) $@@ -107,9 +107,12 @@ let spec = packageSpec pkg checkForSpecFile spec checkSourcesMatch pkg (RelBranch br) spec+ -- FIXME: check for %macros in %changelog unpushed <- gitOneLineLog $ "origin/" ++ showBranch br ++ "..HEAD"- nvr <- pkgNameVerRel' br spec putNewLn+ let msidetagTarget = buildoptSidetagTarget opts+ target <- targetMaybeSidetag dryrun True True br msidetagTarget+ nvr <- pkgNameVerRel' (maybeTargetBranch target) spec mpush <- case unpushed of [] -> return Nothing@@ -124,12 +127,18 @@ 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 True br msidetagTarget buildRun spec nvr merged mpush unpushed target msidetagTarget moverride where dryrun = buildoptDryrun opts + maybeTargetBranch target =+ if showBranch br `isPrefixOf` target+ then br+ else+ case readBranch $ takeWhile (/= '-') target of+ Just b -> b+ Nothing -> error' $ "unknown branch for target" +-+ target+ buildRun spec nvr merged mpush unpushed target msidetagTarget moverride = do let mwaitrepo = buildoptWaitrepo opts buildstatus <- maybeTimeout 30 $ kojiBuildStatus nvr@@ -199,19 +208,24 @@ case mnewest of Nothing -> return $ isNothing mlatest Just newest -> do+ -- FIXME check Update status instead newestTags <- kojiNVRTags newest- unless (any (`elem` newestTags) [showBranch br, showBranch br ++ "-updates", showBranch br ++ "-updates-pending"]) $ do+ -- FIXME separate fedora and epel tags+ unless (any (`elem` newestTags) [showBranch br, showBranch br ++ "-updates", showBranch br ++ "-updates-pending", showBranch br ++ "-testing"]) $ do -- FIXME print how many days left- putStrLn $ "Warning:" +-+ showNVR newest +-+ "still in testing?"- promptEnter "Press Enter to continue"+ putStrLn $ "Warning:" +-+ showNVR newest +-+ "in not stable yet, with current" +-+ pluralOnly newestTags "tag" ++ ":"+ mapM_ putStrLn newestTags+ putNewLn+ promptEnter "Press Enter to continue with build" return False unless (buildoptStash opts) $ unlessM isGitDirClean $ error' "local changes remain (dirty)" unless dryrun krbTicket whenJust mpush $ \ref ->- unless dryrun $+ unless dryrun $ do gitPush False $ Just $ ref ++ ":" ++ showBranch br+ putNewLn unlessM (null <$> gitOneLineLog ("origin/" ++ showBranch br ++ "..HEAD")) $ unless dryrun $ do ok <- yesNo "Unpushed changes remain, continue"
src/Cmd/Bump.hs view
@@ -4,7 +4,7 @@ ) where -import Distribution.Fedora.Branch (branchDestTag)+import System.Console.Pretty (color, Color(Green, Yellow)) import System.IO.Extra import Branches@@ -15,7 +15,8 @@ import Package -- FIXME --force--- FIXME --target+-- FIXME ignore ":"+-- FIXME countdown bumpCmd :: Bool -> Bool -> Maybe String -> Maybe String -> (BranchesReq,[String]) -> IO () bumpCmd dryrun local mcmsg mclog =@@ -25,7 +26,7 @@ bumpPkg :: Bool -> Bool -> Maybe String -> Maybe String -> Package -> AnyBranch -> IO ()-bumpPkg dryrun local mcmsg mclog pkg br = do+bumpPkg dryrun strict mcmsg mclog pkg br = do dead <- doesFileExist "dead.package" if dead then putStrLn "dead package"@@ -34,35 +35,36 @@ unpushed <- gitOneLineLog $ "origin/" ++ show br ++ "..HEAD" displayCommits True unpushed autorelease <- isAutoRelease spec- if autorelease- then- if not (null unpushed)- then putStrLn $ "autorelease: unpushed" +-+- case length unpushed of- 1 -> "commit"- n -> show n +-+ "commits"- else- if dryrun- then putStrLn "autorelease: bump with commit"- else do- let copts =- "-m" :- case mcmsg of- Just msg -> [msg]- Nothing ->- case mclog of- Just cl -> [cl]- Nothing -> ["Bump release"]- git_ "commit" $ "-a" : "--allow-empty" : copts+ alreadybumped <-+ if autorelease+ then do+ let bumped = not $ null unpushed+ when bumped $+ putStrLn $ "autorelease: unpushed" +-+ pluralOnly unpushed "commit"+ if bumped+ then return True+ else do+ if strict+ then do+ rbr <-+ case br of+ RelBranch rbr -> return rbr+ OtherBranch _ -> error' "unsupported branch"+ newnvr <- pkgNameVerRel' rbr spec+ mstate <- kojiGetBuildState fedoraHub $ BuildInfoNVR $ showNVR newnvr+ let built = mstate == Just BuildComplete+ if built+ then putStrLn $ color Yellow $ showNVR newnvr +-+ "already built"+ else putStrLn $ showNVR newnvr +-+ "not built yet"+ return $ not built+ else return False else do- rbr <-- case br of- RelBranch rbr -> return rbr- OtherBranch _ -> systemBranch- newnvr <- pkgNameVerRel' rbr spec- moldnvr <-- if local- then do+ rbr <-+ case br of+ RelBranch rbr -> return rbr+ OtherBranch _ -> error' "unsupported branch"+ newnvr <- pkgNameVerRel' rbr spec+ moldnvr <- withTempDir $ \tempdir -> do git "show" ["origin:" ++ spec] >>= writeFile (tempdir </> spec)@@ -72,36 +74,40 @@ then pkgNameVerRel rbr spec else do -- FIXME check version unchanged before cloning- clonePkg True AnonClone (Just rbr) $ unPackage pkg+ -- FIXME make silent (no "cloning...")+ clonePkg False True AnonClone (Just rbr) $ unPackage pkg withCurrentDirectory (unPackage pkg) $ pkgNameVerRel rbr spec- else- case br of- RelBranch rbr' -> do- tag <- branchDestTag rbr'- kojiLatestNVR tag $ unPackage pkg- -- FIXME fallback to local?- _ -> return Nothing- whenJust moldnvr $ \o -> putStrLn $ showNVR o +-+ "->"- putStrLn $ showNVR newnvr- if equivNVR newnvr moldnvr- then do- git_ "log" ["origin..HEAD", "--pretty=oneline"]- let clog =- case mclog of- Just cl -> cl- Nothing ->- case mcmsg of- Just msg -> msg- _ -> "Rebuild"- unless (autorelease || dryrun) $- cmd_ "rpmdev-bumpspec" ["-c", clog, spec]- let copts =- case mcmsg of- Nothing -> ["-m", "Bump release"]- Just msg -> ["-m", msg]+ if equivNVR newnvr moldnvr+ then+ if strict+ then do+ mstate <- kojiGetBuildState fedoraHub $ BuildInfoNVR $ showNVR newnvr+ let built = mstate == Just BuildComplete+ unless built $+ putStrLn $ showNVR newnvr +-+ "not built yet"+ return $ not built+ else return False+ else do+ whenJust moldnvr $ \o -> do+ putStrLn $ showNVR o +-+ "->"+ putStrLn $ showNVR newnvr+ return True+ if alreadybumped+ then putStrLn $ color Green "already bumped"+ else do+ git_ "log" ["origin..HEAD", "--pretty=oneline"]+ let clog =+ case mclog of+ Just cl -> cl+ Nothing ->+ case mcmsg of+ Just msg -> msg+ _ -> "Rebuild"+ unless (autorelease || dryrun) $+ cmd_ "rpmdev-bumpspec" ["-c", clog, spec]+ let cmsg = fromMaybe "Bump release" mcmsg+ if dryrun+ then putStrLn $ "would be bumped with commit:" +-+ show cmsg -- FIXME quiet commit?- if dryrun- then putStrLn "would be bumped with commit"- else git_ "commit" $ "-a" : (if autorelease then ("--allow-empty" :) else id) copts- else putStrLn "already bumped"+ else git_ "commit" $ "-a" : (if autorelease then ("--allow-empty" :) else id) ["-m", cmsg]
src/Cmd/Clone.hs view
@@ -1,9 +1,12 @@+{-# LANGUAGE OverloadedStrings #-}+ module Cmd.Clone (cloneCmd, CloneRequest(..)) where -import Control.Monad (when)+import Control.Monad.Extra (concatMapM, when) import Fedora.Krb import Branches+import Cmd.ListPackages (listPackages) import Common.System import qualified Common.Text as T import Package@@ -13,16 +16,16 @@ | CloneUser (Maybe String) | ClonePkgs [String] --- FIXME allow pagure repo wildcard+-- FIXME --exclude -- FIXME (detect commit rights or a ssh key?)-cloneCmd :: Maybe Branch -> CloneRequest -> IO ()-cloneCmd mbr request = do+cloneCmd :: Bool -> Maybe Branch -> CloneRequest -> IO ()+cloneCmd dryrun mbr request = do pkgs <- case request of CloneUser mid -> do userid <- maybe fasIdFromKrb return mid map (takeFileName . T.unpack) <$> pagureUserRepos srcfpo userid -- FIXME detect/prevent "path/dir"- ClonePkgs ps -> return ps+ ClonePkgs ps -> concatMapM globPkgs ps CloneGroup grp -> do map (takeFileName . T.unpack) <$> pagureGroupRepos srcfpo False grp mfas <- maybeFasIdFromKrb@@ -30,4 +33,11 @@ when (no > 1) $ putStrLn $ "cloning" +-+ show no +-+ "pkg repos" let auth = maybe AnonClone (const UserClone) mfas- mapM_ (clonePkg False auth mbr) pkgs+ mapM_ (clonePkg dryrun False auth mbr) pkgs++-- FIXME force+globPkgs :: String -> IO [String]+globPkgs pat =+ if '*' `elem` pat+ then listPackages False Nothing [pat]+ else return [pat]
src/Cmd/Copr.hs view
@@ -47,10 +47,6 @@ coprServer :: String coprServer = "copr.fedorainfracloud.org" -data Chroot = Chroot { chrootBranch :: Branch- , chrootArch :: Arch }- deriving Eq- releaseToBranch :: String -> Branch releaseToBranch release | "fedora-" `isPrefixOf` release =@@ -70,7 +66,13 @@ branchToRelease (Fedora n) = "fedora-" ++ show n branchToRelease (EPEL n) = "epel-" ++ show n branchToRelease (EPELNext n) = "epel-" ++ show n ++ "-next"+-- unsupported really, maybe map to rhel?+branchToRelease (EPELMinor n _) = "epel-" ++ show n +data Chroot = Chroot { chrootBranch :: Branch+ , chrootArch :: Arch }+ deriving Eq+ readChroot :: String -> Chroot readChroot ch = case stripInfixEnd "-" ch of@@ -80,7 +82,10 @@ showChroot :: Chroot -> String showChroot (Chroot br ar) = branchToRelease br ++ '-' : showArch ar -data Arch = X86_64 | I686 | AARCH64 | PPC64LE | S390X+instance Ord Chroot where+ compare (Chroot b1 _) (Chroot b2 _) = compare b1 b2++data Arch = X86_64 | I386 | AARCH64 | PPC64LE | S390X deriving (Eq, Enum) allCoprArchs :: [Arch]@@ -88,7 +93,7 @@ readArch :: String -> Arch readArch "x86_64" = X86_64-readArch "i686" = I686+readArch "i386" = I386 readArch "aarch64" = AARCH64 readArch "ppc64le" = PPC64LE readArch "s390x" = S390X@@ -96,7 +101,7 @@ showArch :: Arch -> String showArch X86_64 = "x86_64"-showArch I686 = "i686"+showArch I386 = "i386" showArch AARCH64 = "aarch64" showArch PPC64LE = "ppc64le" showArch S390X = "s390x"@@ -130,7 +135,7 @@ where coprGetChroots :: String -> IO [Chroot] coprGetChroots user = do- chroots <- map (readChroot . T.unpack) <$> coprChroots coprServer user project+ chroots <- reverseSort . map (readChroot . T.unpack) <$> coprChroots coprServer user project when (null chroots) $ error' $ "No chroots found for" +-+ user ++ "/" ++ project branches <-
src/Cmd/FTBFS.hs view
@@ -25,7 +25,7 @@ case mbugsopt of Just bugsopt -> do unless (null pkgs) $- error' "please use bugs option without listing a package"+ error' $ "Cannot combine bugs option with" +-+ pluralOnly pkgs "package" session <- bzApiKeySession bugs <- case bugsopt of
src/Cmd/Fetch.hs view
@@ -4,7 +4,8 @@ where import Branches-import Common (when, (+-+))+import Common ((+-+))+import Common.System (error') import Git import Package @@ -19,9 +20,10 @@ (Branches [], args) where fetchPkgLenient :: Package -> AnyBranch -> IO ()- fetchPkgLenient pkg _br =- when lenient $ do+ fetchPkgLenient pkg _br = do haveGit <- isPkgGitRepo if haveGit then gitFetchSilent False- else putStrLn $ "ignoring" +-+ unPackage pkg+ else if lenient+ then putStrLn $ "ignoring" +-+ unPackage pkg+ else error' "not a dist-git dir"
src/Cmd/Import.hs view
@@ -18,7 +18,7 @@ import Branches import Bugzilla-import Cmd.RequestBranch (requestPkgBranches)+import Cmd.RequestBranch (requestPkgBranches, waitForKojiPkgBranch) import Git import Koji import ListReviews@@ -26,8 +26,8 @@ -- FIXME separate pre-checked listReviews and direct pkg call, which needs checks -- FIXME add --dryrun-importCmd :: Bool -> Bool -> Bool -> (BranchesReq,[String]) -> IO ()-importCmd reporequest existingrepo mock (breq, ps) = do+importCmd :: Bool -> Bool -> Bool -> Bool -> (BranchesReq,[String]) -> IO ()+importCmd showbug reporequest existingrepo mock (breq, ps) = do pkgs <- if null ps then map reviewBugToPackage <$> listReviews ReviewRepoCreated else return ps@@ -41,7 +41,7 @@ when (pkg /= takeFileName dir) $ do exists <- doesDirectoryExist pkg unless exists $ do- clonePkg True UserClone Nothing pkg+ clonePkg False True UserClone Nothing pkg setCurrentDirectory pkg -- FIXME: check branch is rawhide unlessM isGitRepo $ error' "Not a git repo"@@ -53,14 +53,14 @@ -- FIXME get session from importPkgs (bid,session) <- approvedReviewBugIdSession pkg putBugId bid- srpmfile <- downloadReviewSRPM False True pkg bid session+ srpmfile <- downloadReviewSRPM showbug False True pkg bid session putNewLn promptEnter $ "Press Enter to import" +-+ srpmfile krbTicket fedpkg_ "import" [srpmfile] git_ "commit" ["--message", "Import rhbz#" ++ show bid] nvr <- pkgNameVerRel' Rawhide (pkg <.> "spec")- mbuild <- promptPushBuild $ "Press Enter to Push & B[uild]" +-+ showNVR nvr ++ ", or just P[ush], or N[o] to skip? [Y/n/b/p]"+ 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 when (mbuild == Just True) $ do@@ -72,7 +72,8 @@ when (null existing) $ do brs <- getRequestedBranches [] breq unless (reporequest || null brs) $- requestPkgBranches False False mock (Branches brs) (Package pkg)+ requestPkgBranches False False mock (Branches brs) (Package pkg) >>=+ mapM_ (waitForKojiPkgBranch False (Package pkg)) when (pkg /= takeFileName dir) $ setCurrentDirectory dir @@ -91,12 +92,13 @@ "no" -> Just (Just False) _ -> Nothing -downloadReviewSRPM :: Bool -> Bool -> String -> Int -> BugzillaSession+downloadReviewSRPM :: Bool -> Bool -> Bool -> String -> Int -> BugzillaSession -> IO FilePath-downloadReviewSRPM getspec prompt pkg bid session = do- putNewLn+downloadReviewSRPM showbug getspec prompt pkg bid session = do comments <- getComments session bid- mapM_ showComment comments+ when showbug $ do+ putNewLn+ mapM_ showComment comments putNewLn putStr "Review bug: " putBugId bid
src/Cmd/Install.hs view
@@ -3,7 +3,8 @@ module Cmd.Install ( installCmd, notInstalledCmd,- Select(..)+ Select(..),+ unInstallCmd ) where import Data.RPM@@ -30,13 +31,13 @@ -- FIXME handle subpackage renames (eg ghc-rpm-macros-no-prof to ghc-rpm-macros-quick) -- FIXME allow building an srpm installCmd :: Bool -> Bool -> Maybe Branch -> Maybe Natural- -> Maybe ForceShort -> [BCond] -> Bool -> Bool -> Bool -> Select- -> Maybe ExistingStrategy -> (Maybe Branch,[String])+ -> Maybe ForceShort -> [BCond] -> Bool -> Bool -> Bool -> Yes+ -> Select -> Maybe ExistingStrategy -> (Maybe Branch,[String]) -> IO ()-installCmd quiet recurse mfrom mjobs mforceshort bconds reinstall nobuild nobuilddeps select mexisting (mbr, pkgs) = do+installCmd quiet recurse mfrom mjobs mforceshort bconds reinstall nobuild nobuilddeps yes 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)+ withPackagesMaybeBranch (boolHeader (recurse || length pkgs > 1)) True Nothing installPkg (mbr, filter (/= ":") pkgs) where installPkg :: Package -> AnyBranch -> IO () installPkg pkg br = do@@ -55,12 +56,12 @@ let nvras = map readNVRA rpms -- FIXME can this be removed now? already <- filterM nvraInstalled nvras- if isJust mforceshort || null already || reinstall- then doInstallPkg mforceshort spec rpms+ if isJust mforceshort || null already || reinstall || select /= selectDefault+ then doInstallRPMs mforceshort spec rpms else putStrLn $ unlines (map showNVRA already) ++ "\nalready installed!\n" where- doInstallPkg mforceshort' spec rpms = do+ doInstallRPMs mforceshort' spec rpms = do -- FIXME show source NVR (eg not pandoc-common) whenJust (headMay rpms) $ putStrLn . showNVR . dropArch . readNVRA@@ -76,7 +77,7 @@ mpkgdir <- lookForPkgDir rbr ".." dep case mpkgdir of Nothing -> putStrLn $ dep +-+ "not known"- Just pkgdir -> installCmd quiet recurse mfrom mjobs mforceshort bconds reinstall nobuild nobuilddeps select mexisting (mbr, [pkgdir]) >> putNewLn+ Just pkgdir -> installCmd quiet recurse mfrom mjobs mforceshort bconds reinstall nobuild nobuilddeps yes select mexisting (mbr, [pkgdir]) >> putNewLn -- FIXME option to enable/disable installing missing deps -- FIXME --skip-missing-deps or prompt else installDeps True spec@@ -88,10 +89,10 @@ unless (isShortCircuit mforceshort') $ do let nvras = rpmsToNVRAs rpms -- FIXME: prefix = fromMaybe (nvrName nvr) mprefix- decided <- decideRPMs No False mexisting select (unPackage pkg) nvras+ decided <- decideRPMs yes False mexisting select (unPackage pkg) nvras -- FIXME dryrun and debug -- FIXME return Bool?- installRPMs False False Nothing No $ groupOnArch "RPMS" decided+ installRPMs False False Nothing yes $ groupOnArch "RPMS" decided lookForPkgDir :: Branch -> FilePath -> String -> IO (Maybe FilePath) lookForPkgDir rbr topdir p = do@@ -139,10 +140,67 @@ then putStrLn $ unPackage pkg else putStrLn $ " " ++ unPackage pkg -nvraInstalled :: NVRA -> IO Bool-nvraInstalled rpm =- cmdBool "rpm" ["--quiet", "-q", showNVRA rpm]- pkgInstalled :: String -> IO Bool pkgInstalled pkg = cmdBool "rpm" ["--quiet", "-q", pkg]++unInstallCmd :: Yes -> (Maybe Branch,[String]) -> IO ()+unInstallCmd yes (mbr, pkgs) = do+ withPackagesMaybeBranch (boolHeader (length pkgs > 1)) True Nothing unInstallPkg (mbr, pkgs)+ where+ unInstallPkg :: Package -> AnyBranch -> IO ()+ unInstallPkg pkg br = do+ whenJust mbr $ gitSwitchBranch . RelBranch+ dead <- doesFileExist "dead.package"+ if dead+ then putStrLn "dead package"+ else do+ spec <- localBranchSpecFile pkg br+ built <- builtRpms br spec+ let rpms = map (rpmName . readNVRA) built+ -- FIXME can this be removed now?+ installed <- filterM (\p -> cmdBool "rpm" ["--quiet", "-q", p]) rpms+ unless (null installed) $ do+ whenJust (headMay built) $+ putStrLn . showNVR . dropArch . readNVRA+ unInstallRPMs False installed++ unInstallRPMs :: Bool -> [String] -> IO ()+ unInstallRPMs debug rpms =+ unless (null rpms) $ do+ mgr <- do+ ostree <- doesDirectoryExist "/sysroot/ostree"+ if ostree+ then return OSTREE+ else do+ mdnf5 <- findExecutable "dnf5"+ return $ maybe DNF3 (const DNF5) mdnf5+ let pkgmgr =+ case mgr of+ DNF3 -> "dnf-3"+ DNF5 -> "dnf5"+ RPM -> "rpm"+ OSTREE -> "rpm-ostree"+ com = unInstallCommand mgr+ in+ do+ when debug $ mapM_ putStrLn rpms+ (case mgr of+ OSTREE -> cmd_+ _ -> if debug then sudoLog else sudo_) pkgmgr $+ com ++ rpms ++ ["--assumeyes" | yes == Yes && mgr `elem` [DNF3,DNF5]]++ unInstallCommand :: PkgMgr -> [String]+ unInstallCommand mgr =+ case mgr of+ DNF3 -> ["remove"]+ DNF5 -> ["remove"]+ RPM -> ["-e"]+ OSTREE -> ["uninstall"]++#if !MIN_VERSION_simple_cmd(0,2,7)+sudoLog :: String -- ^ command+ -> [String] -- ^ arguments+ -> IO ()+sudoLog = sudo_+#endif
src/Cmd/ListBranches.hs view
@@ -1,6 +1,7 @@ module Cmd.ListBranches ( branchesCmd,- BranchesMode(..)+ BranchesMode(..),+ BranchDead(..) ) where @@ -15,11 +16,13 @@ data BranchesMode = Local | Remote | Current deriving Eq +data BranchDead = SkipDead | OnlyDead+ -- FIXME remote/pagures branch and --remote or --no-remote -- FIXME --local for existing local branches-branchesCmd :: Bool -> Bool -> Bool -> BranchesMode -> (BranchesReq,[String])- -> IO ()-branchesCmd skipdead allbrs missing mode (breq, pkgs) = do+branchesCmd :: Maybe BranchDead -> Bool -> Bool -> BranchesMode+ -> (BranchesReq,[String]) -> IO ()+branchesCmd mdead allbrs missing mode (breq, pkgs) = do -- when (allbrs $ do -- unless (null brs) $ -- error' "cannot combine --all and branches"@@ -29,9 +32,10 @@ case breq of Branches [_] -> return () Branches [] | not missing -> return ()- _ -> error' $ (if missing then "--current --missing needs one branch"- else "use --current with zero or one branches") ++- " specified"+ _ -> error' $ (if missing+ then "--current --missing needs one branch"+ else "use --current with zero or one branches") +-++ "specified" if null pkgs then branchesPkg "." else mapM_ branchesPkg pkgs@@ -42,10 +46,14 @@ then doBranchesPkg else withExistingDirectory path $- if skipdead then- unlessM (doesFileExist "dead.package")- doBranchesPkg- else doBranchesPkg+ case mdead of+ Just SkipDead ->+ unlessM (doesFileExist "dead.package")+ doBranchesPkg+ Just OnlyDead ->+ whenM (doesFileExist "dead.package")+ doBranchesPkg+ Nothing -> doBranchesPkg where doBranchesPkg :: IO () doBranchesPkg = do@@ -53,6 +61,10 @@ unlessM isPkgGitRepo $ error' "not Fedora dist-git" pkg <- getPackageName path+ let pkgprefix =+ if length pkgs > 1+ then unPackage pkg ++ ":"+ else "" if mode == Current then do br <- gitCurrentBranch'@@ -61,18 +73,19 @@ RelBranch rbr -> Branches [rbr] == breq OtherBranch _abr -> False if missing- then unless onbranch $ putStrLn $ unPackage pkg ++ ":" +-+ show br+ then unless onbranch $ putStrLn $ pkgprefix +-+ show br else case breq of Branches [req] -> when (RelBranch req == br) $- putStrLn $ unPackage pkg ++ ":" +-+ show br- _ -> putStrLn $ unPackage pkg ++ ":" +-+ show br+ putStrLn $ pkgprefix +-+ show br+ _ -> putStrLn $ pkgprefix +-+ show br else do brs <- delete "main" <$> if mode == Remote then pagurePkgBranches (unPackage pkg) else localBranches False if allbrs then do- putStrLn $ unPackage pkg ++ ":" +-+ unwords brs+ -- FIXME epel branches are not sorted correctly: epel10 epel10.0 epel9 f41 ...+ putStrLn $ pkgprefix +-+ unwords brs else do if breq == Branches [] then do@@ -82,12 +95,10 @@ if missing then active \\ mapMaybe readBranch brs else activeBranches active brs- putStr $ unPackage pkg ++ ": "- putStrLn $ (unwords . map showBranch) result+ putStrLn $ pkgprefix +-+ (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 showBranch) result+ unless (null result) $+ putStrLn $ pkgprefix +-+ (unwords . map showBranch) result
src/Cmd/ListPackages.hs view
@@ -3,21 +3,20 @@ module Cmd.ListPackages ( listCmd, Packager(..),- listLocalCmd+ listLocalCmd,+ listPackages ) where -import Data.Aeson import Fedora.Pagure import SimplePrompt (yesNoDefault) import Branches import Common import Common.System-import qualified Common.Text as T import Git (gitSwitchBranch') import Package-import Pagure+import Pagure (srcfpo) data Packager = Owner String | Committer String @@ -26,26 +25,31 @@ listCmd force count mpackager pkgs = do unless (force || count || isJust mpackager || not (null pkgs)) $ error' "Please give a package pattern, --count, or --owner/--username"- if null pkgs then listPackage Nothing- else mapM_ (listPackage . Just) pkgs- where- -- FIXME add default --max-pages?- listPackage :: Maybe String -> IO ()- listPackage mpattern = do- let path = "projects"- params = makeKey "short" "1" ++ fork ++ packager ++ makeKey "namespace" "rpms" ++ maybeKey "pattern" mpattern- mnum <- queryPagureCount srcfpo path params "pagination"- whenJust mnum $ \num ->+ ecountpkgs <- countListPackages force count mpackager pkgs+ case ecountpkgs of+ Left num -> print num+ Right packages -> mapM_ putStrLn packages++countListPackages :: Bool -> Bool -> Maybe Packager -> [String]+ -> IO (Either Integer [String])+countListPackages force count mpackager pkgs = do+ emcounts <-+ if null pkgs+ then Left <$> countPackages Nothing+ else Right <$> mapM (countPackages . Just) pkgs+ case emcounts of+ Left mcount -> if count- then print num- else do- ok <-- if num > 1000 && not force- then yesNoDefault False $ show num +-+ "results, continue"- else return True- when ok $ do- pages <- queryPagureCountPaged srcfpo False path params ("pagination", "page")- mapM_ printPage pages+ then return $ Left $ fromMaybe 0 mcount+ else Right <$> doListPackages (mcount, Nothing)+ Right mcounts ->+ if count+ then return $ Left $ sum $ catMaybes mcounts+ else Right <$> concatMapM doListPackages (zip mcounts $ map Just pkgs)+ where+ path = "projects"+ mkParams mpattern =+ makeKey "short" "1" ++ makeKey "fork" "0" ++ packager ++ makeKey "namespace" "rpms" ++ maybeKey "pattern" mpattern where packager = case mpackager of@@ -53,13 +57,27 @@ Just (Owner o) -> makeKey "owner" o Just (Committer c) -> makeKey "username" c - fork = makeKey "fork" "0"+ countPackages :: Maybe String -> IO (Maybe Integer)+ countPackages mpattern =+ queryPagureCount srcfpo path (mkParams mpattern) "pagination" - printPage :: Object -> IO ()- printPage result =- let projects = lookupKey' "projects" result :: [Object]- in- mapM_ (T.putStrLn . lookupKey' "name") projects+ -- FIXME add default --max-pages?+ doListPackages :: (Maybe Integer, Maybe String) -> IO [String]+ doListPackages (Nothing, mpat) =+ error' $ "no matches found" +-+ maybe "" ("for" +-+) mpat+ doListPackages (Just 0, _mpat) = return []+ doListPackages (Just num, mpattern) = do+ ok <-+ if num > 1000 && not force+ then yesNoDefault False $ show num +-+ "results, continue"+ else return True+ if ok+ then do+ pages <- queryPagureCountPaged srcfpo False path (mkParams mpattern) ("pagination", "page")+ return $+ concatMap (map (lookupKey' "name")) $+ mapMaybe (lookupKey "projects") pages+ else error' "aborted" -- FIXME add --count listLocalCmd :: (Maybe Branch, [String]) -> IO ()@@ -67,10 +85,15 @@ withPackagesMaybeBranch HeaderNone False dirtyGit listLocalPkg where listLocalPkg :: Package -> AnyBranch -> IO ()- listLocalPkg _ (OtherBranch _) =- error' "other branches not supported yet" listLocalPkg pkg (RelBranch br) = do exists <- gitSwitchBranch' True br when exists $ whenM (isJust <$> maybeFindSpecfile) $ putStrLn $ unPackage pkg+ listLocalPkg _ (OtherBranch _) =+ error' "other branches not supported yet"++listPackages :: Bool -> Maybe Packager -> [String] -> IO [String]+listPackages force mpackager pkgs =+ either (error' "impossible happened") id <$>+ countListPackages force False mpackager pkgs
src/Cmd/Local.hs view
@@ -5,7 +5,7 @@ localCmd, moveArtifactsCmd, nvrCmd,- renameMasterCmd,+ renameRawhideCmd, srpmCmd, srpmSpecCmd ) where@@ -111,25 +111,12 @@ unless (continue || ret == ExitSuccess) exitFailure -renameMasterCmd :: [String] -> IO ()-renameMasterCmd pkgs =+renameRawhideCmd :: [String] -> IO ()+renameRawhideCmd pkgs = withPackagesByBranches HeaderMay False dirtyGit Zero renameMasterBranch (Branches [], pkgs) where renameMasterBranch :: Package -> AnyBranch -> IO ()- renameMasterBranch _pkg _br = do- locals <- gitLines "branch" ["--format=%(refname:short)"]- -- FIXME dangling warning in current output:- -- From ssh://pkgs.fedoraproject.org/rpms/hedgewars- -- - [deleted] (none) -> origin/master- -- (refs/remotes/origin/HEAD has become dangling)- -- Branch 'rawhide' set up to track remote branch 'rawhide' from 'origin'.- -- compare commands with github rename- unless ("rawhide" `elem` locals) $ do- git_ "fetch" ["--prune"]- git_ "branch" ["--move", "master", "rawhide"]- git_ "remote" ["set-head", "origin", "rawhide"]- git_ "branch" ["--set-upstream-to", "origin/rawhide", "rawhide"]- git_ "pull" []+ renameMasterBranch _pkg _br = renameMasterToRawhide countCmd :: (Maybe Branch,[String]) -> IO () countCmd (mbr,pkgs) =
src/Cmd/Merge.hs view
@@ -13,6 +13,7 @@ import Package import Patch +-- FIXME add --local to merge from local branch instead of origin? mergeCmd :: Bool -> Bool -> Bool -> Maybe Natural -> Bool -> Maybe Branch -> (BranchesReq,[String]) -> IO () mergeCmd dryrun nofetch noprompt mnotrivial showall mfrom =@@ -35,7 +36,7 @@ gitMergeOrigin br (ancestor,unmerged) <- mergeable from br unmerged' <- filterOutTrivial mnotrivial unmerged- mergeBranch dryrun False noprompt showall pkg (ancestor,unmerged') from br+ mergeBranch dryrun nofetch False noprompt showall pkg (ancestor,unmerged') from br where filterOutTrivial :: Maybe Natural -> [Commit] -> IO [Commit] filterOutTrivial Nothing cs = return cs@@ -53,21 +54,20 @@ -- FIXME maybe require local branch already here mergeable :: Branch -> Branch -> IO (Bool,[Commit]) mergeable _ Rawhide = return (False,[])-mergeable from _ = do- locals <- localBranches True- (mancestor, unmerged) <- gitMergeable (showBranch from `notElem` locals) from+mergeable from to = do+ (mancestor, unmerged) <- gitMergeable to from return (mancestor == Just True, unmerged) -- FIXME return merged ref-mergeBranch :: Bool -> Bool -> Bool -> Bool -> Package+mergeBranch :: Bool -> Bool -> Bool -> Bool -> Bool -> Package -> (Bool,[Commit]) -- (ancestor,unmerged) -> Branch -> Branch -> IO ()-mergeBranch _ _ _ _ _ _ _ Rawhide = return ()-mergeBranch _ _ _ _ _ (_,[]) _ _ = return ()-mergeBranch dryrun build noprompt showall pkg (True, unmerged@(unmgd:_)) from br = do- unless build $ putPkgBrnchHdr pkg br+mergeBranch _ _ _ _ _ _ _ _ Rawhide = return ()+mergeBranch _ _ _ _ _ _ (_,[]) _ _ = return ()+mergeBranch dryrun nofetch build noprompt showall pkg (True, unmerged@(unmgd:_)) from br = do+ when (nofetch && not build) $ putPkgBrnchHdr pkg br isnewrepo <- initialPkgRepo- putStrLn $ (if isnewrepo || noprompt then "Merging from" else "New commits in") +-+ showBranch from ++ ":"+ putStrLn $ (if isnewrepo || noprompt then "Merging from" else "New commits in") +-+ "origin/" ++ showBranch from ++ ":" displayCommits showall unmerged putNewLn unpushed <- gitOneLineLog $ "origin/" ++ showBranch br ++ "..HEAD"@@ -78,7 +78,7 @@ mmerge <- if isnewrepo && length unmerged == 1 || noprompt then return $ Just $ commitRef unmgd- else refPrompt unmerged ("Press Enter to merge" +-+ showBranch from +++ else refPrompt unmerged ("Press Enter to merge from" +-+ showBranch from ++ (if build then " and build" else "") ++ (if length unmerged > 1 then "; or give ref to merge" else "") ++ "; or 'no' to skip merge")@@ -91,8 +91,8 @@ unless dryrun $ -- FIXME merge from origin by default not local branch git_ "merge" ["--quiet", ref]-mergeBranch dryrun build noprompt showall pkg (False,unmerged) from br = do- unless build $ putPkgBrnchHdr pkg br+mergeBranch dryrun nofetch build noprompt showall pkg (False,unmerged) from br = do+ when (nofetch && not build) $ putPkgBrnchHdr pkg br putStrLn $ showBranch from +-+ "branch is not directly mergeable:" displayCommits False unmerged putNewLn
src/Cmd/Mock.hs view
@@ -1,31 +1,39 @@ module Cmd.Mock ( mockCmd, NoClean(..),- MockShell(..)+ MockMode(..) ) where import Data.RPM+import Safe (headMay)+import SelectRPMs import Branches import Common import Common.System import Git import Package-import RpmBuild (generateSrpm)+import RpmBuild (builtRpms, generateSrpm, nvraInstalled) data NoClean = NoCleanBefore | NoCleanAfter | NoCleanAll | MockShortCircuit deriving Eq -data MockShell = ShellOnly | BuildShell+-- FIXME (add MockBuild or MockDefault?)+data MockMode = ShellOnly | BuildShell | MockInstall deriving Eq +reqShell :: Maybe MockMode -> Bool+reqShell Nothing = False+reqShell (Just ms) = ms /= MockInstall++-- FIXME error if non-existent branch -- FIXME add repo/copr for build -- FIXME handle non-release branches (on-branch works) -- FIXME option for --shell without rebuild-mockCmd :: Bool -> Maybe NoClean -> Bool-> Maybe MockShell -> Maybe Branch- -> Maybe String -> (BranchesReq, [String]) -> IO ()-mockCmd dryrun mnoclean network mockshell mroot march (breq, ps) = do+mockCmd :: Bool -> Maybe NoClean -> Bool -> Bool -> Maybe MockMode+ -> Maybe Branch -> Maybe String -> (BranchesReq, [String]) -> IO ()+mockCmd dryrun mnoclean network reinstall mockmode mroot march (breq, ps) = do pkggit <- isPkgGitRepo branches <- case breq of@@ -45,7 +53,7 @@ srpms <- mapM (prepSrpm (RelBranch br)) pkgs putNewLn -- FIXME? is it better just to fail asking for target branch?- rootBr <- maybe (if pkggit then getReleaseBranch else systemBranch) return mroot+ rootBr <- maybe (if pkggit then getReleaseBranch else return br) return mroot let resultdir = case srpms of [] -> error' "cannot build zero packages"@@ -65,16 +73,27 @@ mockshell_opts = mockopts_common "--shell" ++ ["--no-clean" | "--no-clean" `notElem` noclean] if dryrun then do- unless (mockshell == Just ShellOnly) $+ unless (mockmode == Just ShellOnly) $ cmdN "mock" mockbuild_opts- when (isJust mockshell) $ cmdN "mock" mockshell_opts+ when (reqShell mockmode) $ cmdN "mock" mockshell_opts else do ok <-- if mockshell == Just ShellOnly+ if mockmode == Just ShellOnly then return True- else cmdBool "mock" mockbuild_opts- when (isJust mockshell) $ cmd_ "mock" mockshell_opts+ else do+ dobuild <-+ if mockmode == Just MockInstall+ then do+ let verrel = showPkgVerRel . readNVRA+ anyM (\s -> not <$> doesFileExist ("results" </> verrel s </> s)) srpms+ else return True+ if dobuild+ then cmdBool "mock" mockbuild_opts+ else return True+ when (reqShell mockmode) $ cmd_ "mock" mockshell_opts unless ok $ error' "mockbuild failed"+ when (mockmode == Just MockInstall) $ do+ mapM_ mockInstall pkgs where prepSrpm :: AnyBranch -> FilePath -> IO FilePath prepSrpm rbr pkgdir =@@ -86,3 +105,33 @@ gitSwitchBranch rbr spec <- findSpecfile generateSrpm Nothing spec++ mockInstall :: String -> IO ()+ mockInstall pkg = do+ spec <- findSpecfile+ rpms <- builtRpms (RelBranch br) spec+ let nvras = map readNVRA rpms+ -- FIXME can this be removed now?+ already <- filterM nvraInstalled nvras+ if null already || reinstall+ then doInstallRPMs rpms+ else putStrLn $ unlines (map showNVRA already) +++ "\nalready installed!\n"+ where+ doInstallRPMs rpms = do+ -- FIXME show source NVR (eg not pandoc-common)+ whenJust (headMay rpms) $+ putStrLn . showNVR . dropArch . readNVRA+ let nvras = rpmsToNVRAs rpms+ -- FIXME: prefix = fromMaybe (nvrName nvr) mprefix+ decided <- -- decideRPMs yes False mexisting select pkg nvras+ decideRPMs Yes False Nothing selectDefault pkg nvras+ -- FIXME dryrun and debug+ -- FIXME return Bool?+ let verrel = showPkgVerRel . readNVRA $ head rpms+ results = "results" </> verrel+ forM_ ["noarch", "x86_64"] $ \arch -> do+ let link = results </> arch+ unlessM (doesDirectoryExist link) $+ createFileLink "." link+ installRPMs False False Nothing Yes $ groupOnArch results decided
src/Cmd/Override.hs view
@@ -34,11 +34,9 @@ putStrLn "Overriding" withPackagesByBranches HeaderMay False cleanGitFetchActive AnyNumber overrideBranch breqpkgs unless nowait $- waitrepoCmd dryrun WaitNoFetch Nothing breqpkgs+ waitrepoCmd dryrun False WaitNoFetch Nothing breqpkgs where overrideBranch :: Package -> AnyBranch -> IO ()- overrideBranch _ (OtherBranch _) =- error' "override only defined for release branches" overrideBranch pkg rbr@(RelBranch br) = do gitSwitchBranch rbr let spec = packageSpec pkg@@ -49,6 +47,8 @@ unless (any (`elem` tags) [showBranch br, showBranch br ++ "-updates", showBranch br ++ "-override"]) $ unlessM (checkAutoBodhiUpdate br) $ bodhiCreateOverride dryrun mduration nvr+ overrideBranch _ (OtherBranch _) =+ error' "override only defined for release branches" overrideCmd _dryrun OverrideList _mduration _nowait (_breq,pkgs) = withPackages pkgs $ packageOverrides >=> mapM_ showOverride
src/Cmd/Parallel.hs view
@@ -16,7 +16,8 @@ import Fedora.Krb (krbTicket) import Say import SimplePrompt (prompt, promptEnter, yesNo)-import System.Console.Pretty+import SimplePrompt.Internal (runPrompt, mapInput, getPromptLine)+import System.Console.Pretty (color, Color(..), style, Style(Bold)) import System.Time.Extra (sleep) import Bodhi@@ -76,19 +77,13 @@ getPackageName p >>= parallelBranches branches _ -> forM_ branches $ \rbr -> do- mtargetSidetag <-- if msidetagTarget == Just SideTag- then do- tags <- kojiUserSideTags (Just rbr)+ when (msidetagTarget == Just SideTag) $ do+ tags <- kojiUserSideTags (Just rbr)+ putStrLn $ case tags of- [] -> do- putStrLn "will use new sidetag"- return $ Just SideTag- [tag] -> do- putStrLn $ "will use" +-+ tag- return $ Just (Target tag)- _ -> error' $ "multiple existing sidetags:" +-+ show tags- else return msidetagTarget+ [] -> "will use new sidetag"+ [tag] -> "will use" +-+ tag+ _ -> "Several user side-tags found for" +-+ showBranch rbr ++ ":\n" ++ unlines tags forM_ (filter (/= ":") pkgs) $ \p -> when (mmerge /= Just False) $ withExistingDirectory p $ do@@ -103,10 +98,11 @@ error' "You must use --target/--sidetag to build package layers for this branch" when (length branches > 1) $ putStrLn $ "#" +-+ showBranch rbr- target <- targetMaybeSidetag dryrun True True rbr mtargetSidetag- nvrclogs <- concatMapM (timeIODesc "layer" . parallelBuild target rbr)- (zip [firstlayer..length allLayers] $- init $ tails layers) -- tails ends in []+ target <- targetMaybeSidetag dryrun True True rbr msidetagTarget+ -- FIXME "layer N took ..."+ nvrclogs <- concatMapM (\(n,l) -> timeIODesc ("layer" +-+ show n) (parallelBuild target rbr (n,l)))+ (zip [firstlayer..length allLayers] $+ init $ tails layers) -- tails ends in [] unless (isNothing (fst mupdate)) $ unless (isNothing msidetagTarget) $ -- FIXME check for an existing sidetag update@@ -134,7 +130,7 @@ when (length brs /= 1) $ gitSwitchBranch currentbranch unless (null failures) $ do- putStrLn $ "Build failures:" +-+ unwords failures+ putStrLn $ "Build failures:" +-+ color Red (unwords failures) okay <- yesNo "Do you want to continue nevertheless" unless okay $ error' "Quitting" when (isNothing msidetagTarget) $ do@@ -159,7 +155,7 @@ (ancestor,unmerged,mnewer) <- newerMergeable (unPackage pkg) br unless dryrun $ whenJust mnewer $ \newer ->- mergeBranch dryrun False (mmerge == Just True) False pkg (ancestor,unmerged) newer br+ mergeBranch dryrun False False (mmerge == Just True) False pkg (ancestor,unmerged) newer br -- FIXME time builds or layers -- FIXME return Either@@ -189,29 +185,40 @@ when (null jobs) $ error' "No jobs run" (failures,nvrs) <- watchJobs (length jobs == 1) (if singlelayer then Nothing else Just layernum) [] [] jobs- unless (null nvrs || null nextLayers) $ do- putNewLn- kojiWaitRepoNVRs dryrun False target $ map jobNvr nvrs- putNewLn+ let kojiWaitRepoForLayer =+ unless (null nvrs || null nextLayers) $ do+ putNewLn+ kojiWaitRepoNVRs dryrun False target $ map jobNvr nvrs+ putNewLn if null failures- then return nvrs+ then do+ kojiWaitRepoForLayer+ return nvrs else do let pending = sum $ map length nextLayers putStrLn $ "\nBuild failures" +-+ (if singlelayer then ":" else "in layer" +-+ show layernum ++ ":") +-+ unwords failures- okay <-+ reply <- if null nextLayers- then return False- else yesNo "Do you want to continue nevertheless"- if okay- then return nvrs- else error' $- if pending > 0- then- plural pending "pending package" ++- ":\n" ++ unwords (map unwords nextLayers)- else "failed"+ then return $ Just False+ -- FIXME edit next layer+ else promptFailure "Do you want to [c]ontinue nevertheless or maybe fix & [r]etry? [c/N/r]"+ case reply of+ Just True -> do+ kojiWaitRepoForLayer+ return nvrs+ Nothing -> do+ res <- parallelBuild target br (layernum, [failures])+ kojiWaitRepoForLayer+ return res+ Just False ->+ error' $+ if pending > 0+ then+ plural pending "pending package" +++ ":\n" ++ unwords (map unwords nextLayers)+ else "failed" where nopkgs = length layer @@ -224,6 +231,21 @@ unless dryrun $ sleep delay return (unPackage pkg,job) + promptFailure = runPrompt . mapInput maybePush . getPromptLine+ where+ maybePush inp =+ case lower inp of+ "" -> Just (Just False)+ "n" -> Just (Just False)+ "no" -> Just (Just False)+ "c" -> Just (Just True)+ "cont" -> Just (Just True)+ "continue" -> Just (Just True)+ "r" -> Just Nothing+ "retry" -> Just Nothing+ "rebuild" -> Just Nothing+ _ -> Nothing+ watchJobs :: Bool -> Maybe Int -> [String] -> [JobDone] -> [JobAsync] -> IO ([String],[JobDone]) -- (failures,successes) watchJobs _ _ fails dones [] = return (fails,dones)@@ -249,11 +271,14 @@ startBuild mlayer n morelayers nopkgs target pkg br dir = withExistingDirectory dir $ do gitSwitchBranch (RelBranch br)- unlessM isGitDirClean $- error' "local uncommitted changes (dirty)"+ unlessM isGitDirClean $ do+ warning $ color Red "local uncommitted changes (dirty)"+ promptEnter "Press Enter to continue after fixing" let spec = packageSpec pkg checkForSpecFile spec nvr <- pkgNameVerRel' br spec+ putStrLn $ showNVR nvr +-+ "(" ++ target ++ ")" +-+ morepkgs+ putNewLn unpushed <- gitOneLineLog $ "origin/" ++ showBranch br ++ "..HEAD" if null unpushed then@@ -262,12 +287,7 @@ unless ok $ error' "no commits with --must-push" else do- putStrLn $ showNVR nvr +-+ "(" ++ target ++ ")" +-+- if nopkgs > 1- then pluralException n (if morelayers then Nothing else Just "last") "more" "more" +-+ maybe "" (\l -> "in layer" +-+ show l) mlayer- else ""- putNewLn- displayCommits True unpushed+ displayCommits False unpushed unless (null unpushed) $ do checkSourcesMatch pkg (RelBranch br) spec unlessM isGitDirClean $@@ -293,19 +313,17 @@ bodhiCreateOverride dryrun Nothing nvr return $ return $ Done pkg nvr br changelog Just BuildBuilding -> do- sayString $ color Yellow (showNVR nvr) +-+ "is already" +-+ color Yellow "building"+ sayString $ color Yellow (showNVR nvr) +-+ "is already" +-+ style Bold (color Yellow "building") mtask <- kojiGetBuildTaskID fedoraHub $ showNVR nvr case mtask of Nothing -> error' $ "Task for" +-+ showNVR nvr +-+ "not found"- Just task ->+ Just task -> do+ putTaskinfoUrl fedoraHub task return $ do- kojiWaitTaskReport (isNothing mlatest) nvr task- return $ Done pkg nvr br changelog+ kojiWaitTaskReport (isNothing mlatest) nvr task+ return $ Done pkg nvr br changelog _ -> do- when (null unpushed) $ do- putStrLn $ showNVR nvr +-+ "(" ++ target ++ ")" +-+ show n +-+ "more" +-+- maybe "" (\l -> "in layer" +-+ show l) mlayer- putNewLn+ when (null unpushed) $ putStrLn changelog buildref <- git "show-ref" ["--hash", "origin/" ++ showBranch br] opentasks <- kojiOpenTasks pkg (Just buildref) target@@ -332,18 +350,23 @@ kojiWaitTaskReport (isNothing mlatest) nvr task return $ Done pkg nvr br changelog where+ morepkgs =+ if nopkgs > 1+ then pluralException n (if morelayers then Nothing else Just "last") "more" "more" +-+ maybe "" (\l -> "in layer" +-+ show l) mlayer+ else ""+ -- throws error on build failure kojiWaitTaskReport :: Bool -> NVR -> TaskID -> IO () kojiWaitTaskReport newpkg nvr task = do finish <- retry 3 $ kojiWaitTask task if finish- then sayString $ color Green $ showNVR nvr +-+ "build success"+ then sayString $ color Green (showNVR nvr) +-+ "complete" else do- whenJustM (findExecutable "koji-tool") $ \kojitool -> do- cmd_ kojitool ["builds", "--tail", "-b", showNVR nvr]- -- FIXME cmdLog deprecated- cmdLog kojitool $ ["tasks", "--children", displayID task, "-s", "fail"] ++ ["--tail" | nopkgs < 3]- putTaskinfoUrl fedoraHub task+ whenJustM (findExecutable "koji-tool") $ \kojitool ->+ -- FIXME probably only needed for early failure now+ --cmdLog kojitool ["builds", "--tail", "-b", showNVR nvr]+ cmdLog kojitool $ ["tasks", "--children", displayID task, "-s", "fail"] ++ [if nopkgs < 5 then "--tail" else "--details"]+ putTaskinfoUrl fedoraHub task error' $ color Red $ showNVR nvr +-+ "build failed" autoupdate <- checkAutoBodhiUpdate br if autoupdate then
src/Cmd/Prep.hs view
@@ -21,7 +21,7 @@ -> IO () prepCmd mpre verbose deps allowhead (mbr,pkgs) = do when (mpre == Just PrepClone) $- cloneCmd mbr (ClonePkgs pkgs)+ cloneCmd False mbr (ClonePkgs pkgs) withPackagesMaybeBranch HeaderNone False (if allowhead then dirtyGitHEAD else Nothing) prepPackage (mbr,pkgs) where prepPackage :: Package -> AnyBranch -> IO ()
src/Cmd/Pull.hs view
@@ -48,9 +48,3 @@ if pullopt == Just PullRebase then git_ "pull" ["origin"] else gitMergeOrigin current- when (pullopt == Just PullStash) $ do- stashes <- git "stash" ["list"]- case line1 stashes of- (s0,_) | stashedWithFbrnch `isSuffixOf` s0 ->- git_ "stash" ["pop", "--quiet"]- _ -> return ()
src/Cmd/Push.hs view
@@ -5,7 +5,7 @@ import Control.Monad.Extra (when, whenJustM) import Data.Maybe (isJust)-import SimpleCmd (error')+import SimpleCmd (error', (+-+)) import Branches import Git@@ -18,8 +18,13 @@ withPackagesByBranches HeaderMust False (if nofetch then cleanGit else cleanGitFetch) AnyNumber pushPkg (breq, pkgs) where pushPkg :: Package -> AnyBranch -> IO ()- pushPkg _pkg br = do- whenJustM (gitShortLog1 $ Just $ "origin/" ++ show br ++ "..HEAD") $ putStrLn . showCommit- if dryrun- then checkOnBranch- else gitPush False mref+ pushPkg _pkg (RelBranch br) = do+ exists <- gitSwitchBranch' True br+ if exists+ then do+ whenJustM (gitShortLog1 $ Just $ "origin/" ++ showBranch br ++ "..HEAD") $ putStrLn . showCommit+ if dryrun+ then checkOnBranch+ else gitPush False mref+ else error' $ "no branch:" +-+ showBranch br+ pushPkg _ (OtherBranch _) = error' "pushing to non-release branches unsupported"
src/Cmd/RequestBranch.hs view
@@ -2,7 +2,8 @@ module Cmd.RequestBranch ( requestBranchesCmd,- requestPkgBranches+ requestPkgBranches,+ waitForKojiPkgBranch ) where import Fedora.Krb (fasIdFromKrb)@@ -22,10 +23,18 @@ import Package import Pagure +-- FIXME try to catch expired token (maybe record date when key updated?)+-- request-branch and request-repo require pagure.io API key in ~/.config/rpkg/fedpkg.conf for opening releng-scm issue: following is error for expired key++-- "Could not execute request_branch: The following error occurred while creating a new issue in Pagure: Invalid or expired token. Please visit https://pagure.io/settings#nav-api-tab to get or renew your API token.+-- For invalid or expired tokens please set a new token in your user configuration by running:+-- fedpkg set-pagure-token+-- The command is interactive; enter the new token when prompted."+ -- FIXME option to do koji scratch build instead of mock-requestBranchesCmd :: Bool -> Bool -> Maybe Branch -> Bool+requestBranchesCmd :: Bool -> Bool -> Bool -> Maybe Branch -> Bool -> (BranchesReq,[String]) -> IO ()-requestBranchesCmd quiet reviews mrecursebr mock (breq, ps) = do+requestBranchesCmd quiet reviews skipcheck mrecursebr mock (breq, ps) = do if null ps then do when (isJust mrecursebr) $@@ -34,11 +43,15 @@ if reviews then do pkgs <- map reviewBugToPackage <$> listReviews ReviewUnbranched- mapM_ (\ p -> withExistingDirectory p $ requestPkgBranches quiet (length pkgs > 1) mock breq (Package p)) pkgs+ when isPkgGit $+ promptEnter "Press Enter to continue inside this dist-git dir!"+ mapM_ (\ p -> withExistingDirectory p $ requestPkgBranches quiet (length pkgs > 1) mock breq (Package $ takeFileName p)) pkgs else if isPkgGit- then- getDirectoryName >>= requestPkgBranches quiet False mock breq . Package+ then do+ pkg <- Package <$> getDirectoryName+ requestPkgBranches quiet False mock breq pkg >>=+ mapM_ (waitForKojiPkgBranch skipcheck pkg) else error' "not a dist-git dir: specify package(s)" else do pkgs <-@@ -46,61 +59,77 @@ Just br -> do -- FIXME --rpmopt deps <- concat <$> srcDeps False [] (br,ps)+ when (null deps) $+ error' "no deps found!" putStrLn $ unwords deps unless quiet $ promptEnter "\nPress Enter to check these packages for branches" return deps Nothing -> return ps- forM_ pkgs $ \ p ->+ newPkgBranches <-+ forM pkgs $ \ p -> withExistingDirectory p $ do- pkg <- getDirectoryName- requestPkgBranches quiet (length pkgs > 1) mock breq (Package pkg)+ pkg <- Package <$> getDirectoryName+ requestPkgBranches quiet (length pkgs > 1) mock breq pkg+ putNewLn+ forM_ (zip pkgs newPkgBranches) $ \(pkg,newbrs) ->+ forM_ newbrs $ waitForKojiPkgBranch skipcheck (Package $ takeFileName pkg) -requestPkgBranches :: Bool -> Bool -> Bool -> BranchesReq -> Package -> IO ()+requestPkgBranches :: Bool -> Bool -> Bool -> BranchesReq -> Package+ -> IO [Branch] requestPkgBranches quiet multiple mock breq pkg = do- when (breq == Branches []) $+ when (multiple && not quiet) $ putPkgHdr pkg brs <- localBranches False branches <- getRequestedBranches brs breq if null branches- then- unless quiet $ do- when multiple $ putStr $ unPackage pkg ++ " "+ then do case breq of Branches [_] -> putStrLn "exists" _ -> putStrLn "branches exist"+ return [] else do- when multiple $ putStr $ unPackage pkg ++ " " gitFetchSilent True brs' <- localBranches False- branches' <- getRequestedBranches brs' (Branches branches)- whenM (havePkgAccess pkg) $ do- newbranches <- filterExistingBranchRequests branches'- unless (null newbranches) $ do- mbidsession <- bzReviewSession- urls <- forM newbranches $ \ br -> do- when mock $ fedpkg_ "mockbuild" ["--root", mockRoot br Nothing]- 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- -- &- -- 2. Can fail like this:- -- Could not execute request_branch: The following error occurred while trying to get the active release branches in PDC: <!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">- -- <title>500 Internal Server Error</title>- -- <p>The server encountered an internal error or- -- misconfiguration and was unable to complete- -- your request.</p> [...]- -- fbrnch: readCreateProcess: fedpkg "request-branch" "epel9" (exit 1): failed- u <- fedpkg "request-branch" [showBranch br]- putStrLn u- return u- whenJust mbidsession $ \(bid,session) ->- commentBug session bid $ unlines urls- forM_ newbranches $ \ br -> do- putStrLn $ "waiting for" +-+ unPackage pkg +-+ "to be added to" +-+ showBranch br ++ "-build"- (buildtag,_desttag) <- kojiBuildTarget' fedoraHub (showBranch br)- waitForPkgBuildTag pkg buildtag+ forM_ branches $ \br ->+ when (showBranch br `elem` brs') $+ let pkgPrefix = if multiple then unPackage pkg ++ ": " else ""+ in putStrLn $ pkgPrefix ++ showBranch br +-+ "branch already exists locally"+ if null (map showBranch branches \\ brs')+ then return []+ else do+ branches' <- getRequestedBranches brs' (Branches branches)+ haveAccess <- havePkgAccess pkg+ if not haveAccess+ then do+ putStrLn "You do not have commit access to this package: request would be rejected"+ return []+ else do+ newbranches <- filterExistingBranchRequests branches'+ if null newbranches+ then return []+ else do+ mbidsession <- bzReviewSession+ urls <- forM newbranches $ \ br -> do+ when mock $ fedpkg_ "mockbuild" ["--root", mockRoot br Nothing]+ 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+ -- &+ -- 2. Can fail like this:+ -- Could not execute request_branch: The following error occurred while trying to get the active release branches in PDC: <!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">+ -- <title>500 Internal Server Error</title>+ -- <p>The server encountered an internal error or+ -- misconfiguration and was unable to complete+ -- your request.</p> [...]+ -- fbrnch: readCreateProcess: fedpkg "request-branch" "epel9" (exit 1): failed+ u <- fedpkg "request-branch" [showBranch br]+ putStrLn u+ return u+ whenJust mbidsession $ \(bid,session) ->+ commentBug session bid $ unlines urls+ return newbranches where -- doRequestBr :: Bool -> Branch -> IO String -- doRequestBr multibr br = do@@ -159,16 +188,26 @@ havePkgAccess :: Package -> IO Bool havePkgAccess pkg = do- -- check have access fasid <- fasIdFromKrb epkginfo <- pagureProjectInfo srcfpo ("rpms" </> unPackage pkg) case epkginfo of Left err -> error' err Right pkginfo -> do let (admins, committers) = usersWithAccess pkginfo :: ([String],[String])- access = fasid `elem` admins ++ committers+ (gadmins, gcommitters) = groupsWithAccess pkginfo :: ([String],[String])+ access <- do+ if fasid `elem` admins ++ committers+ then return True+ else+ fmap or <$>+ forM (gadmins ++ gcommitters) $ \grp -> do+ egrpinfo <- pagureGroupInfo srcfpo grp []+ case egrpinfo of+ Left err -> error' err+ Right grpinfo ->+ return $ fasid `elem` (lookupKey' "members" grpinfo :: [String]) unless access $- warning $ "-" +-+ fasid +-+ "does not have access, ask:" +-+ unwords admins+ warning $ "-" +-+ fasid +-+ "does not have access, ask:" +-+ unwords (nub $ admins ++ gadmins) return access where usersWithAccess pkginfo =@@ -176,10 +215,26 @@ owners = lookupKey' "owner" access admins = lookupKey' "admin" access collabs = lookupKey' "collaborator" access- in (owners ++ admins, collabs)+ commits = lookupKey' "commit" access+ in (owners ++ admins, commits ++ collabs) -waitForPkgBuildTag :: Package -> String -> IO ()-waitForPkgBuildTag pkg buildtag = do- sleep 30 -- wait first to avoid "(undefined package)"- ok <- cmdBool "koji" ["list-pkgs", "--quiet", "--package=" ++ unPackage pkg, "--tag=" ++ buildtag]- unless ok $ waitForPkgBuildTag pkg buildtag+ groupsWithAccess pkginfo =+ let access = lookupKey' "access_groups" pkginfo+ admins = lookupKey' "admin" access+ collabs = lookupKey' "collaborator" access+ commits = lookupKey' "commit" access+ in (admins, commits ++ collabs)++waitForKojiPkgBranch :: Bool -- skipcheck+ -> Package -> Branch -> IO ()+waitForKojiPkgBranch skipcheck pkg br =+ unless skipcheck $ do+ putStrLn $ "waiting for" +-+ unPackage pkg +-+ "to be added to" +-+ showBranch br ++ "-build"+ (buildtag,_desttag) <- kojiBuildTarget' fedoraHub (showBranch br)+ waitBuildTag buildtag+ where+ waitBuildTag :: String -> IO ()+ waitBuildTag buildtag = do+ sleep 30 -- wait first to avoid "(undefined package)"+ ok <- cmdBool "koji" ["list-pkgs", "--quiet", "--package=" ++ unPackage pkg, "--tag=" ++ buildtag]+ unless ok $ waitBuildTag buildtag
src/Cmd/RequestRepo.hs view
@@ -80,7 +80,7 @@ ok <- yesNo $ "Import" +-+ pkg when ok $ do waitForPagureRepo- importCmd True False False (Branches [],[pkg])+ importCmd False True False False (Branches [],[pkg]) where existingRepoRequests :: IO [IssueTitleStatus] existingRepoRequests = do
src/Cmd/ReviewPackage.hs view
@@ -10,7 +10,7 @@ import Data.Char import Data.Tuple.Extra (second) import Safe (headDef, headMay, tailSafe)-import SelectRPMs (selectDefault)+import SelectRPMs (selectDefault, Yes(No)) import SimplePrompt (promptEnter, yesNoDefault) import Branches@@ -25,15 +25,15 @@ -- 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 interactive Nothing = do+reviewPackage full Nothing = do -- FIXME catch no spec file spec <- findSpecfile srpm <- generateSrpm Nothing spec- if interactive+ if not full then doInteractiveReview False (Just spec) srpm else do cmd_ "fedora-review" ["-rn", srpm]-reviewPackage interactive (Just pkgbug) = do+reviewPackage full (Just pkgbug) = do let epkgbid = if all isDigit pkgbug then Right $ read pkgbug@@ -47,7 +47,7 @@ putReviewBug False bug let bid = bugId bug pkg = reviewBugToPackage bug- if interactive+ if not full then reviewPackageInteractive bid pkg session bug else do promptEnter "Press Enter to run fedora-review"@@ -65,7 +65,7 @@ unless exists $ createDirectory dir setCurrentDirectory dir- srpm <- downloadReviewSRPM True False pkg bid session+ srpm <- downloadReviewSRPM True True False pkg bid session importsrpm <- if exists then do@@ -119,7 +119,7 @@ void $ cmdBool "rpmlint" ["."] -- FIXME $ spec:srpm:rpms spec <- maybe findSpecfile return mspec whenM (yesNoDefault importsrpm "Install packages locally") $ do- installCmd False False Nothing Nothing Nothing [] False True True selectDefault Nothing (Nothing,[])+ installCmd False False Nothing Nothing Nothing [] False True True No 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) ""
src/Cmd/Scratch.hs view
@@ -53,7 +53,7 @@ targets <- if null sidetagTargets then return [anyTarget br]- else mapM (targetMaybeSidetag dryrun False True (onlyRelBranch br) . Just) sidetagTargets+ else mapM (targetMaybeSidetag dryrun False False (onlyRelBranch br) . Just) sidetagTargets forM_ targets $ \target -> do archs <- case marchopts of
src/Cmd/SideTags.hs view
@@ -1,6 +1,7 @@ module Cmd.SideTags ( sideTagsCmd,- SidetagMode(..))+ SidetagMode(..),+ tagBuildToSidetagCmd) where import Fedora.Krb (krbTicket)@@ -9,8 +10,10 @@ import Branches import Common-import Git (isPkgGitRepo)+import Git (gitSwitchBranchVerbose, isPkgGitRepo) import Koji+import Package (cleanGit, dirtyGit, findSpecfile, pkgNameVerRel',+ withPackagesMaybeBranch, HeaderShow(HeaderMust)) data SidetagMode = SidetagAdd | SidetagRemove | SidetagTagged deriving Eq@@ -28,9 +31,10 @@ else error' "please specify a branch" else return brs sidetags <-+ sort <$> if null branches then kojiUserSideTags Nothing- else concat <$> mapM (kojiUserSideTags . Just) branches+ else concatMapM (kojiUserSideTags . Just) branches unless (isNothing mmode) krbTicket case mmode of@@ -58,3 +62,31 @@ taggedSideTag tag = do putStrLn $ "#" +-+ tag cmd_ "koji" ["list-tagged", tag]++tagBuildToSidetagCmd :: Bool -> Bool -> Branch -> (Maybe Branch,[FilePath]) -> IO ()+tagBuildToSidetagCmd dryrun allowdirty sidebr (mbr, pkgs) = do+ when (isNothing mbr && length pkgs > 1) $+ error' "Please specify source branch for multiple packages"+ sidetags <- fmap sort <$> kojiUserSideTags $ Just sidebr+ case sidetags of+ [] -> error' $ "No sidetag for" +-+ showBranch sidebr+ [sidetag] -> do+ putStrLn $ "using" +-+ sidetag ++ "\n"+ withPackagesMaybeBranch HeaderMust False (if allowdirty then dirtyGit else cleanGit) (sideTagBuild sidetag) (mbr, pkgs)+ _ -> error' $ "More than one sidetag found:\n" +-+ unwords sidetags+ where+ sideTagBuild sidetag _pkg (RelBranch br) = do+ pkggit <- isPkgGitRepo+ if pkggit+ then do+ gitSwitchBranchVerbose True False $ RelBranch br+ spec <- findSpecfile+ nvr <- pkgNameVerRel' br spec+ ok <- yesNo $ "Tag" +-+ show (showNVR nvr) +-+ "into" +-+ show sidetag+ when ok $+ if dryrun+ then putStrLn "tag-build skipped for dry-run"+ -- FIXME check pkg listed in koji+ else cmd_ "koji" ["tag-build", sidetag, showNVR nvr]+ else error' "needs to be run in dist-git dir and with correct branch"+ sideTagBuild _ _ _ = error' "only for release branches"
src/Cmd/Switch.hs view
@@ -1,13 +1,22 @@ module Cmd.Switch (switchCmd) where +import Control.Monad (unless)+ import Branches+import Common.System import Git import Package -- FIXME noop when on branch already or drop cleanGit-switchCmd :: Bool -> AnyBranch -> [String] -> IO ()-switchCmd verbose br pkgs =+switchCmd :: Bool -> Bool -> AnyBranch -> [String] -> IO ()+switchCmd verbose lenient br pkgs = -- FIXME use withBranchByPackages ? withPackagesByBranches HeaderNone False dirtyGit Zero dummy (Branches [],pkgs) where- dummy _ _ = gitSwitchBranchVerbose verbose False br+ dummy pkg _ =+ if lenient+ then do+ let rbr = onlyRelBranch br+ ok <- gitSwitchBranch' (not verbose) rbr+ unless ok $ warning $ unPackage pkg +-+ "missing" +-+ showBranch rbr+ else gitSwitchBranchVerbose verbose False br
src/Cmd/Update.hs view
@@ -97,12 +97,12 @@ -- FIXME should be sure sources exists for distgit whenM (doesFileExist "sources") $ cmd_ "sed" ["-i", "/" ++ unPackage pkg ++ "-" ++ oldver ++ "./d", "sources"]- whenM isPkgGitSshRepo $ do+ when distgit $ do -- FIXME forM_ sources <- map sourceFieldFile <$> cmdLines "spectool" ["-S", spec] existing <- filterM doesFileExist sources unless (existing == sources) $ do- cmd_ "fedpkg" ["sources"]+ fedpkg_ "sources" [] unless force $ -- FIXME only if not all exist cmd_ "spectool" ["-g", "-S", spec]@@ -111,12 +111,14 @@ unlessM (doesFileExist patch) $ cmd_ "spectool" ["-g", "-P", spec] git_ "add" [patch]+ let (archives,textsources) = partition isArchiveFile existing when force $ do- let archives = filter isArchiveFile existing forM_ archives removeFile cmd_ "spectool" ["-g", "-S", spec] krbTicket- cmd_ "fedpkg" $ "new-sources" : filter isArchiveFile sources+ fedpkg_ "new-sources" archives+ unless (null textsources) $+ git_ "add" textsources whenJust moldnewver $ \(_old,newver) -> do versions <- changelogVersions spec let missing =
src/Cmd/WaitRepo.hs view
@@ -15,22 +15,36 @@ data WaitFetch = WaitNoFetch | WaitDirty | WaitFetch -- FIXME first check/wait for build to actually exist-waitrepoCmd :: Bool -> WaitFetch -> Maybe SideTagTarget+-- FIXME check on previous/origin commit/build+waitrepoCmd :: Bool -> Bool -> WaitFetch -> Maybe SideTagTarget -> (BranchesReq, [String]) -> IO ()-waitrepoCmd dryrun fetch msidetagTarget = do- withPackagesByBranches HeaderMay False- (case fetch of- WaitFetch -> cleanGitFetchActive- WaitNoFetch -> cleanGitActive- WaitDirty -> dirtyGitActive)- AnyNumber waitrepoBranch+waitrepoCmd dryrun noNvr fetch msidetagTarget (breq,pkgs) = do+ -- FIXME detect sidetag so not mistaken for pkg+ if noNvr+ then+ if null pkgs+ then withPackagesByBranches HeaderMay False Nothing AnyNumber waitrepoBranch (breq,["."])+ else error' "cannot specify pkgs with --no-nvr"+ else withPackagesByBranches HeaderMay False+ (case fetch of+ WaitFetch -> cleanGitFetchActive+ WaitNoFetch -> cleanGitActive+ WaitDirty -> dirtyGitActive)+ AnyNumber waitrepoBranchPkg (breq,pkgs) where- waitrepoBranch :: Package -> AnyBranch -> IO ()- waitrepoBranch _ (OtherBranch _) =- error' "waitrepo only defined for release branches"- waitrepoBranch pkg rbr@(RelBranch br) = do+ waitrepoBranchPkg :: Package -> AnyBranch -> IO ()+ waitrepoBranchPkg pkg rbr@(RelBranch br) = do gitSwitchBranch rbr let spec = packageSpec pkg nvr <- pkgNameVerRel' br spec target <- targetMaybeSidetag dryrun True False br msidetagTarget kojiWaitRepoNVR dryrun False target nvr+ waitrepoBranchPkg _ (OtherBranch _) =+ error' "waitrepo only defined for release branches"++ waitrepoBranch :: Package -> AnyBranch -> IO ()+ waitrepoBranch _ (RelBranch br) = do+ target <- targetMaybeSidetag dryrun True False br msidetagTarget+ kojiWaitRepo dryrun False target+ waitrepoBranch _ (OtherBranch _) =+ error' "waitrepo only defined for release branches"
src/Git.hs view
@@ -26,6 +26,7 @@ isPkgGitRepo, isPkgGitSshRepo, checkWorkingDirClean,+ gitUnstash, stashedWithFbrnch, isGitDirClean, checkIfRemoteBranchExists,@@ -58,9 +59,9 @@ -- 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 "") ++ showBranch br+gitMergeable :: Branch -> Branch -> IO (Maybe Bool,[Commit])+gitMergeable target br = do+ let ref = "origin/" ++ showBranch br mancestor <- do ancestor <- gitBool "merge-base" ["--is-ancestor", "HEAD", ref] if ancestor@@ -69,16 +70,9 @@ 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 && mancestor /= Just True) $+ when (br /= target && null commits && mancestor /= Just True) $ if mancestor == Just False then do diff <- git "diff" [ref]@@ -108,7 +102,7 @@ gitMergeOrigin :: Branch -> IO () gitMergeOrigin br = do- (mancestor,commits) <- gitMergeable True br+ (mancestor,commits) <- gitMergeable br br when (mancestor == Just True) $ unless (null commits) $ do pull <- git "pull" []@@ -116,16 +110,16 @@ putStrLn pull -- FIXME maybe require local branch already here+-- FIXME also expose local commits newerMergeable :: String -> Branch -> IO (Bool,[Commit],Maybe Branch) newerMergeable pkg br = if br == Rawhide then return (False,[],Nothing) else do mnewer <- getNewerBranch pkg br- locals <- localBranches True case mnewer of Just newer -> do- (mancestor,commits) <- gitMergeable (showBranch newer `notElem` locals) newer+ (mancestor,commits) <- gitMergeable br newer return (mancestor == Just True, commits, Just newer) Nothing -> return (False,[],Nothing) @@ -233,6 +227,14 @@ dir <- getCurrentDirectory error' $ "Working dir is not clean:" +-+ dir +-- FIXME add quiet option?+gitUnstash :: IO ()+gitUnstash = do+ mstash <- listToMaybe <$> gitLines "stash" ["list"]+ whenJust mstash $ \stash ->+ when (stashedWithFbrnch `isSuffixOf` stash) $+ git_ "stash" ["pop", "--quiet"]+ isGitDirClean :: IO Bool isGitDirClean = gitBool "diff" ["--quiet", "--exit-code", "HEAD"]@@ -339,7 +341,6 @@ data CommitOpt = CommitMsg String | CommitAmend -- FIXME select ref by number--- FIXME minimum length of hash refPrompt :: [Commit] -> String -> IO (Maybe String) refPrompt commits txt = do case map commitRef commits of@@ -347,15 +348,22 @@ (c:cs) -> do -- FIXME use promptMap ref <- prompt txt+ when (length txt < 78) putNewLn case lower ref of "" -> return $ Just c "y" -> return $ Just c "yes" -> return $ Just c "no" -> return Nothing "n" -> return Nothing+ "origin" -> return $ Just "origin" _ -> case find (ref `isPrefixOf`) cs of- Just cref -> return $ Just cref+ Just cref ->+ if length ref > 3+ then return $ Just cref+ else do+ putStrLn "ref should be over 3 characters"+ refPrompt commits txt Nothing -> refPrompt commits txt -- FIXME also include branch
src/Koji.hs view
@@ -3,12 +3,14 @@ kojiBuildStatus, kojiBuildTags, kojiGetBuildID,+ kojiGetBuildState, kojiGetBuildTaskID, kojiLatestNVR, kojiOpenTasks, kojiScratchBuild, kojiUserSideTags, buildIDInfo,+ BuildInfo(BuildInfoNVR), BuildState(..), kojiBuildBranch, kojiBuildBranchNoWait,@@ -17,6 +19,7 @@ kojiTagArchs, kojiWaitRepoNVR, kojiWaitRepoNVRs,+ kojiWaitRepo, kojiWatchTask, kojiWaitTask, putTaskinfoUrl,@@ -43,7 +46,7 @@ import Fedora.Krb (fasIdFromKrb, krbTicket) import Safe (headMay, tailSafe) import Say (sayString)-import SimplePrompt (promptEnter, yesNo)+import SimplePrompt (promptEnter, promptNonEmpty, yesNo) import System.Exit import System.Process.Typed import System.Timeout (timeout)@@ -234,6 +237,16 @@ kojiWaitRepoNVR dryrun quiet target nvr = kojiWaitRepoNVRs dryrun quiet target [nvr] +-- FIXME display more status/age info+kojiWaitRepo :: Bool -> Bool -> String -> IO ()+kojiWaitRepo dryrun quiet target = do+ (buildtag,_desttag) <- kojiBuildTarget' fedoraHub target+ tz <- getCurrentTimeZone+ unless quiet $+ logSay tz $ "Waiting for" +-+ buildtag+ unless dryrun $+ void $ timeIO $ cmd "koji" ["wait-repo", "--request", "--quiet", buildtag]+ kojiTagArchs :: String -> IO [String] kojiTagArchs tag = do st <- Koji.getTag fedoraHub (Koji.InfoString tag) Nothing@@ -285,7 +298,6 @@ return sidetag else error' "'fedpkg request-side-tag' failed" --- FIXME offer choice of existing sidetags targetMaybeSidetag :: Bool -> Bool -> Bool -> Branch -> Maybe SideTagTarget -> IO String targetMaybeSidetag dryrun strict create br msidetagTarget =@@ -304,7 +316,7 @@ unless ok $ error' "aborted" else whenM isPkgGitRepo $- warning ("Note:" +-+ msg)+ warning ("Warning:" +-+ msg) return t Just SideTag -> do tags <- kojiUserSideTags (Just br)@@ -312,11 +324,34 @@ [] -> if create then createKojiSidetag dryrun br- else error' "incorrect side-tag create request"+ else error' "no existing side-tag" [tag] -> return tag- sidetags -> error' $ show (length sidetags) +-+ "user side-tags found for" +-+ showBranch br ++ ":\n" +-+ unwords sidetags+ _ -> do+ putStrLn $ "User side-tags found for" +-+ showBranch br ++ ":" + let num = length tags+ nums = map show [1..num]+ numtags = zip nums $ sort tags+ mapM_ (putStrLn . \(n,s) -> n ++ ":" +-+ s) numtags+ tag <- promptTags numtags $ "Choose" +-+ (if num == 2 then "1 or 2" else "1-" ++ show num) +-+ "or enter sidetag; or 0 to abort"+ putStrLn $ "will use" +-+ tag+ putNewLn+ return tag+ logSay :: TimeZone -> String -> IO () logSay tz str = do now <- utcToLocalTime tz <$> getCurrentTime sayString $ formatTime defaultTimeLocale "%T" now +-+ str++promptTags :: [(String,String)] -> String -> IO String+promptTags numtags txt = do+ ans <- promptNonEmpty txt+ if ans `elem` map snd numtags+ then return ans+ else+ case lookup ans numtags of+ Just t -> return t+ Nothing ->+ if lower ans `elem` ["0", "q", "quit", "no"]+ then error' "aborting"+ else promptTags numtags txt
src/Main.hs view
@@ -8,7 +8,7 @@ #if !MIN_VERSION_simple_cmd_args(0,1,7) import Options.Applicative (maybeReader, ReadM) #endif-import SelectRPMs (existingStrategyOption, selectRpmsOptions)+import SelectRPMs (existingStrategyOption, selectRpmsOptions, Yes(..)) import SimpleCmdArgs -- commands@@ -71,11 +71,13 @@ subcommands [ Subcommand "clone" "Clone packages" $ cloneCmd- <$> optional (optionWith branchM 'b' "branch" "BRANCH" "branch")+ <$> dryrunOpt "Dry run"+ <*> optional (optionWith branchM 'b' "branch" "BRANCH" "branch") <*> cloneRequest , Subcommand "switch" "Switch branch" $ switchCmd <$> verboseOpt "verbose output"+ <*> switchLongWith "lenient" "keep going if package missing branch" <*> anyBranchArg <*> manyPackages , Subcommand "nvr" "Print name-version-release" $@@ -106,7 +108,7 @@ buildCmd <$> buildOpts <*> branchesPackages- , Subcommand "list" "List packages in pagure" $+ , Subcommand "list" "List packages in pagure distgit" $ listCmd <$> forceOpt "Do not prompt if large number of results" <*> switchWith 'c' "count" "Print number of packages"@@ -117,7 +119,8 @@ <$> maybeBranchPackages True , Subcommand "branches" "List package branches" $ branchesCmd- <$> switchWith 'd' "skip-dead" "Skip if dead.package exists"+ <$> optional (flagLongWith' SkipDead "skip-dead" "Skip if dead.package exists" <|>+ flagLongWith' OnlyDead "only-dead" "Skip if not dead.package") <*> switchWith 'a' "all" "List all branches" <*> switchWith 'm' "missing" "Show missing branches" <*> branchesModeOpt@@ -129,7 +132,7 @@ <*> optionalWith auto 'l' "skip-to-layer" "LAYERNO" "Skip the first N layers [default 0]" 0 <*> optional (sidetagTargetOpt $ Just "or creates one for you (with 'fedpkg request-side-tag --base-tag')") <*> switchLongWith "must-push" "Error if no unpushed commits"- <*> optionalWith auto 'd' "delay" "SECONDS" "Sleep delay between starting builds [default 4.0]" 4+ <*> optionalWith auto 'd' "delay" "SECONDS" "Sleep delay between starting builds [default 1s]" 1 <*> updateOpt <*> branchesPackagesDesc "BRANCH... PKG1... [:] PKG2..." , Subcommand "sidetags" "List user's side-tags" $@@ -149,6 +152,7 @@ , Subcommand "waitrepo" "Wait for build to appear in Koji buildroot" $ waitrepoCmd <$> dryrunOpt "Dry run: do not wait"+ <*> switchLongWith "no-nvr" "Generic wait-repo without a build NVR" <*> waitfetchOpt <*> optional (sidetagTargetOpt Nothing) <*> branchesPackages@@ -242,8 +246,10 @@ <$> dryrunOpt "Do not build (but creates srpm)" <*> optional nocleanOpt <*> switchWith 'N' "network" "Use network during build"+ <*> switchLongWith "reinstall" "Allow reinstallation with --install" <*> optional (flagLongWith' ShellOnly "shell-only" "Skip mock build" <|>- flagWith' BuildShell 's' "shell" "Enter chroot shell after building")+ flagWith' BuildShell 's' "shell" "Enter chroot shell after building" <|>+ flagLongWith' MockInstall "install" "Install the built rpms") <*> optional (optionWith branchM 'r' "root" "BRANCH" "Mock config to use") <*> optional archOpt <*> branchesPackages@@ -263,12 +269,17 @@ <*> switchWith 'r' "reinstall" "reinstall rpms" <*> switchLongWith "no-build" "do not (re-)build (install built rpms)" <*> switchLongWith "ignore-builddeps" "do not install builddeps"+ <*> flagWith No Yes 'y' "yes" "Assume yes to questions" <*> selectRpmsOptions <*> optional existingStrategyOption <*> maybeBranchPackages False , Subcommand "not-installed" "Packages not installed locally" $ notInstalledCmd <$> maybeBranchPackages False+ , Subcommand "uninstall" "Remove installed package(s)" $+ unInstallCmd+ <$> flagWith No Yes 'y' "yes" "Assume yes to questions"+ <*> maybeBranchPackages False , Subcommand "bugs" "List package bugs" $ bugsCmd <$> optional (strOptionWith 's' "summary" "KEY" "Search for bugs containing keyword")@@ -276,7 +287,7 @@ , Subcommand "bump" "Bump release for package" $ bumpCmd <$> dryrunOpt "Dry run: do not bump"- <*> switchWith 'l' "local" "Use local origin rather than checking latest koji"+ <*> switchLongWith "strict" "Check koji if NVR was built" <*> optional (strOptionWith 'm' "message" "COMMITMSG" "Specify commit message") <*> optional (strOptionWith 'c' "changelog" "CLOGENTRY"@@ -322,7 +333,7 @@ <*> optional (strArg "SPECFILE") , Subcommand "review-package" "Run fedora-review on a package Review Request bug" $ reviewPackage- <$> switchWith 'i' "interactive" "Download and check package review without fedora-review mock build"+ <$> switchWith 'f' "full" "Download and check package review with fedora-review mock build" <*> optional (pkgArg "PACKAGE/BZID") , Subcommand "reviews" "List package reviews" $ reviewsCmd@@ -344,7 +355,7 @@ <*> switchWith 'r' "resubmit" "Re-request repo" <*> branchesPackages , Subcommand "import" "Import new approved created packages from bugzilla review" $- importCmd False+ importCmd True False <$> switchLongWith "existing" "Use an existing repo" <*> mockOpt True <*> branchesPackages@@ -352,6 +363,7 @@ requestBranchesCmd <$> quietOpt "Quieter output" <*> switchWith 'r' "reviews" "Request branches for package reviews"+ <*> switchLongWith "skip-check" "Skip koji check for branch package" <*> optional (optionWith branchM 'R' "recurse-from" "BRANCH" "Add neighboring dependencies from branch") <*> mockOpt False <*> branchesPackages@@ -379,7 +391,7 @@ <*> pkgArg "PROJECT" <*> branchesPackages , Subcommand "rename-rawhide" "Rename local 'master' branch to 'rawhide'" $- renameMasterCmd+ renameRawhideCmd <$> manyPackages , Subcommand "count" "Count number of living packages" $ countCmd@@ -412,6 +424,12 @@ moveArtifactsCmd <$> switchWith 'd' "delete" "Remove duplicate artifacts" <*> manyPackages+ , Subcommand "tag-build-to-sidetag" "Tag NVR for current branch to sidetag" $+ tagBuildToSidetagCmd+ <$> dryrunOpt "Dry run"+ <*> switchWith 'k' "allow-dirty" "Allow unclean git repo"+ <*> optionWith branchM 't' "to" "BRANCH" "Target branch of sidetag"+ <*> maybeBranchPackages False ] where cloneRequest :: Parser CloneRequest
src/Package.hs view
@@ -9,7 +9,6 @@ getChangelog, cleanChangelog, changeLogPrompt,- releaseSystemBranch, getPackageName, getSummaryURL, findSpecfile,@@ -300,13 +299,14 @@ else Just <$> gitCurrentBranch else return Nothing let fetch = have gitOptFetch+ -- quiet to avoid output before header+ -- fetch first to include any new branches+ when fetch $ gitFetchSilent True brs <- listOfAnyBranches (haveGit && not (have gitOptHEAD)) (have gitOptActive) breq when ((header /= HeaderNone || fetch) && dir /= ".") $ case brs of [br] -> when (fetch || header == HeaderMust) $ putPkgAnyBrnchHdr pkg br _ -> when (fetch || header /= HeaderNone) $ putPkgHdr pkg- -- quiet to avoid output before header- when fetch $ gitFetchSilent True case limitBranches of ZeroOrOne | length brs > 1 -> -- FIXME: could be handled better (testcase: run long list of packages in wrong directory)@@ -326,8 +326,9 @@ when (header /= HeaderNone && length brs > 1) $ putPkgAnyBrnchHdr p b action p b mapM_ (action' pkg) brs- when (length brs /= 1) $+ when (length brs /= 1 || have gitOptStash) $ do whenJust mcurrentbranch gitSwitchBranch+ when (have gitOptStash) gitUnstash have :: (GitOpts -> Bool) -> Bool have opt = maybe False opt mgitopts@@ -358,8 +359,9 @@ data CloneUser = AnonClone | UserClone -clonePkg :: Bool -> CloneUser -> Maybe Branch -> String -> IO ()-clonePkg quiet cloneuser mbr pkg = do+-- FIXME use Verbosity+clonePkg :: Bool -> Bool -> CloneUser -> Maybe Branch -> String -> IO ()+clonePkg dryrun quiet cloneuser mbr pkg = do exists <- doesDirectoryExist pkg if exists then putStrLn $ pkg ++ "/ already exists"@@ -370,9 +372,13 @@ case cloneuser of AnonClone -> do msgout- git_ "clone" $ ["--quiet"] ++ mbranch ++ ["https://src.fedoraproject.org/rpms/" ++ pkg <.> "git"]- UserClone -> do- fedpkg_ "clone" $ mbranch ++ [pkg]+ if dryrun+ then putStrLn $ "would clone" +-+ pkg+ else git_ "clone" $ ["--quiet"] ++ mbranch ++ ["https://src.fedoraproject.org/rpms/" ++ pkg <.> "git"]+ UserClone ->+ if dryrun+ then putStrLn $ unwords $ "fedpkg" : "clone" : mbranch ++ [pkg]+ else fedpkg_ "clone" $ mbranch ++ [pkg] where msgout = putStrLn $ if quiet then "cloning..." else "Cloning:" +-+ pkg@@ -456,10 +462,6 @@ Nothing -> error' $ "rpmspec failed to parse" +-+ spec Just nvr -> return nvr -releaseSystemBranch :: AnyBranch -> IO Branch-releaseSystemBranch (RelBranch br) = return br-releaseSystemBranch (OtherBranch _) = systemBranch- -- FIXME should be more strict about dist tag (eg .fcNN only) equivNVR :: NVR -> Maybe NVR -> Bool equivNVR _ Nothing = False@@ -570,8 +572,10 @@ isArchiveFile f = any ($ f) [(".tar." `isInfixOf`), (".zip" `isSuffixOf`),+ (".crate" `isSuffixOf`), (".gpg" `isSuffixOf`), (".tgz" `isSuffixOf`)]+ && not (".sig" `isSuffixOf` f) sourceDirCwdOpt :: IO [String] sourceDirCwdOpt = do
src/Pagure.hs view
@@ -1,6 +1,7 @@ module Pagure ( srcfpo, pagureio,+ pagureGroupInfo, pagureGroupRepos, pagureListGitBranches, pagureListProjectIssueTitlesStatus,
src/Repoquery.hs view
@@ -29,4 +29,8 @@ EPELNext _ -> ["--disablerepo=*", "--enablerepo=epel-next"] ++ ["--enablerepo=epel-next-testing" | isJust mtesting] ++ ["--releasever=" ++ branchVersion br]+ -- FIXME: need minor mapping+ EPELMinor _ _ -> ["--disablerepo=*", "--enablerepo=epel"] +++ ["--enablerepo=epel-testing" | isJust mtesting] +++ ["--releasever=" ++ branchVersion br] cmd "dnf" (["repoquery", "--quiet"] ++ brOpts ++ args)
src/RpmBuild.hs view
@@ -15,6 +15,7 @@ isShortCircuit, checkSourcesMatch, notInstalled,+ nvraInstalled, rpmEval, distRpmOptions )@@ -50,7 +51,7 @@ distOptAny :: AnyBranch -> IO [String] distOptAny b =- releaseSystemBranch b >>= distOpt+ anyBranchToRelease b >>= distOpt -- FIXME hardcoding distRpmOptions :: Branch -> IO [String]@@ -66,6 +67,8 @@ return ["rhel" +-+ show n, "el" ++ show n +-+ "1"] EPELNext n -> return ["rhel" +-+ show n, "el" ++ show n +-+ "1"]+ EPELMinor n _ ->+ return ["rhel" +-+ show n, "el" ++ show n +-+ "1"] -- branchToRelease :: AnyBranch -> IO Release -- branchToRelease (RelBranch br) = branchRelease br@@ -112,7 +115,7 @@ (patches,srcs) <- partitionEithers . map sourcePatchFile <$> cmdLines "spectool" ["-a", spec] forM_ srcs $ \ src -> do- exists <- doesFileExist src &&^ checkCompression src+ exists <- checkCompression src inSrcdir <- doesSourceDirFileExist msrcdir src unless exists $ do if inSrcdir@@ -156,6 +159,7 @@ "source" -> Right "patch" -> Left _ -> error' $! "illegal field:" +-+ f)+ -- either url or local file (cannot really have subdir/file) $ takeFileName v checkCompression :: FilePath -> IO Bool@@ -175,8 +179,11 @@ when (isNothing have) $ do putStrLn $ "Running 'dnf install'" +-+ prog cmd_ "/usr/bin/sudo" $ "/usr/bin/dnf":"install": ["--assumeyes", prog]- cmdBool prog ["-t", file]- Nothing -> return True+ exists <- doesFileExist file+ if exists+ then cmdBool prog ["-t", file]+ else return False+ Nothing -> doesFileExist file maybeSourceDir :: (FilePath -> FilePath -> IO ()) -> Maybe FilePath -> FilePath -> IO ()@@ -204,7 +211,7 @@ case mbr of Nothing -> return [] Just br -> do- rbr <- releaseSystemBranch br+ rbr <- anyBranchToRelease br distOpt rbr msrcrpmdir <- rpmEval "%{_srcrpmdir}" autoreleaseOpt <- getAutoReleaseOptions spec@@ -221,6 +228,7 @@ then buildSrpm srpmfile opts else do srpmTime <- getModificationTime srpmfile+ -- FIXME: cp -p means modified patch may look older: maybe should cache/consider file hash fileTimes <- mapM getModificationTime (spec:srcs) if any (srpmTime <) fileTimes then buildSrpm srpmfile opts@@ -328,8 +336,8 @@ prevsize <- getFileSize backup currsize <- getFileSize buildlog when (prevsize > currsize) $- copyFile backup (backup <.> "prev")- copyFile buildlog (buildlog <.> "prev")+ cmd_ "cp" ["-p", backup, backup <.> "prev"]+ cmd_ "cp" ["-p", buildlog, buildlog <.> "prev"] -- FIXME also backup successful buildtree (if log ends in "+ exit 0") timeIO $ if not quiet || isShortCircuit mforceshort@@ -481,13 +489,13 @@ if exists then lines <$> readFile "sources" else return []- gitfiles <- gitLines "ls-files" []- let missing = filter (\src -> isNothing (find (src `isInfixOf`) sources) &&- src `notElem` gitfiles)+ gitfiles <- gitLines "ls-files" ["--no-cached"]+ -- FIXME warn about non-sha512 sources+ let missing = filter (\src -> isNothing (find (\s -> ('(' : src ++ ")") `isInfixOf` s || (' ' : src) `isSuffixOf` s) sources) && src `notElem` gitfiles) sourcefiles unless (null missing) $ do -- FIXME maybe change to yesNo- promptEnter $ color Red $ unwords missing +-+ "not in sources, press Enter to fix"+ promptEnter $ color Red $ unwords missing +-+ "not in" +-+ unPackage pkg +-+ "sources, press Enter to fix" -- FIXME check if already fixed before proceeding updateSourcesPkg False False True Nothing pkg br git_ "status" ["--short"]@@ -528,3 +536,7 @@ getDynSourcesMacros spec = whenM (grep_ "^%generate_buildrequires" spec) $ getSourcesMacros spec++nvraInstalled :: NVRA -> IO Bool+nvraInstalled rpm =+ cmdBool "rpm" ["--quiet", "-q", showNVRA rpm]