diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/fbrnch.cabal b/fbrnch.cabal --- a/fbrnch.cabal +++ b/fbrnch.cabal @@ -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 maintainer: Jens Petersen -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, diff --git a/src/Bodhi.hs b/src/Bodhi.hs --- a/src/Bodhi.hs +++ b/src/Bodhi.hs @@ -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 diff --git a/src/Branches.hs b/src/Branches.hs --- a/src/Branches.hs +++ b/src/Branches.hs @@ -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 diff --git a/src/Bugzilla.hs b/src/Bugzilla.hs --- a/src/Bugzilla.hs +++ b/src/Bugzilla.hs @@ -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) diff --git a/src/Cmd/BranchLogs.hs b/src/Cmd/BranchLogs.hs new file mode 100644 --- /dev/null +++ b/src/Cmd/BranchLogs.hs @@ -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 diff --git a/src/Cmd/Build.hs b/src/Cmd/Build.hs --- a/src/Cmd/Build.hs +++ b/src/Cmd/Build.hs @@ -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 diff --git a/src/Cmd/Commit.hs b/src/Cmd/Commit.hs --- a/src/Cmd/Commit.hs +++ b/src/Cmd/Commit.hs @@ -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 diff --git a/src/Cmd/Compare.hs b/src/Cmd/Compare.hs deleted file mode 100644 --- a/src/Cmd/Compare.hs +++ /dev/null @@ -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 diff --git a/src/Cmd/CompareBranches.hs b/src/Cmd/CompareBranches.hs new file mode 100644 --- /dev/null +++ b/src/Cmd/CompareBranches.hs @@ -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 diff --git a/src/Cmd/CompareTarballs.hs b/src/Cmd/CompareTarballs.hs new file mode 100644 --- /dev/null +++ b/src/Cmd/CompareTarballs.hs @@ -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" diff --git a/src/Cmd/Copr.hs b/src/Cmd/Copr.hs --- a/src/Cmd/Copr.hs +++ b/src/Cmd/Copr.hs @@ -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 diff --git a/src/Cmd/FTBFS.hs b/src/Cmd/FTBFS.hs --- a/src/Cmd/FTBFS.hs +++ b/src/Cmd/FTBFS.hs @@ -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"] diff --git a/src/Cmd/Install.hs b/src/Cmd/Install.hs --- a/src/Cmd/Install.hs +++ b/src/Cmd/Install.hs @@ -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 diff --git a/src/Cmd/ListBranches.hs b/src/Cmd/ListBranches.hs --- a/src/Cmd/ListBranches.hs +++ b/src/Cmd/ListBranches.hs @@ -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 diff --git a/src/Cmd/Merge.hs b/src/Cmd/Merge.hs --- a/src/Cmd/Merge.hs +++ b/src/Cmd/Merge.hs @@ -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 -> diff --git a/src/Cmd/Parallel.hs b/src/Cmd/Parallel.hs --- a/src/Cmd/Parallel.hs +++ b/src/Cmd/Parallel.hs @@ -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 diff --git a/src/Cmd/Prep.hs b/src/Cmd/Prep.hs --- a/src/Cmd/Prep.hs +++ b/src/Cmd/Prep.hs @@ -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" diff --git a/src/Cmd/Repoquery.hs b/src/Cmd/Repoquery.hs new file mode 100644 --- /dev/null +++ b/src/Cmd/Repoquery.hs @@ -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 diff --git a/src/Cmd/RequestBranch.hs b/src/Cmd/RequestBranch.hs --- a/src/Cmd/RequestBranch.hs +++ b/src/Cmd/RequestBranch.hs @@ -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" diff --git a/src/Cmd/RequestRepo.hs b/src/Cmd/RequestRepo.hs --- a/src/Cmd/RequestRepo.hs +++ b/src/Cmd/RequestRepo.hs @@ -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" diff --git a/src/Cmd/ReviewPackage.hs b/src/Cmd/ReviewPackage.hs --- a/src/Cmd/ReviewPackage.hs +++ b/src/Cmd/ReviewPackage.hs @@ -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)] diff --git a/src/Cmd/Scratch.hs b/src/Cmd/Scratch.hs --- a/src/Cmd/Scratch.hs +++ b/src/Cmd/Scratch.hs @@ -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] diff --git a/src/Cmd/Status.hs b/src/Cmd/Status.hs --- a/src/Cmd/Status.hs +++ b/src/Cmd/Status.hs @@ -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 diff --git a/src/Cmd/Switch.hs b/src/Cmd/Switch.hs --- a/src/Cmd/Switch.hs +++ b/src/Cmd/Switch.hs @@ -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 diff --git a/src/Cmd/Update.hs b/src/Cmd/Update.hs --- a/src/Cmd/Update.hs +++ b/src/Cmd/Update.hs @@ -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 diff --git a/src/Git.hs b/src/Git.hs --- a/src/Git.hs +++ b/src/Git.hs @@ -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: diff --git a/src/Koji.hs b/src/Koji.hs --- a/src/Koji.hs +++ b/src/Koji.hs @@ -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:: -- [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: : 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" diff --git a/src/ListReviews.hs b/src/ListReviews.hs --- a/src/ListReviews.hs +++ b/src/ListReviews.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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" diff --git a/src/Package.hs b/src/Package.hs --- a/src/Package.hs +++ b/src/Package.hs @@ -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 diff --git a/src/RpmBuild.hs b/src/RpmBuild.hs --- a/src/RpmBuild.hs +++ b/src/RpmBuild.hs @@ -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] diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -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