fbrnch 1.2 → 1.2.1
raw patch · 26 files changed
+680/−555 lines, 26 filesdep −unordered-containersdep ~bugzilla-redhat
Dependencies removed: unordered-containers
Dependency ranges changed: bugzilla-redhat
Files
- CHANGELOG.md +21/−3
- README.md +7/−7
- fbrnch.cabal +5/−6
- src/Bodhi.hs +2/−0
- src/Cmd/Build.hs +10/−7
- src/Cmd/Copr.hs +8/−7
- src/Cmd/Install.hs +16/−4
- src/Cmd/Local.hs +1/−0
- src/Cmd/Merge.hs +11/−9
- src/Cmd/Mock.hs +1/−0
- src/Cmd/Override.hs +55/−4
- src/Cmd/Parallel.hs +53/−25
- src/Cmd/PkgReview.hs +1/−0
- src/Cmd/Prep.hs +1/−0
- src/Cmd/RequestBranch.hs +6/−15
- src/Cmd/Scratch.hs +1/−0
- src/Cmd/SideTags.hs +3/−1
- src/Cmd/Update.hs +26/−21
- src/Cmd/WaitRepo.hs +1/−1
- src/Common.hs +2/−2
- src/Git.hs +14/−10
- src/Koji.hs +9/−2
- src/Main.hs +8/−1
- src/Package.hs +62/−428
- src/Prompt.hs +3/−2
- src/RpmBuild.hs +353/−0
CHANGELOG.md view
@@ -1,5 +1,25 @@ # Changelog +## 1.2.1 (2022-11-23)+- 'install': if dnf install fails, include command in error message+- 'override': check for kerberos ticket+- 'override': new --list and --expire option subcommands+- 'parallel': change "0 jobs left in layer" message to "end of layer"+- 'parallel': print package header for merge+- 'parallel': wait for sidetag update to transition to request testing+- 'request-branches': check package owner and admins: drop unordered-containers+- 'sidetags': ensure krb ticket+- 'update-version': now commits sources too+- 'update-version': prompt rather than warn if not updating rawhide+- Common plural: use 'no' for zero+- Git: fix conflictPrompt to handle long hashes correctly+- Prompt: use show for unprintable characters+- mergeBranch: print package branch header+- new RpmBuild module for rpm/build related functions moved from Package+- newerMergeable may now include the newer branch+- require bugzilla-redhat-1.0.1 since b.r.c dropped Bug see_also field (juhp/hsbugzilla#18)+- use logMsg when waiting for repo+ ## 1.2 (2022-11-12) - Bodhi: for template file prompt instead of using fedpkg update - Bodhi: updates need to be comma separated (#36, Otto Liljalaakso)@@ -47,14 +67,12 @@ - 'parallel': dryrun for merge and delay until bodhiSidetagUpdate - 'parallel': filter out rawhide from parallel branch package builds update (#36) - 'parallel': formatting - use +-+, plural, don't color "is already"-- 'parallel': no longer prompt for sidetag removal+- 'parallel': no longer offers sidetag removal - 'parallel': only write "in layer" if there are layers - 'parallel': print pkg brnch header before merging-- 'parallel': sidetag prompt now needs 'yes' to delete - 'request-branches/repos': check 100 fedora-scm-requests for duplicate - 'request-branches': add --quiet to suppress "exists" messages - 'request-branches': add --recurse-from BRANCH-- 'request-branches': add another fedpkg failure error - 'request-branches': do not fetch if remote branch known - 'request-branches': improve --quiet help - 'request-branches': output if exists, again
README.md view
@@ -9,7 +9,7 @@ Fedora developers use a lot of time building packages across releases and workflow for adding new packages, etc. fbrnch was made to help (semi-)automate common workflows to save time-and effort.+and effort, and avoid common some mistakes. fbrnch is distributed under the GPL license version 2 or later. @@ -185,8 +185,8 @@ unless using `--no-merge` (though you may prefer to run `fbrnch merge <branch> ...` first instead). -Except for rawhide using a sidetag is required.-If you have more than one branch active sidetag for a branch,+Except for rawhide using a --sidetag or --target is required.+If you have more than one active sidetag for a branch, you can select one using `--target`. After parallel building you can create a Bodhi update from the sidetag.@@ -257,7 +257,7 @@ ``` $ fbrnch --version-1.2+1.2.1 $ fbrnch --help Fedora branch building tool @@ -332,7 +332,7 @@ 3. Then either: -a) using stack >= 2.1: `stack install`+a) using stack (probably 2.3 or later): `stack install` or @@ -417,9 +417,9 @@ and gradually more features, including some generic commands across packages inspired by the older fedora-haskell-tools project. -I have given a couple of short talks about fbranch:+I have given a couple of short talks about fbrnch: - Nest with Fedora: [youtube](https://www.youtube.com/watch?v=40kTBsA674U) and [slides](https://github.com/juhp/presentations/blob/master/fedora-nest-2020-fbrnch/fbrnch-nest.md)-- Lightning talk at devconf.cz 2021: [youtube](https://www.youtube.com/watch?v=O2-6rDuPMRA&t=2s)+- Lightning talk for devconf.cz 2021: [youtube](https://www.youtube.com/watch?v=O2-6rDuPMRA&t=2s) ## Contribute Bug reports, feedback, and pull requests are all highly appreciated.
fbrnch.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.0 name: fbrnch-version: 1.2+version: 1.2.1 synopsis: Fedora packager tool to build package branches description: fbrnch (fedora branch) is a convenient packaging tool for@@ -32,8 +32,8 @@ build-type: Simple extra-doc-files: CHANGELOG.md README.md-tested-with: GHC == 7.10.3, 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+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.5 source-repository head type: git@@ -93,6 +93,7 @@ Paths_fbrnch Prompt Repoquery+ RpmBuild Types hs-source-dirs: src@@ -103,7 +104,7 @@ -- pretty-terminal depends on base >= 4.9 (ghc8) base >= 4.9 && < 5, bodhi,- bugzilla-redhat >= 1.0,+ bugzilla-redhat >= 1.0.1, bytestring, config-ini, copr-api,@@ -129,8 +130,6 @@ text, time, typed-process >= 0.2.4.0,- -- for aeson-1 compatibility:- unordered-containers, utf8-string, unix, xdg-basedir
src/Bodhi.hs view
@@ -162,6 +162,8 @@ warning "overriding update type with 'newpackage'" putStrLn $ "Creating Bodhi Update for " ++ nvrs ++ ":" -- FIXME check for Bodhi URL to confirm update+ -- FIXME returns json error string if it exists:+ -- {"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", changelog, "--autokarma", "--autotime", "--close-bugs"] ++ bugs ++ [nvrs] return True when updatedone $ do
src/Cmd/Build.hs view
@@ -17,6 +17,7 @@ import Koji import Package import Prompt+import RpmBuild (checkSourcesMatch) import Types data BuildOpts = BuildOpts@@ -33,6 +34,7 @@ , buildoptAllowDirty :: Bool } +-- FIXME merge --from -- FIXME check bugs before building? -- FIXME --sidetag -- FIXME --sort@@ -77,24 +79,25 @@ gitMergeOrigin br newrepo <- initialPkgRepo tty <- isTty- (ancestor,unmerged) <- newerMergeable br+ (ancestor,unmerged,mnewer) <- newerMergeable br -- FIXME if already built or failed, also offer merge merged <- case buildoptMerge opts of Just False -> return False Just True -> do- whenJustM (getNewerBranch br) $ \newer ->- mergeBranch (buildoptDryrun opts) True True False (ancestor,unmerged) newer br+ whenJust mnewer $ \newer ->+ mergeBranch (buildoptDryrun opts) True True False (Just pkg) (ancestor,unmerged) newer br return True Nothing -> if ancestor && (newrepo || tty) then do- whenJustM (getNewerBranch br) $ \newer ->- mergeBranch (buildoptDryrun opts) True False True (ancestor,unmerged) newer br+ whenJust mnewer $ \newer ->+ mergeBranch (buildoptDryrun opts) True False True (Just pkg) (ancestor,unmerged) newer br return True else do unless (br == Rawhide) $- putStrLn "newer branch cannot be merged"+ whenJust mnewer $ \newer ->+ putStrLn $ show newer +-+ "branch not mergeable" return False let spec = packageSpec pkg checkForSpecFile spec@@ -114,7 +117,7 @@ -- see mergeBranch for: unmerged == 1 (774b5890) if tty && (not merged || (newrepo && ancestor && length unmerged == 1)) then do- refPrompt unpushed $ "Press Enter to push and build" ++ (if length unpushed > 1 then "; or give a ref to push" else "") ++ (if not newrepo then "; or 'no' to skip pushing" else "")+ refPrompt unpushed $ "Press Enter to push and build" ++ (if length unpushed > 1 then "; or give ref to push" else "") ++ (if not newrepo then "; or 'no' to skip pushing" else "") else return $ Just $ commitRef $ head unpushed let dryrun = buildoptDryrun opts buildstatus <- maybeTimeout 30 $ kojiBuildStatus nvr
src/Cmd/Copr.hs view
@@ -7,19 +7,20 @@ ) where -import Branches-import Common-import Common.System-import qualified Common.Text as T-import Package-import Types (Archs(..))- import Data.Ini.Config import Network.HTTP.Query (lookupKey, lookupKey') import System.Environment.XDG.BaseDir (getUserConfigDir) import System.Time.Extra (sleep) import Web.Fedora.Copr (coprChroots, fedoraCopr) import Web.Fedora.Copr.API (coprGetBuild)++import Branches+import Common+import Common.System+import qualified Common.Text as T+import Package+import RpmBuild (generateSrpm)+import Types (Archs(..)) data BuildBy = SingleBuild | ValidateByRelease | ValidateByArch | BuildByRelease deriving (Eq)
src/Cmd/Install.hs view
@@ -13,7 +13,10 @@ import Package import Prompt import Repoquery+import RpmBuild +-- FIXME --force removal of existing incompatible dependent packages+-- FIXME --subpackage to specify subpackage(s) to install/add -- FIXME --ignore-uninstalled subpackages -- FIXME --skip-unavailable -- FIXME --check any/all of package installed@@ -68,7 +71,7 @@ ps <- filterM (pkgInstalled . rpmName . readNVRA) rpms return $ if null ps then rpms else ps if reinstall || mforceshort' == Just ForceBuild- then do+ then do let reinstalls = filter (\ f -> readNVRA f `elem` already) toinstalls unless (null reinstalls) $@@ -76,11 +79,12 @@ let remaining = filterDebug $ toinstalls \\ reinstalls unless (null remaining) $ sudo_ "/usr/bin/dnf" $ "install" : "-q" : "-y" : remaining- else do- ok <- cmdBool "sudo" $ "/usr/bin/dnf" : "install" : "-q" : "-y" : filterDebug toinstalls+ else do+ let command = "/usr/bin/dnf" : "install" : "-q" : "-y" : filterDebug toinstalls+ ok <- cmdBool "sudo" command unless ok $ if wasbuilt- then error' "build failed to install"+ then error' $ "error from:" +-+ unwords command else do prompt_ "Press Enter to rebuild package" doInstallPkg (Just ForceBuild) spec rpms already@@ -132,3 +136,11 @@ if null older then putStrLn $ unPackage pkg else putStrLn $ " " ++ unPackage pkg++nvraInstalled :: NVRA -> IO Bool+nvraInstalled rpm =+ cmdBool "rpm" ["--quiet", "-q", showNVRA rpm]++pkgInstalled :: String -> IO Bool+pkgInstalled pkg =+ cmdBool "rpm" ["--quiet", "-q", pkg]
src/Cmd/Local.hs view
@@ -19,6 +19,7 @@ import Common.System import Git import Package+import RpmBuild localCmd :: Bool -> Bool -> Maybe ForceShort -> [BCond] -> (BranchesReq, [String]) -> IO ()
src/Cmd/Merge.hs view
@@ -22,7 +22,7 @@ runMergeBranch :: Package -> AnyBranch -> IO () runMergeBranch _ (OtherBranch _) = error' "merge only defined for release branches"- runMergeBranch _pkg (RelBranch br) = do+ runMergeBranch pkg (RelBranch br) = do exists <- gitSwitchBranch' False br when exists $ do mfrom' <- if isJust mfrom@@ -35,7 +35,7 @@ gitMergeOrigin br (ancestor,unmerged) <- mergeable from br unmerged' <- filterOutTrivial mnotrivial unmerged- mergeBranch dryrun False noprompt showall (ancestor,unmerged') from br+ mergeBranch dryrun False noprompt showall (Just pkg) (ancestor,unmerged') from br where filterOutTrivial :: Maybe Natural -> [Commit] -> IO [Commit] filterOutTrivial Nothing cs = return cs@@ -58,12 +58,13 @@ gitMergeable (show from `notElem` locals) from -- FIXME return merged ref-mergeBranch :: Bool -> Bool -> Bool -> Bool+mergeBranch :: Bool -> Bool -> Bool -> Bool -> Maybe Package -> (Bool,[Commit]) -- (ancestor,unmerged) -> Branch -> Branch -> IO ()-mergeBranch _ _ _ _ _ _ Rawhide = return ()-mergeBranch _ _ _ _ (_,[]) _ _ = return ()-mergeBranch dryrun build noprompt showall (True, unmerged) from br = do+mergeBranch _ _ _ _ _ _ _ Rawhide = return ()+mergeBranch _ _ _ _ _ (_,[]) _ _ = return ()+mergeBranch dryrun build noprompt showall mpkg (True, unmerged) from br = do+ whenJust mpkg $ flip putPkgBrnchHdr br isnewrepo <- initialPkgRepo putStrLn $ (if isnewrepo || noprompt then "Merging from" else "New commits in") ++ " " ++ show from ++ ":" displayCommits showall unmerged@@ -76,7 +77,7 @@ then return $ Just $ commitRef (head unmerged) else refPrompt unmerged ("Press Enter to merge " ++ show from ++ (if build then " and build" else "") ++- (if length unmerged > 1 then "; or give a ref to merge" else "") +++ (if length unmerged > 1 then "; or give ref to merge" else "") ++ "; or 'no' to skip merge") -- ensure still on same branch! gitSwitchBranch (RelBranch br)@@ -86,7 +87,8 @@ git_ "fetch" ["origin", show from ++ ":" ++ show from] unless dryrun $ git_ "merge" ["--quiet", ref]-mergeBranch dryrun build noprompt showall (False,unmerged) from br = do+mergeBranch dryrun build noprompt showall mpkg (False,unmerged) from br = do+ whenJust mpkg $ flip putPkgBrnchHdr br putStrLn $ show from ++ " branch is not directly mergeable:" displayCommits False unmerged putNewLn@@ -96,7 +98,7 @@ displayCommits showall unpushed mmerge <- if noprompt then return Nothing- else conflictPrompt unmerged $ "Press Enter to skip merge" ++ (if build then " and build" else "") ++ "; or give a ref or 'HEAD' to attempt merge"+ else conflictPrompt unmerged $ "Press Enter to skip merge" ++ (if build then " and build" else "") ++ "; or give ref or 'HEAD' to attempt merge" -- ensure still on same branch! gitSwitchBranch (RelBranch br) whenJust mmerge $ \ ref ->
src/Cmd/Mock.hs view
@@ -11,6 +11,7 @@ import Common.System import Git import Package+import RpmBuild (generateSrpm) data NoClean = NoCleanBefore | NoCleanAfter | NoCleanAll | MockShortCircuit deriving Eq
src/Cmd/Override.hs view
@@ -1,6 +1,15 @@-module Cmd.Override (overrideCmd)+{-# LANGUAGE OverloadedStrings #-}++module Cmd.Override (+ overrideCmd,+ OverrideMode(..)+ ) where +import Data.Aeson (Object)+import Fedora.Bodhi (bodhiOverrides)+import Network.HTTP.Query+ import Common import Common.System @@ -9,11 +18,18 @@ import Cmd.WaitRepo (waitrepoCmd, WaitFetch(WaitNoFetch)) import Git import Koji+import Krb (krbTicket) import Package+import Prompt (yesno) --- FIXME option to expire (all) overrides-overrideCmd :: Bool -> Maybe Int -> Bool -> (BranchesReq, [String]) -> IO ()-overrideCmd dryrun mduration nowait breqpkgs = do+data OverrideMode = OverrideCreate | OverrideList | OverrideExpire+ deriving Eq++-- FIXME debug option?+overrideCmd :: Bool -> OverrideMode -> Maybe Int -> Bool+ -> (BranchesReq, [String]) -> IO ()+overrideCmd dryrun OverrideCreate mduration nowait breqpkgs = do+ krbTicket unless nowait $ putStrLn "Overriding" withPackagesByBranches HeaderMay False cleanGitFetchActive AnyNumber overrideBranch breqpkgs@@ -33,3 +49,38 @@ unless (any (`elem` tags) [show br, show br ++ "-updates", show br ++ "-override"]) $ unlessM (checkAutoBodhiUpdate br) $ bodhiCreateOverride dryrun mduration nvr+overrideCmd _dryrun OverrideList _mduration _nowait (_breq,pkgs) =+ withPackages pkgs $+ packageOverrides >=> mapM_ showOverride+ where+ showOverride override =+ case (lookupKey "expired_date" override :: Maybe String) of+ Just _expiry -> return ()+ Nothing ->+ whenJust (lookupKey "nvr" override) $ \nvr ->+ putStrLn $ nvr +-++ fromMaybe "" (lookupKey "expiration_date" override :: Maybe String)+overrideCmd _dryrun OverrideExpire _mduration _nowait (_breq,pkgs) =+ withPackages pkgs $+ packageOverrides >=> mapM_ expireOverride+ where+ expireOverride override =+ case (lookupKey "expired_date" override :: Maybe String) of+ Just _expired -> return ()+ Nothing -> do+ whenJust (lookupKey "nvr" override) $ \nvr -> do+ ok <- yesno $ "Expire override" +-+ nvr+ when ok $+ cmd_ "bodhi" ["overrides", "edit", "--expire", nvr]++withPackages :: [FilePath] -> (Package -> IO ()) -> IO ()+withPackages pkgs act =+ forM_ pkgs $ \pkgdir ->+ withExistingDirectory pkgdir $+ getPackageName "." >>= act++packageOverrides :: Package -> IO [Object]+packageOverrides pkg =+ -- FIXME could filter by "releases" for Branch's+ bodhiOverrides [makeItem "packages" (unPackage pkg),+ makeItem "expired" "0"]
src/Cmd/Parallel.hs view
@@ -1,16 +1,18 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP, OverloadedStrings #-} module Cmd.Parallel ( parallelBuildCmd,- SideTagTarget(..) ) where import Common import Common.System import Control.Concurrent.Async+import Data.Aeson (Object,Value(String))+import qualified Data.Text as T import Distribution.RPM.Build.Order (dependencyLayers) import Fedora.Bodhi hiding (bodhiUpdate)+import qualified Fedora.Bodhi as FedoraBodhi (bodhiUpdate) import System.Console.Pretty import System.Time.Extra (sleep) @@ -22,6 +24,7 @@ import Krb import Koji import Package+import RpmBuild (checkSourcesMatch) import Prompt import Types @@ -31,13 +34,16 @@ } type JobAsync = (String, Async JobDone) +-- FIXME offer to untag overrides afterwards+-- FIXME merge --from -- FIXME print koji url of failed process or use koji-tool -- FIXME option to build multiple packages over branches in parallel -- FIXME use --wait-build=NVR -- FIXME check sources as early as possible--- FIXME --single-layer to build packages at once regardless+-- FIXME --ignore-dependencies to build packages at once regardless -- FIXME time builds -- FIXME copy bodhi notes from another branch update+-- FIXME support non-sidetag update for parallel packages parallelBuildCmd :: Bool -> Maybe Bool -> Int -> Maybe SideTagTarget -> (Maybe UpdateType, UpdateSeverity) -> (BranchesReq, [String]) -> IO ()@@ -60,14 +66,16 @@ when (isJust mtarget && length branches > 1) $ error' "You can only specify target with one branch" case pkgs of- [] -> parallelBranches "." branches+ [] -> getPackageName "." >>= parallelBranches branches [p] -> withExistingDirectory p $- parallelBranches p branches+ getPackageName p >>= parallelBranches branches _ -> forM_ branches $ \rbr -> do forM_ pkgs $ \p -> when (mmerge /= Just False) $- withExistingDirectory p $ mergeNewerBranch rbr+ withExistingDirectory p $ do+ pkg <- getPackageName p+ mergeNewerBranch (Just pkg) rbr allLayers <- dependencyLayers pkgs let layers = drop firstlayer allLayers when (isNothing msidetagTarget && length allLayers > 1) $@@ -91,14 +99,13 @@ bodhiSidetagUpdate rbr (map jobNvr nvrclogs) target $ if null input then changelog else input where- parallelBranches :: FilePath -> [Branch] -> IO ()- parallelBranches pkgdir brs = do+ parallelBranches :: [Branch] -> Package -> IO ()+ parallelBranches brs pkg = do krbTicket currentbranch <- gitCurrentBranch putStrLn $ "= Building " ++ pluralException (length brs) "branch" "branches" ++ " in parallel:" putStrLn $ unwords $ map show brs- pkg <- getPackageName pkgdir- jobs <- mapM (setupBranch pkg) brs+ jobs <- mapM setupBranch brs (failures,nvrclogs) <- timeIO $ watchJobs Nothing [] [] jobs -- switch back to the original branch when (length brs /= 1) $@@ -108,27 +115,26 @@ when (isNothing msidetagTarget) $ do let spec = packageSpec pkg bodhiUpdate dryrun mupdate Nothing False spec $- intercalate "," $- map jobNvr $+ intercalate "," . map jobNvr $ filter ((/= Rawhide) . jobBranch) nvrclogs where -- FIXME time jobs- setupBranch :: Package -> Branch -> IO JobAsync- setupBranch pkg br = do+ setupBranch :: Branch -> IO JobAsync+ setupBranch br = do putPkgBrnchHdr pkg br target <- targetMaybeSidetag dryrun br msidetagTarget- when (mmerge /= Just False) $ mergeNewerBranch br+ when (mmerge /= Just False) $ mergeNewerBranch Nothing br job <- startBuild Nothing 0 False False target pkg br "." >>= async unless dryrun $ sleep 3 return (show br,job) - mergeNewerBranch :: Branch -> IO ()- mergeNewerBranch br = do+ mergeNewerBranch :: Maybe Package -> Branch -> IO ()+ mergeNewerBranch mpkg br = do gitSwitchBranch (RelBranch br)- (ancestor,unmerged) <- newerMergeable br+ (ancestor,unmerged,mnewer) <- newerMergeable br unless dryrun $- whenJustM (getNewerBranch br) $ \newer -> do- mergeBranch dryrun True (mmerge == Just True) False (ancestor,unmerged) newer br+ whenJust mnewer $ \newer ->+ mergeBranch dryrun False (mmerge == Just True) False mpkg (ancestor,unmerged) newer br -- FIXME time builds or layers parallelBuild :: String -> Branch -> (Int,[[String]])@@ -186,7 +192,10 @@ Nothing -> sleep 1 >> watchJobs mlayer fails results (jobs ++ [job]) -- (nvr,changelog) Just (Right result) -> do- putStrLn $ plural (length jobs) "job" +-+ "left" +-+ maybe "" (\l -> "in layer" +-+ show l) mlayer+ putStrLn $+ if null jobs+ then "ending layer" +-+ maybe "" show mlayer+ else plural (length jobs) "job" +-+ "left" +-+ maybe "" (\l -> "in layer" +-+ show l) mlayer watchJobs mlayer fails (result:results) jobs Just (Left except) -> do print except@@ -316,8 +325,7 @@ then bodhiSidetagUpdate rbr nvrs sidetag notes else unlessM (checkAutoBodhiUpdate rbr) $ do- -- arguably we already received the Updateid from the above bodhi command,- -- but we query it here via nvr+ -- FIXME get updateid from above bodhi command output res <- bodhiUpdates [makeItem "display_user" "0", makeItem "builds" (last nvrs)] case res of [] -> do@@ -325,7 +333,27 @@ prompt_ "Press Enter to resubmit to Bodhi" bodhiSidetagUpdate rbr nvrs sidetag notes [update] ->- case lookupKey "updateid" update :: Maybe String of+ case lookupKey "updateid" update of Nothing -> error' "could not determine Update id"- Just _updateid -> return ()+ Just updateid -> do+ putStr "Waiting for sidetag update to transition to 'request testing'"+ sleep 80+ bodhiUpdateTestingRequesting 1 updateid update _ -> error' $ "impossible happened: more than one update found for " ++ last nvrs++ bodhiUpdateTestingRequesting :: Double -> String -> Object -> IO ()+ bodhiUpdateTestingRequesting retries updateid update =+ if retries > 4+ then error' "\nupdate still not in 'request testing' status"+ else+ case lookupKey "request" update of+ Just (String request) ->+ putStrLn $ "\nrequest:" +-+ T.unpack request+ _ -> do+ mupdate' <- FedoraBodhi.bodhiUpdate updateid+ case mupdate' of+ Just update' -> do+ putChar '.'+ sleep (retries * 10)+ bodhiUpdateTestingRequesting (retries + 1) updateid update'+ _ -> error' "\nfailed to get updated metadata"
src/Cmd/PkgReview.hs view
@@ -20,6 +20,7 @@ import Krb import Package import Prompt+import RpmBuild data ScratchOption = ScratchBuild | ScratchTask Int | SkipScratch deriving Eq
src/Cmd/Prep.hs view
@@ -10,6 +10,7 @@ import Git import InterleaveOutput (cmdSilent') import Package+import RpmBuild data PrepPre = PrepClone | PrepPull deriving Eq
src/Cmd/RequestBranch.hs view
@@ -5,12 +5,6 @@ requestPkgBranches ) where -#if MIN_VERSION_aeson(2,0,0)-import qualified Data.Aeson.KeyMap as M-#else-import qualified Data.HashMap.Lazy as M-import Data.Text (Text)-#endif import Network.HTTP.Query (lookupKey') import Common@@ -154,16 +148,13 @@ case epkginfo of Left err -> error' err Right pkginfo -> do- -- FIXME exclude unprivileged roles- let access = fasid `elem` concat (lookupKeyElems "access_users" pkginfo)+ let access = fasid `elem` (lookupOwnerAdmins pkginfo :: [String]) unless access $ warning $ "-" +-+ fasid +-+ "does not have access" return access where- lookupKeyElems k o =- lookupKey' k o ::-#if MIN_VERSION_aeson(2,0,0)- M.KeyMap [String]-#else- M.HashMap Text [String]-#endif+ lookupOwnerAdmins pkginfo =+ let access = lookupKey' "access_users" pkginfo+ owners = lookupKey' "owner" access+ admins = lookupKey' "admin" access+ in owners ++ admins
src/Cmd/Scratch.hs view
@@ -13,6 +13,7 @@ import Git import Koji import Package+import RpmBuild (generateSrpm) import Types (Archs(..),SideTagTarget) -- FIXME allow parallel targets
src/Cmd/SideTags.hs view
@@ -1,10 +1,11 @@ module Cmd.SideTags (sideTagsCmd) where -import Control.Monad.Extra (whenM) import SimpleCmd (cmd_) import Branches+import Common import Koji+import Krb (krbTicket) import Prompt (yesno) sideTagsCmd :: Bool -> [Branch] -> IO ()@@ -13,6 +14,7 @@ if null brs then kojiUserSideTags Nothing else concat <$> mapM (kojiUserSideTags . Just) brs+ when remove krbTicket mapM_ (if remove then removeSideTag else putStrLn) sidetags where removeSideTag :: String -> IO ()
src/Cmd/Update.hs view
@@ -10,6 +10,7 @@ import InterleaveOutput (cmdSilent') import Krb import Package+import Prompt (prompt_) import Data.RPM.VerCmp @@ -41,7 +42,7 @@ updatePkg :: Maybe String -> Package -> AnyBranch -> IO () updatePkg mver pkg br = do when (br /= RelBranch Rawhide) $- warning $ "Are you sure you want to update " ++ show br ++ "?\n"+ prompt_ $ "Are you sure you want to update " ++ show br ++ "?" spec <- if allowHEAD then findSpecfile else localBranchSpecFile pkg br@@ -59,33 +60,26 @@ error' $ "spec version already bumped to " ++ curver when (curver == nver) $ putStrLn $ "already new version " ++ curver+ let moldnewver =+ case mver of+ Just nver -> Just (curver,nver)+ Nothing ->+ case map (last . words) vdiff of+ [old,new] -> Just (old,new)+ _ -> Nothing unless onlysources $ do let (oldver,newver) =- case mver of- Just nver -> (curver,nver)- Nothing ->- case map (last . words) vdiff of- [old,new] -> (old,new)- _ -> error' "complex version change"+ fromMaybe (error' "complex version change") moldnewver -- FIXME take epoch into account when (rpmVerCompare oldver newver == GT) $ putStrLn $ "current" +-+ oldver +-+ "is newer!" putStrLn $ oldver ++ " ->\n" ++ newver- if curver /= newver- then do+ when (curver /= newver) $ do editSpecField "Version" newver spec editSpecField "Release" "0%{?dist}" spec- cmd_ "rpmdev-bumpspec" ["-c", "update to " ++ newver, spec] -- FIXME should be sure sources exists for distgit whenM (doesFileExist "sources") $ cmd_ "sed" ["-i", "/" ++ unPackage pkg ++ "-" ++ oldver ++ "./d", "sources"]- else do- versions <- changelogVersions spec- let missing = null versions || not ((newver ++ "-") `isPrefixOf` head versions)- when missing $ do- cmd_ "rpmdev-bumpspec" ["-c", "update to " ++ newver, spec]- -- FIXME need to commit after add sources- git_ "commit" ["-a", "-m", "update to " ++ newver] whenM isPkgGitSshRepo $ do -- FIXME forM_ sources <- map sourceFieldFile <$> cmdLines "spectool" ["-S", spec]@@ -105,10 +99,16 @@ cmd_ "spectool" ["-g", "-S", spec] krbTicket cmd_ "fedpkg" $ "new-sources" : filter isArchiveFile sources- putStr "Prepping... "- cmdSilent' "rpmbuild" ["-bp", spec]- putStrLn "done"- -- FIXME git amend (if previous commit was update)+ whenJust moldnewver $ \(_old,newver) -> do+ versions <- changelogVersions spec+ let missing = null versions || not ((newver ++ "-") `isPrefixOf` head versions)+ when missing $ do+ cmd_ "rpmdev-bumpspec" ["-c", "update to " ++ newver, spec]+ git_ "commit" ["-a", "-m", "update to " ++ newver]+ putStr "Prepping... "+ cmdSilent' "rpmbuild" ["-bp", spec]+ putStrLn "done"+ -- FIXME git amend (if previous commit was update) sourceFieldFile :: String -> FilePath sourceFieldFile field =@@ -142,3 +142,8 @@ editSpecField :: String -> String -> FilePath -> IO () editSpecField field new spec = cmd_ "sed" ["-i", "-e s/^\\(" ++ field ++ ":\\s\\+\\).*/\\1" ++ new ++ "/", spec]++changelogVersions :: FilePath -> IO [String]+changelogVersions spec = do+ ns <- cmdLines "rpmspec" ["-q", "--srpm", "--qf", "%{changelogname}", spec]+ return $ map (removePrefix "- " . dropWhile (/= '-')) ns
src/Cmd/WaitRepo.hs view
@@ -33,6 +33,6 @@ let spec = packageSpec pkg nvr <- pkgNameVerRel' br spec target <- targetMaybeSidetag dryrun br msidetagTarget- putStrLn $ "waiting for " ++ nvr ++ " to appear in " ++ target+ logMsg $ "waiting for " ++ nvr ++ " to appear in " ++ target timeIO $ kojiWaitRepo dryrun True target nvr
src/Common.hs view
@@ -14,7 +14,7 @@ ) where import Control.Monad.Extra -- hiding (loop)-import Data.List.Extra hiding (merge)+import Data.List.Extra hiding (list, merge) import Data.Maybe #if !MIN_VERSION_base(4,11,0)@@ -31,7 +31,7 @@ pluralException i ns ps = mconcat [- show i,+ if i == 0 then "no" else show i, " ", if i == 1 then ns else ps ]
src/Git.hs view
@@ -90,16 +90,18 @@ putStr pull -- FIXME maybe require local branch already here-newerMergeable :: Branch -> IO (Bool,[Commit])+newerMergeable :: Branch -> IO (Bool,[Commit],Maybe Branch) newerMergeable br = if br == Rawhide- then return (False,[])+ then return (False,[],Nothing) else do mnewer <- getNewerBranch br locals <- localBranches True case mnewer of- Just newer -> gitMergeable (show newer `notElem` locals) newer- Nothing -> return (False,[])+ Just newer -> do+ (ancestor,commits) <- gitMergeable (show newer `notElem` locals) newer+ return (ancestor, commits, Just newer)+ Nothing -> return (False,[],Nothing) data Commit = Commit { commitRef :: String,@@ -282,6 +284,7 @@ data CommitOpt = CommitMsg String | CommitAmend -- FIXME select ref by number+-- FIXME minimum length of hash refPrompt :: [Commit] -> String -> IO (Maybe String) refPrompt commits txt = do case map commitRef commits of@@ -298,6 +301,7 @@ Nothing -> refPrompt commits txt -- FIXME also include branch+-- FIXME minimum length of hash conflictPrompt :: [Commit] -> String -> IO (Maybe String) conflictPrompt commits txt = do case map commitRef commits of@@ -307,9 +311,9 @@ if null ref then return Nothing else- if ref `elem` commitrefs- then return $ Just ref- else- if lower ref == "head"- then return $ Just c- else conflictPrompt commits txt+ case find (ref `isPrefixOf`) commitrefs of+ Just cref -> return $ Just cref+ Nothing ->+ if lower ref == "head"+ then return $ Just c+ else conflictPrompt commits txt
src/Koji.hs view
@@ -42,7 +42,7 @@ import Common.System import Git import Krb-import Package+import Package (fedpkg, Package, unPackage) import Pagure import Prompt import Types@@ -220,6 +220,13 @@ logMsg $ "Waiting for " ++ buildtag ++ " to have " ++ nvr waitRepo buildtag mrepo + -- FIXME: obsolete by using NVR+ -- n-v-r -> n+ nameOfNVR :: String -> String+ nameOfNVR = removeSeg . removeSeg+ where+ removeSeg = init . dropWhileEnd (/= '-')+ kojiTagArchs :: String -> IO [String] kojiTagArchs tag = do st <- Koji.getTag fedoraHub (Koji.InfoString tag) Nothing@@ -266,7 +273,7 @@ putStrLn out let sidetag = init . dropWhileEnd (/= '\'') $ dropPrefix "Side tag '" out- putStrLn $ "waiting for " ++ sidetag ++ " repo"+ logMsg $ "waiting for " ++ sidetag ++ " repo" unless dryrun $ cmd_ "koji" ["wait-repo", sidetag] return sidetag
src/Main.hs view
@@ -50,8 +50,9 @@ import Common.System import Git (CommitOpt(..)) import ListReviews-import Package (ForceShort(..), BCond(..))+import RpmBuild (ForceShort(..), BCond(..)) import Paths_fbrnch (version)+import Types (SideTagTarget(..)) main :: IO () main = do@@ -116,6 +117,7 @@ , Subcommand "override" "Tag builds into buildroot override in Koji" $ overrideCmd <$> dryrunOpt+ <*> overrideModeOpt <*> optional (optionWith auto 'd' "duration" "DAYS" "Number of days until expiry [default 4]") <*> switchWith 'w' "no-wait" "Skip waitrepo step" <*> branchesPackages@@ -598,3 +600,8 @@ waitfetchOpt = flagWith' WaitDirty 'k' "allow-dirty" "Allow unclean git repo" <|> flagWith WaitFetch WaitNoFetch 'F' "no-fetch" "Skip git fetch"++ overrideModeOpt :: Parser OverrideMode+ overrideModeOpt =+ flagWith' OverrideList 'l' "list" "List active override(s)" <|>+ flagWith OverrideCreate OverrideExpire 'X' "expire" "Expire override(s)"
src/Package.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} module Package (- builtRpms, clonePkg, CloneUser(..), fedpkg,@@ -9,23 +8,13 @@ checkForSpecFile, getChangelog, cleanChangelog,- changelogVersions, changeLogPrompt,+ getBranchDist, getPackageName, getSummaryURL, findSpecfile, maybeFindSpecfile, localBranchSpecFile,- generateSrpm,- generateSrpm',- BCond(..),- ForceShort(..),- isShortCircuit,- buildRPMs,- installDeps,- installMissingMacros,- checkSourcesMatch,- getSources, putPkgHdr, putPkgBrnchHdr, putPkgAnyBrnchHdr,@@ -50,23 +39,11 @@ packageSpec, pkgNameVerRel, pkgNameVerRel',- buildRequires,- notInstalled,- nvraInstalled,- pkgInstalled,- equivNVR,- nameOfNVR+ equivNVR ) where -import Data.Char (isDigit)-import Data.Either (partitionEithers)-import Data.RPM import Distribution.Fedora hiding (Fedora,EPEL,EPELNext)-import Network.HTTP.Directory (Manager, httpExists, httpManager) import SimpleCmd.Rpm-import System.Console.Pretty-import System.IO.Extra (withTempDir)-import System.Posix.Files import Branches import Common@@ -103,11 +80,6 @@ userlog <- prompt $ "Press Enter to use above or input " ++ fromMaybe "change" mcontext ++ " summary now" ++ if isJust mcontext then "; or 'no' to skip update" else "" return $ if null userlog then clog else userlog -changelogVersions :: FilePath -> IO [String]-changelogVersions spec = do- ns <- cmdLines "rpmspec" ["-q", "--srpm", "--qf", "%{changelogname}", spec]- return $ map (removePrefix "- " . dropWhile (/= '-')) ns- getChangelog :: FilePath -> IO [String] getChangelog spec = do autochangelog <- grep_ "^%autochangelog" spec@@ -179,284 +151,6 @@ Nothing -> error' $ "No spec file for: " ++ unPackage pkg else findSpecfile -rpmEval :: String -> IO (Maybe String)-rpmEval s = do- res <- cmd "rpm" ["--eval", s]- return $ if null res || res == s then Nothing else Just res---- rpmEval' :: String -> IO String--- rpmEval' s = do--- mres <- rpmEval s--- fromMaybe (error' (show s ++ " undefined!")) mres--generateSrpm :: Maybe AnyBranch -> FilePath -> IO FilePath-generateSrpm = generateSrpm' False--generateSrpm' :: Bool -> Maybe AnyBranch -> FilePath -> IO FilePath-generateSrpm' force mbr spec = do- srcs <- getSources spec- distopt <- case mbr of- Nothing -> return []- Just br -> do- dist <- getBranchDist br- return ["--define", "dist " ++ rpmDistTag dist]- msrcrpmdir <- rpmEval "%{_srcrpmdir}"- srpmfile <- cmd "rpmspec" $ ["-q", "--srpm"] ++ distopt ++ ["--qf", fromMaybe "" msrcrpmdir </> "%{name}-%{version}-%{release}.src.rpm", spec]- cwd <- getCurrentDirectory- let sourcediropt = ["--define", "_sourcedir " ++ cwd]- opts = distopt ++ sourcediropt- if force then- buildSrpm opts- else do- exists <- doesFileExist srpmfile- if not exists- then buildSrpm opts- else do- srpmTime <- getModificationTime srpmfile- fileTimes <- mapM getModificationTime (spec:srcs)- if any (srpmTime <) fileTimes- then buildSrpm opts- else do- -- pretty print with ~/- putStrLn $ srpmfile ++ " is up to date"- return srpmfile- where- buildSrpm opts = do- srpm <- last . words <$> cmd "rpmbuild" (opts ++ ["-bs", spec])- putStrLn $ "Created " ++ takeFileName srpm- return srpm--data ForceShort = ForceBuild | ShortCompile | ShortInstall- deriving Eq--isShortCircuit :: Maybe ForceShort -> Bool-isShortCircuit ms =- case ms of- Just s -> s /= ForceBuild- Nothing -> False--data BCond = BuildWith String | BuildWithout String--instance Show BCond where- show (BuildWith s) = "--with=" ++ s- show (BuildWithout s) = "--without=" ++ s---- FIXME create build.log--- Note does not check if bcond changed--- FIXME check tarball timestamp-buildRPMs :: Bool -> Bool -> Bool -> Maybe ForceShort -> [BCond] -> [FilePath]- -> AnyBranch -> FilePath -> IO Bool-buildRPMs quiet debug noclean mforceshort bconds rpms br spec = do- needBuild <-- if isJust mforceshort- then return True- else- ifM (not . and <$> mapM doesFileExist rpms)- (return True) $- do specTime <- getModificationTime spec- rpmTimes <- sort <$> mapM getModificationTime rpms- return $ specTime > head rpmTimes- if not needBuild then- putStrLn "Existing rpms are newer than spec file (use --force to rebuild)"- else do- installDeps True spec- void $ getSources spec- dist <- getBranchDist br- cwd <- getCurrentDirectory- let buildopt =- case mforceshort of- Just ShortCompile -> ["-bc", "--short-circuit"]- Just ShortInstall -> ["-bi", "--short-circuit"]- _ -> "-bb" : ["--noclean" | noclean]- sourcediropt = ["--define", "_sourcedir " ++ cwd]- args = sourcediropt ++ ["--define", "dist " ++ rpmDistTag dist] ++- buildopt ++ map show bconds ++ [spec]- date <- cmd "date" ["+%T"]- putStr $ date ++ " Building " ++ takeBaseName spec ++ " locally... "- ok <- do- rbr <- anyBranchToRelease br- nvr <- pkgNameVerRel' rbr spec- let buildlog = ".build-" ++ showNVRVerRel (readNVR nvr) <.> "log"- timeIO $- if not quiet || isShortCircuit mforceshort- then do- putNewLn- -- FIXME would like to have pipeOutErr- let buildcmd = unwords $ "rpmbuild" : map quoteArg args ++ "|&" : "tee" : [buildlog ++ " && exit ${PIPESTATUS[0]}"]- when debug $ putStrLn buildcmd- shellBool buildcmd- else do- let buildcmd = unwords $ "rpmbuild" : map quoteArg args ++ [">&", buildlog]- when debug $ putStrLn buildcmd- res <- shellBool buildcmd- if res- then putStrLn "done"- else cmd_ "tail" ["-n 100", buildlog]- return res- unless ok $- error' $ takeBaseName spec ++ " failed to build"- return needBuild- where- quoteArg :: String -> String- quoteArg cs =- if ' ' `elem` cs then '\'' : cs ++ "'" else cs---- FIXME print unavailable deps-installDeps :: Bool -> FilePath -> IO ()-installDeps strict spec = do- missingdeps <- nub <$> (buildRequires spec >>= filterM notInstalled)- unless (null missingdeps) $ do- putStrLn $ "Running 'dnf install' " ++ unwords missingdeps- cmd_ "/usr/bin/sudo" $ "/usr/bin/dnf":"install": ["--skip-broken" | not strict] ++ ["--assumeyes"] ++ missingdeps--installMissingMacros :: FilePath -> IO ()-installMissingMacros spec = do- macros <- mapMaybeM needSrpmMacro srpmMacros- missing <- filterM notInstalled macros- unless (null missing) $- cmd_ "/usr/bin/sudo" $ ["/usr/bin/dnf", "install", "--assumeyes"] ++ missing- where- srpmMacros :: [(String,String)]- srpmMacros =- [("%gometa", "go-rpm-macros"),- ("fontpkgname", "fonts-rpm-macros"),- ("%cargo_prep", "rust-packaging")]-- needSrpmMacro :: (String,String) -> IO (Maybe String)- needSrpmMacro (meta, macros) = do- contents <- readFile spec- return $ if meta `isInfixOf` contents then Just macros else Nothing--checkSourcesMatch :: FilePath -> IO ()-checkSourcesMatch spec = do- -- "^[Ss]ource[0-9]*:"- sourcefiles <- map (takeFileName . last . words) <$> cmdLines "spectool" [spec]- sources <- lines <$> readFile "sources"- gitfiles <- gitLines "ls-files" []- let missing = filter (\src -> isNothing (find (src `isInfixOf`) sources) &&- src `notElem` gitfiles)- sourcefiles- unless (null missing) $ do- prompt_ $ color Red $ unwords missing ++ " not in sources, please fix"- checkOnBranch- checkSourcesMatch spec- mgr <- httpManager- let pkg = takeBaseName spec- mapM_ (checkLookasideCache mgr pkg) sources- where- checkLookasideCache :: Manager -> String -> String -> IO ()- checkLookasideCache mgr pkg source = do- let (file,url) =- case words source of- ("SHA512":('(':fileparen):"=":[hash]) ->- let file' = dropSuffix ")" fileparen- in (file', "https://src.fedoraproject.org/lookaside/pkgs" +/+ pkg +/+ file +/+ "sha512" +/+ hash +/+ file)- [hash,file'] ->- (file', "https://src.fedoraproject.org/lookaside/pkgs" +/+ pkg +/+ file +/+ "md5" +/+ hash +/+ file)- _ -> error' $ "invalid/unknown source:\n" ++ source- unlessM (httpExists mgr url) $ do- putStrLn $ url ++ " not found"- putStrLn $ "uploading " ++ file ++ " to lookaside source repo"- fedpkg_ "upload" [file]--getSources :: FilePath -> IO [FilePath]-getSources spec = do- -- FIXME fallback to ~/rpmbuild/SOURCES?- msrcdir <- do- cwd <- getCurrentDirectory- msourcedir <- rpmEval "%{_sourcedir}"- case msourcedir of- Nothing -> return Nothing- Just srcdir -> do- canon <- canonicalizePath srcdir- if canon == cwd- then return Nothing- else do- dir <- doesDirectoryExist srcdir- if dir- then return msourcedir- else return Nothing- isPkgGit <- isPkgGitRepo- (patches,srcs) <- partitionEithers . map sourceFieldFile- <$> cmdLines "spectool" ["-a", spec]- forM_ srcs $ \ src -> do- exists <- doesFileExist src &&^ checkCompression src- inSrcdir <- doesSourceDirFileExist msrcdir src- unless exists $ do- if inSrcdir- then maybeSourceDir createLink msrcdir src- else do- uploaded <-- if isPkgGit then do- have_sources <- doesFileExist "sources"- if have_sources then- grep_ src "sources"- else return False- else return False- mfedpkg <- findExecutable "fedpkg"- if uploaded && isJust mfedpkg- then cmd_ "fedpkg" ["sources"]- else do- cmd_ "spectool" ["-g", "-S", spec]- unlessM (doesFileExist src) $- error' $ "download failed: " ++ src- unless inSrcdir $- whenJust msrcdir $ \srcdir ->- createLink src (srcdir </> src)- forM_ patches $ \patch ->- unlessM (doesFileExist patch) $ do- inSrcdir <- doesSourceDirFileExist msrcdir patch- if inSrcdir- then maybeSourceDir copyFile msrcdir patch- else do- cmd_ "spectool" ["-g", "-P", spec]- unlessM (doesFileExist patch) $- error' $ "missing patch: " ++ patch- return $ srcs ++ patches- where- sourceFieldFile :: String -> Either FilePath FilePath- sourceFieldFile field =- case word1 field of- (f,v) ->- -- rpmdevtools 9.3 (spectool always lists --all)- -- "Source0:" or "Patch1:"- (case lower (dropWhileEnd isDigit (init f)) of- "source" -> Right- "patch" -> Left- _ -> error' $! "illegal field: " ++ f)- $ takeFileName v-- checkCompression :: FilePath -> IO Bool- checkCompression file =- case- case takeExtension file of- ".gz" -> Just "gzip"- ".tgz" -> Just "gzip"- ".bz2" -> Just "bzip2"- ".xz" -> Just "xz"- ".lz" -> Just "lzip"- ".zstd" -> Just "zstd"- _ -> Nothing- of- Just prog -> do- have <- findExecutable prog- when (isNothing have) $ do- putStrLn $ "Running 'dnf install' " ++ prog- cmd_ "/usr/bin/sudo" $ "/usr/bin/dnf":"install": ["--assumeyes", prog]- cmdBool prog ["-t", file]- Nothing -> return True-- maybeSourceDir :: (FilePath -> FilePath -> IO ())- -> Maybe FilePath -> FilePath -> IO ()- maybeSourceDir act mdir file =- whenJust mdir $ \dir ->- act (dir </> file) file-- doesSourceDirFileExist :: Maybe FilePath -> FilePath -> IO Bool- doesSourceDirFileExist Nothing _ = return False- doesSourceDirFileExist (Just srcdir) file =- doesFileExist (srcdir </> file)- withExistingDirectory :: FilePath -> IO a -> IO a withExistingDirectory dir act = do exists <- doesDirectoryExist dir@@ -488,67 +182,6 @@ packageSpec :: Package -> FilePath packageSpec pkg = unPackage pkg <.> "spec" -data BrPkg = IsBr AnyBranch | Unknown String | IsPkg String- deriving Show---- splitBranchesPkgs :: Bool -> Maybe BranchOpts -> Bool -> [String]--- -> IO ([AnyBranch], [String])--- splitBranchesPkgs release mbrnchopts exists args = do--- pkggit <- isPkgGitRepo--- brPkgs <- mapM (toBrPkg pkggit) args--- let (brs,pkgs) = brPkgsToBranchesPkgs brPkgs--- return $ case mbrnchopts of--- Just _ | brs /= [] -> error' "cannot specify branches with branch options"--- _ -> (brs,pkgs)--- where--- toBrPkg :: Bool -> String -> IO BrPkg--- toBrPkg gitdir str =--- case anyBranch str of--- rbr@(RelBranch _) -> return (IsBr rbr)--- abr@(OtherBranch p) -> if release then return (IsPkg p)--- else--- ifM (isPath str)--- (return $ IsPkg str) $--- if gitdir--- then return (IsBr abr)--- else return $ if exists--- then IsBr abr--- else IsPkg str--- where--- isPath :: FilePath -> IO Bool--- isPath fp =--- if ".spec" `isExtensionOf` fp--- then do--- exists' <- doesFileExist fp--- unless exists' $ error' $ fp ++ " file not found"--- return True--- else do--- exists' <- doesDirectoryExist fp--- let ispath = '/' `elem` fp--- when (not exists' && ispath) $--- error' $ fp ++ " directory not found"--- return exists'---- brPkgsToBranchesPkgs :: [BrPkg] -> ([AnyBranch], [String])--- brPkgsToBranchesPkgs brpkgs =--- let (pbrs,ppkgs) = span isBranch brpkgs--- in (map toBranch pbrs, map toPackage ppkgs)--- where--- isBranch :: BrPkg -> Bool--- isBranch (IsBr _) = True--- isBranch (Unknown _) = True--- isBranch (IsPkg _) = False---- toBranch :: BrPkg -> AnyBranch--- toBranch (IsBr br) = br--- toBranch (Unknown br) = OtherBranch br--- toBranch (IsPkg p) = error' $ "can't map package to branch: " ++ p---- toPackage :: BrPkg -> String--- toPackage (IsPkg p) = p--- toPackage (Unknown p) = p--- toPackage (IsBr b) = error' $ "can't map branch to package: " ++ show b- data GitOpts = GitOpts { gitOptClean :: Bool@@ -741,61 +374,12 @@ Nothing -> error' $ "rpmspec failed to parse " ++ spec Just nvr -> return nvr -builtRpms :: AnyBranch -> FilePath -> IO [FilePath]-builtRpms br spec = do- dist <- getBranchDist br- -- previously was "" for pkggit- rpmdir <- fromMaybe "" <$> rpmEval "%{_rpmdir}"- rpms <- rpmspec ["--builtrpms", "--define", "dist " ++ rpmDistTag dist] (Just (rpmdir </> "%{arch}/%{name}-%{version}-%{release}.%{arch}.rpm")) spec- if null rpms- then error' $ spec ++ " does not seem to create any rpms"- else return rpms- getBranchDist :: AnyBranch -> IO Dist getBranchDist (RelBranch br) = branchDist br getBranchDist (OtherBranch _) = systemBranch >>= branchDist --- from fedora-haskell-tools-buildRequires :: FilePath -> IO [String]-buildRequires spec = do- autorelease <- grep_ " %autorelease" spec- dynbr <- grep_ "^%generate_buildrequires" spec- brs <- mapMaybe primary <$>- if dynbr- then do- installMissingMacros spec- withTempDir $ \tmpdir -> do- let srpmdiropt = ["--define", "_srcrpmdir" ++ tmpdir]- out <- cmdIgnoreErr "rpmbuild" (["-br", "--nodeps", spec] ++ srpmdiropt) ""- -- Wrote: /current/dir/SRPMS/name-version-release.buildreqs.nosrc.rpm- case words out of- [] -> error' $ spec +-+ "could not generate source rpm for dynamic buildrequires"- ws -> cmdLines "rpm" ["-qp", "--requires", last ws]- else- -- FIXME should resolve meta- rpmspec ["--buildrequires"] Nothing spec- return $ brs ++ ["rpmautospec" | autorelease]- where- primary dep =- case (head . words) dep of- '(':rest -> Just rest- d -> if "rpmlib(" `isPrefixOf` d- then Nothing- else Just d--notInstalled :: String -> IO Bool-notInstalled pkg =- not <$> cmdBool "rpm" ["--quiet", "-q", "--whatprovides", pkg]--nvraInstalled :: NVRA -> IO Bool-nvraInstalled rpm =- cmdBool "rpm" ["--quiet", "-q", showNVRA rpm]--pkgInstalled :: String -> IO Bool-pkgInstalled pkg =- cmdBool "rpm" ["--quiet", "-q", pkg]- -- FIXME should be more strict about dist tag (eg .fcNN only)+-- FIXME replace with NVR's? equivNVR :: String -> String -> Bool equivNVR nvr1 nvr2 | nvr1 == nvr2 = True@@ -811,13 +395,63 @@ -- allow differing dist in length r1 == length r2 && r1' == r2' --- FIXME: obsolete by using NVR--- n-v-r -> n-nameOfNVR :: String -> String-nameOfNVR = removeSeg . removeSeg- where- removeSeg = init . dropWhileEnd (/= '-')+-- data BrPkg = IsBr AnyBranch | Unknown String | IsPkg String+-- deriving Show --- FIXME: drop when rpm-nvr has nvrVerRel-showNVRVerRel :: NVR -> String-showNVRVerRel (NVR _n vr) = showVerRel vr+-- splitBranchesPkgs :: Bool -> Maybe BranchOpts -> Bool -> [String]+-- -> IO ([AnyBranch], [String])+-- splitBranchesPkgs release mbrnchopts exists args = do+-- pkggit <- isPkgGitRepo+-- brPkgs <- mapM (toBrPkg pkggit) args+-- let (brs,pkgs) = brPkgsToBranchesPkgs brPkgs+-- return $ case mbrnchopts of+-- Just _ | brs /= [] -> error' "cannot specify branches with branch options"+-- _ -> (brs,pkgs)+-- where+-- toBrPkg :: Bool -> String -> IO BrPkg+-- toBrPkg gitdir str =+-- case anyBranch str of+-- rbr@(RelBranch _) -> return (IsBr rbr)+-- abr@(OtherBranch p) -> if release then return (IsPkg p)+-- else+-- ifM (isPath str)+-- (return $ IsPkg str) $+-- if gitdir+-- then return (IsBr abr)+-- else return $ if exists+-- then IsBr abr+-- else IsPkg str+-- where+-- isPath :: FilePath -> IO Bool+-- isPath fp =+-- if ".spec" `isExtensionOf` fp+-- then do+-- exists' <- doesFileExist fp+-- unless exists' $ error' $ fp ++ " file not found"+-- return True+-- else do+-- exists' <- doesDirectoryExist fp+-- let ispath = '/' `elem` fp+-- when (not exists' && ispath) $+-- error' $ fp ++ " directory not found"+-- return exists'++-- brPkgsToBranchesPkgs :: [BrPkg] -> ([AnyBranch], [String])+-- brPkgsToBranchesPkgs brpkgs =+-- let (pbrs,ppkgs) = span isBranch brpkgs+-- in (map toBranch pbrs, map toPackage ppkgs)+-- where+-- isBranch :: BrPkg -> Bool+-- isBranch (IsBr _) = True+-- isBranch (Unknown _) = True+-- isBranch (IsPkg _) = False++-- toBranch :: BrPkg -> AnyBranch+-- toBranch (IsBr br) = br+-- toBranch (Unknown br) = OtherBranch br+-- toBranch (IsPkg p) = error' $ "can't map package to branch: " ++ p++-- toPackage :: BrPkg -> String+-- toPackage (IsPkg p) = p+-- toPackage (Unknown p) = p+-- toPackage (IsBr b) = error' $ "can't map branch to package: " ++ show b
src/Prompt.hs view
@@ -30,8 +30,9 @@ if all isPrint inp then return inp else do- warning $ "input rejected because of unprintable character(s): " ++- filter (not . isPrint) inp+ warning $+ "input rejected because of unprintable character(s): '" +++ show inp ++ "'" prompt s prompt_ :: String -> IO ()
+ src/RpmBuild.hs view
@@ -0,0 +1,353 @@+module RpmBuild (+ builtRpms,+ buildRPMs,+ installDeps,+ installMissingMacros,+ buildRequires,+ getSources,+ generateSrpm,+ generateSrpm',+ BCond(..),+ ForceShort(..),+ isShortCircuit,+ checkSourcesMatch,+ notInstalled,+ )+where++import Data.Char (isDigit)+import Data.Either (partitionEithers)+import Data.RPM+import Distribution.Fedora hiding (Fedora,EPEL,EPELNext)+import Network.HTTP.Directory (Manager, httpExists, httpManager)+import SimpleCmd.Rpm+import System.Console.Pretty+import System.IO.Extra (withTempDir)+import System.Posix.Files++import Branches+import Common+import Common.System+import Git+import Package+import Prompt (prompt_)++builtRpms :: AnyBranch -> FilePath -> IO [FilePath]+builtRpms br spec = do+ dist <- getBranchDist br+ -- previously was "" for pkggit+ rpmdir <- fromMaybe "" <$> rpmEval "%{_rpmdir}"+ rpms <- rpmspec ["--builtrpms", "--define", "dist " ++ rpmDistTag dist] (Just (rpmdir </> "%{arch}/%{name}-%{version}-%{release}.%{arch}.rpm")) spec+ if null rpms+ then error' $ spec ++ " does not seem to create any rpms"+ else return rpms++rpmEval :: String -> IO (Maybe String)+rpmEval s = do+ res <- cmd "rpm" ["--eval", s]+ return $ if null res || res == s then Nothing else Just res++-- rpmEval' :: String -> IO String+-- rpmEval' s = do+-- mres <- rpmEval s+-- fromMaybe (error' (show s ++ " undefined!")) mres++getSources :: FilePath -> IO [FilePath]+getSources spec = do+ -- FIXME fallback to ~/rpmbuild/SOURCES?+ msrcdir <- do+ cwd <- getCurrentDirectory+ msourcedir <- rpmEval "%{_sourcedir}"+ case msourcedir of+ Nothing -> return Nothing+ Just srcdir -> do+ canon <- canonicalizePath srcdir+ if canon == cwd+ then return Nothing+ else do+ dir <- doesDirectoryExist srcdir+ if dir+ then return msourcedir+ else return Nothing+ isPkgGit <- isPkgGitRepo+ (patches,srcs) <- partitionEithers . map sourceFieldFile+ <$> cmdLines "spectool" ["-a", spec]+ forM_ srcs $ \ src -> do+ exists <- doesFileExist src &&^ checkCompression src+ inSrcdir <- doesSourceDirFileExist msrcdir src+ unless exists $ do+ if inSrcdir+ then maybeSourceDir createLink msrcdir src+ else do+ uploaded <-+ if isPkgGit then do+ have_sources <- doesFileExist "sources"+ if have_sources then+ grep_ src "sources"+ else return False+ else return False+ mfedpkg <- findExecutable "fedpkg"+ if uploaded && isJust mfedpkg+ then cmd_ "fedpkg" ["sources"]+ else do+ cmd_ "spectool" ["-g", "-S", spec]+ unlessM (doesFileExist src) $+ error' $ "download failed: " ++ src+ unless inSrcdir $+ whenJust msrcdir $ \srcdir ->+ createLink src (srcdir </> src)+ forM_ patches $ \patch ->+ unlessM (doesFileExist patch) $ do+ inSrcdir <- doesSourceDirFileExist msrcdir patch+ if inSrcdir+ then maybeSourceDir copyFile msrcdir patch+ else do+ cmd_ "spectool" ["-g", "-P", spec]+ unlessM (doesFileExist patch) $+ error' $ "missing patch: " ++ patch+ return $ srcs ++ patches+ where+ sourceFieldFile :: String -> Either FilePath FilePath+ sourceFieldFile field =+ case word1 field of+ (f,v) ->+ -- rpmdevtools 9.3 (spectool always lists --all)+ -- "Source0:" or "Patch1:"+ (case lower (dropWhileEnd isDigit (init f)) of+ "source" -> Right+ "patch" -> Left+ _ -> error' $! "illegal field: " ++ f)+ $ takeFileName v++ checkCompression :: FilePath -> IO Bool+ checkCompression file =+ case+ case takeExtension file of+ ".gz" -> Just "gzip"+ ".tgz" -> Just "gzip"+ ".bz2" -> Just "bzip2"+ ".xz" -> Just "xz"+ ".lz" -> Just "lzip"+ ".zstd" -> Just "zstd"+ _ -> Nothing+ of+ Just prog -> do+ have <- findExecutable prog+ when (isNothing have) $ do+ putStrLn $ "Running 'dnf install' " ++ prog+ cmd_ "/usr/bin/sudo" $ "/usr/bin/dnf":"install": ["--assumeyes", prog]+ cmdBool prog ["-t", file]+ Nothing -> return True++ maybeSourceDir :: (FilePath -> FilePath -> IO ())+ -> Maybe FilePath -> FilePath -> IO ()+ maybeSourceDir act mdir file =+ whenJust mdir $ \dir ->+ act (dir </> file) file++ doesSourceDirFileExist :: Maybe FilePath -> FilePath -> IO Bool+ doesSourceDirFileExist Nothing _ = return False+ doesSourceDirFileExist (Just srcdir) file =+ doesFileExist (srcdir </> file)++generateSrpm :: Maybe AnyBranch -> FilePath -> IO FilePath+generateSrpm = generateSrpm' False++generateSrpm' :: Bool -> Maybe AnyBranch -> FilePath -> IO FilePath+generateSrpm' force mbr spec = do+ srcs <- getSources spec+ distopt <- case mbr of+ Nothing -> return []+ Just br -> do+ dist <- getBranchDist br+ return ["--define", "dist " ++ rpmDistTag dist]+ msrcrpmdir <- rpmEval "%{_srcrpmdir}"+ srpmfile <- cmd "rpmspec" $ ["-q", "--srpm"] ++ distopt ++ ["--qf", fromMaybe "" msrcrpmdir </> "%{name}-%{version}-%{release}.src.rpm", spec]+ cwd <- getCurrentDirectory+ let sourcediropt = ["--define", "_sourcedir " ++ cwd]+ opts = distopt ++ sourcediropt+ if force then+ buildSrpm opts+ else do+ exists <- doesFileExist srpmfile+ if not exists+ then buildSrpm opts+ else do+ srpmTime <- getModificationTime srpmfile+ fileTimes <- mapM getModificationTime (spec:srcs)+ if any (srpmTime <) fileTimes+ then buildSrpm opts+ else do+ -- pretty print with ~/+ putStrLn $ srpmfile ++ " is up to date"+ return srpmfile+ where+ buildSrpm opts = do+ srpm <- last . words <$> cmd "rpmbuild" (opts ++ ["-bs", spec])+ putStrLn $ "Created " ++ takeFileName srpm+ return srpm++data ForceShort = ForceBuild | ShortCompile | ShortInstall+ deriving Eq++isShortCircuit :: Maybe ForceShort -> Bool+isShortCircuit ms =+ case ms of+ Just s -> s /= ForceBuild+ Nothing -> False++data BCond = BuildWith String | BuildWithout String++instance Show BCond where+ show (BuildWith s) = "--with=" ++ s+ show (BuildWithout s) = "--without=" ++ s++-- FIXME create build.log+-- Note does not check if bcond changed+-- FIXME check tarball timestamp+buildRPMs :: Bool -> Bool -> Bool -> Maybe ForceShort -> [BCond] -> [FilePath]+ -> AnyBranch -> FilePath -> IO Bool+buildRPMs quiet debug noclean mforceshort bconds rpms br spec = do+ needBuild <-+ if isJust mforceshort+ then return True+ else+ ifM (not . and <$> mapM doesFileExist rpms)+ (return True) $+ do specTime <- getModificationTime spec+ rpmTimes <- sort <$> mapM getModificationTime rpms+ return $ specTime > head rpmTimes+ if not needBuild then+ putStrLn "Existing rpms are newer than spec file (use --force to rebuild)"+ else do+ installDeps True spec+ void $ getSources spec+ dist <- getBranchDist br+ cwd <- getCurrentDirectory+ let buildopt =+ case mforceshort of+ Just ShortCompile -> ["-bc", "--short-circuit"]+ Just ShortInstall -> ["-bi", "--short-circuit"]+ _ -> "-bb" : ["--noclean" | noclean]+ sourcediropt = ["--define", "_sourcedir " ++ cwd]+ args = sourcediropt ++ ["--define", "dist " ++ rpmDistTag dist] +++ buildopt ++ map show bconds ++ [spec]+ date <- cmd "date" ["+%T"]+ putStr $ date ++ " Building " ++ takeBaseName spec ++ " locally... "+ ok <- do+ rbr <- anyBranchToRelease br+ nvr <- pkgNameVerRel' rbr spec+ let buildlog = ".build-" ++ (showVerRel . nvrVerRel . readNVR) nvr <.> "log"+ timeIO $+ if not quiet || isShortCircuit mforceshort+ then do+ putNewLn+ -- FIXME would like to have pipeOutErr+ let buildcmd = unwords $ "rpmbuild" : map quoteArg args ++ "|&" : "tee" : [buildlog ++ " && exit ${PIPESTATUS[0]}"]+ when debug $ putStrLn buildcmd+ shellBool buildcmd+ else do+ let buildcmd = unwords $ "rpmbuild" : map quoteArg args ++ [">&", buildlog]+ when debug $ putStrLn buildcmd+ res <- shellBool buildcmd+ if res+ then putStrLn "done"+ else cmd_ "tail" ["-n 100", buildlog]+ return res+ unless ok $+ error' $ takeBaseName spec ++ " failed to build"+ return needBuild+ where+ quoteArg :: String -> String+ quoteArg cs =+ if ' ' `elem` cs then '\'' : cs ++ "'" else cs++-- FIXME print unavailable deps+installDeps :: Bool -> FilePath -> IO ()+installDeps strict spec = do+ missingdeps <- nub <$> (buildRequires spec >>= filterM notInstalled)+ unless (null missingdeps) $ do+ putStrLn $ "Running 'dnf install' " ++ unwords missingdeps+ cmd_ "/usr/bin/sudo" $ "/usr/bin/dnf":"install": ["--skip-broken" | not strict] ++ ["--assumeyes"] ++ missingdeps++installMissingMacros :: FilePath -> IO ()+installMissingMacros spec = do+ macros <- mapMaybeM needSrpmMacro srpmMacros+ missing <- filterM notInstalled macros+ unless (null missing) $+ cmd_ "/usr/bin/sudo" $ ["/usr/bin/dnf", "install", "--assumeyes"] ++ missing+ where+ srpmMacros :: [(String,String)]+ srpmMacros =+ [("%gometa", "go-rpm-macros"),+ ("fontpkgname", "fonts-rpm-macros"),+ ("%cargo_prep", "rust-packaging")]++ needSrpmMacro :: (String,String) -> IO (Maybe String)+ needSrpmMacro (meta, macros) = do+ contents <- readFile spec+ return $ if meta `isInfixOf` contents then Just macros else Nothing++-- from fedora-haskell-tools+buildRequires :: FilePath -> IO [String]+buildRequires spec = do+ autorelease <- grep_ " %autorelease" spec+ dynbr <- grep_ "^%generate_buildrequires" spec+ brs <- mapMaybe primary <$>+ if dynbr+ then do+ installMissingMacros spec+ withTempDir $ \tmpdir -> do+ let srpmdiropt = ["--define", "_srcrpmdir" ++ tmpdir]+ out <- cmdIgnoreErr "rpmbuild" (["-br", "--nodeps", spec] ++ srpmdiropt) ""+ -- Wrote: /current/dir/SRPMS/name-version-release.buildreqs.nosrc.rpm+ case words out of+ [] -> error' $ spec +-+ "could not generate source rpm for dynamic buildrequires"+ ws -> cmdLines "rpm" ["-qp", "--requires", last ws]+ else+ -- FIXME should resolve meta+ rpmspec ["--buildrequires"] Nothing spec+ return $ brs ++ ["rpmautospec" | autorelease]+ where+ primary dep =+ case (head . words) dep of+ '(':rest -> Just rest+ d -> if "rpmlib(" `isPrefixOf` d+ then Nothing+ else Just d++checkSourcesMatch :: FilePath -> IO ()+checkSourcesMatch spec = do+ -- "^[Ss]ource[0-9]*:"+ sourcefiles <- map (takeFileName . last . words) <$> cmdLines "spectool" [spec]+ sources <- lines <$> readFile "sources"+ gitfiles <- gitLines "ls-files" []+ let missing = filter (\src -> isNothing (find (src `isInfixOf`) sources) &&+ src `notElem` gitfiles)+ sourcefiles+ unless (null missing) $ do+ prompt_ $ color Red $ unwords missing ++ " not in sources, please fix"+ checkOnBranch+ checkSourcesMatch spec+ mgr <- httpManager+ let pkg = takeBaseName spec+ mapM_ (checkLookasideCache mgr pkg) sources+ where+ checkLookasideCache :: Manager -> String -> String -> IO ()+ checkLookasideCache mgr pkg source = do+ let (file,url) =+ case words source of+ ("SHA512":('(':fileparen):"=":[hash]) ->+ let file' = dropSuffix ")" fileparen+ in (file', "https://src.fedoraproject.org/lookaside/pkgs" +/+ pkg +/+ file +/+ "sha512" +/+ hash +/+ file)+ [hash,file'] ->+ (file', "https://src.fedoraproject.org/lookaside/pkgs" +/+ pkg +/+ file +/+ "md5" +/+ hash +/+ file)+ _ -> error' $ "invalid/unknown source:\n" ++ source+ unlessM (httpExists mgr url) $ do+ putStrLn $ url ++ " not found"+ putStrLn $ "uploading " ++ file ++ " to lookaside source repo"+ fedpkg_ "upload" [file]++notInstalled :: String -> IO Bool+notInstalled pkg =+ not <$> cmdBool "rpm" ["--quiet", "-q", "--whatprovides", pkg]