fbrnch 1.7.1 → 1.8
raw patch · 34 files changed
+1102/−372 lines, 34 filesdep ~http-directorydep ~rpmbuild-orderdep ~select-rpms
Dependency ranges changed: http-directory, rpmbuild-order, select-rpms, simple-cmd
Files
- CHANGELOG.md +46/−0
- README.md +10/−7
- fbrnch.cabal +14/−11
- src/Bodhi.hs +9/−7
- src/Branches.hs +42/−10
- src/Bugzilla.hs +3/−3
- src/Cmd/BranchLogs.hs +208/−0
- src/Cmd/Build.hs +32/−21
- src/Cmd/Commit.hs +22/−4
- src/Cmd/Compare.hs +0/−52
- src/Cmd/CompareBranches.hs +80/−0
- src/Cmd/CompareTarballs.hs +97/−0
- src/Cmd/Copr.hs +129/−23
- src/Cmd/FTBFS.hs +1/−1
- src/Cmd/Install.hs +26/−25
- src/Cmd/ListBranches.hs +13/−9
- src/Cmd/Merge.hs +35/−36
- src/Cmd/Parallel.hs +19/−17
- src/Cmd/Prep.hs +8/−7
- src/Cmd/Repoquery.hs +14/−0
- src/Cmd/RequestBranch.hs +1/−1
- src/Cmd/RequestRepo.hs +2/−3
- src/Cmd/ReviewPackage.hs +33/−11
- src/Cmd/Scratch.hs +7/−3
- src/Cmd/Status.hs +3/−2
- src/Cmd/Switch.hs +12/−6
- src/Cmd/Update.hs +44/−33
- src/Git.hs +30/−13
- src/Koji.hs +72/−26
- src/ListReviews.hs +1/−1
- src/Main.hs +37/−10
- src/Package.hs +15/−7
- src/RpmBuild.hs +32/−22
- src/Types.hs +5/−1
CHANGELOG.md view
@@ -1,5 +1,51 @@ # Changelog +## 1.8 (2026-01-02)+- 'branch-log': new command to check local and remote branches+- 'branch-log': --latest finds connected branches+- 'branch-log': logic to warn about older branch being ahead+- 'build --sidetag': fix "release not found for branch f43" rawhide regression+- 'build': use --ref to build from a commit+- 'build','parallel': can now merge --from a particular branch+- 'commit': error if changelog is unstaged+- 'commit': require -b option to confirm non-rawhide commit+- 'compare-branches': renamed from 'compare'+- 'compare-branches': list changes for both local & remote branches+- 'compare-tarballs': new command to diff source tarballs+- 'compare-tarballs': add --max-line-length option (default 200)+- 'copr --failures': fetches tails of failed build logs+- 'copr --monitor': add --filter to only list results matching needle+- 'copr --monitor': add --name-only to only print package name with filter+- 'copr': handle user/project (for queries, etc)+- 'install': select-rpms-0.3.1 allows selecting debuginfo subpkgs+- 'install': select-rpms-0.3.1 adds --allow-erasing+- 'install': options to select package manager to use (eg --rpm)+- 'install': use needToBuildRPMS with prompt, factored out of buildRPMs+- 'repoquery': use fedora-repoquery+- 'review-package': for licensecheck find build source dir & use SPDX shortnames+- 'review-package': ignore error for non-zero diff+- 'review-package': download upstream with spectool and prep if not building+- 'review-package': prompt if bugid review not in NEW/ASSIGNED state+- 'scratch': exclude i386 as i686+- 'switch': add --stash+- 'update-sources': do sanity prep in a tmpdir to avoid any ongoing build+- 'update-sources': offer to compare tarballs+- 'update-sources --force': need to partition all sources not previously existing+- 'update-sources': detect version change by diff better again+- 'update-sources': if Release was already bumped then use it+- `FBRNCH_KOJI_PROFILE` provides experimental Koji profile support (eg riscv)+- bodhiUpdate: switch back to branch if necessary+- mergeBranch: colorize the unmergeable warning+- mergeBranch: relax the unmergeable prompt condition for no unpushed commits+- mergeBranch: warn about unpushed commits in newer branch+- mergeBranch: setup local branch with tracking if missing+- use rpmbuild-order-0.4.13: handle cmake dirs and python3dist dyn provides+- use simple-cmd-0.2.7 for cmdLog_ forward compatibility+- Branches getRequestedBranches: error if no active branches requested+- Branches: new listBranches/listAllBranches & listRemoteBranches/listRemoteAllBranches+- Git gitOneLineLog: add '--' after range to avoid path confusion+- Git gitPush: make sure upstream branch is setup+ ## 1.7.1 (2025-06-07) - Merge: prompt even with --merge (--no-prompt) when branch unmergeable - parallel: restore package heading for merge
README.md view
@@ -39,7 +39,7 @@ One can change the branch of one or more packages: ```-$ fbrnch switch f42 [package] ...+$ fbrnch switch f43 [package] ... ``` You can also git pull over packages:@@ -97,13 +97,13 @@ You can merge branches with: ```-$ fbrnch merge f41 [package]+$ fbrnch merge f42 [package] ```-which will offer to merge f42 (or up to a git hash you choose) into f41.+which will offer to merge f43 (or up to a git hash you choose) into f42. Merging can also be done together with building: ```-$ fbrnch build f42 [package]+$ fbrnch build f43 [package] ``` will ask if you want to merge newer commits from a newer branch, then push and build it.@@ -270,7 +270,7 @@ `$ fbrnch --version` ```-1.7+1.8 ``` `$ fbrnch --help`@@ -292,6 +292,7 @@ switch Switch branch nvr Print name-version-release status Status package/branch status+ branch-log Show log with branches decor merge Merge from newer branch unpushed Show unpushed commits build Build package(s) in Koji@@ -313,7 +314,8 @@ srpm Build srpm srpm-spec Show the spec file in an srpm diff Diff local changes- compare Show commits between branches+ compare-branches Show commits between branches+ compare-tarballs Diff source tarballs src-deps List source package dependencies mock Local mock build builddeps Install package build dependencies@@ -342,7 +344,8 @@ rename-rawhide Rename local 'master' branch to 'rawhide' count Count number of living packages graph Output dependency graph- ftbfs Check FTBFS status+ repoquery Repoquery branches (put repoquery options after '--')+ ftbfs Check FTBFS bug status autospec Convert package to use rpmautospec unautospec Unconvert rpmautospec package move-artifacts Move old rpm artifacts into rpmbuild dirs
fbrnch.cabal view
@@ -1,6 +1,6 @@-cabal-version: 2.0+cabal-version: 2.2 name: fbrnch-version: 1.7.1+version: 1.8 synopsis: Fedora packager tool to build package branches description: fbrnch (fedora branch or "f-branch" for short) is@@ -24,18 +24,19 @@ and many more commands. homepage: https://github.com/juhp/fbrnch bug-reports: https://github.com/juhp/fbrnch/issues-license: GPL-2+license: GPL-2.0-or-later license-file: LICENSE author: Jens Petersen <petersen@redhat.com> maintainer: Jens Petersen <petersen@fedoraproject.org>-copyright: 2019-2025 Jens Petersen+copyright: 2019-2026 Jens Petersen category: Distribution build-type: Simple extra-doc-files: CHANGELOG.md README.md tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.8,- GHC == 9.4.8, GHC == 9.6.7, GHC == 9.8.4, GHC == 9.10.2+ GHC == 9.4.8, GHC == 9.6.7, GHC == 9.8.4, GHC == 9.10.3,+ GHC == 9.12.3 source-repository head type: git@@ -48,12 +49,14 @@ Branches Bugzilla Cmd.Autospec+ Cmd.BranchLogs Cmd.Bugs Cmd.Build Cmd.Bump Cmd.Clone Cmd.Commit- Cmd.Compare+ Cmd.CompareBranches+ Cmd.CompareTarballs Cmd.Copr Cmd.CreateReview Cmd.Diff@@ -72,7 +75,7 @@ Cmd.Prep Cmd.Pull Cmd.Push- --Cmd.Repoquery+ Cmd.Repoquery Cmd.RequestBranch Cmd.RequestRepo Cmd.ReviewPackage@@ -123,7 +126,7 @@ fedora-releases >= 0.3, filepath, http-conduit,- http-directory >= 0.1.5,+ http-directory >= 0.1.9, http-query, koji, network-uri,@@ -131,12 +134,12 @@ pretty-terminal, process, -- regex-tdfa,- rpmbuild-order >= 0.4.12,+ rpmbuild-order >= 0.4.13, rpm-nvr >= 0.1.2, safe, say,- select-rpms >= 0.3,- simple-cmd >= 0.2.3,+ select-rpms >= 0.3.1,+ simple-cmd >= 0.2.7, simple-cmd-args >= 0.1.8, simple-prompt >= 0.2.3, text,
src/Bodhi.hs view
@@ -27,6 +27,7 @@ import Bugzilla (BugId) import Common import Common.System+import Git (gitSwitchBranch) import Package import Types (ChangeType(ChangeBodhi)) @@ -112,21 +113,22 @@ -- FIXME support --no-close-bugs -- push comma separated list of builds for a package to bodhi bodhiUpdate :: Bool -> (Maybe UpdateType, UpdateSeverity) -> Maybe BugId- -> Maybe UpdateNotes -> FilePath -> String -> IO ()-bodhiUpdate _ _ _ _ _ [] = putStrLn "no package to push"-bodhiUpdate dryrun (mupdate,severity) mreview mnotes spec nvrs = do+ -> Maybe UpdateNotes -> Maybe Branch -> FilePath -> String -> IO ()+bodhiUpdate _ _ _ _ _ _ [] = putStrLn "no package to push"+bodhiUpdate dryrun (mupdate,severity) mreview mnotes mrbr spec nvrs = do case mupdate of Nothing -> return () Just updateType -> unless dryrun $ do- -- use cmdLog to debug, but notes are not quoted- updatedone <- do+ updateDone <- do mtemplate <- maybeTemplate updateType case mtemplate of Just file -> do+ -- FIXME use cmdLog_ to debug, but notes are not quoted cmd_ "bodhi" ["updates", "new", "--file", file, nvrs] return True Nothing -> do+ whenJust mrbr $ gitSwitchBranch . RelBranch -- FIXME also query for open existing bugs changelog <- if isJust mreview then getSummaryURL spec@@ -159,7 +161,7 @@ -- {"status": "error", "errors": [{"location": "body", "name": "builds", "description": "Update for ghc9.2-9.2.5-14.fc36 already exists"}]} cmd_ "bodhi" $ ["updates", "new", "--type", if isJust mreview then "newpackage" else show updateType, "--severity", show severity, "--request", "testing", "--notes", take 10000 changelog, "--autokarma", "--autotime", "--close-bugs"] ++ bugs ++ [nvrs] return True- when updatedone $ do+ when updateDone $ do -- FIXME avoid this if we know the update URLs (split update does not seem to return URLs) eupdates <- bodhiUpdatesEither [makeItem "display_user" "0", makeItem "builds" nvrs] case eupdates of@@ -169,7 +171,7 @@ then do putStrLn $ "bodhi submission failed for" +-+ nvrs promptEnter "Press Enter to resubmit to Bodhi"- bodhiUpdate dryrun (mupdate,severity) mreview mnotes spec nvrs+ bodhiUpdate dryrun (mupdate,severity) mreview mnotes mrbr spec nvrs else forM_ updates $ \update -> case lookupKey "url" update of
src/Branches.hs view
@@ -1,13 +1,15 @@ {-# LANGUAGE CPP #-} module Branches (- activeBranches, fedoraBranches, fedoraBranchesNoRawhide, isFedoraBranch, isEPELBranch, localBranches,- pagurePkgBranches,+ listBranches,+ listAllBranches,+ listRemoteBranches,+ listRemoteAllBranches, mockRoot, Branch(..), showBranch,@@ -66,21 +68,34 @@ show (RelBranch br) = showBranch br show (OtherBranch obr) = obr -activeBranches :: [Branch] -> [String] -> [Branch]-activeBranches active =+-- FIXME replace with next fedora-releases+readActiveBranches :: [Branch] -> [String] -> [Branch]+readActiveBranches active = -- newest branch first reverseSort . mapMaybe (readActiveBranch active) +readAllBranches :: [String] -> [Branch]+readAllBranches = reverseSort . mapMaybe readBranch+ fedoraBranches :: IO [String] -> IO [Branch] fedoraBranches mthd = do active <- getActiveBranches- activeBranches active <$> mthd+ readActiveBranches active <$> mthd fedoraBranchesNoRawhide :: IO [String] -> IO [Branch] fedoraBranchesNoRawhide mthd = do active <- getActiveBranched- activeBranches active <$> mthd+ readActiveBranches active <$> mthd +listBranches :: Bool -- ^ local+ -> IO [Branch]+listBranches = fedoraBranches . localBranches++listAllBranches :: Bool -- ^ local+ -> IO [Branch]+listAllBranches local =+ readAllBranches <$> localBranches local+ isFedoraBranch :: Branch -> Bool isFedoraBranch (Fedora _) = True isFedoraBranch Rawhide = True@@ -113,9 +128,17 @@ where include p e = e ++ ":" +-+ p +listRemoteBranches :: String -> IO [Branch]+listRemoteBranches pkg =+ fedoraBranches (pagurePkgBranches pkg)++listRemoteAllBranches :: String -> IO [Branch]+listRemoteAllBranches pkg = do+ readAllBranches <$> pagurePkgBranches pkg+ mockRoot :: Branch -> Maybe String -> String mockRoot br march =- let arch = fromMaybe System.Info.arch march+ let arch = maybe System.Info.arch mapArch march in case br of Rawhide -> "fedora-rawhide-" ++ arch@@ -123,6 +146,10 @@ EPEL n -> "centos-stream+epel-" ++ show n ++ "-" ++ arch EPELNext n -> "centos-stream+epel-next-" ++ show n ++ "-" ++ arch EPELMinor n _ -> "rhel+epel-" ++ show n ++ "-" ++ arch+ where+ mapArch :: String -> String+ mapArch "i686" = "i386"+ mapArch a = a ------ @@ -179,6 +206,7 @@ osPrefix "enterprise_linux" = "epel" osPrefix s = s +-- FIXME should be NonEmpty Branch listOfBranches :: Bool -> Bool -> BranchesReq -> IO [Branch] listOfBranches distgit _active (BranchOpt AllBranches) = if distgit@@ -288,9 +316,13 @@ getRequestedBranches existing breq = do activenew <- filter (\b -> showBranch b `notElem` existing) <$> getActiveBranched case breq of- Branches brs -> if null brs- then branchingPrompt activenew- else return $ [b | b <- brs, b `elem` activenew]+ Branches brs ->+ if null brs+ then branchingPrompt activenew+ else+ case [b | b <- brs, b `elem` activenew] of+ [] -> error' "no active branch requested"+ bs -> return bs BranchOpt request -> do let requested = case request of AllBranches -> activenew
src/Bugzilla.hs view
@@ -333,7 +333,7 @@ reviewBugIdSession pkg = do bugs <- bugIdsAnon $ pkgReviews pkg .&&. statusOpen case bugs of- [] -> error $ "No review bug found for" +-+ pkg+ [] -> error' $ "No review bug found for" +-+ pkg [bug] -> do session <- bzApiKeySession return (bug, session)@@ -344,7 +344,7 @@ bugs <- bugIdsAnon $ pkgReviews pkg .&&. statusOpen .&&. reviewApproved case bugs of- [] -> error $ "No review bug found for" +-+ pkg+ [] -> error' $ "No review bug found for" +-+ pkg [bug] -> do session <- bzApiKeySession return (bug, session)@@ -355,7 +355,7 @@ bugs <- bugsAnon $ pkgReviews pkg .&&. statusOpen .&&. reviewApproved case bugs of- [] -> error $ "No review bug found for" +-+ pkg+ [] -> error' $ "No review bug found for" +-+ pkg [bug] -> do session <- bzApiKeySession return (bug, session)
+ src/Cmd/BranchLogs.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE CPP #-}++-- FIXME rename to BranchLog?+module Cmd.BranchLogs (+ branchLogCmd+ )+where++import Control.Monad (forM_, unless, when)+import Data.Function (on)+#if !MIN_VERSION_base(4,18,0)+import qualified Data.List as List+import qualified Data.Foldable as Foldable+#endif+import Data.List.Extra (dropPrefix, find, splitOn, stripInfix, uncons)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe (mapMaybe)+import Distribution.Fedora.Branch (readBranch)+import System.Console.Pretty (color, Color(..), supportsPretty)++import Branches+import Common.System+import Git (gitSwitchBranch)+import Package++-- FIXME --all-commits+-- FIXME select latest branches (local and remote)+-- FIXME how to handle dirty+-- FIXME handle detached head+branchLogCmd :: Bool -> Bool -> Bool -> (BranchesReq,[String]) -> IO ()+branchLogCmd latest allbrs nosimplydecor (breq, pkgs) = do+ colored <- supportsPretty+ if null pkgs+ then logPkg colored "."+ else mapM_ (logPkg colored) pkgs+-- withPackagesMaybeBranch (if length pkgs > 1 then HeaderMust else HeaderNone) False Nothing (logPkg colored active) (breq, packages)+ where+ logPkg :: Bool -> FilePath -> IO ()+ logPkg colored path =+ withExistingDirectory path $ do+ -- FIXME handle inactive branch automatically (without --inactive or error)+ branches <- listOfBranches True (not allbrs) breq+ let listBranches' =+ if allbrs then listAllBranches else listBranches+ locals <- listBranches' True+ remotes <- listBranches' False+ current <- gitCurrentBranch+ forM_ branches $ \br ->+ unless (br `elem` locals) $+ if br `elem` remotes+ then+ gitSwitchBranch (RelBranch br)+ else error' $ "branch does not exist:" +-+ showBranch br+ gitSwitchBranch current+ if latest+ then latestBranches branches+ else do+ forM_ branches $ \br -> do+ when (length pkgs > 1 || length branches > 1) $ do+ pkg <- getPackageName "."+ if length branches > 1+ then putPkgBrnchHdr pkg br+ else putPkgHdr pkg+ commits <- getLogCommits allbrs simplydecor br+ checkBranchOrder br $ NE.tail commits+ mapM_ (putLogCommit colored) commits+ where+ simplydecor = not nosimplydecor++ checkBranchOrder br oldcommits = do+ let brs = map logBranches oldcommits+ newer = mapMaybe (find ((br<) . toBranch)) brs+ unless (null newer) $+ putStrLn $ showBranch br +-+ "is ahead of:" +-+ unwords (map showBR newer)++ latestBranches :: [Branch] -> IO ()+ latestBranches branches = do+ logbrs <- fmap (NE.toList . NE.nubBy ((==) `on` NE.head)) <$> mapM (getLogCommits allbrs True) $ NE.fromList branches+ let containedIn l = any ((NE.head l `elem`) . NE.tail)+ reduced = [ l | l <- logbrs, not (l `containedIn` logbrs)]+ forM_ reduced $ \r -> do+ checkBranchOrders r+ mapM_ (putLogCommit colored) r+ putChar '\n'++ checkBranchOrders commits = do+ let brs = NE.map logBranches commits+ forM_ (tails1 brs) $ \(b:|bs) ->+ forM_ b $ \b' -> do+ let newer = mapMaybe (find (b'<)) bs+ unless (null newer || allbrs) $+ putStrLn $ showBR b' +-+ "is ahead of:" +-+ unwords (map showBR newer)++data BranchRemote = BR (Maybe String) Branch+ deriving Eq++toBranch :: BranchRemote -> Branch+toBranch (BR _ b) = b++instance Ord BranchRemote where+ compare (BR mr1 b1) (BR mr2 b2) =+ compare (b1,mr1) (b2,mr2)++type BranchList = NonEmpty BranchRemote++data LogCommit = LogCommit+ { logRef :: String,+ logBranches :: BranchList,+ _logText :: String,+ _logDate :: String }++instance Eq LogCommit where+ lc1 == lc2 = logRef lc1 == logRef lc2++instance Ord LogCommit where+ lc1 <= lc2 = NE.head (logBranches lc1) <= NE.head (logBranches lc2)++logCommitFormat :: String+logCommitFormat = "--pretty=format:%h\US%D\US%s\US%ch"++getLogCommits :: Bool -> Bool -> Branch -> IO (NonEmpty LogCommit)+getLogCommits allbrs simplydecor br = do+ existing <- (if allbrs then listAllBranches else listBranches) True+ unless (br `elem` existing) $+ error' $ "no local branch:" +-+ showBranch br+ ls <- mapMaybe (readLogCommit existing) <$> gitLines "log" (["--simplify-by-decoration" | simplydecor] ++ [logCommitFormat, showBranch br])+ case NE.nonEmpty ls of+ Nothing -> error' $ "empty branch:" +-+ showBranch br+ Just ne -> return ne+ where+ readLogCommit :: [Branch] -> String -> Maybe LogCommit+ readLogCommit existing cs =+ case splitOn "\US" cs of+ [h,ds,s,t] ->+ let mbrs =+ NE.nonEmpty $+ filter (\b' -> any (hasBranch b') existing) $+ mapMaybe (readBranchRemote . dropPrefix "HEAD -> ") $+ splitOn ", " ds+ in+ case mbrs of+ Nothing -> Nothing+ Just brs -> Just $ LogCommit h (NE.sort brs) s t+ _ -> error' $ "malformed log line:" +-+ cs++hasBranch :: BranchRemote -> Branch -> Bool+hasBranch (BR _ b1) b2 = b1 == b2++readBranchRemote :: String -> Maybe BranchRemote+readBranchRemote s =+ case stripInfix "/" s of+ Nothing ->+ case readBranch s of+ Nothing -> Nothing+ Just br -> Just $ BR Nothing br+ Just (r,b) ->+ case readBranch b of+ Nothing -> Nothing+ Just br -> Just $ BR (Just r) br++showBR :: BranchRemote -> String+showBR (BR mr b) =+ case mr of+ Nothing -> showBranch b+ Just r -> r ++ '/' : showBranch b++showLogCommit :: Bool -> LogCommit -> String+showLogCommit colored (LogCommit h brs s time) =+ h +-+ showBranches colored brs +-+ s +-+ '(' : time ++ ")"++putLogCommit :: Bool -> LogCommit -> IO ()+putLogCommit colored = putStrLn . showLogCommit colored++showBranches :: Bool -> BranchList -> String+showBranches colored =+ unwords . reverse . NE.toList . NE.map renderBranches . NE.groupWith1 toBranch+ where+ -- groupSortWith1 :: Ord b => (a -> b) -> NonEmpty a -> NonEmpty (NonEmpty a)+ -- groupSortWith1 f = map (map snd) . NE.groupAllWith1 fst . NE.sortWith fst . map (f &&& id)++ remote (BR mr _) = mr++ renderBranches bs@(b :| t) =+ case uncons t of+ Nothing -> docolor Red $ showBR b+ Just (b',t') ->+ if null t'+ then+ case (remote b, remote b') of+ (Nothing, Just "origin") ->+ origin ++ docolor Green (showBranch $ toBranch b)+ _ -> unwords $ map (docolor Red . showBR) $ NE.toList bs+ else unwords $ map (docolor Magenta . showBR) $ NE.toList bs+ where+ origin = if colored then "origin/" else "{origin/}"++ docolor c = if colored then color c else id+++tails1 :: NonEmpty a -> NonEmpty (NonEmpty a)+tails1 =+#if MIN_VERSION_base(4,18,0)+ NE.tails1+#else+ -- from base-4.20+ NE.fromList . Prelude.map NE.fromList . List.init . List.tails . Foldable.toList+#endif
src/Cmd/Build.hs view
@@ -6,6 +6,7 @@ ) where import Distribution.Fedora.Branch (branchDestTag, readBranch)+import Distribution.Fedora.Release (getRawhideVersion) import Fedora.Krb (krbTicket) import SimplePrompt (promptEnter, yesNo) @@ -23,12 +24,14 @@ data BuildOpts = BuildOpts { buildoptMerge :: Maybe Bool+ , buildoptMergeFrom :: Maybe Branch , buildoptNoFailFast :: Bool , buildoptSidetagTarget :: Maybe SideTagTarget , buildoptOverride :: Maybe Int , buildoptWaitrepo :: Maybe Bool , buildoptDryrun :: Bool , buildoptSkipFetch :: Bool+ , buildoptGitRef :: Maybe String , buildoptUpdate :: (Maybe UpdateType, UpdateSeverity) , buildoptNotes :: Maybe UpdateNotes , buildoptByPackage :: Bool@@ -43,7 +46,6 @@ -- FIXME --add-to-update nvr -- FIXME --rpmlint (default for rawhide?) -- FIXME support --wait-build=NVR--- FIXME build from ref -- FIXME tail of failed build.log -- FIXME --auto-override for deps in testing -- FIXME -B fails to find new branches (fixed?)@@ -84,25 +86,22 @@ gitMergeOrigin br newrepo <- initialPkgRepo tty <- isTty- (ancestor,unmerged,mnewer) <- newerMergeable (unPackage pkg) br+ (mancestor,unmerged,from) <- mergeable pkg br $ buildoptMergeFrom opts -- FIXME if already built or failed, also offer merge merged <- case buildoptMerge opts of Just False -> return False Just True -> do- whenJust mnewer $ \newer ->- mergeBranch (buildoptDryrun opts) False True True False pkg (ancestor,unmerged) newer br+ mergeBranch (buildoptDryrun opts) False True True False pkg (mancestor,unmerged) from br return True Nothing ->- if ancestor && (newrepo || tty)+ if mancestor == Just True && (newrepo || tty) then do- whenJust mnewer $ \newer ->- mergeBranch (buildoptDryrun opts) False True False True pkg (ancestor,unmerged) newer br- return $ isJust mnewer+ mergeBranch (buildoptDryrun opts) False True False True pkg (mancestor,unmerged) from br+ return True else do unless (br == Rawhide) $- whenJust mnewer $ \newer ->- putStrLn $ showBranch newer +-+ "branch not mergeable"+ putStrLn $ showBranch from +-+ "branch not mergeable" return False let spec = packageSpec pkg checkForSpecFile spec@@ -112,7 +111,8 @@ putNewLn let msidetagTarget = buildoptSidetagTarget opts target <- targetMaybeSidetag dryrun True True br msidetagTarget- nvr <- pkgNameVerRel' (maybeTargetBranch target) spec+ rawhide <- getRawhideVersion+ nvr <- pkgNameVerRel' (maybeTargetBranch rawhide target) spec mpush <- case unpushed of [] -> return Nothing@@ -124,19 +124,23 @@ displayCommits True unpushed putNewLn -- see mergeBranch for: unmerged == 1 (774b5890)- if tty && (not merged || (newrepo && ancestor && length unmerged == 1))+ if tty && (not merged || (newrepo && mancestor == Just True && 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 buildRun spec nvr merged mpush unpushed target msidetagTarget moverride where dryrun = buildoptDryrun opts - maybeTargetBranch target =+ maybeTargetBranch :: Natural -> String -> Branch+ maybeTargetBranch rawhide target = if showBranch br `isPrefixOf` target then br else case readBranch $ takeWhile (/= '-') target of- Just b -> b+ Just b ->+ if b == Fedora rawhide+ then Rawhide+ else b Nothing -> error' $ "unknown branch for target" +-+ target buildRun spec nvr merged mpush unpushed target msidetagTarget moverride = do@@ -157,7 +161,7 @@ then putStrLn "update exists" else do mbug <- bzReviewAnon- bodhiUpdate dryrun (buildoptUpdate opts) mbug (buildoptNotes opts) spec $ showNVR nvr+ bodhiUpdate dryrun (buildoptUpdate opts) mbug (buildoptNotes opts) (Just br) spec $ showNVR nvr whenJust moverride $ \days -> do tags <- maybeTimeout 30 $ kojiNVRTags nvr unless (any (`elem` tags) [showBranch br, showBranch br ++ "-updates", showBranch br ++ "-override"]) $@@ -173,13 +177,19 @@ putStrLn $ showNVR nvr +-+ "is already building" when (isJust mpush) $ error' "Please bump the spec file"- whenJustM (kojiGetBuildTaskID fedoraHub (showNVR nvr)) kojiWatchTask+ hub <- getKojiProfileHub+ whenJustM (kojiGetBuildTaskID hub (showNVR nvr)) kojiWatchTask buildRun spec nvr merged mpush unpushed target msidetagTarget moverride _ -> do mbuildref <-- case mpush of- Nothing -> Just <$> git "show-ref" ["--hash", "origin/" ++ showBranch br]- _ -> return mpush+ case buildoptGitRef opts of+ Just ref ->+ -- FIXME check ref exists+ return $ Just ref+ Nothing ->+ case mpush of+ Nothing -> Just <$> git "show-ref" ["--hash", "origin/" ++ showBranch br]+ _ -> return mpush opentasks <- kojiOpenTasks pkg mbuildref target case opentasks of [task] -> do@@ -242,11 +252,12 @@ then whenJust mBugSess $ \ (bid,session) -> putBugBuild dryrun session bid nvr else do- when (isNothing msidetagTarget) $ do+ when (isNothing msidetagTarget &&+ isNothing (buildoptGitRef opts)) $ do whenJust (fmap fst mBugSess) $ \bid -> putStr "review bug: " >> putBugId bid -- FIXME diff previous changelog?- bodhiUpdate dryrun (buildoptUpdate opts) (fmap fst mBugSess) (buildoptNotes opts) spec $ showNVR nvr+ bodhiUpdate dryrun (buildoptUpdate opts) (fmap fst mBugSess) (buildoptNotes opts) (Just br) spec $ showNVR nvr -- FIXME prompt for override note whenJust moverride $ \days -> bodhiCreateOverride dryrun (Just days) nvr
src/Cmd/Commit.hs view
@@ -3,8 +3,9 @@ ) where -import SimplePrompt (promptNonEmpty)+import SimplePrompt (promptEnter, promptNonEmpty) +import Branches (getReleaseBranch, showBranch, Branch(Rawhide)) import Common import Common.System import Git@@ -16,8 +17,20 @@ -- FIXME --undo last change: eg undo accidential --amend -- FIXME --empty -- FIXME include only (used) changelog if not staged-commitCmd :: Bool -> Maybe CommitOpt -> Bool -> Bool -> [String] -> IO ()-commitCmd dryrun mopt firstLine unstaged paths = do+commitCmd :: Bool -> Bool -> Maybe CommitOpt -> Bool -> Bool -> [String]+ -> IO ()+commitCmd dryrun branched mopt firstLine unstaged paths = do+ distgit <- isPkgGitSshRepo+ if distgit+ then do+ br <- getReleaseBranch+ if br == Rawhide+ then when branched $+ error' "cannot use --branched for rawhide"+ else unless branched $+ promptEnter $ "Are you sure you want to update" +-+ showBranch br +-+ "branch?! Press Enter to continue"+ else when branched $+ error' "cannot use --branched with dist-git" when (isJust mopt && firstLine) $ error' "--first-line cannot be used with other commit msg options" if null paths@@ -50,7 +63,12 @@ clog <- lines <$> cleanChangelog True spec case clog of [] -> readCommitMsg- [msg] -> return msg+ [msg] -> do+ unless addall $ do+ remaining <- git "diff" ["-U0"]+ when (msg `isInfixOf` remaining) $+ error' "changelog is unstaged!"+ return msg (msg:_) -> if firstLine then return $ removePrefix "- " msg
− src/Cmd/Compare.hs
@@ -1,52 +0,0 @@-module Cmd.Compare (- compareCmd)-where--import Branches-import Common-import Common.System-import Git-import Package---- FIXME warn if older branch ahead-compareCmd :: Bool -> Maybe String -> AnyBranch -> AnyBranch -> [String] -> IO ()-compareCmd long mignore br1 br2 pkgs = do- if null pkgs- then do- unlessM isPkgGitRepo $- error' "Please specify at least one package"- else do- whenM isPkgGitRepo $- error' "Cannot specify multiple packages inside a package dir"- let packages = if null pkgs then ["."] else pkgs- mapM_ comparePkg packages- where- comparePkg :: String -> IO ()- comparePkg pkgdir =- withExistingDirectory pkgdir $- unlessM (doesFileExist "dead.package") $ do- localbranches <- localBranches True- oldcurrent <- gitCurrentBranch- have1 <- haveBranch localbranches br1- have2 <- haveBranch localbranches br2- newcurrent <- gitCurrentBranch- when (newcurrent /= oldcurrent) $- gitSwitchBranch oldcurrent- when (have1 && have2) $ do- output <- ignoredLines <$> gitLines "log" (["--format=reference" | not long] ++ [show br1 ++ ".." ++ show br2])- unless (null output) $ do- unless (null pkgs) $- getPackageName pkgdir >>= putPkgHdr- mapM_ putStrLn output-- ignoredLines :: [String] -> [String]- ignoredLines =- case mignore of- Nothing -> id- Just ignore -> filter (not . (ignore `isInfixOf`))-- haveBranch :: [String] -> AnyBranch -> IO Bool- haveBranch locals br =- if show br `elem` locals- then return True- else gitSwitchBranch' True $ onlyRelBranch br
+ src/Cmd/CompareBranches.hs view
@@ -0,0 +1,80 @@+module Cmd.CompareBranches (+ compareBranchesCmd)+where++import Branches+import Common+import Common.System+import Git+import Package++-- FIXME warn if older branch ahead+compareBranchesCmd :: Bool -> Maybe String -> AnyBranch -> AnyBranch -> [String] -> IO ()+compareBranchesCmd long mignore br1 br2 pkgs = do+ if null pkgs+ then do+ unlessM isPkgGitRepo $+ error' "Please specify at least one package"+ else do+ whenM isPkgGitRepo $+ error' "Cannot specify multiple packages inside a package dir"+ let packages = if null pkgs then ["."] else pkgs+ mapM_ comparePkg packages+ where+ comparePkg :: String -> IO ()+ comparePkg pkgdir =+ withExistingDirectory pkgdir $ do+ local <- compareLocal+ remote <- compareRemote+ unless (null local && null remote) $ do+ unless (null pkgs) $+ getPackageName pkgdir >>= putPkgHdr+ unless (null local) $ do+ putStrLn "local changes:"+ mapM_ putStrLn local+ unless (null remote) $ do+ putStrLn "remote changes:"+ mapM_ putStrLn remote++ logFormat = "--pretty=format:%h %s (%cs)"++ compareLocal :: IO [String]+ compareLocal = do+ localbranches <- localBranches True+ oldcurrent <- gitCurrentBranch+ have1 <- haveBranch localbranches br1+ have2 <- haveBranch localbranches br2+ newcurrent <- gitCurrentBranch+ when (newcurrent /= oldcurrent) $+ gitSwitchBranch oldcurrent+ if have1 && have2+ then ignoredLines <$> gitLines "log" ([logFormat | not long] ++ [show br1 ++ ".." ++ show br2])+ else do+ let missing =+ map show $ [br1 | not have1] ++ [br2 | not have2]+ warning $ "didn't find local" +-+ unwords missing+ return []++ compareRemote :: IO [String]+ compareRemote = do+ have1 <- checkIfRemoteBranchExists br1+ have2 <- checkIfRemoteBranchExists br2+ if have1 && have2+ then ignoredLines <$> gitLines "log" ([logFormat | not long] ++ ["origin/" ++ show br1 ++ ".." ++ "origin/" ++ show br2])+ else do+ let missing =+ map show $ [br1 | not have1] ++ [br2 | not have2]+ warning $ "didn't find remote" +-+ unwords missing+ return []++ ignoredLines :: [String] -> [String]+ ignoredLines =+ case mignore of+ Nothing -> id+ Just ignore -> filter (not . (ignore `isInfixOf`))++ haveBranch :: [String] -> AnyBranch -> IO Bool+ haveBranch locals br =+ if show br `elem` locals+ then return True+ else gitSwitchBranch' True $ onlyRelBranch br
+ src/Cmd/CompareTarballs.hs view
@@ -0,0 +1,97 @@+module Cmd.CompareTarballs (+ compareTarballsCmd+ )+where++import Safe (tailSafe)+import SimpleCmd+import SimpleCmd.Git+import System.Console.Pretty (supportsPretty)+import System.IO.Extra (withTempDir)++import Common+import Common.System+import Package (findSpecfile, pkgVersion)+import Patch (simplifyMinimalDiff)++compareTarballsCmd :: Maybe Natural -> Maybe String -> Maybe String -> IO ()+compareTarballsCmd mmaxlen (Just nv1) (Just nv2) = diffTarballs mmaxlen nv1 nv2+compareTarballsCmd mmaxlen (Just nv) Nothing = do+ spec <- findSpecfile+ cur <- pkgVersion spec+ if nv == cur+ then error' "same source version!"+ else diffTarballs mmaxlen nv cur+compareTarballsCmd _ Nothing (Just _) = error' "impossible happened: only second arg"+compareTarballsCmd mmaxlen Nothing Nothing = do+ let sourcesfile = "sources"+ havesrc <- doesFileExist sourcesfile+ if havesrc+ then do+ -- was "origin"+ diff <- git "diff" ["-U0", "--cached", sourcesfile]+ case lines diff of+ [] -> error' $ "no uncommitted version changes in" +-+ show sourcesfile+ ls ->+ -- FIXME cannot handle majorversion macros etc (eg lean4)+ case simplifyMinimalDiff ls of+ [s1,s2] -> diffTarballs mmaxlen (sourcesFilename s1) (sourcesFilename s2)+ _ -> error' $ "could not determine changed versions in" +-+ show sourcesfile+ else do+ spec <- findSpecfile+ diff <- git "diff" ["-U0", spec]+ case lines diff of+ [] -> error' $ "no uncommitted version changes in" +-+ show spec+ ls ->+ case filter (("Version:" `isPrefixOf`) . tailSafe) $ simplifyMinimalDiff ls of+ [v1,v2] -> do+ let name = takeBaseName spec+ let newtar = name ++ '-' : specVersion v2 <.> "tar.gz"+ exists <- doesFileExist newtar+ unless exists $ cmd_ "spectool" ["-g", "-S", spec]+ diffTarballs mmaxlen (name ++ '-' : specVersion v1 <.> "tar.gz") newtar+ _ -> error' $ "could not determine changed versions in" +-+ show sourcesfile+ where+ sourcesFilename s =+ -- "+SHA512 (filestore-0.6.5.1.tar.gz) = 9eec4d23737bcdfc3d0ded..."+ case words s of+ (_:"SHA512") : ('(':fp) : "=" : _hash -> init fp+ _ -> error' $ "Failed to parse:" +-+ s++ specVersion s =+ -- "-Version: 0.1.50.1"+ case words s of+ (_:"Version:") : [ver] -> ver+ _ -> error' $ "Failed to parse:" +-+ s++-- FIXME --reverse diff+diffTarballs :: Maybe Natural -> String -> String -> IO ()+diffTarballs mmaxlen src1 src2 = do+ cwd <- getCurrentDirectory+ withTempDir $ \tmp ->+ withCurrentDirectory tmp $ do+ adir <- getDirTop "a" cwd src1+ bdir <- getDirTop "b" cwd src2+ -- createDirectory "b"+ -- withCurrentDirectory "b" $+ -- cmd_ "tar" ["xf", cwd </> src2]+ -- listDirectory "."+ color <- supportsPretty+ pipe_+ -- FIXME add option to filter out certain files+ ("diff", ["--color=always" | color] ++ ["-u", "-r", "-w", "a" </> adir, "b" </> bdir])+ ("grep", ["-v", ".\\{" ++ maybe "200" show mmaxlen ++ ",\\}"])+ where+ getDirTop :: FilePath -> FilePath -> FilePath -> IO FilePath+ getDirTop subdir topdir src = do+ createDirectory subdir+ withCurrentDirectory subdir $ do+ exists <- doesFileExist $ topdir </> src+ if exists+ then do+ cmd_ "tar" ["xf", topdir </> src]+ ls <- listDirectory "."+ case ls of+ [n] -> return n+ _ -> error' $ "more than one top-level dir in" +-+ src+ else error' $ src +-+ "not found"
src/Cmd/Copr.hs view
@@ -16,6 +16,7 @@ #else import qualified Data.HashMap.Strict as M #endif+import qualified Data.ByteString.Lazy.UTF8 as U import Data.Char (isDigit) import Data.Either.Combinators (whenLeft) import Data.Ini.Config@@ -24,7 +25,8 @@ import Data.Tuple.Extra (first) import Distribution.Fedora.Branch (getActiveBranches, getActiveBranched) import Network.HTTP.Query (lookupKey, lookupKey')-import Safe (headDef)+import Network.HTTP.Simple as HTTP+import Safe (headDef, lastMay) import System.Environment.XDG.BaseDir (getUserConfigDir) import System.Time.Extra (sleep) import Web.Fedora.Copr (coprChroots, fedoraCopr)@@ -106,7 +108,11 @@ showArch PPC64LE = "ppc64le" showArch S390X = "s390x" -data CoprMode = ListChroots | CoprMonitor | CoprBuild | CoprNew+data CoprMode = ListChroots+ | CoprMonitor (Maybe String) Bool -- FIXME should be Maybe (String, Bool) probably+ | CoprBuild+ | CoprNew+ | CoprFailures (Maybe String) -- FIXME take ExclusiveArch/ExcludeArch into account -- FIXME -1 for only first unbuilt chroot@@ -119,22 +125,24 @@ -- FIXME time builds? coprCmd :: Bool -> CoprMode -> Bool -> Maybe BuildBy -> Maybe Archs -> String -> (BranchesReq,[String]) -> IO ()-coprCmd dryrun mode force mbuildBy marchs project (breq, pkgs) = do- user <- getUsername+coprCmd dryrun mode force mbuildBy marchs copr (breq, pkgs) = do+ -- FIXME disallow user/project for build/new?+ (user,project) <- coprUserProject copr let buildBy = fromMaybe ValidateByRelease mbuildBy case mode of- ListChroots -> coprGetChroots user >>= mapM_ (putStrLn . showChroot)- CoprMonitor -> coprMonitorPackages user project >>= mapM_ printPkgRes+ ListChroots -> coprGetChroots user project >>= mapM_ (putStrLn . showChroot)+ CoprMonitor mneedle nameonly -> coprMonitorPackages user project >>= mapM_ (printPkgRes mneedle nameonly) CoprNew -> coprNewProject dryrun project marchs breq pkgs+ CoprFailures mgrep -> coprMonitorPackages user project >>= mapM_ (printFailures user project mgrep) CoprBuild -> do- chroots <- coprGetChroots user+ chroots <- coprGetChroots user project if null pkgs- then coprBuildPkg user buildBy chroots False+ then coprBuildPkg user project buildBy chroots False else- mapM_ (\(n,p) -> withExistingDirectory p $ coprBuildPkg user buildBy chroots (n>0)) $ zip (reverse [0..length pkgs - 1]) pkgs+ mapM_ (\(n,p) -> withExistingDirectory p $ coprBuildPkg user project buildBy chroots (n>0)) $ zip (reverse [0..length pkgs - 1]) pkgs where- coprGetChroots :: String -> IO [Chroot]- coprGetChroots user = do+ coprGetChroots :: String -> String -> IO [Chroot]+ coprGetChroots user project = do chroots <- reverseSort . map (readChroot . T.unpack) <$> coprChroots coprServer user project when (null chroots) $ error' $ "No chroots found for" +-+ user ++ "/" ++ project@@ -162,8 +170,8 @@ then error' "No valid chroots" else return buildroots - coprBuildPkg :: String -> BuildBy -> [Chroot] -> Bool -> IO ()- coprBuildPkg user buildBy chroots morepkgs = do+ coprBuildPkg :: String -> String -> BuildBy -> [Chroot] -> Bool -> IO ()+ coprBuildPkg user project buildBy chroots morepkgs = do -- FIXME check is pkg.spec -- was: localBranchSpecFile pkg (RelBranch Rawhide) spec <- findSpecfile@@ -208,6 +216,22 @@ sameRelease r1 r2 = chrootBranch r1 == chrootBranch r2 +-- from copr-tool+-- FIXME CoprProject datatype+coprUserProject :: String -> IO (String,String)+coprUserProject copr =+ case splitCopr of+ Just (u,p) -> return (u,p)+ Nothing -> do+ fasid <- getUsername+ return (fasid, copr)+ where+ splitCopr :: Maybe (String, String)+ splitCopr =+ case splitOn "/" copr of+ [u,c] | not (null u || null c) -> Just (u,c)+ _ -> Nothing+ getUsername :: IO String getUsername = do rc <- getUserConfigDir "copr"@@ -281,14 +305,16 @@ putStrLn $ "Failed: copr" +-+ unwords buildargs -- FIXME determine which chroot(s) failed -- eg 06482247- let zbid =- let s = show bid- in (if length s < 8 then ('0' :) else id) s actualpkg <- cmd "rpmspec" ["-q", "--srpm", "--qf", "%{name}", spec] -- FIXME which chroot? -- FIXME print buildlog size- error' $ "https://download.copr.fedorainfracloud.org/results" +/+ user +/+ project +/+ showChroot (headDef (error' " nochroot!") chroots) +/+ zbid ++ "-" ++ actualpkg +/+ "builder-live.log.gz"+ error' $ "https://download.copr.fedorainfracloud.org/results" +/+ user +/+ project +/+ showChroot (headDef (error' " nochroot!") chroots) +/+ zeroBuildId bid ++ "-" ++ actualpkg +/+ "builder-live.log.gz" +zeroBuildId :: Int -> String+zeroBuildId bid =+ let s = show bid+ in (if length s < 8 then ('0' :) else id) s+ -- FIXME idea: Maybe Seconds to increment FIXME -- sleep should have all chroots in pending CoprTask build coprWatchBuild :: Maybe String -> Either CoprTask Int -> IO Bool@@ -362,15 +388,95 @@ build <- lookupKey "build_id" obj return $ CoprTask (readChroot (T.unpack chroot)) build state version -printPkgRes :: (Package, [CoprTask]) -> IO ()-printPkgRes (pkg,chroots) = do- putStrLn $ "# " <> unPackage pkg- mapM_ printCoprTask chroots+-- FIXME NonEmpty String+printPkgRes :: Maybe String -> Bool -> CoprPackage -> IO ()+printPkgRes Nothing _nameonly (pkg,chroots) = do+ putStr $ "# " <> unPackage pkg+ case chroots of+ [] -> putNewLn+ [ch] -> putStr ": " >> printCoprTask ch+ _ -> putNewLn >> mapM_ printCoprTask chroots putNewLn+printPkgRes (Just needle) nameonly (pkg,chroots) = do+ case filterResults chroots of+ [] -> return ()+ [ch] ->+ if nameonly+ then putStrLn $ unPackage pkg+ else do+ putStr $ "# " <> unPackage pkg <> ": "+ printCoprTask ch+ _ -> do+ putStrLn $ "# " <> unPackage pkg+ mapM_ printCoprTask chroots+ where+ filterResults :: [CoprTask] -> [CoprTask]+ filterResults [] = []+ filterResults (c:cs) =+ (if needle `isInfixOf` renderCoprTask c then (c :) else id)+ $ filterResults cs +renderCoprTask :: CoprTask -> String+renderCoprTask (CoprTask chr build status version) =+ version +-+ status +-+ "on" +-+ showChroot chr +-+ show build+ printCoprTask :: CoprTask -> IO ()-printCoprTask (CoprTask chr build status version) =- putStrLn $ showChroot chr +-+ show build ++ ":" +-+ status +-+ version+printCoprTask =+ putStrLn . renderCoprTask++-- FIXME only latest pkg builds+printFailures :: String -> String -> Maybe String -> CoprPackage -> IO ()+printFailures user project mgrep (pkg,chroots) = do+ let fails = filter ((== "failed") . taskStatus) chroots+ unless (null fails) $ do+ putStrLn $ "#" +-+ unPackage pkg+ mapM_ (displayLog mgrep . logUrl) fails+ where+ logUrl task = "https://download.copr.fedorainfracloud.org/results" +/+ user +/+ project +/+ showChroot (taskChroot task) +/+ zeroBuildId (taskBuild task) ++ "-" ++ unPackage pkg +/+ "builder-live.log.gz"++-- adapted from koji-tool Tasks+displayLog :: Maybe String -> String -> IO ()+displayLog mgrep logurl = do+ req <- HTTP.parseRequest logurl+ resp <- HTTP.httpLBS req+ let out = U.toString $ HTTP.getResponseBody resp+ ls = lines out+ putStrLn ""+ let output+ | length out < 4000 =+ let excluded = ["Executing command:",+ "Child return code was: 0",+ "child environment: None",+ "ensuring that dir exists:",+ "touching file:",+ "creating dir:",+ "kill orphans"]+ in+ map (dropPrefix "DEBUG ") $ takeEnd 30 $+ filter (\l -> not (any (`isInfixOf` l) excluded)) ls+ | otherwise =+ case breakOnEnd ["RPM build errors:"] ls of+ ([],ls') -> ls'+ (ls',_) -> dropEnd 2 ls'+ putStr $ unlines $+ case mgrep of+ Nothing -> takeEnd 80 output+ Just needle ->+ filter (match needle) ls+ putStrLn $ '\n' : logurl ++ "\n"+ where+ match :: String -> String -> Bool+ match "" _ = error' "empty grep string not allowed"+ match _ "" = False+ match ('^':needle) ls =+ if lastMay needle == Just '$'+ then needle == ls+ else needle `isPrefixOf` ls+ match needle ls =+ if lastMay needle == Just '$'+ then needle `isSuffixOf` ls+ else needle `isInfixOf` ls+ coprWaitPackage :: Object -> IO () coprWaitPackage build = do
src/Cmd/FTBFS.hs view
@@ -86,7 +86,7 @@ print status case status of BuildFailed -> do- cmdLog "koji-tool" ["tasks", "--details", "-T", "-s", "fail", "-b", showNVR nvr]+ cmdLog_ "koji-tool" ["tasks", "--details", "-T", "-s", "fail", "-b", showNVR nvr] putNewLn BuildComplete -> do if bugStatus bug `elem` ["NEW", "ASSIGNED", "POST"]
src/Cmd/Install.hs view
@@ -21,7 +21,6 @@ import RpmBuild -- FIXME --rpm to avoid dnf--- FIXME --force removal of existing incompatible dependent packages -- FIXME --subpackage to specify subpackage(s) to install/add -- FIXME --exclude to specify subpackage(s) not to install -- FIXME --ignore-uninstalled subpackages@@ -31,10 +30,10 @@ -- 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 -> Yes- -> Select -> Maybe ExistingStrategy -> (Maybe Branch,[String])- -> IO ()-installCmd quiet recurse mfrom mjobs mforceshort bconds reinstall nobuild nobuilddeps yes select mexisting (mbr, pkgs) = do+ -> Maybe ForceShort -> [BCond] -> Maybe PkgMgr -> Bool -> Bool+ -> Bool -> Bool -> Yes -> Select -> Maybe ExistingStrategy+ -> (Maybe Branch,[String]) -> IO ()+installCmd quiet recurse mfrom mjobs mforceshort bconds mmgr reinstall allowerasing 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, filter (/= ":") pkgs)@@ -57,42 +56,44 @@ -- FIXME can this be removed now? already <- filterM nvraInstalled nvras if isJust mforceshort || null already || reinstall || select /= selectDefault- then doInstallRPMs mforceshort spec rpms+ then doInstallRPMs spec rpms else putStrLn $ unlines (map showNVRA already) ++ "\nalready installed!\n" where- doInstallRPMs mforceshort' spec rpms = do+ doInstallRPMs spec rpms = do -- FIXME show source NVR (eg not pandoc-common) whenJust (headMay rpms) $ putStrLn . showNVR . dropArch . readNVRA unless (nobuilddeps || nobuild) $ do- missingdeps <- nub <$> (buildRequires spec >>= filterM notInstalled)- unless (null missingdeps) $- if recurse- then do- -- srcs <- nub <$> mapM (derefSrcPkg topdir dist True) hmissing- rbr <- anyBranchToRelease br- forM_ missingdeps $ \ dep -> do- -- FIXME check not metadep with parens- mpkgdir <- lookForPkgDir rbr ".." dep- case mpkgdir of- Nothing -> putStrLn $ dep +-+ "not known"- Just pkgdir -> installCmd 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+ needBuild <- needToBuildRPMS True mforceshort rpms spec+ when needBuild $ do+ missingdeps <- nub <$> (buildRequires spec >>= filterM notInstalled)+ unless (null missingdeps) $+ if recurse+ then do+ -- srcs <- nub <$> mapM (derefSrcPkg topdir dist True) hmissing+ rbr <- anyBranchToRelease br+ forM_ missingdeps $ \ dep -> do+ -- FIXME check not metadep with parens+ mpkgdir <- lookForPkgDir rbr ".." dep+ case mpkgdir of+ Nothing -> putStrLn $ dep +-+ "not known"+ Just pkgdir -> installCmd quiet recurse mfrom mjobs mforceshort bconds mmgr reinstall allowerasing 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 -- FIXME unused _wasbuilt <- if nobuild then return True- else buildRPMs quiet False False mjobs mforceshort' bconds rpms br spec- unless (isShortCircuit mforceshort') $ do+ else buildRPMs quiet False False mjobs mforceshort bconds rpms br spec+ unless (isShortCircuit mforceshort) $ do let nvras = rpmsToNVRAs rpms -- FIXME: prefix = fromMaybe (nvrName nvr) mprefix decided <- decideRPMs yes False mexisting select (unPackage pkg) nvras -- FIXME dryrun and debug -- FIXME return Bool?- installRPMs False False Nothing yes $ groupOnArch "RPMS" decided+ installRPMsAllowErasing False False mmgr allowerasing yes $ groupOnArch "RPMS" decided lookForPkgDir :: Branch -> FilePath -> String -> IO (Maybe FilePath) lookForPkgDir rbr topdir p = do
src/Cmd/ListBranches.hs view
@@ -5,7 +5,7 @@ ) where -import Distribution.Fedora.Branch (getActiveBranches, readBranch)+import Distribution.Fedora.Branch (getActiveBranches) import Branches import Common@@ -79,26 +79,30 @@ 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 -- FIXME epel branches are not sorted correctly: epel10 epel10.0 epel9 f41 ...- putStrLn $ pkgprefix +-+ unwords brs+ brs <-+ if mode == Remote+ then listRemoteAllBranches (unPackage pkg)+ else listAllBranches False+ putStrLn $ pkgprefix +-+ unwords (map showBranch brs) else do+ brs <-+ if mode == Remote+ then listRemoteBranches (unPackage pkg)+ else listBranches False if breq == Branches [] then do -- FIXME better to filter inactive instead active <- getActiveBranches let result = if missing- then active \\ mapMaybe readBranch brs- else activeBranches active brs+ then active \\ brs+ else brs putStrLn $ pkgprefix +-+ (unwords . map showBranch) result else do branches <- listOfBranches True False breq- let havebrs = filter (`elem` branches) $ mapMaybe readBranch brs+ let havebrs = filter (`elem` branches) brs result = if missing then branches \\ havebrs else havebrs unless (null result) $ putStrLn $ pkgprefix +-+ (unwords . map showBranch) result
src/Cmd/Merge.hs view
@@ -5,6 +5,8 @@ where import Safe (tailSafe)+import SimplePrompt (promptEnter)+import System.Console.Pretty (color, Color(Magenta, Red)) import Common import Common.System@@ -24,19 +26,15 @@ error' "merge only defined for release branches" -- FIXME should rawhide default to no-op runMergeBranch pkg (RelBranch br) = do+ when (mfrom == Just br) $+ error' "cannot merge branch to itself" exists <- gitSwitchBranch' False br when exists $ do- mfrom' <- if isJust mfrom- then return mfrom- else getNewerBranch (unPackage pkg) br- whenJust mfrom' $ \from -> do- when (from == br) $- error' "cannot merge branch to itself"- unless dryrun $- gitMergeOrigin br- (ancestor,unmerged) <- mergeable from br- unmerged' <- filterOutTrivial mnotrivial unmerged- mergeBranch dryrun nofetch False noprompt showall pkg (ancestor,unmerged') from br+ unless dryrun $+ gitMergeOrigin br+ (mancestor,unmerged,from) <- mergeable pkg br mfrom+ unmerged' <- filterOutTrivial mnotrivial unmerged+ mergeBranch dryrun nofetch False noprompt showall pkg (mancestor,unmerged') from br where filterOutTrivial :: Maybe Natural -> [Commit] -> IO [Commit] filterOutTrivial Nothing cs = return cs@@ -51,29 +49,33 @@ then filterOutTrivial (Just (no -1)) cs else return css --- FIXME maybe require local branch already here-mergeable :: Branch -> Branch -> IO (Bool,[Commit])-mergeable _ Rawhide = return (False,[])-mergeable from to = do- (mancestor, unmerged) <- gitMergeable to from- return (mancestor == Just True, unmerged)- -- FIXME return merged ref mergeBranch :: Bool -> Bool -> Bool -> Bool -> Bool -> Package- -> (Bool,[Commit]) -- (ancestor,unmerged)+ -> (Maybe Bool,[Commit]) -- (mancestor,unmerged) -> Branch -> Branch -> IO () mergeBranch _ _ _ _ _ _ _ _ Rawhide = return () mergeBranch _ _ _ _ _ _ (_,[]) _ _ = return ()-mergeBranch dryrun nofetch build noprompt showall pkg (True, unmerged@(unmgd:_)) from br = do+mergeBranch _ _ _ _ _ _ (Nothing,_) _ _ = return ()+mergeBranch dryrun nofetch build noprompt showall pkg (Just True, unmerged@(unmgd:_)) from br = do when (nofetch && not build) $ putPkgBrnchHdr pkg br isnewrepo <- initialPkgRepo+ locals <- localBranches True+ -- FIXME what if branch doesn't exist at all?+ unless (showBranch from `elem` locals) $ do+ git_ "fetch" ["origin"]+ git_ "branch" ["--track", showBranch from, "origin/" ++ showBranch from]+ newerlocal <- gitOneLineLog $ "origin/" ++ showBranch from ++ ".." ++ showBranch from+ unless (null newerlocal) $ do+ putStr "*Warning!* "+ displayHdrCommits ("Unpushed" +-+ showBranch from +-+ "commit") showall newerlocal+ putNewLn+ promptEnter "Press Enter to continue anyway" putStrLn $ (if isnewrepo || noprompt then "Merging from" else "New commits in") +-+ "origin/" ++ showBranch from ++ ":" displayCommits showall unmerged putNewLn unpushed <- gitOneLineLog $ "origin/" ++ showBranch br ++ "..HEAD" unless (null unpushed) $ do- putStrLn "Local commits:"- displayCommits showall unpushed+ displayHdrCommits "Local commit" showall unpushed putNewLn mmerge <- if isnewrepo && length unmerged == 1 || noprompt@@ -84,23 +86,20 @@ "; or 'no' to skip merge") -- ensure still on same branch! gitSwitchBranch (RelBranch br)- whenJust mmerge $ \ ref -> do- locals <- localBranches True- unless (showBranch from `elem` locals) $- git_ "fetch" ["origin", showBranch from ++ ":" ++ showBranch from]- unless dryrun $- -- FIXME merge from origin by default not local branch- git_ "merge" ["--quiet", ref]-mergeBranch dryrun nofetch build _noprompt showall pkg (False,unmerged) from br = do+ whenJust mmerge $ \ ref ->+ unless dryrun $ git_ "merge" ["--quiet", ref]+mergeBranch dryrun nofetch build noprompt showall pkg (Just False,unmerged) from br = do+ unpushed <- gitOneLineLog $ "origin/" ++ showBranch br ++ "..HEAD" when (nofetch && not build) $ putPkgBrnchHdr pkg br- putStrLn $ showBranch from +-+ "branch is not directly mergeable:"+ putStrLn $ color (if null unpushed then Magenta else Red) $ showBranch from +-+ "branch is not directly mergeable:" displayCommits False unmerged putNewLn- unpushed <- gitOneLineLog $ "origin/" ++ showBranch br ++ "..HEAD"- unless (null unpushed) $ do- putStrLn "Local commits:"- displayCommits showall unpushed- mmerge <- conflictPrompt unmerged $ "Press Enter to skip merge" ++ (if build then " and build" else "") ++ "; or give ref or 'HEAD' to attempt merge"+ unless (null unpushed) $+ displayHdrCommits "Local commits" showall unpushed+ mmerge <-+ if noprompt && null unpushed+ then return Nothing+ else conflictPrompt unmerged $ "Press Enter to skip merge" ++ (if build then " and build" else "") ++ "; or give ref or 'HEAD' to attempt merge" -- ensure still on same branch! gitSwitchBranch (RelBranch br) whenJust mmerge $ \ ref ->
src/Cmd/Parallel.hs view
@@ -50,10 +50,11 @@ -- FIXME push update -- FIXME use more say -- FIXME --skip-bumps NUM-parallelBuildCmd :: Bool -> Maybe Bool -> Int -> Maybe SideTagTarget -> Bool- -> Double -> (Maybe UpdateType, UpdateSeverity)+parallelBuildCmd :: Bool -> Maybe Bool -> Maybe Branch -> Int+ -> Maybe SideTagTarget -> Bool -> Double+ -> (Maybe UpdateType, UpdateSeverity) -> (BranchesReq, [String]) -> IO ()-parallelBuildCmd dryrun mmerge firstlayer msidetagTarget mustpush delay mupdate (breq, pkgs) =+parallelBuildCmd dryrun mmerge mfrom firstlayer msidetagTarget mustpush delay mupdate (breq, pkgs) = do branches <- case pkgs of@@ -91,7 +92,7 @@ withExistingDirectory p $ do pkg <- getPackageName p putPkgBrnchHdr pkg rbr- mergeNewerBranch pkg rbr+ mergeFromBranch pkg rbr getDynSourcesMacros $ packageSpec pkg distopts <- distRpmOptions rbr allLayers <- getLayers distopts pkgs@@ -138,7 +139,7 @@ unless okay $ error' "Quitting" when (isNothing msidetagTarget) $ do let spec = packageSpec pkg- bodhiUpdate dryrun mupdate Nothing Nothing spec $+ bodhiUpdate dryrun mupdate Nothing Nothing Nothing spec $ intercalate "," . map (showNVR . jobNvr) $ filter ((/= Rawhide) . jobBranch) nvrclogs where@@ -147,18 +148,17 @@ setupBranch br = do putPkgBrnchHdr pkg br target <- targetMaybeSidetag dryrun True True br msidetagTarget- when (mmerge /= Just False) $ mergeNewerBranch pkg br- job <- startBuild Nothing 0 False (length brs) target pkg br "." >>= async+ when (mmerge /= Just False) $ mergeFromBranch pkg br+ job <- startBuild Nothing 0 False 1 target pkg br "." >>= async unless dryrun $ sleep delay return (showBranch br,job) - mergeNewerBranch :: Package -> Branch -> IO ()- mergeNewerBranch pkg br = do+ mergeFromBranch :: Package -> Branch -> IO ()+ mergeFromBranch pkg br = do gitSwitchBranch (RelBranch br)- (ancestor,unmerged,mnewer) <- newerMergeable (unPackage pkg) br+ (mancestor,unmerged,from) <- mergeable pkg br mfrom unless dryrun $- whenJust mnewer $ \newer ->- mergeBranch dryrun False False (mmerge == Just True) False pkg (ancestor,unmerged) newer br+ mergeBranch dryrun False False (mmerge == Just True) False pkg (mancestor,unmerged) from br -- FIXME time builds or layers -- FIXME return Either@@ -317,11 +317,12 @@ return $ return $ Done pkg nvr br changelog Just BuildBuilding -> do sayString $ color Yellow (showNVR nvr) +-+ "is already" +-+ style Bold (color Yellow "building")- mtask <- kojiGetBuildTaskID fedoraHub $ showNVR nvr+ hub <- getKojiProfileHub+ mtask <- kojiGetBuildTaskID hub $ showNVR nvr case mtask of Nothing -> error' $ "Task for" +-+ showNVR nvr +-+ "not found" Just task -> do- putTaskinfoUrl fedoraHub task+ putTaskinfoUrl hub task return $ do kojiWaitTaskReport (isNothing mlatest) nvr task return $ Done pkg nvr br changelog@@ -367,9 +368,10 @@ else do 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+ --cmdLog_ kojitool ["builds", "--tail", "-b", showNVR nvr]+ cmdLog_ kojitool $ ["tasks", "--children", displayID task, "-s", "fail"] ++ [if nopkgs < 5 then "--tail" else "--details"]+ hub <- getKojiProfileHub+ putTaskinfoUrl hub task error' $ color Red $ showNVR nvr +-+ "build failed" autoupdate <- checkAutoBodhiUpdate br if autoupdate then
src/Cmd/Prep.hs view
@@ -41,17 +41,18 @@ getSourcesMacros spec when deps $ installDeps False spec- case br of- RelBranch rbr -> do- nvr <- pkgNameVerRel' rbr spec- -- newline avoids error starting on same line- putStr $ "Prepping" +-+ showNVR nvr ++ ": "- _ -> return ()+ whenM isPkgGitRepo $+ case br of+ RelBranch rbr -> do+ nvr <- pkgNameVerRel' rbr spec+ -- newline avoids error starting on same line+ putStr $ "Prepping" +-+ showNVR nvr ++ ": "+ _ -> return () sourcediropt <- do distgit <- isGitRepo if distgit then sourceDirCwdOpt else return [] timeIO $- (if verbose then cmdLog else cmdSilent') "rpmbuild" $ "-bp" : ["--nodeps" | not deps] ++ sourcediropt ++ [spec]+ (if verbose then cmdLog_ else cmdSilent') "rpmbuild" $ "-bp" : ["--nodeps" | not deps] ++ sourcediropt ++ [spec] putStrLn "done"
+ src/Cmd/Repoquery.hs view
@@ -0,0 +1,14 @@+module Cmd.Repoquery+ (repoqueryCmd)+where++import Branches+import Common.System++repoqueryCmd :: (BranchesReq, [String]) -> IO ()+repoqueryCmd (breq, pkgs) = do+ query <- if null pkgs+ then pure <$> getDirectoryName+ else return pkgs+ brs <- listOfBranches True False breq+ cmd_ "fedora-repoquery" $ ["--qf", "nvr"] ++ map showBranch brs ++ query
src/Cmd/RequestBranch.hs view
@@ -154,7 +154,7 @@ if null brs' then return [] else do- current <- fedoraBranchesNoRawhide $ pagurePkgBranches (unPackage pkg)+ current <- delete Rawhide <$> listRemoteBranches (unPackage pkg) forM_ brs' $ \ br -> when (br `elem` current) $ putStrLn $ pkgPrefix ++ showBranch br +-+ "remote branch already exists"
src/Cmd/RequestRepo.hs view
@@ -4,7 +4,7 @@ import Control.Exception.Extra (retry) import Fedora.Krb (fasIdFromKrb)-import Network.HTTP.Directory (httpExists, httpManager)+import Network.HTTP.Directory (httpExists') import Safe (headMay) import SimplePrompt (promptEnter, promptInitial, yesNo) import System.Time.Extra (sleep)@@ -99,8 +99,7 @@ checkNoPagureRepo :: IO () checkNoPagureRepo = do- mgr <- httpManager- exists <- httpExists mgr $ "https://" ++ srcfpo +/+ "rpms" +/+ pkg+ exists <- httpExists' $ "https://" ++ srcfpo +/+ "rpms" +/+ pkg when exists $ error' $ "Repo for" +-+ pkg +-+ "already exists"
src/Cmd/ReviewPackage.hs view
@@ -8,6 +8,7 @@ import Common.System import Data.Char+import Data.Either (isRight) import Data.Tuple.Extra (second) import Safe (headDef, headMay, tailSafe) import SelectRPMs (selectDefault, Yes(No))@@ -18,6 +19,7 @@ import Cmd.Import (downloadReviewSRPM, upstreamDir) import Cmd.Install (installCmd) import Cmd.Local (localCmd)+import Cmd.Prep (prepCmd) import Git (isGitRepo, git_, gitBool) import Package import RpmBuild@@ -40,11 +42,15 @@ else Left pkgbug (bugs,session) <- bugsSession $ case epkgbid of- Right bid -> packageReview .&&. statusNewAssigned .&&. bugIdIs bid+ Right bid -> packageReview .&&. bugIdIs bid Left pkg -> pkgReviews pkg .&&. statusNewAssigned case bugs of [bug] -> do putReviewBug False bug+ when (isRight epkgbid) $+ unless (bugStatus bug `elem` ["NEW", "ASSIGNED"]) $ do+ putStrLn "Warning: review is past NEW/ASSIGNED state!"+ promptEnter "Press Enter to continue anyway" let bid = bugId bug pkg = reviewBugToPackage bug if not full@@ -98,9 +104,9 @@ unless (isArchiveFile src) $ git_ "add" [src] putStrLn $ "# Diff with" +-+ upstreamDir- cmd_ "diff" ["-u", spec, upstreamDir </> spec]+ void $ cmdBool "diff" ["-u", spec, upstreamDir </> spec] withCurrentDirectory upstreamDir $- void $ getSources spec+ cmd_ "spectool" ["-g", spec] diff <- lines <$> cmdIgnoreErr "diff" ["--brief", ".", upstreamDir] "" let filterdiff = filter (\d -> not (any (`isSuffixOf` d) ["SPEC","SRPMS","RPMS","BUILD","BUILDROOT","src.rpm",".log", ".git", upstreamDir])) diff if null filterdiff@@ -112,14 +118,15 @@ putStrLn "# Build" -- FIXME or download rpms build <- yesNoDefault importsrpm "Build package locally"- when build $- localCmd False False False Nothing Nothing [] (Branches [],[])+ if build+ then localCmd False False False Nothing Nothing [] (Branches [],[])+ else prepCmd Nothing False False False (Nothing,[]) putNewLn putStrLn "# RpmLint" void $ cmdBool "rpmlint" ["."] -- FIXME $ spec:srpm:rpms spec <- maybe findSpecfile return mspec whenM (yesNoDefault importsrpm "Install packages locally") $ do- installCmd False False Nothing Nothing Nothing [] False True True No selectDefault Nothing (Nothing,[])+ installCmd False False Nothing Nothing Nothing [] Nothing False 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) ""@@ -138,11 +145,26 @@ unless (null err) $ warning $ "rpmlint stderr:\n" ++ err putNewLn putStrLn "# Licensing"- -- FIXME use build subdir- -- FIXME filter out files not in tarball or prep- cmdLines "licensecheck" ["-r", "BUILD"] >>=- -- handle "FILEPATH: *No copyright* UNKNOWN [generated file]"- mapM_ putStrLn . filter (not . (" UNKNOWN" `isInfixOf`))+ whenM (yesNoDefault True "Run licensecheck") $ do+ buildls <- listDirectory "BUILD"+ let builddir =+ case sort buildls of+ [] -> error' "empty BUILD/"+ [d] -> "BUILD" </> d+ -- FIXME not good enough! use nvr+ ds -> "BUILD" </> last ds+ builddirls <- listDirectory builddir+ let builddir2 =+ case sort $ builddirls \\ ["BUILDROOT","SPECPARTS"] of+ [] -> error' $ "empty" +-+ "BUILD" </> builddir+ [d] -> builddir </> d+ -- FIXME? some projects might have more than one topdir+ ds -> error' $ "more than one dir:" +-+ unwords ds+ let args = ["--shortname-scheme", "spdx", "-r", builddir2]+ cmdN "licensecheck" args+ cmdLines "licensecheck" args >>=+ -- handle "FILEPATH: *No copyright* UNKNOWN [generated file]"+ mapM_ putStrLn . filter (not . (" UNKNOWN" `isInfixOf`)) cmd_ "rpmspec" ["-q", "--srpm", "--qf", "Spec license: %{license}\n", spec] summarizeErrors :: [String] -> [(String,Int)]
src/Cmd/Scratch.hs view
@@ -54,6 +54,7 @@ if null sidetagTargets then return [anyTarget br] else mapM (targetMaybeSidetag dryrun False False (onlyRelBranch br) . Just) sidetagTargets+ hub <- getKojiProfileHub forM_ targets $ \target -> do archs <- case marchopts of@@ -62,7 +63,7 @@ case archopts of Archs as -> return as ExcludedArchs as -> do- (buildtag,_desttag) <- kojiBuildTarget' fedoraHub target+ (buildtag,_desttag) <- kojiBuildTarget' hub target tagArchs <- kojiTagArchs buildtag excludedarchs <- do excluded <- map words . filter ("ExcludeArch:" `isPrefixOf`) <$> cmdLines "rpmspec" ["-P", spec]@@ -70,13 +71,13 @@ if null excluded then return [] else concatMap tailSafe excluded- return $ tagArchs \\ (as ++ excludedarchs)+ return $ tagArchs \\ (map normalArch as ++ excludedarchs) if stagger then do archlist <- if null archs then do- (buildtag,_desttag) <- kojiBuildTarget' fedoraHub target+ (buildtag,_desttag) <- kojiBuildTarget' hub target tagArchs <- kojiTagArchs buildtag -- prioritize preferred archs return $ nub $ priorityArchs ++ tagArchs@@ -87,6 +88,9 @@ else doScratchBuild pkggit spec target archs where priorityArchs = ["x86_64", "aarch64", "ppc64le"]++ normalArch "i386" = "i686"+ normalArch s = s doScratchBuild pkggit spec target archs = do let kojiargs = ["--arch-override=" ++ intercalate "," archs | notNull archs] ++ ["--fail-fast" | not nofailfast && length archs /= 1] ++ ["--no-rebuild-srpm" | not rebuildSrpm]
src/Cmd/Status.hs view
@@ -76,9 +76,10 @@ -- putStrLn $ "Newer commits in" +-+ show newerBr ++ ":" -- mapM_ putStrLn unmerged munpushed <- gitShortLog1 $ Just $ "origin/" ++ showBranch br ++ "..HEAD"+ hub <- getKojiProfileHub case munpushed of Nothing -> do- mbuild <- kojiGetBuildID fedoraHub (showNVR nvr)+ mbuild <- kojiGetBuildID hub (showNVR nvr) case mbuild of Nothing -> do destTag <- branchDestTag br@@ -88,7 +89,7 @@ Just latest -> putStrLn $ if equivNVR nvr mlatest then showNVR latest +-+ "is latest modulo disttag" else showNVR latest +-+ "->\n" ++ showNVR nvr Just buildid -> do- tags <- kojiBuildTags fedoraHub (buildIDInfo buildid)+ tags <- kojiBuildTags hub (buildIDInfo buildid) if null tags then do mstatus <- kojiBuildStatus nvr
src/Cmd/Switch.hs view
@@ -1,6 +1,6 @@ module Cmd.Switch (switchCmd) where -import Control.Monad (unless)+import Control.Monad (unless, when) import Branches import Common.System@@ -8,15 +8,21 @@ import Package -- FIXME noop when on branch already or drop cleanGit-switchCmd :: Bool -> Bool -> AnyBranch -> [String] -> IO ()-switchCmd verbose lenient br pkgs =+switchCmd :: Bool -> Bool -> Bool -> AnyBranch -> [String] -> IO ()+switchCmd verbose lenient stash br pkgs = -- FIXME use withBranchByPackages ? withPackagesByBranches HeaderNone False dirtyGit Zero dummy (Branches [],pkgs) where- dummy pkg _ =+ dummy pkg _ = do+ dostash <-+ if stash+ then not <$> isGitDirClean+ else return False+ when dostash $ git_ "stash" ["-m", stashedWithFbrnch] if lenient- then do+ then do let rbr = onlyRelBranch br ok <- gitSwitchBranch' (not verbose) rbr unless ok $ warning $ unPackage pkg +-+ "missing" +-+ showBranch rbr- else gitSwitchBranchVerbose verbose False br+ else gitSwitchBranchVerbose verbose False br+ when dostash gitUnstash
src/Cmd/Update.hs view
@@ -7,10 +7,13 @@ import Data.RPM.VerCmp import Data.Version (parseVersion) import Fedora.Krb (krbTicket)-import SimplePrompt (promptEnter)+import Safe (headMay, tailSafe)+import SimplePrompt (promptEnter, yesNoDefault)+import System.IO.Extra (withTempDir) import Text.ParserCombinators.ReadP (readP_to_S) import Branches+import Cmd.CompareTarballs import Common import Common.System import Git@@ -46,7 +49,6 @@ where isVersion = not . null . readP_to_S parseVersion --- FIXME use tempdir or don't prep to prevent overwriting an ongoing build updateSourcesPkg :: Bool -> Bool -> Bool -> Maybe String -> Package -> AnyBranch -> IO () updateSourcesPkg force allowHEAD distgit mver pkg br = do@@ -55,16 +57,17 @@ spec <- if allowHEAD then findSpecfile else localBranchSpecFile pkg br- -- FIXME detect uncommitted version bump, ie old committed version- (curver,_) <- pkgVerRel spec- vdiff <- filter ("+Version:" `isPrefixOf`) . filter (not . ("@@ " `isPrefixOf`)) <$> gitLines "diff" ["-U0", "HEAD", spec]- when (length vdiff > 1) $+ curver <- pkgVersion spec+ diff <- filter (not . ("@@ " `isPrefixOf`)) <$> gitLines "diff" ["-U0", "HEAD", spec]+ let vdiff = filter (\v -> any (`isPrefixOf` v) ["-Version:","+Version:"]) diff+ mnewrel = find ("+Release:" `isPrefixOf`) diff+ when (length vdiff > 2) $ error' $ "diff contains complex multi-version changes:\n" ++ unlines vdiff case mver of Nothing -> do putStrLn $ "current version:" +-+ curver Just nver -> do- when (length vdiff == 1) $+ when (length vdiff == 2) $ error' $ "spec version already bumped to" +-+ curver when (curver == nver) $ putStrLn $ "already new version" +-+ curver@@ -72,8 +75,7 @@ case mver of Just nver -> Just (curver,nver) Nothing ->- -- FIXME confused by fresh multiversion package (eg hadrian-0.1.0.0 make new ghcX.Y to 0.1.0.0- case map (last . words) vdiff of+ case map extractFieldValue vdiff of [old,new] -> Just (old,new) _ -> Nothing when (isJust mver) $@@ -85,12 +87,19 @@ putStrLn $ "current" +-+ oldver +-+ "is newer!" putStrLn $ oldver +-+ "->\n" ++ newver when (curver /= newver) $ do+ specversions <- grep "^Version:" spec+ case specversions of+ [] -> error' "no Version field found"+ [specver] ->+ when ('%' `elem` specver) $+ error' "Please edit complex 'Version' fields with macro(s) by hand"+ _ -> error' "Please edit package with multiple versions by hand" editSpecField "Version" newver spec autorelease <- isAutoRelease spec if autorelease then do- autobump <- autoReleaseBump spec- when autobump $+ autoreset <- autoReleaseReset spec+ when autoreset $ editSpecField "Release" "%autorelease" spec -- FIXME if multiple versions need to bump release else editSpecField "Release" "0%{?dist}" spec@@ -111,7 +120,7 @@ unlessM (doesFileExist patch) $ cmd_ "spectool" ["-g", "-P", spec] git_ "add" [patch]- let (archives,textsources) = partition isArchiveFile existing+ let (archives,textsources) = partition isArchiveFile sources when force $ do forM_ archives removeFile cmd_ "spectool" ["-g", "-S", spec]@@ -120,38 +129,40 @@ unless (null textsources) $ git_ "add" textsources whenJust moldnewver $ \(_old,newver) -> do+ whenM (yesNoDefault False "Do you want to diff the sources") $+ compareTarballsCmd Nothing Nothing Nothing versions <- changelogVersions spec let missing = case versions of [] -> True (h:_) -> not $ (newver ++ "-") `isPrefixOf` h when missing $ do- cmd_ "rpmdev-bumpspec" ["-c", "Update to" +-+ newver, spec]- git_ "commit" ["-a", "-m", "Update to" +-+ newver]+ -- FIXME newver may contain macros!+ newversion <- pkgVersion spec+ cmd_ "rpmdev-bumpspec" ["-c", "Update to" +-+ newversion, spec]+ newrelease <- cmd "rpmspec" ["-q", "--srpm", "--undefine=dist", "--qf", "%{release}", spec]+ -- revert release if was already bumped+ whenJust (extractFieldValue <$> mnewrel) $ \newrel -> do+ editSpecField "Release" newrel spec+ cmd_ "sed" ["-i", "s/> -" +-+ newversion ++ '-' : newrelease ++ "/> -" +-+ newversion ++ '-' : replace "%{?dist}" "" newrel ++ "/" , spec]+ git_ "commit" ["-a", "-m", "Update to" +-+ newversion] putStr "Prepping... " sourcediropt <- sourceDirCwdOpt- cmdSilent' "rpmbuild" $ "-bp" : sourcediropt ++ ["--nodeps", spec]- putStrLn "done"+ withTempDir $ \tempdir -> do+ cwd <- getCurrentDirectory+ withCurrentDirectory tempdir $ do+ cmdSilent' "rpmbuild" $ "-bp" : sourcediropt ++ ["--nodeps", cwd </> spec]+ putStrLn "done" -- FIXME git amend (if previous commit was update) -pkgVerRel :: FilePath -> IO (String,String)-pkgVerRel spec = do- --dist <- branchDist br- -- workaround dist with bootstrap- --hostdist <- cmd "rpm" ["--eval", "%{dist}"]- mvr <- cmdMaybe "rpmspec" ["-q", "--srpm", "--qf", "%{version}-%{release}", spec]- case mvr of- Nothing -> error' $ "Failed to read package ver-rel:" +-+ spec- Just vr -> return $ splitBy "-" vr--splitBy :: String -> String -> (String,String)-splitBy sep xs =- let ws = splitOn sep xs in- case ws of- [f,v] -> (f,v)- _ -> error $ "inconsistent field:" +-+ xs- changelogVersions :: FilePath -> IO [String] changelogVersions spec = do ns <- cmdLines "rpmspec" ["-q", "--srpm", "--qf", "%{changelogname}", spec] return $ map (removePrefix "- " . dropWhile (/= '-')) ns++-- eg "?Release: 0.2%{?dist}"+extractFieldValue :: String -> String+extractFieldValue vs =+ case headMay . tailSafe . words $ vs of+ Just h -> h+ Nothing -> error' $ "no field value:" +-+ vs
src/Git.hs view
@@ -8,13 +8,14 @@ gitMergeable, gitMergeOrigin, getNewerBranch,- newerMergeable,+ mergeable, gitFetchSilent, gitPush, gitRepoName, Commit(commitRef,commitLog), showCommit, displayCommits,+ displayHdrCommits, gitOneLineLog, gitShortLogN, gitShortLog1,@@ -46,6 +47,7 @@ import Branches import Common import Common.System+import Types (Package(..)) #if !MIN_VERSION_simple_cmd(0,2,2) -- | 'gitBool c args' runs git command and return result@@ -77,13 +79,12 @@ then do diff <- git "diff" [ref] unless (null diff) $ do- putStrLn $ "current branch is ahead of newer" +-+ showBranch br +-+ "!!"+ putStrLn $ showBranch target +-+ "is ahead of" +-+ ref +-+ "!!" promptEnter "Press Enter if you want to continue"- else putStrLn $ "current branch" +-+ "is diverged from" +-+ showBranch br+ else putStrLn $ "current branch" +-+ "is diverged from" +-+ ref return (mancestor, commits) --- FIXME use Package-getNewerBranch :: String -> Branch -> IO (Maybe Branch)+getNewerBranch :: Package -> Branch -> IO (Maybe Branch) getNewerBranch _ Rawhide = return Nothing getNewerBranch pkg br = do localbrs <- fedoraBranches (localBranches False)@@ -92,7 +93,7 @@ if newer `elem` localbrs then return $ Just newer else do- remotebrs <- fedoraBranches (pagurePkgBranches pkg)+ remotebrs <- listRemoteBranches (unPackage pkg) if newer `elem` remotebrs then do gitFetchSilent False@@ -110,18 +111,24 @@ 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 =+mergeable :: Package -> Branch -> Maybe Branch -> IO (Maybe Bool,[Commit],Branch)+mergeable pkg br Nothing = if br == Rawhide- then return (False,[],Nothing)+ then return (Nothing,[],br) else do mnewer <- getNewerBranch pkg br case mnewer of Just newer -> do (mancestor,commits) <- gitMergeable br newer- return (mancestor == Just True, commits, Just newer)- Nothing -> return (False,[],Nothing)+ return (mancestor, commits, newer)+ Nothing -> return (Nothing,[],br)+-- FIXME check from exists+mergeable _pkg br (Just from) =+ if br == from+ then error' "cannot merge to same branch!"+ else do+ (mancestor,commits) <- gitMergeable br from+ return (mancestor, commits, from) data Commit = Commit { commitRef :: String,@@ -141,9 +148,14 @@ if length cs > 20 then take 20 cs ++ [":"] else cs showAll True cs = cs +displayHdrCommits :: String -> Bool -> [Commit] -> IO ()+displayHdrCommits hdr showall commits = do+ putStrLn $ pluralOnly commits hdr ++ ":"+ displayCommits showall commits+ gitOneLineLog :: String -> IO [Commit] gitOneLineLog range =- map mkCommit <$> gitLines "log" ["--pretty=format:%H (%s, %cs)", range]+ map mkCommit <$> gitLines "log" ["--pretty=format:%H (%s, %cs)", range, "--"] gitShortLogN :: Maybe Int -> Maybe String -> IO [Commit] gitShortLogN mnum mrange =@@ -168,10 +180,15 @@ (plogcs,datep) -> Commit hash (init $ tailSafe $ trim plogcs) (init datep) +-- FIXME Verbosity gitPush :: Bool -> Maybe String -> IO () gitPush quiet mref = do -- FIXME also check ref on branch checkOnBranch+ br <- getReleaseBranch+ mupstream <- cmdMaybe "git" ["rev-parse", "--abbrev-ref", showBranch br ++ "@{upstream}"]+ when (isNothing mupstream) $+ git_ "branch" ["--set-upstream-to=origin/" ++ showBranch br] when quiet $ sayString "git pushing" -- Can error like this:
src/Koji.hs view
@@ -26,6 +26,7 @@ TaskID, displayID, fedoraHub,+ getKojiProfileHub, maybeTimeout, createKojiSidetag, targetMaybeSidetag@@ -47,6 +48,7 @@ import Safe (headMay, tailSafe) import Say (sayString) import SimplePrompt (promptEnter, promptNonEmpty, yesNo)+import System.Environment (lookupEnv) import System.Exit import System.Process.Typed import System.Timeout (timeout)@@ -56,27 +58,55 @@ import Common import Common.System import Git-import Package (fedpkg, Package, unPackage)+import Package (fedpkg) import Pagure import Types fedoraHub :: String fedoraHub = fedoraKojiHub +getKojiProfile :: IO (Maybe String)+getKojiProfile = lookupEnv "FBRNCH_KOJI_PROFILE"++getKojiProfileHub' :: Maybe String -> IO String+getKojiProfileHub' mprofile = do+ case mprofile of+ Nothing -> return fedoraKojiHub+ Just p -> do+ let file = "/etc/koji.conf.d" </> p <.> "conf"+ exists <- doesFileExist file+ if exists+ then do+ serv <- grep "^server =" $ "/etc/koji.conf.d" </> p <.> "conf"+ case serv of+ [sl] ->+ case words sl of+ ["server","=",hub] -> return hub+ _ -> error' $ "Invalid server config in" +-+ file+ _ -> error' $ "Undefined server in" +-+ file+ else error' $ "Undefined koji profile:" +-+ p++getKojiProfileHub :: IO String+getKojiProfileHub =+ getKojiProfile >>= getKojiProfileHub'+ kojiNVRTags :: NVR -> IO [String] kojiNVRTags nvr = do- mbldid <- kojiGetBuildID fedoraHub $ showNVR nvr+ hub <- getKojiProfileHub+ mbldid <- kojiGetBuildID hub $ showNVR nvr case mbldid of Nothing -> error' $ showNVR nvr +-+ "koji build not found"- Just bldid -> kojiBuildTags fedoraHub (buildIDInfo bldid)+ Just bldid -> kojiBuildTags hub (buildIDInfo bldid) kojiBuildStatus :: NVR -> IO (Maybe BuildState)-kojiBuildStatus nvr =- kojiGetBuildState fedoraHub (BuildInfoNVR (showNVR nvr))+kojiBuildStatus nvr = do+ hub <- getKojiProfileHub+ kojiGetBuildState hub (BuildInfoNVR (showNVR nvr)) kojiLatestNVR :: String -> String -> IO (Maybe NVR) kojiLatestNVR tag pkg = do- mbld <- kojiLatestBuild fedoraHub tag pkg+ hub <- getKojiProfileHub+ mbld <- kojiLatestBuild hub tag pkg return $ case mbld of Nothing -> Nothing Just bld -> lookupStruct "nvr" bld >>= maybeNVR@@ -84,12 +114,13 @@ kojiOpenTasks :: Package -> Maybe String -> String -> IO [TaskID] kojiOpenTasks pkg mref target = do+ hub <- getKojiProfileHub user <- fasIdFromKrb- muserid <- kojiGetUserID fedoraHub user+ muserid <- kojiGetUserID hub user let userid = fromMaybe (error' $ "Koji failed to return userid for '" ++ user ++ "'") muserid commit <- maybe (git "rev-parse" ["HEAD"]) return mref let source = kojiSource pkg commit- kojiUserBuildTasks fedoraHub userid (Just source) (Just target)+ kojiUserBuildTasks hub userid (Just source) (Just target) -- * Koji building @@ -109,11 +140,12 @@ else ".src.rpm" `isSuffixOf` last args -- FIXME use tee functionality when srpm $ putStrLn "koji srpm build: uploading..."+ mprofile <- getKojiProfile -- can fail like: -- [ERROR] koji: Request error: POST::https://koji.fedoraproject.org/kojihub/ssllogin::<PreparedRequest [POST]> -- [ERROR] koji: AuthError: unable to obtain a session -- readCreateProcess: koji "build" "--nowait" "f33-build-side-25385" "--fail-fast" "--background" ... (exit 1): failed- (ret,out) <- readProcessStdout $ proc "koji" $ ["build", "--nowait", target] ++ args+ (ret,out) <- readProcessStdout $ proc "koji" $ kojiProfileOpt mprofile ++ ["build", "--nowait", target] ++ args -- for srpm: drop uploading line until doing tee -- for git: drop "Created task: " -- init to drop final newline@@ -138,24 +170,29 @@ -- Right url <- kojiBuild' True target args -- return url +kojiProfileOpt :: Maybe String -> [String]+kojiProfileOpt Nothing = []+kojiProfileOpt (Just p) = ["--profile", p]+ -- FIXME filter/simplify output -- FIXME implement native watchTask kojiWatchTask :: TaskID -> IO () kojiWatchTask task = do+ mprofile <- getKojiProfile -- FIXME can error: -- eg1 [ERROR] koji: HTTPError: 503 Server Error: Service Unavailable for url: https://koji.fedoraproject.org/kojihub -- eg2 [ERROR] koji: ServerOffline: database outage: - user error (Error 1014: database outage) -- eg3 [ERROR] koji: ReadTimeout: HTTPSConnectionPool(host='koji.fedoraproject.org', port=443): Read timed out. (read timeout=43200) -- This might error with exit 0 occasionally so we check the taskstate always- void $ cmdBool "koji" ["watch-task", displayID task]- mst <- kojiGetTaskState fedoraHub task+ void $ cmdBool "koji" $ kojiProfileOpt mprofile ++ ["watch-task", displayID task]+ hub <- getKojiProfileHub' mprofile+ mst <- kojiGetTaskState hub task case mst of Just TaskClosed -> return () Just TaskFailed -> do whenJustM (findExecutable "koji-tool") $ \kojitool -> do- -- FIXME cmdLog deprecated- cmdLog kojitool ["tasks", "--children", displayID task, "--tail", "-s", "fail"]- putTaskinfoUrl fedoraHub task+ cmdLog_ kojitool ["tasks", "--hub", hub, "--children", displayID task, "--tail", "-s", "fail"]+ putTaskinfoUrl hub task error' "Task failed!" Just TaskCanceled -> return () _ -> kojiWatchTask task@@ -170,10 +207,11 @@ -- Network.Socket.connect: <socket: 11>: does not exist (No route to host) kojiWaitTask :: TaskID -> IO Bool kojiWaitTask task = do+ hub <- getKojiProfileHub -- FIXME can error: -- eg1 [ERROR] koji: HTTPError: 503 Server Error: Service Unavailable for url: https://koji.fedoraproject.org/kojihub -- eg2 [ERROR] koji: ServerOffline: database outage: - user error (Error 1014: database outage)- mst <- maybeTimeout 45 $ kojiGetTaskState fedoraHub task+ mst <- maybeTimeout 45 $ kojiGetTaskState hub task case mst of Just ts -> if ts `elem` openTaskStates@@ -220,7 +258,8 @@ kojiWaitRepoNVRs :: Bool -> Bool -> String -> [NVR] -> IO () kojiWaitRepoNVRs _ _ _ [] = error' "no NVRs given to wait for" kojiWaitRepoNVRs dryrun quiet target nvrs = do- (buildtag,_desttag) <- kojiBuildTarget' fedoraHub target+ hub <- getKojiProfileHub+ (buildtag,_desttag) <- kojiBuildTarget' hub target unless dryrun $ do tz <- getCurrentTimeZone unless quiet $@@ -228,10 +267,12 @@ case nvrs of [nvr] -> showNVR nvr _ -> "builds"+ mprofile <- getKojiProfile -- FIXME use knowntag to quieten output: for override outputs, eg -- "nvr ghc-rpm-macros-2.7.5-1.fc41 is not current in tag f41-build -- latest build is ghc-rpm-macros-2.7.2-4.fc41"- void $ timeIO $ cmd "koji" (["wait-repo", "--request", "--quiet"] ++ ["--build=" ++ showNVR nvr | nvr <- nvrs] ++ [buildtag])+ -- or "No clang18 builds in tag epel10.1-build"+ void $ timeIO $ cmd "koji" (kojiProfileOpt mprofile ++ ["wait-repo", "--request", "--quiet"] ++ ["--build=" ++ showNVR nvr | nvr <- nvrs] ++ [buildtag]) kojiWaitRepoNVR :: Bool -> Bool -> String -> NVR -> IO () kojiWaitRepoNVR dryrun quiet target nvr =@@ -240,31 +281,35 @@ -- FIXME display more status/age info kojiWaitRepo :: Bool -> Bool -> String -> IO () kojiWaitRepo dryrun quiet target = do- (buildtag,_desttag) <- kojiBuildTarget' fedoraHub target+ hub <- getKojiProfileHub+ (buildtag,_desttag) <- kojiBuildTarget' hub target tz <- getCurrentTimeZone unless quiet $ logSay tz $ "Waiting for" +-+ buildtag- unless dryrun $- void $ timeIO $ cmd "koji" ["wait-repo", "--request", "--quiet", buildtag]+ unless dryrun $ do+ mprofile <- getKojiProfile+ void $ timeIO $ cmd "koji" $ kojiProfileOpt mprofile ++ ["wait-repo", "--request", "--quiet", buildtag] kojiTagArchs :: String -> IO [String] kojiTagArchs tag = do- st <- Koji.getTag fedoraHub (Koji.InfoString tag) Nothing+ hub <- getKojiProfileHub+ st <- Koji.getTag hub (Koji.InfoString tag) Nothing return $ maybe [] words $ lookupStruct "arches" st kojiUserSideTags :: Maybe Branch -> IO [String] kojiUserSideTags mbr = do+ hub <- getKojiProfileHub user <- fasIdFromKrb mapMaybe (headMay . words) <$> case mbr of Nothing -> do- maybeTimeout 55 $ kojiListSideTags fedoraKojiHub Nothing (Just user)+ maybeTimeout 55 $ kojiListSideTags hub Nothing (Just user) Just br -> do- mtags <- kojiBuildTarget fedoraHub (showBranch br)+ mtags <- kojiBuildTarget hub (showBranch br) case mtags of Nothing -> return [] Just (buildtag,_desttag) ->- kojiListSideTags fedoraKojiHub (Just buildtag) (Just user)+ kojiListSideTags hub (Just buildtag) (Just user) maybeTimeout :: Micro -> IO a -> IO a maybeTimeout secs act = do@@ -277,7 +322,8 @@ createKojiSidetag :: Bool -> Branch -> IO String createKojiSidetag dryrun br = do- (buildtag,_desttag) <- kojiBuildTarget' fedoraHub (showBranch br)+ hub <- getKojiProfileHub+ (buildtag,_desttag) <- kojiBuildTarget' hub (showBranch br) out <- if dryrun then return $ "Side tag '" ++ buildtag ++ "'"@@ -295,7 +341,7 @@ putStrLn $ "Sidetag" +-+ sidetag +-+ "created" -- logMsg $ "Waiting for" +-+ sidetag +-+ "repo" -- unless dryrun $- -- cmd_ "koji" ["wait-repo", sidetag]+ -- cmd_ koji ["wait-repo", sidetag] return sidetag else error' "'fedpkg request-side-tag' failed"
src/ListReviews.hs view
@@ -90,4 +90,4 @@ branched pkg = not <$> notBranched pkg notBranched :: String -> IO Bool- notBranched pkg = null <$> fedoraBranchesNoRawhide (pagurePkgBranches pkg)+ notBranched pkg = null . delete Rawhide <$> listRemoteBranches pkg
src/Main.hs view
@@ -8,17 +8,20 @@ #if !MIN_VERSION_simple_cmd_args(0,1,7) import Options.Applicative (maybeReader, ReadM) #endif-import SelectRPMs (existingStrategyOption, selectRpmsOptions, Yes(..))+import SelectRPMs (existingStrategyOption, pkgMgrOpt, selectRpmsOptions,+ Yes(..)) import SimpleCmdArgs -- commands import Cmd.Autospec+import Cmd.BranchLogs import Cmd.Bugs import Cmd.Build import Cmd.Bump import Cmd.Clone import Cmd.Commit-import Cmd.Compare+import Cmd.CompareBranches+import Cmd.CompareTarballs import Cmd.CreateReview import Cmd.Copr import Cmd.Diff@@ -37,7 +40,7 @@ import Cmd.Prep import Cmd.Pull import Cmd.Push---import Cmd.Repoquery+import Cmd.Repoquery import Cmd.RequestBranch import Cmd.RequestRepo import Cmd.ReviewPackage@@ -78,6 +81,7 @@ switchCmd <$> verboseOpt "verbose output" <*> switchLongWith "lenient" "keep going if package missing branch"+ <*> switchLongWith "stash" "git stash local changes" <*> anyBranchArg <*> manyPackages , Subcommand "nvr" "Print name-version-release" $@@ -89,6 +93,13 @@ <*> switchWith 'r' "reviews" "Status of reviewed packages" <*> switchWith 'l' "latest-commit" "Show the last commit" <*> branchesPackages+ , Subcommand "branch-log" "Show log with branches decor" $+ branchLogCmd+ <$> switchLongWith "latest" "Find related branches"+ <*> switchLongWith "inactive" "Include old inactive branches"+ -- FIXME currently actually no-op+ <*> pure False --switchWith 'n' "no-simplify-by-decoration" "Do not filter for decorated commits"+ <*> branchesPackages , Subcommand "merge" "Merge from newer branch" $ mergeCmd <$> dryrunOpt "Dry run (do not merge)"@@ -129,6 +140,7 @@ parallelBuildCmd <$> dryrunOpt "Dry run: do not build anything" <*> mergeOpt+ <*> optional (optionWith branchM 'f' "from" "BRANCH" "Branch to merge from [default newer]") <*> 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"@@ -229,13 +241,18 @@ <*> many diffFilterOpt <*> optional (optionWith anyBranchM 'w' "with-branch" "BRANCH" "Compare with BRANCH") <*> maybeBranchPackages False- , Subcommand "compare" "Show commits between branches" $- compareCmd+ , Subcommand "compare-branches" "Show commits between branches" $+ compareBranchesCmd <$> switchWith 'l' "long" "show full commit log" <*> optional (strOptionWith 'i' "ignore" "SUBSTRING" "Matching substring to ignore") <*> anyBranchArg <*> anyBranchArg <*> manyPackages+ , Subcommand "compare-tarballs" "Diff source tarballs" $+ compareTarballsCmd+ <$> optional (optionLongWith auto "max-line-length" "LENGTH" "Skip diff files longer than this [default 200]")+ <*> optional (strArg "[NAME-]VERSION1")+ <*> optional (strArg "[NAME-]VERSION2") , Subcommand "src-deps" "List source package dependencies" $ srcDepsCmd <$> switchWith 'r' "reverse" "Reverse dependencies"@@ -266,7 +283,9 @@ <*> jobsOpt <*> optional forceshortOpt <*> many bcondOpt+ <*> optional pkgMgrOpt <*> switchWith 'r' "reinstall" "reinstall rpms"+ <*> switchLongWith "allow-erasing" "use dnf --allowerasing" <*> 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"@@ -296,6 +315,7 @@ , Subcommand "commit" "Git commit packages" $ commitCmd <$> dryrunOpt "Dry run: do not commit"+ <*> switchWith 'b' "branched" "Commit to branched dist-git" <*> optional commitOpts <*> switchWith '1' "first-line" "use first line of changelog" <*> switchWith 'a' "unstaged" "include unstaged changes"@@ -384,7 +404,11 @@ <$> dryrunOpt "Dry run: do not build" <*> (flagWith' ListChroots 'l' "list-chroots" "Show project chroots" <|> flagLongWith' CoprNew "new" "Create new copr repo" <|>- flagWith CoprBuild CoprMonitor 'm' "monitor" "Show project chroots")+ -- FIXME: NonEmpty String+ flagWith' CoprMonitor 'm' "monitor" "Show project chroots" <*> optional (strOptionLongWith "filter" "NEEDLE" "Filter to results matching NEEDLE") <*> switchLongWith "name-only" "Only print package names" <|>+ flagLongWith' CoprFailures "failures" "Show build failures with build.log tails" <*> optional (strOptionLongWith "filter" "NEEDLE" "Filter to results matching NEEDLE") <|>+ -- FIXME: NonEmpty String+ pure CoprBuild) <*> forceOpt "build even if existing n-v-r" <*> optional buildByOpt <*> optional archesOpt@@ -400,10 +424,10 @@ graphCmd <$> switchWith 'o' "output" "Output graph in gv/dot format" <*> optional rpmWithOpt <*> maybeBranchPackages True- -- , Subcommand "repoquery" "Repoquery branches (put repoquery options after '--')" $- -- repoqueryCmd- -- <$> branchesPackages- , Subcommand "ftbfs" "Check FTBFS status" $+ , Subcommand "repoquery" "Repoquery branches (put repoquery options after '--')" $+ repoqueryCmd+ <$> branchesPackages+ , Subcommand "ftbfs" "Check FTBFS bug status" $ ftbfsCmd <$> dryrunOpt "dry run" <*> switchWith 'l' "short" "Only list packages"@@ -567,12 +591,14 @@ buildOpts = BuildOpts <$> mergeOpt+ <*> optional (optionWith branchM 'f' "from" "BRANCH" "Branch to merge from [default newer]") <*> noFailFastOpt <*> optional (sidetagTargetOpt Nothing) <*> overrideOpt <*> waitrepoOpt <*> dryrunOpt "Dry run: do not merge/push/build" <*> skipFetchOpt+ <*> gitrefOpt <*> updateOpt <*> optional notesOpt <*> switchWith 'p' "by-package" "Build by each package across brs"@@ -583,6 +609,7 @@ waitrepoOpt = optional (flagWith' True 'w' "waitrepo" "Waitrepo for each build" <|> flagWith' False 'W' "no-waitrepo" "Do not waitrepo for each build")+ gitrefOpt = optional (strOptionLongWith "ref" "COMMIT" "commit to build") notesOpt = flagWith' NotesChangelog 'c' "changelog-notes" "Use spec changelog for Bodhi notes" <|> NotesText <$> strOptionLongWith "notes" "NOTES" "Bodhi update notes"
src/Package.hs view
@@ -41,12 +41,13 @@ pkgNameVerRel', pkgNameVerRelNodist, pkgNameVerRelDist,+ pkgVersion, equivNVR, editSpecField, isAutoChangelog, isAutoRelease, calculateRelease,- autoReleaseBump,+ autoReleaseReset, sourceFieldFile, isArchiveFile, sourceDirCwdOpt@@ -63,7 +64,7 @@ import Common import Common.System import Git-import Types (ChangeType(..))+import Types (ChangeType(..), Package(..)) fedpkg :: String -> [String] -> IO String fedpkg c args =@@ -191,9 +192,6 @@ commits <- length <$> gitShortLogN (Just 2) Nothing return $ commits <= 1 -newtype Package = Package {unPackage :: String}- deriving Eq- putPkgHdr :: Package -> IO () putPkgHdr pkg = putStrLn $ "\n=" +-+ unPackage pkg +-+ "="@@ -388,8 +386,8 @@ matches <- filter ("Release:" `isPrefixOf`) <$> grep "%autorelease" spec return $ not (null matches) -autoReleaseBump :: FilePath -> IO Bool-autoReleaseBump spec = do+autoReleaseReset :: FilePath -> IO Bool+autoReleaseReset spec = do matches <- filter ("Release:" `isPrefixOf`) <$> grep "%autorelease" spec return $ case matches of@@ -461,6 +459,16 @@ case mnvr of Nothing -> error' $ "rpmspec failed to parse" +-+ spec Just nvr -> return nvr++pkgVersion :: FilePath -> IO String+pkgVersion spec = do+ --dist <- branchDist br+ -- workaround dist with bootstrap+ --hostdist <- cmd "rpm" ["--eval", "%{dist}"]+ mvr <- cmdMaybe "rpmspec" ["-q", "--srpm", "--qf", "%{version}", spec]+ case mvr of+ Nothing -> error' $ "Failed to read package version:" +-+ spec+ Just vr -> return vr -- FIXME should be more strict about dist tag (eg .fcNN only) equivNVR :: NVR -> Maybe NVR -> Bool
src/RpmBuild.hs view
@@ -2,6 +2,7 @@ builtRpms, buildRPMs, buildRPMsNoBranch,+ needToBuildRPMS, installDeps, buildRequires, getSources,@@ -28,8 +29,8 @@ import Data.RPM import Distribution.Fedora.Branch (branchDistTag, branchRelease) import Distribution.Fedora.Release (releaseVersion)-import Network.HTTP.Directory (Manager, httpExists, httpManager)-import Safe (lastMay)+import Network.HTTP.Directory (httpExists')+import Safe (lastMay, headMay) import SimpleCmd.Rpm import SimplePrompt (promptEnter, yesNo) import System.Console.Pretty@@ -281,14 +282,8 @@ Just s -> s /= ForceBuild Nothing -> False --- FIXME create build.log--- Note does not check if bcond changed--- FIXME check tarball timestamp--- FIXME handle prep (-bp) too?-buildRPMs :: Bool -> Bool -> Bool -> Maybe Natural -> Maybe ForceShort- -> [BCond] -> [FilePath] -> AnyBranch -> FilePath -> IO Bool-buildRPMs quiet debug noclean mjobs mforceshort bconds rpms br spec = do- needBuild <-+needToBuildRPMS :: Bool -> Maybe ForceShort -> [FilePath] -> FilePath -> IO Bool+needToBuildRPMS confirm mforceshort rpms spec = if isJust mforceshort then return True else do@@ -298,9 +293,24 @@ else do specTime <- getModificationTime spec rpmTimes <- sort <$> mapM getModificationTime rpms- case rpmTimes of- [] -> return True -- corner case- (rpmtime:_) -> return $ specTime > rpmtime+ case headMay rpmTimes of+ Nothing -> error' "rpms have no modification time!"+ Just rpmtime ->+ if specTime > rpmtime+ then+ if confirm+ then yesNo "Rebuild with newer spec file?"+ else return True+ else return False++-- FIXME create build.log+-- Note does not check if bcond changed+-- FIXME check tarball timestamp+-- FIXME handle prep (-bp) too?+buildRPMs :: Bool -> Bool -> Bool -> Maybe Natural -> Maybe ForceShort+ -> [BCond] -> [FilePath] -> AnyBranch -> FilePath -> IO Bool+buildRPMs quiet debug noclean mjobs mforceshort bconds rpms br spec = do+ needBuild <- needToBuildRPMS False mforceshort rpms spec if not needBuild then putStrLn "Existing rpms are newer than spec file (use --force to rebuild)" else do@@ -495,7 +505,7 @@ sourcefiles unless (null missing) $ do -- FIXME maybe change to yesNo- promptEnter $ color Red $ unwords missing +-+ "not in" +-+ unPackage pkg +-+ "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"]@@ -505,20 +515,20 @@ error' "local changes remain (dirty)" checkOnBranch checkSourcesMatch pkg br spec- mgr <- httpManager- mapM_ (checkLookasideCache mgr) sources+ mapM_ checkLookasideCache sources where- checkLookasideCache :: Manager -> String -> IO ()- checkLookasideCache mgr source = do- let (file,url) =+ checkLookasideCache :: String -> IO ()+ checkLookasideCache source = do+ let lookaside = "https://src.fedoraproject.org/lookaside/pkgs" +/+ unPackage pkg+ (file,url) = case words source of ("SHA512":('(':fileparen):"=":[hash]) -> let file' = dropSuffix ")" fileparen- in (file', "https://src.fedoraproject.org/lookaside/pkgs" +/+ unPackage pkg +/+ file +/+ "sha512" +/+ hash +/+ file)+ in (file', lookaside +/+ file' +/+ "sha512" +/+ hash +/+ file') [hash,file'] ->- (file', "https://src.fedoraproject.org/lookaside/pkgs" +/+ unPackage pkg +/+ file +/+ "md5" +/+ hash +/+ file)+ (file', lookaside +/+ file' +/+ "md5" +/+ hash +/+ file') _ -> error' $ "invalid/unknown source:\n" ++ source- unlessM (httpExists mgr url) $ do+ unlessM (httpExists' url) $ do putStrLn $ url +-+ "not found" putStrLn $ "uploading" +-+ file +-+ "to lookaside source repo" fedpkg_ "upload" [file]
src/Types.hs view
@@ -2,7 +2,8 @@ Archs(..), SideTagTarget(..), maybeTarget,- ChangeType(..)+ ChangeType(..),+ Package(..) ) where @@ -17,4 +18,7 @@ maybeTarget _ = Nothing data ChangeType = ChangeBodhi | ChangeCommit | ChangeReview+ deriving Eq++newtype Package = Package {unPackage :: String} deriving Eq