├── .github └── workflows │ └── build.yml ├── .gitignore ├── .stack-all ├── CHANGELOG.md ├── LICENSE ├── README.md ├── TODO ├── cabal.project ├── fbrnch.cabal ├── src ├── Bodhi.hs ├── Branches.hs ├── Bugzilla.hs ├── Cmd │ ├── Autospec.hs │ ├── Bugs.hs │ ├── Build.hs │ ├── Bump.hs │ ├── Clone.hs │ ├── Commit.hs │ ├── Compare.hs │ ├── Copr.hs │ ├── CreateReview.hs │ ├── Diff.hs │ ├── FTBFS.hs │ ├── Fetch.hs │ ├── Import.hs │ ├── Install.hs │ ├── ListBranches.hs │ ├── ListPackages.hs │ ├── Local.hs │ ├── Merge.hs │ ├── Mock.hs │ ├── Override.hs │ ├── Owner.hs │ ├── Parallel.hs │ ├── Prep.hs │ ├── Pull.hs │ ├── Push.hs │ ├── Repoquery.hs │ ├── RequestBranch.hs │ ├── RequestRepo.hs │ ├── ReviewPackage.hs │ ├── Reviews.hs │ ├── Scratch.hs │ ├── SideTags.hs │ ├── Sort.hs │ ├── SrcDeps.hs │ ├── Status.hs │ ├── Switch.hs │ ├── Unpushed.hs │ ├── Update.hs │ ├── UpdateReview.hs │ └── WaitRepo.hs ├── Common.hs ├── Common │ ├── System.hs │ └── Text.hs ├── Git.hs ├── InterleaveOutput.hs ├── Koji.hs ├── ListReviews.hs ├── Main.hs ├── Package.hs ├── Pagure.hs ├── Patch.hs ├── PkgReview.hs ├── Repoquery.hs ├── RpmBuild.hs ├── Types.hs └── json │ ├── invalidtoken.json │ ├── login.json │ └── result.json ├── stack-lts12.yaml ├── stack-lts13.yaml ├── stack-lts14.yaml ├── stack-lts16.yaml ├── stack-lts18.yaml ├── stack-lts19.yaml ├── stack-lts20.yaml ├── stack-lts21.yaml ├── stack-lts22.yaml ├── stack-nightly.yaml └── stack.yaml /.github/workflows/build.yml: -------------------------------------------------------------------------------- 1 | name: build 2 | on: 3 | push: 4 | branches: [ main ] 5 | pull_request: 6 | branches: [ main ] 7 | jobs: 8 | build: 9 | runs-on: ubuntu-latest 10 | strategy: 11 | matrix: 12 | ghc: ['9.10', '9.8', '9.6', '9.4', '9.2', '9.0', '8.10', '8.8', '8.6', '8.4'] 13 | name: Haskell GHC ${{ matrix.ghc }} 14 | steps: 15 | - uses: actions/checkout@v4 16 | - uses: haskell-actions/setup@v2 17 | with: 18 | ghc-version: ${{ matrix.ghc }} 19 | - uses: actions/cache@v4 20 | with: 21 | path: | 22 | ~/.cabal 23 | dist-newstyle 24 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('**/*.cabal','**/cabal.project') }} 25 | restore-keys: | 26 | ${{ runner.os }}-${{ matrix.ghc }}- 27 | ${{ runner.os }}- 28 | - run: cabal update 29 | - run: cabal build 30 | - run: cabal sdist 31 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | ### Haskell 2 | dist 3 | dist-* 4 | cabal-dev 5 | *.o 6 | *.hi 7 | *.chi 8 | *.chs.h 9 | *.dyn_o 10 | *.dyn_hi 11 | *.prof 12 | *.aux 13 | *.hp 14 | *.eventlog 15 | .virtualenv 16 | .hsenv 17 | .hpc 18 | .cabal-sandbox/ 19 | cabal.sandbox.config 20 | cabal.config 21 | cabal.project.local 22 | .ghc.environment.* 23 | .HTF/ 24 | # Stack 25 | .stack-work/ 26 | /stack.yaml.lock 27 | /.hie/ 28 | 29 | ### IDE/support 30 | # Vim 31 | [._]*.s[a-v][a-z] 32 | [._]*.sw[a-p] 33 | [._]s[a-v][a-z] 34 | [._]sw[a-p] 35 | *~ 36 | tags 37 | 38 | # IntellijIDEA 39 | .idea/ 40 | .ideaHaskellLib/ 41 | *.iml 42 | 43 | # Atom 44 | .haskell-ghc-mod.json 45 | 46 | # VS 47 | .vscode/ 48 | 49 | # Emacs 50 | *# 51 | .dir-locals.el 52 | TAGS 53 | 54 | # other 55 | .DS_Store 56 | -------------------------------------------------------------------------------- /.stack-all: -------------------------------------------------------------------------------- 1 | [versions] 2 | # Cabal, haskeline exceptions 3 | oldest = lts-12 4 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | - EDITOR feature 2 | 3 | - warn about macros in %changelog 4 | 5 | - tag builds without disttag 6 | - scratch/build: show total build times 7 | - filter bz# out from bodhi notes 8 | - layers command to print 9 | - diff commit trees (eg version 0.30.2 vs 0.30.3) 10 | 11 | - abstract rpmspec and spectool: for better errors if missing 12 | 13 | - color warnings 14 | 15 | - config option to cache tarballs in ~/rpmbuild/SOURCES if it exists when _sourcedir is cwd 16 | 17 | - check envr > any existing current package, before building 18 | - use rpm-nvr: eg for nameOfNVR 19 | - 'clean' command 20 | - merge rawhide pushes to local main? 21 | - pull creating new branches and/or clone --all? 22 | - stash and restore 23 | 24 | - push/build a commit (eg if one doesn't want to build HEAD yet) 25 | - merge koji-progress 26 | - install from koji (koji-tool) 27 | 28 | # new commands 29 | - 'unpushed' command, etc (from f-h-t) 30 | - 'check-sources' 31 | - worktree support 32 | ? 'update-sources' 33 | - 'clean-old-source-dirs' (--threshold SIZE) 34 | - 'chain' 35 | - 'check-deps' 36 | - 'clone-deps' 37 | - 'remove-sidetag(s)' 38 | - 'retire': more than one branch pre-release branch with merge 39 | - 'fas-email': https://fasjson.fedoraproject.org/docs/v1/ 40 | - 'source': only fetch sources 41 | - 'grep' 42 | - 'state': summary of current state of repo: branch,clean/dirty etc 43 | 44 | # other namespaces 45 | - support containers/ and modules/ 46 | 47 | # multipackage 48 | - build sequence of packages by branch 49 | - build: auto override if dep 50 | - multipackage update 51 | - use sidetag 52 | - combines release updates into single bodhi update 53 | 54 | # misc 55 | - unify checking for pagure and git remote branches 56 | - remove ifM's? 57 | - SPDX migration 58 | - koji cancel 59 | 60 | # auth 61 | - update pagure key in ~/.config/rpkg/fedpkg.conf 62 | 63 | # status/*unbuilt*/unreleased 64 | - list pending new package builds 65 | - list builds not pushed to bodhi 66 | - status when no local dir/checkout 67 | 68 | # longterm ideas 69 | - "fbrnch todo" list 70 | - local state caching 71 | - use hs-git 72 | - rpminspect 73 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | -- source-repository-package 4 | -- type: git 5 | -- location: https://github.com/juhp/fedora-releases.git 6 | -- tag: 7ce60897223c7fded338bd01a449d1f2a603973c 7 | -------------------------------------------------------------------------------- /fbrnch.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.0 2 | name: fbrnch 3 | version: 1.6.2 4 | synopsis: Fedora packager tool to build package branches 5 | description: 6 | fbrnch (fedora branch or "f-branch" for short) is 7 | a convenient packaging tool for Fedora Packagers, 8 | with integration for Bugzilla, Koji, and Bodhi. 9 | . 10 | Features include: 11 | . 12 | - merging and building a package across release branches 13 | . 14 | - automated parallel builds of sets of packages in dependency order 15 | . 16 | - creating, updating and listing one's package reviews 17 | . 18 | - requesting repos for new approved packages and branch requests 19 | . 20 | - import srpms from package reviews 21 | . 22 | - progressive copr builds 23 | . 24 | and many more commands. 25 | homepage: https://github.com/juhp/fbrnch 26 | bug-reports: https://github.com/juhp/fbrnch/issues 27 | license: GPL-2 28 | license-file: LICENSE 29 | author: Jens Petersen 30 | maintainer: Jens Petersen 31 | copyright: 2019-2025 Jens Petersen 32 | category: Distribution 33 | build-type: Simple 34 | extra-doc-files: CHANGELOG.md 35 | README.md 36 | tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, 37 | GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.8, 38 | GHC == 9.4.8, GHC == 9.6.6, GHC == 9.8.4, GHC == 9.10.1 39 | 40 | source-repository head 41 | type: git 42 | location: https://github.com/juhp/fbrnch.git 43 | 44 | executable fbrnch 45 | main-is: Main.hs 46 | autogen-modules: Paths_fbrnch 47 | other-modules: Bodhi 48 | Branches 49 | Bugzilla 50 | Cmd.Autospec 51 | Cmd.Bugs 52 | Cmd.Build 53 | Cmd.Bump 54 | Cmd.Clone 55 | Cmd.Commit 56 | Cmd.Compare 57 | Cmd.Copr 58 | Cmd.CreateReview 59 | Cmd.Diff 60 | Cmd.Fetch 61 | Cmd.FTBFS 62 | Cmd.Import 63 | Cmd.Install 64 | Cmd.ListBranches 65 | Cmd.ListPackages 66 | Cmd.Local 67 | Cmd.Merge 68 | Cmd.Mock 69 | Cmd.Override 70 | Cmd.Owner 71 | Cmd.Parallel 72 | Cmd.Prep 73 | Cmd.Pull 74 | Cmd.Push 75 | --Cmd.Repoquery 76 | Cmd.RequestBranch 77 | Cmd.RequestRepo 78 | Cmd.ReviewPackage 79 | Cmd.Reviews 80 | Cmd.Scratch 81 | Cmd.SideTags 82 | Cmd.Sort 83 | Cmd.SrcDeps 84 | Cmd.Status 85 | Cmd.Switch 86 | Cmd.Unpushed 87 | Cmd.Update 88 | Cmd.UpdateReview 89 | Cmd.WaitRepo 90 | Common 91 | Common.System 92 | Common.Text 93 | Git 94 | InterleaveOutput 95 | Koji 96 | ListReviews 97 | Package 98 | Pagure 99 | Patch 100 | Paths_fbrnch 101 | PkgReview 102 | Repoquery 103 | RpmBuild 104 | Types 105 | 106 | hs-source-dirs: src 107 | default-language: Haskell2010 108 | 109 | build-depends: aeson, 110 | async, 111 | -- pretty-terminal depends on base >= 4.9 (ghc8) 112 | base >= 4.9 && < 5, 113 | bodhi, 114 | bugzilla-redhat >= 1.0.1, 115 | bytestring, 116 | config-ini, 117 | copr-api >= 0.2, 118 | directory >= 1.2.3, 119 | either, 120 | email-validate, 121 | extra, 122 | fedora-krb, 123 | fedora-releases >= 0.2, 124 | filepath, 125 | http-conduit, 126 | http-directory >= 0.1.5, 127 | http-query, 128 | koji, 129 | network-uri, 130 | pagure >= 0.2.1, 131 | pretty-terminal, 132 | process, 133 | -- regex-tdfa, 134 | rpmbuild-order >= 0.4.12, 135 | rpm-nvr >= 0.1.2, 136 | safe, 137 | say, 138 | select-rpms >= 0.2, 139 | simple-cmd >= 0.2.3, 140 | simple-cmd-args >= 0.1.8, 141 | simple-prompt >= 0.2.3, 142 | text, 143 | time, 144 | typed-process >= 0.2.4.0, 145 | utf8-string, 146 | unix, 147 | xdg-basedir 148 | 149 | if impl(ghc<8.3) 150 | build-depends: semigroups 151 | if impl(ghc<8.4) 152 | build-depends: http-common < 0.8.3.4 153 | if impl(ghc<9) 154 | build-depends: unordered-containers 155 | 156 | ghc-options: -threaded 157 | -Wall 158 | -Wcompat 159 | -Widentities 160 | -Wincomplete-uni-patterns 161 | -Wincomplete-record-updates 162 | if impl(ghc >= 8.0) 163 | ghc-options: -Wredundant-constraints 164 | if impl(ghc >= 8.2) 165 | ghc-options: -fhide-source-paths 166 | if impl(ghc >= 8.4) 167 | ghc-options: -Wmissing-export-lists 168 | -Wpartial-fields 169 | if impl(ghc >= 8.10) 170 | ghc-options: -Wunused-packages 171 | -------------------------------------------------------------------------------- /src/Bodhi.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Bodhi ( 4 | bodhiCreateOverride, 5 | bodhiTestingRepoTag, 6 | checkAutoBodhiUpdate, 7 | UpdateType(..), 8 | UpdateSeverity(..), 9 | UpdateNotes(..), 10 | bodhiUpdate, 11 | bodhiBuildExists 12 | ) 13 | where 14 | 15 | import Data.Char (isDigit) 16 | import Data.RPM.NVR (NVR) 17 | import Distribution.Fedora.Branch (branchRelease) 18 | import Distribution.Fedora.Release (Release(..)) 19 | import Fedora.Bodhi hiding (bodhiUpdate) 20 | import SimplePrompt (promptEnter, promptNonEmpty) 21 | import Text.Read 22 | import qualified Text.ParserCombinators.ReadP as R 23 | import qualified Text.ParserCombinators.ReadPrec as RP 24 | 25 | import Branches 26 | import Bugzilla (BugId) 27 | import Common 28 | import Common.System 29 | import Package 30 | import Types (ChangeType(ChangeBodhi)) 31 | 32 | checkAutoBodhiUpdate :: Branch -> IO Bool 33 | checkAutoBodhiUpdate Rawhide = return True 34 | checkAutoBodhiUpdate br = 35 | releaseAutomaticUpdates <$> branchRelease br 36 | 37 | -- FIXME should determine 3 days for branched devel release 38 | -- FIXME handle expired override? 39 | bodhiCreateOverride :: Bool -> Maybe Int -> NVR -> IO () 40 | bodhiCreateOverride dryrun mduration nvr = do 41 | putStrLn $ "Creating Bodhi Override for" +-+ showNVR nvr ++ ":" 42 | unless dryrun $ do 43 | ok <- cmdBool "bodhi" ["overrides", "save", "--notes", "chain building with fbrnch", "--duration", show (fromMaybe 4 mduration), "--no-wait", showNVR nvr] 44 | if ok 45 | then putStrLn $ "https://bodhi.fedoraproject.org/overrides/" ++ showNVR nvr 46 | else do 47 | moverride <- bodhiOverride $ showNVR nvr 48 | case moverride of 49 | Nothing -> do 50 | putStrLn "bodhi override failed" 51 | promptEnter "Press Enter to retry" 52 | bodhiCreateOverride dryrun mduration nvr 53 | -- FIXME prettyprint 54 | Just obj -> error' $ show obj 55 | 56 | data UpdateType = 57 | SecurityUpdate | BugfixUpdate | EnhancementUpdate | NewPackageUpdate | 58 | TemplateUpdate 59 | deriving Eq 60 | 61 | instance Show UpdateType where 62 | show SecurityUpdate = "security" 63 | show BugfixUpdate = "bugfix" 64 | show EnhancementUpdate = "enhancement" 65 | show NewPackageUpdate = "newpackage" 66 | show TemplateUpdate = error "template update" 67 | 68 | instance Read UpdateType where 69 | readPrec = do 70 | s <- look 71 | case lower s of 72 | "security" -> RP.lift (R.string s) >> return SecurityUpdate 73 | "bugfix" -> RP.lift (R.string s) >> return BugfixUpdate 74 | "enhancement" -> RP.lift (R.string s) >> return EnhancementUpdate 75 | "newpackage" -> RP.lift (R.string s) >> return NewPackageUpdate 76 | "template" -> RP.lift (R.string s) >> return TemplateUpdate 77 | _ -> error' "unknown bodhi update type" >> RP.pfail 78 | 79 | data UpdateSeverity = 80 | SeverityLow | SeverityMedium | SeverityHigh | SeverityUrgent | 81 | SeverityUnspecified 82 | deriving Eq 83 | 84 | instance Show UpdateSeverity where 85 | show SeverityLow = "low" 86 | show SeverityMedium = "medium" 87 | show SeverityHigh = "high" 88 | show SeverityUrgent = "urgent" 89 | show SeverityUnspecified = "unspecified" 90 | 91 | instance Read UpdateSeverity where 92 | readPrec = do 93 | s <- look 94 | case lower s of 95 | "low" -> RP.lift (R.string s) >> return SeverityLow 96 | "medium" -> RP.lift (R.string s) >> return SeverityMedium 97 | "high" -> RP.lift (R.string s) >> return SeverityHigh 98 | "urgent" -> RP.lift (R.string s) >> return SeverityUrgent 99 | _ -> error' "unknown bodhi update severity" >> RP.pfail 100 | 101 | bodhiTestingRepoTag :: Branch -> IO (Maybe String) 102 | bodhiTestingRepoTag Rawhide = return Nothing 103 | bodhiTestingRepoTag br = do 104 | rel <- branchRelease br 105 | return $ do 106 | _ <- releaseTestingRepo rel 107 | pure $ releaseTestingTag rel 108 | 109 | data UpdateNotes = NotesChangelog | NotesText String 110 | 111 | -- FIXME support --no-close-bugs 112 | -- push comma separated list of builds for a package to bodhi 113 | bodhiUpdate :: Bool -> (Maybe UpdateType, UpdateSeverity) -> Maybe BugId 114 | -> Maybe UpdateNotes -> FilePath -> String -> IO () 115 | bodhiUpdate _ _ _ _ _ [] = putStrLn "no package to push" 116 | bodhiUpdate dryrun (mupdate,severity) mreview mnotes spec nvrs = do 117 | case mupdate of 118 | Nothing -> return () 119 | Just updateType -> 120 | unless dryrun $ do 121 | -- use cmdLog to debug, but notes are not quoted 122 | updatedone <- do 123 | mtemplate <- maybeTemplate updateType 124 | case mtemplate of 125 | Just file -> do 126 | cmd_ "bodhi" ["updates", "new", "--file", file, nvrs] 127 | return True 128 | Nothing -> do 129 | -- FIXME also query for open existing bugs 130 | changelog <- if isJust mreview 131 | then getSummaryURL spec 132 | else 133 | case mnotes of 134 | Just NotesChangelog -> 135 | cleanChangelog True spec 136 | Just (NotesText notes) -> 137 | return notes 138 | Nothing -> 139 | -- FIXME list open bugs 140 | changeLogPrompt ChangeBodhi spec 141 | if trim (lower changelog) `elem` ["no","n"] 142 | then return False 143 | else do 144 | when (length changelog > 10000) $ 145 | putStrLn "Bodhi only accepts up to 10000 chars: will be truncated" 146 | let cbugs = extractBugReferences changelog 147 | bugs = 148 | let bids = [show rev | Just rev <- [mreview]] ++ cbugs in 149 | if null bids 150 | then [] 151 | else ["--bugs", intercalate "," bids] 152 | when (isJust mreview && 153 | updateType `elem` [SecurityUpdate,BugfixUpdate]) $ 154 | warning "overriding update type with 'newpackage'" 155 | putStrLn $ "Creating Bodhi Update for" +-+ nvrs ++ ":" 156 | -- FIXME check for Bodhi URL to confirm update 157 | -- FIXME returns json error string if it exists: 158 | -- {"status": "error", "errors": [{"location": "body", "name": "builds", "description": "Update for ghc9.2-9.2.5-14.fc36 already exists"}]} 159 | 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] 160 | return True 161 | when updatedone $ do 162 | -- FIXME avoid this if we know the update URLs (split update does not seem to return URLs) 163 | updates <- bodhiUpdates [makeItem "display_user" "0", makeItem "builds" nvrs] 164 | if null updates 165 | then do 166 | putStrLn $ "bodhi submission failed for" +-+ nvrs 167 | promptEnter "Press Enter to resubmit to Bodhi" 168 | bodhiUpdate dryrun (mupdate,severity) mreview mnotes spec nvrs 169 | else 170 | forM_ updates $ \update -> 171 | case lookupKey "url" update of 172 | Nothing -> error' "Update created but no url" 173 | Just uri -> putStrLn uri 174 | where 175 | extractBugReferences :: String -> [String] 176 | extractBugReferences clog = 177 | case dropWhile (/= '#') clog of 178 | "" -> [] 179 | (_:rest) -> 180 | case span isDigit rest of 181 | (ds,more) -> 182 | -- make sure is contemporary 7-digit bug 183 | (if length ds > 6 then (ds :) else id) $ 184 | extractBugReferences more 185 | 186 | maybeTemplate :: UpdateType -> IO (Maybe FilePath) 187 | maybeTemplate TemplateUpdate = do 188 | file <- promptNonEmpty "Please input the update template filepath" 189 | exists <- doesFileExist file 190 | if exists 191 | then return $ Just file 192 | else do 193 | putStrLn ("no such file:" +-+ file) 194 | maybeTemplate TemplateUpdate 195 | maybeTemplate _ = return Nothing 196 | 197 | bodhiBuildExists :: NVR -> IO Bool 198 | bodhiBuildExists nvr = do 199 | obj <- bodhiBuild $ showNVR nvr 200 | return $ isNothing (lookupKey "status" obj :: Maybe String) 201 | -------------------------------------------------------------------------------- /src/Branches.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Branches ( 4 | activeBranches, 5 | fedoraBranches, 6 | fedoraBranchesNoRawhide, 7 | isFedoraBranch, 8 | isEPELBranch, 9 | localBranches, 10 | pagurePkgBranches, 11 | mockRoot, 12 | Branch(..), 13 | showBranch, 14 | AnyBranch(..), 15 | anyBranch, 16 | isRelBranch, 17 | onlyRelBranch, 18 | BranchOpts(..), 19 | listOfBranches, 20 | listOfAnyBranches, 21 | gitCurrentBranch, 22 | gitCurrentBranch', 23 | checkOnBranch, 24 | systemBranch, 25 | getReleaseBranch, 26 | getReleaseBranchWarn, 27 | branchVersion, 28 | anyBranchToRelease, 29 | getRequestedBranches, 30 | BranchesReq(..), 31 | gitLines 32 | ) where 33 | 34 | import Data.Either (partitionEithers) 35 | import Distribution.Fedora.Branch (Branch(..), eitherBranch, getActiveBranched, 36 | getActiveBranches, getLatestFedoraBranch, 37 | readActiveBranch, eitherActiveBranch, 38 | readBranch, showBranch) 39 | import SimpleCmd.Git 40 | import SimplePrompt (promptEnter, promptInitial) 41 | import qualified System.Info (arch) 42 | 43 | import Common 44 | import Common.System 45 | import Pagure 46 | 47 | data AnyBranch = RelBranch Branch | OtherBranch String 48 | deriving Eq 49 | 50 | anyBranch :: String -> AnyBranch 51 | anyBranch = either OtherBranch RelBranch . eitherBranch 52 | 53 | -- allRelBranches :: [AnyBranch] -> Bool 54 | -- allRelBranches = all isRelBranch 55 | 56 | isRelBranch :: AnyBranch -> Bool 57 | isRelBranch (RelBranch _) = True 58 | isRelBranch _ = False 59 | 60 | instance Show AnyBranch where 61 | show (RelBranch br) = showBranch br 62 | show (OtherBranch obr) = obr 63 | 64 | activeBranches :: [Branch] -> [String] -> [Branch] 65 | activeBranches active = 66 | -- newest branch first 67 | reverseSort . mapMaybe (readActiveBranch active) 68 | 69 | fedoraBranches :: IO [String] -> IO [Branch] 70 | fedoraBranches mthd = do 71 | active <- getActiveBranches 72 | activeBranches active <$> mthd 73 | 74 | fedoraBranchesNoRawhide :: IO [String] -> IO [Branch] 75 | fedoraBranchesNoRawhide mthd = do 76 | active <- getActiveBranched 77 | activeBranches active <$> mthd 78 | 79 | isFedoraBranch :: Branch -> Bool 80 | isFedoraBranch (Fedora _) = True 81 | isFedoraBranch Rawhide = True 82 | isFedoraBranch _ = False 83 | 84 | isEPELBranch :: Branch -> Bool 85 | isEPELBranch (EPEL _) = True 86 | isEPELBranch _ = False 87 | 88 | localBranches :: Bool -> IO [String] 89 | localBranches local = 90 | if local 91 | then do 92 | locals <- gitLines "branch" ["--list", "--format=%(refname:lstrip=-1)"] 93 | return $ locals \\ ["HEAD", "master"] 94 | else do 95 | origins <- 96 | filter ("origin/" `isPrefixOf`) <$> 97 | gitLines "branch" ["--remote", "--list", "--format=%(refname:lstrip=-2)"] 98 | return $ map (removePrefix "origin/") origins \\ ["HEAD", "master"] 99 | 100 | -- FIXME use Package? 101 | pagurePkgBranches :: String -> IO [String] 102 | pagurePkgBranches pkg = do 103 | let project = "rpms/" ++ pkg 104 | res <- pagureListGitBranches srcfpo project 105 | return $ either (error' . include project) id res 106 | where 107 | include p e = e ++ ":" +-+ p 108 | 109 | mockRoot :: Branch -> Maybe String -> String 110 | mockRoot br march = 111 | let arch = fromMaybe System.Info.arch march 112 | in 113 | case br of 114 | Rawhide -> "fedora-rawhide-" ++ arch 115 | Fedora n -> "fedora-" ++ show n ++ "-" ++ arch 116 | EPEL n -> "epel-" ++ show n ++ "-" ++ arch 117 | EPELNext n -> "centos-stream+epel-next-" ++ show n ++ "-" ++ arch 118 | 119 | ------ 120 | 121 | data BranchOpts = AllBranches | AllFedora | AllEPEL | ExcludeBranches [Branch] 122 | deriving Eq 123 | 124 | onlyRelBranch :: AnyBranch -> Branch 125 | onlyRelBranch (RelBranch br) = br 126 | onlyRelBranch (OtherBranch br) = error' $ "Non-release branch not allowed:" +-+ br 127 | 128 | systemBranch :: IO Branch 129 | systemBranch = do 130 | platform <- init . removePrefix "PLATFORM_ID=\"platform:" <$> cmd "grep" ["PLATFORM_ID=", "/etc/os-release"] 131 | if platform == "eln" 132 | then return Rawhide 133 | else 134 | case readBranch platform of 135 | Just br -> do 136 | branched <- getLatestFedoraBranch 137 | return $ 138 | if br > branched 139 | then Rawhide 140 | else br 141 | Nothing -> error' $ "could not determine system branch from platform" +-+ platform 142 | 143 | listOfBranches :: Bool -> Bool -> BranchesReq -> IO [Branch] 144 | listOfBranches distgit _active (BranchOpt AllBranches) = 145 | if distgit 146 | then fedoraBranches (localBranches False) 147 | else getActiveBranches 148 | listOfBranches distgit _active (BranchOpt AllFedora) = 149 | filter isFedoraBranch <$> 150 | if distgit 151 | then fedoraBranches (localBranches False) 152 | else getActiveBranches 153 | listOfBranches distgit _active (BranchOpt AllEPEL) = 154 | filter isEPELBranch <$> 155 | if distgit 156 | then fedoraBranches (localBranches False) 157 | else getActiveBranches 158 | listOfBranches distgit _ (BranchOpt (ExcludeBranches brs)) = do 159 | branches <- if distgit 160 | then fedoraBranches (localBranches False) 161 | else getActiveBranches 162 | return $ branches \\ brs 163 | listOfBranches distgit active (Branches brs) = 164 | if null brs 165 | then 166 | pure <$> if distgit 167 | then getReleaseBranch 168 | else systemBranch 169 | else do 170 | activeBrs <- getActiveBranches 171 | forM_ brs $ \ br -> 172 | if active 173 | then unless (br `elem` activeBrs) $ 174 | error' $ showBranch br +-+ "is not an active branch" 175 | else 176 | case br of 177 | Fedora _ -> do 178 | let latest = maximum (delete Rawhide activeBrs) 179 | when (br > latest) $ 180 | error' $ showBranch br +-+ "is newer than latest branch" 181 | -- FIXME also check for too new EPEL 182 | _ -> return () 183 | return brs 184 | 185 | listOfAnyBranches :: Bool -> Bool -> BranchesReq -> IO [AnyBranch] 186 | listOfAnyBranches distgit active breq = 187 | if breq == Branches [] && distgit 188 | then pure <$> gitCurrentBranch 189 | else fmap RelBranch <$> listOfBranches distgit active breq 190 | 191 | getReleaseBranch :: IO Branch 192 | getReleaseBranch = 193 | gitCurrentBranch >>= anyBranchToRelease 194 | 195 | getReleaseBranchWarn :: IO Branch 196 | getReleaseBranchWarn = 197 | gitCurrentBranchWarn >>= anyBranchToRelease 198 | 199 | gitCurrentBranch :: IO AnyBranch 200 | gitCurrentBranch = do 201 | br <- gitCurrentBranch' 202 | if br == OtherBranch "HEAD" 203 | then do 204 | dir <- getDirectoryName 205 | promptEnter $ dir ++ ":" +-+ show br +-+ "is not a branch, please fix" 206 | gitCurrentBranch 207 | else return br 208 | 209 | gitCurrentBranch' :: IO AnyBranch 210 | gitCurrentBranch' = do 211 | anyBranch <$> git "rev-parse" ["--abbrev-ref", "HEAD"] 212 | 213 | gitCurrentBranchWarn :: IO AnyBranch 214 | gitCurrentBranchWarn = do 215 | br <- gitCurrentBranch 216 | if br == OtherBranch "master" 217 | then do 218 | dir <- getDirectoryName 219 | promptEnter $ dir ++ ":" +-+ show br +-+ "is not a valid branch, please use 'rename-rawhide'" 220 | gitCurrentBranchWarn 221 | else return br 222 | 223 | checkOnBranch :: IO () 224 | checkOnBranch = void gitCurrentBranch 225 | 226 | anyBranchToRelease :: AnyBranch -> IO Branch 227 | anyBranchToRelease (RelBranch rbr) = return rbr 228 | anyBranchToRelease (OtherBranch _) = systemBranch 229 | 230 | -- move to fedora-dists 231 | branchVersion :: Branch -> String 232 | branchVersion Rawhide = "rawhide" 233 | branchVersion (Fedora n) = show n 234 | branchVersion (EPEL n) = show n 235 | branchVersion (EPELNext n) = show n 236 | 237 | getRequestedBranches :: [String] -> BranchesReq -> IO [Branch] 238 | getRequestedBranches existing breq = do 239 | activenew <- filter (\b -> showBranch b `notElem` existing) <$> getActiveBranched 240 | case breq of 241 | Branches brs -> if null brs 242 | then branchingPrompt activenew 243 | else return $ [b | b <- brs, b `elem` activenew] 244 | BranchOpt request -> do 245 | let requested = case request of 246 | AllBranches -> activenew 247 | AllFedora -> filter isFedoraBranch activenew 248 | AllEPEL -> filter isEPELBranch activenew 249 | ExcludeBranches xbrs -> activenew \\ xbrs 250 | confirmBranches activenew requested 251 | where 252 | branchingPrompt :: [Branch] -> IO [Branch] 253 | branchingPrompt active = do 254 | inp <- promptInitial "Enter required branches" $ 255 | unwords $ map showBranch $ take 2 active 256 | let abrs = map anyBranch $ words inp 257 | in if all isRelBranch abrs 258 | then return $ map onlyRelBranch abrs 259 | else branchingPrompt active 260 | 261 | confirmBranches :: [Branch] -> [Branch] -> IO [Branch] 262 | confirmBranches activenew requested = do 263 | inp <- promptInitial "Confirm branches to request" $ unwords (map showBranch requested) 264 | let (errs,oks) = partitionEithers $ 265 | map (eitherActiveBranch activenew) $ words inp 266 | if null errs 267 | then return oks 268 | else do 269 | putStrLn $ "unknown branches:" +-+ unwords errs 270 | confirmBranches activenew requested 271 | 272 | data BranchesReq = 273 | BranchOpt BranchOpts | Branches [Branch] 274 | deriving Eq 275 | 276 | gitLines :: String -> [String] -> IO [String] 277 | gitLines c args = lines <$> git c args 278 | -------------------------------------------------------------------------------- /src/Cmd/Autospec.hs: -------------------------------------------------------------------------------- 1 | module Cmd.Autospec ( 2 | autospecCmd, 3 | unautospecCmd 4 | ) 5 | where 6 | 7 | import Control.Monad.Extra (unlessM, when) 8 | import SimpleCmd (cmd, cmd_) 9 | import System.Directory (doesFileExist, removeFile) 10 | 11 | import Branches 12 | import Git 13 | import Package 14 | 15 | -- FIXME! calculate baserelease: calculate bumped release and count back to last version bump commit 16 | autospecCmd :: Bool -> [String] -> IO () 17 | autospecCmd force pkgs = 18 | withPackagesByBranches HeaderMay False cleanGitFetchActive ExactlyOne autospecPkg (Branches [Rawhide], pkgs) 19 | where 20 | autospecPkg :: Package -> AnyBranch -> IO () 21 | autospecPkg _pkg br = do 22 | gitSwitchBranch br 23 | let changelogfile = "changelog" 24 | exists <- doesFileExist changelogfile 25 | if exists 26 | then 27 | if force 28 | then do 29 | cmd "rpmautospec" ["generate-changelog"] >>= 30 | writeFile changelogfile 31 | unlessM (null <$> git "status" ["--porcelain", "--untracked=no"]) $ do 32 | git_ "add" [changelogfile] 33 | git_ "commit" ["-m", "Refresh changelog"] 34 | else putStrLn "'changelog' file already exists" 35 | else cmd_ "rpmautospec" ["convert"] 36 | 37 | unautospecCmd :: (BranchesReq, [String]) -> IO () 38 | unautospecCmd = 39 | withPackagesByBranches HeaderMay False cleanGitFetchActive ExactlyOne unautospecPkg 40 | where 41 | unautospecPkg :: Package -> AnyBranch -> IO () 42 | unautospecPkg pkg br = do 43 | spec <- localBranchSpecFile pkg br 44 | autorelease <- isAutoRelease spec 45 | autochange <- isAutoChangelog spec 46 | when autochange $ do 47 | changelog <- cmd "rpmautospec" ["generate-changelog", spec] 48 | cmd_ "sed" ["-i", "/%autochangelog/d", spec] 49 | appendFile spec $ "%changelog\n" ++ changelog ++ "\n" 50 | removeFile "changelog" 51 | when autorelease $ do 52 | release <- calculateRelease spec 53 | cmd_ "sed" ["-i", "s/%autorelease/" ++ release ++ "%{?dist}/", spec] 54 | -------------------------------------------------------------------------------- /src/Cmd/Bugs.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, RecordWildCards #-} 2 | 3 | module Cmd.Bugs 4 | (bugsCmd, 5 | bzusersCmd) 6 | where 7 | 8 | import Bugzilla 9 | import Common 10 | import Common.System (error') 11 | import qualified Common.Text as T 12 | import Package 13 | 14 | bugsCmd :: Maybe String -> [String] -> IO () 15 | bugsCmd keyword pkgs = do 16 | if null pkgs 17 | -- FIXME check for distgit 18 | then bugsPkg "." 19 | else mapM_ bugsPkg pkgs 20 | where 21 | bugsPkg :: String -> IO () 22 | bugsPkg path = do 23 | pkg <- getPackageName path 24 | putPkgHdr pkg 25 | let query = 26 | case keyword of 27 | Nothing -> statusOpen 28 | Just key -> statusOpen .&&. summaryContains key 29 | bugs <- bugsAnon $ pkgBugs (unPackage pkg) .&&. query 30 | mapM_ putBugVer $ sortBugsByProduct bugs 31 | 32 | bzusersCmd :: String -> IO () 33 | bzusersCmd name = do 34 | if length (trim name) < 3 35 | then error' "use more than 2 characters" 36 | else do 37 | session <- bzApiKeySession 38 | users <- searchUsers session (T.pack name) 39 | mapM_ printUser users 40 | where 41 | printUser :: User -> IO () 42 | printUser User{..} = 43 | T.putStrLn $ userRealName <> " " <> "<" <> userName <> ">" 44 | -------------------------------------------------------------------------------- /src/Cmd/Build.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Cmd.Build ( 4 | buildCmd, 5 | BuildOpts(..) 6 | ) where 7 | 8 | import Distribution.Fedora.Branch (branchDestTag) 9 | import Fedora.Krb (krbTicket) 10 | import SimplePrompt (promptEnter, yesNo) 11 | 12 | import Bodhi 13 | import Bugzilla 14 | import Branches 15 | import Common 16 | import Common.System 17 | import Cmd.Merge 18 | import Git 19 | import Koji 20 | import Package 21 | import RpmBuild (checkSourcesMatch) 22 | import Types 23 | 24 | data BuildOpts = BuildOpts 25 | { buildoptMerge :: Maybe Bool 26 | , buildoptNoFailFast :: Bool 27 | , buildoptSidetagTarget :: Maybe SideTagTarget 28 | , buildoptOverride :: Maybe Int 29 | , buildoptWaitrepo :: Maybe Bool 30 | , buildoptDryrun :: Bool 31 | , buildoptSkipFetch :: Bool 32 | , buildoptUpdate :: (Maybe UpdateType, UpdateSeverity) 33 | , buildoptNotes :: Maybe UpdateNotes 34 | , buildoptByPackage :: Bool 35 | , buildoptStash :: Bool 36 | } 37 | 38 | -- FIXME --yes 39 | -- FIXME merge --from 40 | -- FIXME check bugs before building? 41 | -- FIXME --sidetag 42 | -- FIXME --sort 43 | -- FIXME --add-to-update nvr 44 | -- FIXME --rpmlint (default for rawhide?) 45 | -- FIXME support --wait-build=NVR 46 | -- FIXME build from ref 47 | -- FIXME tail of failed build.log 48 | -- FIXME --auto-override for deps in testing 49 | -- FIXME -B fails to find new branches (fixed?) 50 | -- FIXME disallow override for autoupdate? 51 | -- FIXME --scratch build first 52 | -- FIXME --skip-bumps NUM 53 | buildCmd :: BuildOpts -> (BranchesReq, [String]) -> IO () 54 | buildCmd opts (breq, pkgs) = do 55 | let singleBrnch = if isJust (buildoptSidetagTarget opts) 56 | then ZeroOrOne 57 | else AnyNumber 58 | mlastOfPkgs = if length pkgs > 1 59 | then Just (Package (last pkgs)) 60 | else Nothing 61 | gitopts 62 | | buildoptStash opts = stashGitFetch 63 | | buildoptSkipFetch opts = cleanGitActive 64 | | otherwise = cleanGitFetchActive 65 | if not (buildoptByPackage opts) && breq /= Branches [] && length pkgs > 1 66 | then do 67 | brs <- listOfBranches True True breq 68 | forM_ brs $ \br -> 69 | withPackagesByBranches HeaderMay True gitopts singleBrnch (buildBranch mlastOfPkgs opts) (Branches [br], pkgs) 70 | else 71 | withPackagesByBranches HeaderMay True gitopts singleBrnch (buildBranch mlastOfPkgs opts) (breq, pkgs) 72 | 73 | -- FIXME display existing sidetag early 74 | -- FIXME what if untracked files 75 | -- FIXME --merge instead of --yes confusing 76 | buildBranch :: Maybe Package -> BuildOpts -> Package -> AnyBranch -> IO () 77 | buildBranch _ _ _ (OtherBranch _) = 78 | error' "build only defined for release branches" 79 | buildBranch mlastpkg opts pkg rbr@(RelBranch br) = do 80 | let moverride = buildoptOverride opts 81 | whenJust moverride $ \days -> 82 | when (days < 1) $ error "override duration must be positive number of days" 83 | gitSwitchBranch rbr 84 | gitMergeOrigin br 85 | newrepo <- initialPkgRepo 86 | tty <- isTty 87 | (ancestor,unmerged,mnewer) <- newerMergeable (unPackage pkg) br 88 | -- FIXME if already built or failed, also offer merge 89 | merged <- 90 | case buildoptMerge opts of 91 | Just False -> return False 92 | Just True -> do 93 | whenJust mnewer $ \newer -> 94 | mergeBranch (buildoptDryrun opts) True True False pkg (ancestor,unmerged) newer br 95 | return True 96 | Nothing -> 97 | if ancestor && (newrepo || tty) 98 | then do 99 | whenJust mnewer $ \newer -> 100 | mergeBranch (buildoptDryrun opts) True False True pkg (ancestor,unmerged) newer br 101 | return $ isJust mnewer 102 | else do 103 | unless (br == Rawhide) $ 104 | whenJust mnewer $ \newer -> 105 | putStrLn $ showBranch newer +-+ "branch not mergeable" 106 | return False 107 | let spec = packageSpec pkg 108 | checkForSpecFile spec 109 | checkSourcesMatch pkg (RelBranch br) spec 110 | unpushed <- gitOneLineLog $ "origin/" ++ showBranch br ++ "..HEAD" 111 | nvr <- pkgNameVerRel' br spec 112 | putNewLn 113 | mpush <- 114 | case unpushed of 115 | [] -> return Nothing 116 | (unpd:_) -> do 117 | when (not merged || br == Rawhide) $ do 118 | -- FIXME should be printed for new package branch 119 | putStrLn $ showNVR nvr ++ "\n" 120 | putStrLn "Local commits:" 121 | displayCommits True unpushed 122 | putNewLn 123 | -- see mergeBranch for: unmerged == 1 (774b5890) 124 | if tty && (not merged || (newrepo && ancestor && length unmerged == 1)) 125 | 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 "") 126 | else return $ Just $ commitRef unpd 127 | let msidetagTarget = buildoptSidetagTarget opts 128 | target <- targetMaybeSidetag dryrun True True br msidetagTarget 129 | buildRun spec nvr merged mpush unpushed target msidetagTarget moverride 130 | where 131 | dryrun = buildoptDryrun opts 132 | 133 | buildRun spec nvr merged mpush unpushed target msidetagTarget moverride = do 134 | let mwaitrepo = buildoptWaitrepo opts 135 | buildstatus <- maybeTimeout 30 $ kojiBuildStatus nvr 136 | case buildstatus of 137 | Just BuildComplete -> do 138 | putStrLn $ showNVR nvr +-+ "is built" 139 | when (isJust mpush) $ 140 | error' "Please bump the spec file" 141 | autoupdate <- checkAutoBodhiUpdate br 142 | if not autoupdate && isNothing msidetagTarget 143 | then do 144 | updateExists <- maybeTimeout 30 $ bodhiBuildExists nvr 145 | -- FIXME update referenced bugs for autoupdate branch 146 | unless autoupdate $ do 147 | if updateExists 148 | then putStrLn "update exists" 149 | else do 150 | mbug <- bzReviewAnon 151 | bodhiUpdate dryrun (buildoptUpdate opts) mbug (buildoptNotes opts) spec $ showNVR nvr 152 | whenJust moverride $ \days -> do 153 | tags <- maybeTimeout 30 $ kojiNVRTags nvr 154 | unless (any (`elem` tags) [showBranch br, showBranch br ++ "-updates", showBranch br ++ "-override"]) $ 155 | bodhiCreateOverride dryrun (Just days) nvr 156 | when (isJust mlastpkg && mlastpkg /= Just pkg || mwaitrepo == Just True) $ 157 | when ((isJust moverride && mwaitrepo /= Just False) || 158 | (mwaitrepo == Just True)) $ 159 | kojiWaitRepoNVR dryrun False target nvr 160 | else 161 | when (mwaitrepo == Just True) $ 162 | kojiWaitRepoNVR dryrun False target nvr 163 | Just BuildBuilding -> do 164 | putStrLn $ showNVR nvr +-+ "is already building" 165 | when (isJust mpush) $ 166 | error' "Please bump the spec file" 167 | whenJustM (kojiGetBuildTaskID fedoraHub (showNVR nvr)) kojiWatchTask 168 | buildRun spec nvr merged mpush unpushed target msidetagTarget moverride 169 | _ -> do 170 | mbuildref <- 171 | case mpush of 172 | Nothing -> Just <$> git "show-ref" ["--hash", "origin/" ++ showBranch br] 173 | _ -> return mpush 174 | opentasks <- kojiOpenTasks pkg mbuildref target 175 | case opentasks of 176 | [task] -> do 177 | putStrLn $ showNVR nvr +-+ "task" +-+ displayID task +-+ "is already open" 178 | when (isJust mpush) $ 179 | error' "Please bump the spec file" 180 | kojiWatchTask task 181 | (_:_) -> error' $ show (length opentasks) +-+ "open" +-+ unPackage pkg +-+ "tasks already!" 182 | [] -> do 183 | tag <- 184 | if target == showBranch br 185 | then branchDestTag br 186 | else return target 187 | mlatest <- kojiLatestNVR tag $ unPackage pkg 188 | if equivNVR nvr mlatest 189 | then putStrLn $ showNVR nvr +-+ "is already latest" +-+ if Just nvr /= mlatest then "(modulo disttag)" else "" 190 | else do 191 | when (null unpushed || merged && br /= Rawhide) $ do 192 | putStrLn $ showNVR nvr ++ "\n" 193 | firstBuild <- do 194 | mtestingtag <- bodhiTestingRepoTag br 195 | case mtestingtag of 196 | Nothing -> return $ isNothing mlatest 197 | Just testingtag -> do 198 | mnewest <- kojiLatestNVR testingtag $ unPackage pkg 199 | case mnewest of 200 | Nothing -> return $ isNothing mlatest 201 | Just newest -> do 202 | newestTags <- kojiNVRTags newest 203 | unless (any (`elem` newestTags) [showBranch br, showBranch br ++ "-updates", showBranch br ++ "-updates-pending"]) $ do 204 | -- FIXME print how many days left 205 | putStrLn $ "Warning:" +-+ showNVR newest +-+ "still in testing?" 206 | promptEnter "Press Enter to continue" 207 | return False 208 | unless (buildoptStash opts) $ 209 | unlessM isGitDirClean $ 210 | error' "local changes remain (dirty)" 211 | unless dryrun krbTicket 212 | whenJust mpush $ \ref -> 213 | unless dryrun $ 214 | gitPush False $ Just $ ref ++ ":" ++ showBranch br 215 | unlessM (null <$> gitOneLineLog ("origin/" ++ showBranch br ++ "..HEAD")) $ 216 | unless dryrun $ do 217 | ok <- yesNo "Unpushed changes remain, continue" 218 | unless ok $ error' "aborted" 219 | -- FIXME parse build output 220 | unless dryrun $ 221 | kojiBuildBranch target pkg mbuildref ["--fail-fast" | not (buildoptNoFailFast opts)] 222 | mBugSess <- 223 | if firstBuild && isJust (fst (buildoptUpdate opts)) 224 | then bzReviewSession 225 | else return Nothing 226 | autoupdate <- checkAutoBodhiUpdate br 227 | if autoupdate 228 | then whenJust mBugSess $ 229 | \ (bid,session) -> putBugBuild dryrun session bid nvr 230 | else do 231 | when (isNothing msidetagTarget) $ do 232 | whenJust (fmap fst mBugSess) $ 233 | \bid -> putStr "review bug: " >> putBugId bid 234 | -- FIXME diff previous changelog? 235 | bodhiUpdate dryrun (buildoptUpdate opts) (fmap fst mBugSess) (buildoptNotes opts) spec $ showNVR nvr 236 | -- FIXME prompt for override note 237 | whenJust moverride $ \days -> 238 | bodhiCreateOverride dryrun (Just days) nvr 239 | when (isJust mlastpkg && mlastpkg /= Just pkg || mwaitrepo == Just True) $ 240 | when ((isJust moverride && mwaitrepo /= Just False) || 241 | (mwaitrepo == Just True)) $ 242 | kojiWaitRepoNVR dryrun False target nvr 243 | -------------------------------------------------------------------------------- /src/Cmd/Bump.hs: -------------------------------------------------------------------------------- 1 | module Cmd.Bump 2 | ( bumpCmd, 3 | bumpPkg 4 | ) 5 | where 6 | 7 | import Distribution.Fedora.Branch (branchDestTag) 8 | import System.IO.Extra 9 | 10 | import Branches 11 | import Common 12 | import Common.System 13 | import Git 14 | import Koji 15 | import Package 16 | 17 | -- FIXME --force 18 | -- FIXME --target 19 | bumpCmd :: Bool -> Bool -> Maybe String -> Maybe String 20 | -> (BranchesReq,[String]) -> IO () 21 | bumpCmd dryrun local mcmsg mclog = 22 | withPackagesByBranches (boolHeader local) False 23 | (if local then cleanGit else cleanGitFetchActive) 24 | AnyNumber (bumpPkg dryrun local mcmsg mclog) 25 | 26 | bumpPkg :: Bool -> Bool -> Maybe String -> Maybe String 27 | -> Package -> AnyBranch -> IO () 28 | bumpPkg dryrun local mcmsg mclog pkg br = do 29 | dead <- doesFileExist "dead.package" 30 | if dead 31 | then putStrLn "dead package" 32 | else do 33 | spec <- localBranchSpecFile pkg br 34 | unpushed <- gitOneLineLog $ "origin/" ++ show br ++ "..HEAD" 35 | displayCommits True unpushed 36 | autorelease <- isAutoRelease spec 37 | if autorelease 38 | then 39 | if not (null unpushed) 40 | then putStrLn $ "autorelease: unpushed" +-+ 41 | case length unpushed of 42 | 1 -> "commit" 43 | n -> show n +-+ "commits" 44 | else 45 | if dryrun 46 | then putStrLn "autorelease: bump with commit" 47 | else do 48 | let copts = 49 | "-m" : 50 | case mcmsg of 51 | Just msg -> [msg] 52 | Nothing -> 53 | case mclog of 54 | Just cl -> [cl] 55 | Nothing -> ["Bump release"] 56 | git_ "commit" $ "-a" : "--allow-empty" : copts 57 | else do 58 | rbr <- 59 | case br of 60 | RelBranch rbr -> return rbr 61 | OtherBranch _ -> systemBranch 62 | newnvr <- pkgNameVerRel' rbr spec 63 | moldnvr <- 64 | if local 65 | then do 66 | withTempDir $ \tempdir -> do 67 | git "show" ["origin:" ++ spec] >>= 68 | writeFile (tempdir spec) 69 | withCurrentDirectory tempdir $ do 70 | oldautorel <- isAutoRelease (tempdir spec) 71 | if not oldautorel 72 | then pkgNameVerRel rbr spec 73 | else do 74 | -- FIXME check version unchanged before cloning 75 | clonePkg True AnonClone (Just rbr) $ unPackage pkg 76 | withCurrentDirectory (unPackage pkg) $ 77 | pkgNameVerRel rbr spec 78 | else 79 | case br of 80 | RelBranch rbr' -> do 81 | tag <- branchDestTag rbr' 82 | kojiLatestNVR tag $ unPackage pkg 83 | -- FIXME fallback to local? 84 | _ -> return Nothing 85 | whenJust moldnvr $ \o -> putStrLn $ showNVR o +-+ "->" 86 | putStrLn $ showNVR newnvr 87 | if equivNVR newnvr moldnvr 88 | then do 89 | git_ "log" ["origin..HEAD", "--pretty=oneline"] 90 | let clog = 91 | case mclog of 92 | Just cl -> cl 93 | Nothing -> 94 | case mcmsg of 95 | Just msg -> msg 96 | _ -> "Rebuild" 97 | unless (autorelease || dryrun) $ 98 | cmd_ "rpmdev-bumpspec" ["-c", clog, spec] 99 | let copts = 100 | case mcmsg of 101 | Nothing -> ["-m", "Bump release"] 102 | Just msg -> ["-m", msg] 103 | -- FIXME quiet commit? 104 | if dryrun 105 | then putStrLn "would be bumped with commit" 106 | else git_ "commit" $ "-a" : (if autorelease then ("--allow-empty" :) else id) copts 107 | else putStrLn "already bumped" 108 | -------------------------------------------------------------------------------- /src/Cmd/Clone.hs: -------------------------------------------------------------------------------- 1 | module Cmd.Clone (cloneCmd, CloneRequest(..)) where 2 | 3 | import Control.Monad (when) 4 | import Fedora.Krb 5 | 6 | import Branches 7 | import Common.System 8 | import qualified Common.Text as T 9 | import Package 10 | import Pagure 11 | 12 | data CloneRequest = CloneGroup String 13 | | CloneUser (Maybe String) 14 | | ClonePkgs [String] 15 | 16 | -- FIXME allow pagure repo wildcard 17 | -- FIXME (detect commit rights or a ssh key?) 18 | cloneCmd :: Maybe Branch -> CloneRequest -> IO () 19 | cloneCmd mbr request = do 20 | pkgs <- case request of 21 | CloneUser mid -> do 22 | userid <- maybe fasIdFromKrb return mid 23 | map (takeFileName . T.unpack) <$> pagureUserRepos srcfpo userid 24 | -- FIXME detect/prevent "path/dir" 25 | ClonePkgs ps -> return ps 26 | CloneGroup grp -> do 27 | map (takeFileName . T.unpack) <$> pagureGroupRepos srcfpo False grp 28 | mfas <- maybeFasIdFromKrb 29 | let no = length pkgs 30 | when (no > 1) $ 31 | putStrLn $ "cloning" +-+ show no +-+ "pkg repos" 32 | let auth = maybe AnonClone (const UserClone) mfas 33 | mapM_ (clonePkg False auth mbr) pkgs 34 | -------------------------------------------------------------------------------- /src/Cmd/Commit.hs: -------------------------------------------------------------------------------- 1 | module Cmd.Commit 2 | ( commitCmd, 3 | ) 4 | where 5 | 6 | import SimplePrompt (promptNonEmpty) 7 | 8 | import Common 9 | import Common.System 10 | import Git 11 | import Package 12 | 13 | -- FIXME reject if nvr ahead of newer branch 14 | -- FIXME use branches after all? 15 | -- FIXME handle multiline changelog entries with "-m description" 16 | -- FIXME --undo last change: eg undo accidential --amend 17 | -- FIXME --empty 18 | -- FIXME include only (used) changelog if not staged 19 | commitCmd :: Bool -> Maybe CommitOpt -> Bool -> Bool -> [String] -> IO () 20 | commitCmd dryrun mopt firstLine unstaged paths = do 21 | when (isJust mopt && firstLine) $ 22 | error' "--first-line cannot be used with other commit msg options" 23 | if null paths 24 | then commitPkg "." 25 | else mapM_ commitPkg paths 26 | where 27 | commitPkg :: FilePath -> IO () 28 | commitPkg dir = 29 | withExistingDirectory dir $ 30 | unlessM isGitDirClean $ do 31 | getPackageName dir >>= putPkgHdr 32 | addall <- 33 | if null paths && not unstaged 34 | then null <$> git "diff" ["--cached"] 35 | else return unstaged 36 | opts <- case mopt of 37 | Just opt -> return $ 38 | case opt of 39 | CommitMsg msg -> ["-m", msg] 40 | -- FIXME reject amend if already pushed 41 | CommitAmend -> ["--amend", "--no-edit"] 42 | Nothing -> do 43 | changelog <- do 44 | spec <- findSpecfile 45 | autochangelog <- grep_ "^%autochangelog" spec 46 | if autochangelog 47 | -- rpmautospec generates "Uncommitted changes" 48 | then error' "set commit msg with --message" 49 | else do 50 | clog <- lines <$> cleanChangelog True spec 51 | case clog of 52 | [] -> readCommitMsg 53 | [msg] -> return msg 54 | (msg:_) -> 55 | if firstLine 56 | then return $ removePrefix "- " msg 57 | else do 58 | diff <- git "diff" ["-U0", if addall then "HEAD" else "--cached"] 59 | let newlogs = 60 | filter (\c -> ('+' : c) `elem` lines (unquoteMacros diff)) clog 61 | case newlogs of 62 | [] -> putStrLn diff >> readCommitMsg 63 | [m] -> return (removePrefix "- " m) 64 | [m,m'] -> mapM_ putStrLn newlogs >> 65 | return (unlines $ map (removePrefix "- ") [m,"",m']) 66 | (m:ms) -> mapM_ putStrLn newlogs >> 67 | return (unlines (removePrefix "- " m:"":ms)) 68 | return ["-m", changelog] 69 | if dryrun 70 | then cmdN "git" $ ["-a" | addall] ++ opts 71 | else git_ "commit" $ ["--dry-run" | dryrun] ++ ["-a" | addall] ++ opts 72 | 73 | readCommitMsg :: IO String 74 | readCommitMsg = do 75 | tty <- isTty 76 | if tty 77 | then promptNonEmpty "\nPlease input the commit message" 78 | else error' "please input commit message in a terminal" 79 | 80 | unquoteMacros :: String -> String 81 | unquoteMacros [] = [] 82 | unquoteMacros ('%':'%':cs) = '%':unquoteMacros cs 83 | unquoteMacros (c:cs) = c : unquoteMacros cs 84 | -------------------------------------------------------------------------------- /src/Cmd/Compare.hs: -------------------------------------------------------------------------------- 1 | module Cmd.Compare ( 2 | compareCmd) 3 | where 4 | 5 | import Branches 6 | import Common 7 | import Common.System 8 | import Git 9 | import Package 10 | 11 | -- FIXME warn if older branch ahead 12 | compareCmd :: Bool -> Maybe String -> AnyBranch -> AnyBranch -> [String] -> IO () 13 | compareCmd long mignore br1 br2 pkgs = do 14 | if null pkgs 15 | then do 16 | unlessM isPkgGitRepo $ 17 | error' "Please specify at least one package" 18 | else do 19 | whenM isPkgGitRepo $ 20 | error' "Cannot specify multiple packages inside a package dir" 21 | let packages = if null pkgs then ["."] else pkgs 22 | mapM_ comparePkg packages 23 | where 24 | comparePkg :: String -> IO () 25 | comparePkg pkgdir = 26 | withExistingDirectory pkgdir $ 27 | unlessM (doesFileExist "dead.package") $ do 28 | localbranches <- localBranches True 29 | oldcurrent <- gitCurrentBranch 30 | have1 <- haveBranch localbranches br1 31 | have2 <- haveBranch localbranches br2 32 | newcurrent <- gitCurrentBranch 33 | when (newcurrent /= oldcurrent) $ 34 | gitSwitchBranch oldcurrent 35 | when (have1 && have2) $ do 36 | output <- ignoredLines <$> gitLines "log" (["--format=reference" | not long] ++ [show br1 ++ ".." ++ show br2]) 37 | unless (null output) $ do 38 | unless (null pkgs) $ 39 | getPackageName pkgdir >>= putPkgHdr 40 | mapM_ putStrLn output 41 | 42 | ignoredLines :: [String] -> [String] 43 | ignoredLines = 44 | case mignore of 45 | Nothing -> id 46 | Just ignore -> filter (not . (ignore `isInfixOf`)) 47 | 48 | haveBranch :: [String] -> AnyBranch -> IO Bool 49 | haveBranch locals br = 50 | if show br `elem` locals 51 | then return True 52 | else gitSwitchBranch' True $ onlyRelBranch br 53 | -------------------------------------------------------------------------------- /src/Cmd/CreateReview.hs: -------------------------------------------------------------------------------- 1 | module Cmd.CreateReview ( 2 | createReviewCmd 3 | ) 4 | where 5 | 6 | import Data.Char (isAscii) 7 | import Fedora.Krb (maybeFasIdFromKrb) 8 | import SimpleCmd (cmd, error') 9 | import SimplePrompt (promptEnter) 10 | import System.Directory (doesFileExist) 11 | 12 | import Branches 13 | import Bugzilla 14 | import Common 15 | import Package 16 | import PkgReview 17 | import RpmBuild 18 | 19 | -- FIXME add --dependent pkgreview 20 | -- FIXME verify tarball is same as upstream 21 | -- FIXME post URL field too 22 | createReviewCmd :: Bool -> Maybe ScratchOption -> Bool -> [FilePath] -> IO () 23 | createReviewCmd force mscratchOpt mock pkgs = 24 | withPackagesByBranches HeaderMust False Nothing Zero createPkgReview (Branches [], pkgs) 25 | where 26 | createPkgReview :: Package -> AnyBranch -> IO () 27 | createPkgReview package _br = do 28 | let spec = packageSpec package 29 | pkg = unPackage package 30 | unlessM (doesFileExist spec) $ 31 | error' $ "This does not look like a pkg dir:" +-+ spec +-+ "not found" 32 | unless (all isAscii pkg) $ 33 | putStrLn "Warning: package name is not ASCII!" 34 | putStrLn "checking for existing reviews..." 35 | (bugs,session) <- bugsSession $ pkgReviews pkg 36 | unless (null bugs) $ do 37 | let nobugs = length bugs 38 | putStrLn $ plural nobugs "Existing review" ++ ":" 39 | mapM_ putBug bugs 40 | putNewLn 41 | unless force $ 42 | error' $ plural nobugs "package review" +-+ "already" +-+ singularVerb (nobugs == 1) "exist" 43 | promptEnter "Press Enter to create a new review" 44 | srpm <- generateSrpm Nothing spec 45 | mockRpmLint mock pkg spec srpm 46 | (mkojiurl,specSrpmUrls) <- buildAndUpload mscratchOpt srpm pkg spec 47 | bugid <- postReviewReq session spec specSrpmUrls mkojiurl pkg 48 | putStrLn "Review request posted:" 49 | putBugId bugid 50 | where 51 | postReviewReq :: BugzillaSession -> FilePath -> String -> Maybe String -> String -> IO BugId 52 | postReviewReq session spec specSrpmUrls mkojiurl pkg = do 53 | summary <- cmd "rpmspec" ["-q", "--srpm", "--qf", "%{summary}", spec] 54 | description <- cmd "rpmspec" ["-q", "--srpm", "--qf", "%{description}", spec] 55 | url <- cmd "rpmspec" ["-q", "--srpm", "--qf", "%{url}", spec] 56 | mfas <- maybeFasIdFromKrb 57 | createBug session 58 | [ ("product", "Fedora") 59 | , ("component", "Package Review") 60 | , ("version", "rawhide") 61 | , ("summary", "Review Request: " <> pkg <> " - " <> summary) 62 | , ("url", url) 63 | , ("description", 64 | unlines $ 65 | [specSrpmUrls, 66 | "", 67 | "Description:", 68 | description] 69 | ++ 70 | case mfas of 71 | Just fasid -> 72 | ["", 73 | "Fedora Account System Username:" +-+ fasid] 74 | Nothing -> [] 75 | ++ 76 | case mkojiurl of 77 | Just kojiurl -> 78 | ["", 79 | "", 80 | "Koji scratch build:" +-+ kojiurl] 81 | Nothing -> [] 82 | )] 83 | -------------------------------------------------------------------------------- /src/Cmd/Diff.hs: -------------------------------------------------------------------------------- 1 | module Cmd.Diff ( 2 | diffCmd, 3 | DiffFilter(..), 4 | DiffFormat(..), 5 | DiffWork(..) 6 | ) where 7 | 8 | import Branches 9 | import Common 10 | import Common.System 11 | import Git 12 | import Package 13 | import Patch 14 | 15 | data DiffFormat = 16 | DiffDefault | DiffContext Int | DiffMinimal | DiffStatus | DiffStats | 17 | DiffQuiet 18 | deriving Eq 19 | 20 | data DiffWork = 21 | DiffWorkAll | DiffWorkUnstage | DiffWorkStaged 22 | deriving Eq 23 | 24 | data DiffFilter = 25 | DiffMatch String | DiffNotMatch String 26 | -- | DiffRegex String | DiffNotRegex String 27 | deriving Eq 28 | 29 | filterOpt :: DiffFilter -> [String] 30 | filterOpt (DiffMatch m) = ["-G", m] 31 | filterOpt (DiffNotMatch m) = ["-I", m] 32 | 33 | -- FIXME diff other branches without switching 34 | -- FIXME --older/--newer branch 35 | diffCmd :: Bool -> Bool -> DiffWork -> DiffFormat -> Bool -> [DiffFilter] 36 | -> Maybe AnyBranch -> (Maybe Branch,[String]) -> IO () 37 | diffCmd debug speconly work fmt ignorebumps patts mwbr = 38 | withPackagesMaybeBranch (if debug then HeaderMust else HeaderNone) False dirtyGit diffPkg 39 | where 40 | diffPkg :: Package -> AnyBranch -> IO () 41 | diffPkg pkg br = do 42 | ok <- 43 | case br of 44 | OtherBranch _ -> gitSwitchBranch br >> return True 45 | RelBranch rbr -> gitSwitchBranch' False rbr 46 | when ok $ do 47 | speconlyNone <- 48 | if speconly 49 | then notM $ doesFileExist $ packageSpec pkg 50 | else return False 51 | if speconlyNone 52 | then do 53 | dead <- doesFileExist "dead.package" 54 | unless dead $ putStrLn $ "no" +-+ packageSpec pkg 55 | else do 56 | let contxt = case fmt of 57 | DiffContext n -> ["--unified=" ++ show n] 58 | DiffMinimal -> ["--unified=0"] 59 | DiffStatus -> ["--name-status"] 60 | -- FIXME hide "files changed" and "insertions" summary 61 | DiffStats -> ["--compact-summary"] 62 | _ -> [] 63 | (workOpts,workArgs) = 64 | case work of 65 | DiffWorkAll -> ([],["HEAD" | isNothing mwbr]) 66 | DiffWorkUnstage -> ([],[]) 67 | DiffWorkStaged -> (["--cached"],[]) 68 | file = [packageSpec pkg | speconly] 69 | mwithBranch <- 70 | case mwbr of 71 | Nothing -> return $ Just [] 72 | Just wbr -> 73 | let brn = show wbr in 74 | if '/' `elem` brn 75 | then return $ Just [brn] 76 | else do 77 | localbrs <- gitLines "branch" ["--format=%(refname:short)"] 78 | if brn `elem` localbrs 79 | then return $ Just [brn] 80 | else do 81 | wbexists <- checkIfRemoteBranchExists wbr 82 | if wbexists 83 | then return $ Just ["origin/" ++ brn] 84 | else 85 | if brn == "origin" 86 | then return $ Just ["origin/" ++ show br] 87 | else do 88 | putStrLn $ "no" +-+ show wbr +-+ "for" +-+ unPackage pkg 89 | return Nothing 90 | whenJust mwithBranch $ \withBranch -> do 91 | let revdiff = 92 | case mwbr of 93 | Nothing -> [] 94 | Just wbr -> case (wbr,br) of 95 | (RelBranch rwbr, RelBranch rbr) -> ["-R" | rwbr > rbr] 96 | _ -> [] 97 | filterOpts = 98 | concatMap filterOpt patts 99 | diff <- gitLines "diff" $ contxt ++ workOpts ++ revdiff ++ withBranch ++ filterOpts ++ workArgs ++ file 100 | let diffout = simplifyDiff fmt diff 101 | -- FIXME: sometimes we may want to list even if diff but no diffout 102 | unless (null diffout) $ 103 | unless (ignorebumps && isTrivialRebuildCommit diffout) $ 104 | if fmt == DiffQuiet 105 | then putStrLn $ unPackage pkg 106 | else do 107 | putPkgAnyBrnchHdr pkg br 108 | mapM_ putStrLn diffout 109 | where 110 | simplifyDiff :: DiffFormat -> [String] -> [String] 111 | simplifyDiff DiffMinimal ds = simplifyMinimalDiff ds 112 | -- drop "2 files changed, 113 insertions(+)" 113 | simplifyDiff DiffStats ds = if null ds then ds else init ds 114 | simplifyDiff _ ds = ds 115 | -------------------------------------------------------------------------------- /src/Cmd/FTBFS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Cmd.FTBFS ( 4 | ftbfsCmd, 5 | FTBFSBugs(..) 6 | ) 7 | where 8 | 9 | import Branches 10 | import Bugzilla 11 | import Common 12 | import Common.System 13 | import qualified Common.Text as T 14 | import Koji 15 | import Package 16 | 17 | data FTBFSBugs = FtbfsUser (Maybe String) | FtbfsSubstring String 18 | 19 | -- FIXME option for status filter 20 | -- FIXME check arch 21 | -- FIXME ask resolution 22 | ftbfsCmd :: Bool -> Bool -> Maybe FTBFSBugs -> (Maybe Branch, [FilePath]) 23 | -> IO () 24 | ftbfsCmd dryrun short mbugsopt (mbr,pkgs) = do 25 | case mbugsopt of 26 | Just bugsopt -> do 27 | unless (null pkgs) $ 28 | error' "please use bugs option without listing a package" 29 | session <- bzApiKeySession 30 | bugs <- 31 | case bugsopt of 32 | FtbfsUser muser -> do 33 | accountid <- getBzAccountId session muser 34 | searchBugs session (query .&&. assigneeIs accountid) 35 | FtbfsSubstring substr -> 36 | searchBugs session (query .&&. componentSubStr substr) 37 | mapM_ (ftbfsBugs session) bugs 38 | Nothing -> 39 | mapM_ ftbfsPkg $ if null pkgs then ["."] else pkgs 40 | where 41 | bugComponents :: Bug -> String 42 | bugComponents bug = 43 | case bugComponent bug of 44 | [component] -> T.unpack component 45 | _ -> error' $ "multiple components!\n" ++ show bug 46 | 47 | query = 48 | ftbfsFedoraBugs .&&. 49 | case mbr of 50 | Nothing -> statusNewModified 51 | Just br -> statusNewModified .&&. versionIs (branchVersion br) 52 | 53 | ftbfsBugs :: BugzillaSession -> Bug -> IO () 54 | ftbfsBugs session bug = do 55 | let pkg = bugComponents bug 56 | handleBug session pkg (Package pkg) bug 57 | 58 | ftbfsPkg :: FilePath -> IO () 59 | ftbfsPkg path = do 60 | pkg <- getPackageName path 61 | session <- bzApiKeySession 62 | mbug <- bzBugMaybe session $ pkgBugs (unPackage pkg) .&&. query 63 | whenJust mbug $ handleBug session path pkg 64 | 65 | handleBug :: BugzillaSession -> FilePath -> Package -> Bug -> IO () 66 | handleBug session path pkg bug = do 67 | if short then 68 | putStrLn $ unPackage pkg 69 | else do 70 | putStr $ unPackage pkg ++ ": " 71 | let br = fromMaybe Rawhide mbr 72 | exists <- doesDirectoryExist path 73 | if not exists 74 | then putBug bug 75 | else do 76 | nvr <- withExistingDirectory path $ 77 | localBranchSpecFile pkg (RelBranch br) >>= 78 | -- FIXME handle %autorelease correctly here 79 | pkgNameVerRel' br 80 | mstatus <- kojiBuildStatus nvr 81 | case mstatus of 82 | Nothing -> do 83 | putStrLn $ showNVR nvr ++ ": unknown nvr" 84 | putBug bug 85 | Just status -> do 86 | print status 87 | case status of 88 | BuildFailed -> do 89 | cmdLog "koji-tool" ["tasks", "--details", "-T", "-s", "fail", "-b", showNVR nvr] 90 | putNewLn 91 | BuildComplete -> do 92 | if bugStatus bug `elem` ["NEW", "ASSIGNED", "POST"] 93 | then do 94 | when dryrun $ putBug bug 95 | putBugBuild dryrun session (bugId bug) nvr 96 | putNewLn 97 | else do 98 | putBugURLStatus bug 99 | putNewLn 100 | _ -> return () 101 | -------------------------------------------------------------------------------- /src/Cmd/Fetch.hs: -------------------------------------------------------------------------------- 1 | module Cmd.Fetch ( 2 | fetchPkgs 3 | ) 4 | where 5 | 6 | import Branches 7 | import Common (when, (+-+)) 8 | import Git 9 | import Package 10 | 11 | fetchPkgs :: Bool -> [String] -> IO () 12 | fetchPkgs lenient args = 13 | withPackagesByBranches 14 | (if length args > 1 then HeaderMust else HeaderMay) 15 | False 16 | (if lenient then Nothing else dirtyGitFetch) 17 | Zero 18 | fetchPkgLenient 19 | (Branches [], args) 20 | where 21 | fetchPkgLenient :: Package -> AnyBranch -> IO () 22 | fetchPkgLenient pkg _br = 23 | when lenient $ do 24 | haveGit <- isPkgGitRepo 25 | if haveGit 26 | then gitFetchSilent False 27 | else putStrLn $ "ignoring" +-+ unPackage pkg 28 | -------------------------------------------------------------------------------- /src/Cmd/Import.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Cmd.Import ( 4 | importCmd, 5 | downloadReviewSRPM, 6 | upstreamDir 7 | ) 8 | where 9 | 10 | import Common 11 | import Common.System 12 | import qualified Common.Text as T 13 | 14 | import Fedora.Krb (krbTicket) 15 | import Network.URI 16 | import SimplePrompt (promptEnter) 17 | import SimplePrompt.Internal (runPrompt, mapInput, getPromptLine) 18 | 19 | import Branches 20 | import Bugzilla 21 | import Cmd.RequestBranch (requestPkgBranches) 22 | import Git 23 | import Koji 24 | import ListReviews 25 | import Package 26 | 27 | -- FIXME separate pre-checked listReviews and direct pkg call, which needs checks 28 | -- FIXME add --dryrun 29 | importCmd :: Bool -> Bool -> Bool -> (BranchesReq,[String]) -> IO () 30 | importCmd reporequest existingrepo mock (breq, ps) = do 31 | pkgs <- if null ps 32 | then map reviewBugToPackage <$> listReviews ReviewRepoCreated 33 | else return ps 34 | mapM_ importPkg pkgs 35 | where 36 | -- FIXME check not in a different git dir 37 | importPkg :: String -> IO () 38 | importPkg pkg = do 39 | putPkgHdr (Package pkg) 40 | dir <- getCurrentDirectory 41 | when (pkg /= takeFileName dir) $ do 42 | exists <- doesDirectoryExist pkg 43 | unless exists $ do 44 | clonePkg True UserClone Nothing pkg 45 | setCurrentDirectory pkg 46 | -- FIXME: check branch is rawhide 47 | unlessM isGitRepo $ error' "Not a git repo" 48 | newrepo <- initialPkgRepo 49 | if not newrepo && not existingrepo 50 | then putStrLn "Skipping: already imported" 51 | else do 52 | checkWorkingDirClean False 53 | -- FIXME get session from importPkgs 54 | (bid,session) <- approvedReviewBugIdSession pkg 55 | putBugId bid 56 | srpmfile <- downloadReviewSRPM False True pkg bid session 57 | putNewLn 58 | promptEnter $ "Press Enter to import" +-+ srpmfile 59 | krbTicket 60 | fedpkg_ "import" [srpmfile] 61 | git_ "commit" ["--message", "Import rhbz#" ++ show bid] 62 | nvr <- pkgNameVerRel' Rawhide (pkg <.> "spec") 63 | mbuild <- promptPushBuild $ "Press Enter to Push & B[uild]" +-+ showNVR nvr ++ ", or just P[ush], or N[o] to skip? [Y/n/b/p]" 64 | when (mbuild /= Just False) $ do 65 | gitPush True Nothing 66 | when (mbuild == Just True) $ do 67 | -- FIXME check package exists in koji (for instant import) 68 | -- FIXME build more branches 69 | kojiBuildBranch "rawhide" (Package pkg) Nothing ["--fail-fast"] 70 | putBugBuild False session bid nvr 71 | existing <- fedoraBranchesNoRawhide (localBranches False) 72 | when (null existing) $ do 73 | brs <- getRequestedBranches [] breq 74 | unless (reporequest || null brs) $ 75 | requestPkgBranches False False mock (Branches brs) (Package pkg) 76 | when (pkg /= takeFileName dir) $ 77 | setCurrentDirectory dir 78 | 79 | promptPushBuild = runPrompt . mapInput maybePush . getPromptLine 80 | where 81 | maybePush inp = 82 | case lower inp of 83 | "" -> Just (Just True) 84 | "y" -> Just (Just True) 85 | "yes" -> Just (Just True) 86 | "b" -> Just (Just True) 87 | "build" -> Just (Just True) 88 | "p" -> Just Nothing 89 | "push" -> Just Nothing 90 | "n" -> Just (Just False) 91 | "no" -> Just (Just False) 92 | _ -> Nothing 93 | 94 | downloadReviewSRPM :: Bool -> Bool -> String -> Int -> BugzillaSession 95 | -> IO FilePath 96 | downloadReviewSRPM getspec prompt pkg bid session = do 97 | putNewLn 98 | comments <- getComments session bid 99 | mapM_ showComment comments 100 | putNewLn 101 | putStr "Review bug: " 102 | putBugId bid 103 | putNewLn 104 | when prompt $ 105 | promptEnter "Press Enter to continue" 106 | when getspec $ 107 | downloadSpec comments 108 | let srpms = map (T.replace "/reviews//" "/reviews/") $ concatMap findSRPMs comments 109 | mapM_ T.putStrLn srpms 110 | unless (null srpms) putNewLn 111 | downloadSRPM (last srpms) 112 | where 113 | findSRPMs :: Comment -> [T.Text] 114 | findSRPMs = 115 | filter (\ l -> "https://" `T.isInfixOf` l && any (`T.isPrefixOf` T.toLower l) ["srpm url:", "srpm:", "new srpm:", "updated srpm:"] && ".src.rpm" `T.isSuffixOf` l) . T.lines . commentText 116 | 117 | findSpecs :: Comment -> [T.Text] 118 | findSpecs = 119 | filter (\ l -> "https://" `T.isInfixOf` l && any (`T.isPrefixOf` T.toLower l) ["spec url:", "spec:", "new spec:", "updated spec:"] && T.pack (pkg <.> "spec") `T.isSuffixOf` l) . T.lines . commentText 120 | 121 | maybeEncodeURI cs = 122 | if '%' `elem` cs 123 | then cs 124 | else escapeURIString isUnescapedInURI cs 125 | 126 | downloadSRPM :: T.Text -> IO FilePath 127 | downloadSRPM srpm = do 128 | case (filter (".src.rpm" `isSuffixOf`) . words . T.unpack) srpm of 129 | [] -> error' "no srpm filename found" 130 | srcrpms -> 131 | case filter (isURI . maybeEncodeURI) srcrpms of 132 | [] -> error "no valid srpm urls found" 133 | [srpmurl] -> do 134 | let srpmfile = takeFileName srpmurl 135 | -- FIXME if havesrpm then print local filename 136 | havesrpm <- doesFileExist srpmfile 137 | if havesrpm 138 | then putStrLn $ srpmfile +-+ "already exists" 139 | else 140 | -- was "--silent" 141 | cmd_ "curl" ["--show-error", "--remote-name", srpmurl] 142 | return srpmfile 143 | srpmurls -> error' $ "multiple srpm urls:" +-+ unwords srpmurls 144 | 145 | downloadSpec :: [Comment] -> IO () 146 | downloadSpec comments = do 147 | let specs = map (T.replace "/reviews//" "/reviews/") $ concatMap findSpecs comments 148 | mapM_ T.putStrLn specs 149 | unless (null specs) putNewLn 150 | case (filter ((pkg <.> "spec") `isSuffixOf`) . words . T.unpack . last) specs of 151 | [] -> error' "no spec filename found" 152 | specfiles -> 153 | case filter (isURI . maybeEncodeURI) specfiles of 154 | [] -> error "no valid spec urls found" 155 | [specurl] -> do 156 | let specfile = upstreamDir takeFileName specurl 157 | havespec <- doesFileExist specfile 158 | if havespec 159 | then putStrLn $ specfile +-+ "already exists" 160 | else 161 | cmd_ "curl" ["--silent", "--show-error", "--create-dirs", "--output", specfile, specurl] 162 | specurls -> error' $ "multiple spec urls:" +-+ unwords specurls 163 | 164 | upstreamDir :: FilePath 165 | upstreamDir = "UPSTREAM" 166 | -------------------------------------------------------------------------------- /src/Cmd/Install.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Cmd.Install ( 4 | installCmd, 5 | notInstalledCmd, 6 | Select(..) 7 | ) where 8 | 9 | import Data.RPM 10 | import Safe (headMay) 11 | import SelectRPMs 12 | 13 | import Branches 14 | import Cmd.Merge 15 | import Common 16 | import Common.System 17 | import Git 18 | import Package 19 | import Repoquery 20 | import RpmBuild 21 | 22 | -- FIXME --rpm to avoid dnf 23 | -- FIXME --force removal of existing incompatible dependent packages 24 | -- FIXME --subpackage to specify subpackage(s) to install/add 25 | -- FIXME --exclude to specify subpackage(s) not to install 26 | -- FIXME --ignore-uninstalled subpackages 27 | -- FIXME --skip-unavailable 28 | -- FIXME --check any/all of package installed 29 | -- FIXME add --debug or respect --verbose for dnf commands 30 | -- FIXME handle subpackage renames (eg ghc-rpm-macros-no-prof to ghc-rpm-macros-quick) 31 | -- FIXME allow building an srpm 32 | installCmd :: Bool -> Bool -> Maybe Branch -> Maybe Natural 33 | -> Maybe ForceShort -> [BCond] -> Bool -> Bool -> Bool -> Select 34 | -> Maybe ExistingStrategy -> (Maybe Branch,[String]) 35 | -> IO () 36 | installCmd quiet recurse mfrom mjobs mforceshort bconds reinstall nobuild nobuilddeps select mexisting (mbr, pkgs) = do 37 | when (recurse && isShortCircuit mforceshort) $ 38 | error' "cannot use --recurse and --shortcircuit" 39 | withPackagesMaybeBranch (boolHeader (recurse || length pkgs > 1)) True Nothing installPkg (mbr, pkgs) 40 | where 41 | installPkg :: Package -> AnyBranch -> IO () 42 | installPkg pkg br = do 43 | whenJust mbr $ gitSwitchBranch . RelBranch 44 | dead <- doesFileExist "dead.package" 45 | if dead 46 | then putStrLn "dead package" 47 | else do 48 | spec <- 49 | if isNothing mfrom 50 | then localBranchSpecFile pkg br 51 | else do 52 | mergeCmd False False True Nothing False mfrom (Branches [onlyRelBranch br], ["."]) 53 | localBranchSpecFile pkg br 54 | rpms <- builtRpms br spec 55 | let nvras = map readNVRA rpms 56 | -- FIXME can this be removed now? 57 | already <- filterM nvraInstalled nvras 58 | if isJust mforceshort || null already || reinstall 59 | then doInstallPkg mforceshort spec rpms 60 | else putStrLn $ unlines (map showNVRA already) ++ 61 | "\nalready installed!\n" 62 | where 63 | doInstallPkg mforceshort' spec rpms = do 64 | -- FIXME show source NVR (eg not pandoc-common) 65 | whenJust (headMay rpms) $ 66 | putStrLn . showNVR . dropArch . readNVRA 67 | unless (nobuilddeps || nobuild) $ do 68 | missingdeps <- nub <$> (buildRequires spec >>= filterM notInstalled) 69 | unless (null missingdeps) $ 70 | if recurse 71 | then do 72 | -- srcs <- nub <$> mapM (derefSrcPkg topdir dist True) hmissing 73 | rbr <- anyBranchToRelease br 74 | forM_ missingdeps $ \ dep -> do 75 | -- FIXME check not metadep with parens 76 | mpkgdir <- lookForPkgDir rbr ".." dep 77 | case mpkgdir of 78 | Nothing -> putStrLn $ dep +-+ "not known" 79 | Just pkgdir -> installCmd quiet recurse mfrom mjobs mforceshort bconds reinstall nobuild nobuilddeps select mexisting (mbr, [pkgdir]) >> putNewLn 80 | -- FIXME option to enable/disable installing missing deps 81 | -- FIXME --skip-missing-deps or prompt 82 | else installDeps True spec 83 | -- FIXME unused 84 | _wasbuilt <- 85 | if nobuild 86 | then return True 87 | else buildRPMs quiet False False mjobs mforceshort' bconds rpms br spec 88 | unless (isShortCircuit mforceshort') $ do 89 | let nvras = rpmsToNVRAs rpms 90 | -- FIXME: prefix = fromMaybe (nvrName nvr) mprefix 91 | decided <- decideRPMs No False mexisting select (unPackage pkg) nvras 92 | -- FIXME dryrun and debug 93 | -- FIXME return Bool? 94 | installRPMs False False Nothing No $ groupOnArch "RPMS" decided 95 | 96 | lookForPkgDir :: Branch -> FilePath -> String -> IO (Maybe FilePath) 97 | lookForPkgDir rbr topdir p = do 98 | mdir <- checkForPkgDir p 99 | case mdir of 100 | Just dir -> return $ Just dir 101 | Nothing -> 102 | if '-' `elem` p then do 103 | -- FIXME check provides p 104 | mdir' <- checkForPkgDir (init (dropWhileEnd (/= '-') p)) 105 | case mdir' of 106 | Just dir' -> return $ Just dir' 107 | Nothing -> repoquerySrc >>= checkForPkgDir 108 | else repoquerySrc >>= checkForPkgDir 109 | where 110 | checkForPkgDir :: FilePath -> IO (Maybe FilePath) 111 | checkForPkgDir p' = do 112 | let pdir = topdir p' 113 | exists <- doesDirectoryExist pdir 114 | return $ if exists 115 | then Just pdir 116 | else Nothing 117 | 118 | repoquerySrc = do 119 | putStrLn $ "Repoquerying" +-+ p 120 | sysbr <- systemBranch 121 | repoquery sysbr rbr ["--qf=%{source_name}", "--whatprovides", p] 122 | 123 | notInstalledCmd :: (Maybe Branch,[String]) -> IO () 124 | notInstalledCmd = 125 | withPackagesMaybeBranchNoHeadergit notInstalledPkg 126 | where 127 | notInstalledPkg :: Package -> AnyBranch -> IO () 128 | notInstalledPkg pkg br = do 129 | dead <- doesFileExist "dead.package" 130 | unless dead $ do 131 | spec <- findSpecfile 132 | rpms <- builtRpms br spec 133 | let nvras = map readNVRA rpms 134 | installed <- filterM nvraInstalled nvras 135 | when (null installed) $ do 136 | let pkgnames = map rpmName nvras 137 | older <- filterM pkgInstalled pkgnames 138 | if null older 139 | then putStrLn $ unPackage pkg 140 | else putStrLn $ " " ++ unPackage pkg 141 | 142 | nvraInstalled :: NVRA -> IO Bool 143 | nvraInstalled rpm = 144 | cmdBool "rpm" ["--quiet", "-q", showNVRA rpm] 145 | 146 | pkgInstalled :: String -> IO Bool 147 | pkgInstalled pkg = 148 | cmdBool "rpm" ["--quiet", "-q", pkg] 149 | -------------------------------------------------------------------------------- /src/Cmd/ListBranches.hs: -------------------------------------------------------------------------------- 1 | module Cmd.ListBranches ( 2 | branchesCmd, 3 | BranchesMode(..) 4 | ) 5 | where 6 | 7 | import Distribution.Fedora.Branch (getActiveBranches, readBranch) 8 | 9 | import Branches 10 | import Common 11 | import Common.System 12 | import Git 13 | import Package 14 | 15 | data BranchesMode = Local | Remote | Current 16 | deriving Eq 17 | 18 | -- FIXME remote/pagures branch and --remote or --no-remote 19 | -- FIXME --local for existing local branches 20 | branchesCmd :: Bool -> Bool -> Bool -> BranchesMode -> (BranchesReq,[String]) 21 | -> IO () 22 | branchesCmd skipdead allbrs missing mode (breq, pkgs) = do 23 | -- when (allbrs $ do 24 | -- unless (null brs) $ 25 | -- error' "cannot combine --all and branches" 26 | -- when missing $ 27 | -- error' "cannot combine --all and --missing" 28 | when (mode == Current) $ 29 | case breq of 30 | Branches [_] -> return () 31 | Branches [] | not missing -> return () 32 | _ -> error' $ (if missing then "--current --missing needs one branch" 33 | else "use --current with zero or one branches") ++ 34 | " specified" 35 | if null pkgs 36 | then branchesPkg "." 37 | else mapM_ branchesPkg pkgs 38 | where 39 | branchesPkg :: FilePath -> IO () 40 | branchesPkg path = do 41 | if mode == Remote 42 | then doBranchesPkg 43 | else 44 | withExistingDirectory path $ 45 | if skipdead then 46 | unlessM (doesFileExist "dead.package") 47 | doBranchesPkg 48 | else doBranchesPkg 49 | where 50 | doBranchesPkg :: IO () 51 | doBranchesPkg = do 52 | unless (mode == Remote) $ 53 | unlessM isPkgGitRepo $ 54 | error' "not Fedora dist-git" 55 | pkg <- getPackageName path 56 | if mode == Current 57 | then do 58 | br <- gitCurrentBranch' 59 | let onbranch = 60 | case br of 61 | RelBranch rbr -> Branches [rbr] == breq 62 | OtherBranch _abr -> False 63 | if missing 64 | then unless onbranch $ putStrLn $ unPackage pkg ++ ":" +-+ show br 65 | else case breq of 66 | Branches [req] -> when (RelBranch req == br) $ 67 | putStrLn $ unPackage pkg ++ ":" +-+ show br 68 | _ -> putStrLn $ unPackage pkg ++ ":" +-+ show br 69 | else do 70 | brs <- delete "main" <$> 71 | if mode == Remote 72 | then pagurePkgBranches (unPackage pkg) 73 | else localBranches False 74 | if allbrs then do 75 | putStrLn $ unPackage pkg ++ ":" +-+ unwords brs 76 | else do 77 | if breq == Branches [] 78 | then do 79 | -- FIXME better to filter inactive instead 80 | active <- getActiveBranches 81 | let result = 82 | if missing 83 | then active \\ mapMaybe readBranch brs 84 | else activeBranches active brs 85 | putStr $ unPackage pkg ++ ": " 86 | putStrLn $ (unwords . map showBranch) result 87 | else do 88 | branches <- listOfBranches True False breq 89 | let havebrs = filter (`elem` branches) $ mapMaybe readBranch brs 90 | result = if missing then branches \\ havebrs else havebrs 91 | unless (null result) $ do 92 | putStr $ unPackage pkg ++ ": " 93 | putStrLn $ (unwords . map showBranch) result 94 | -------------------------------------------------------------------------------- /src/Cmd/ListPackages.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Cmd.ListPackages ( 4 | listCmd, 5 | Packager(..), 6 | listLocalCmd 7 | ) 8 | where 9 | 10 | import Data.Aeson 11 | import Fedora.Pagure 12 | import SimplePrompt (yesNoDefault) 13 | 14 | import Branches 15 | import Common 16 | import Common.System 17 | import qualified Common.Text as T 18 | import Git (gitSwitchBranch') 19 | import Package 20 | import Pagure 21 | 22 | data Packager = Owner String | Committer String 23 | 24 | -- FIXME remote/pagure branch and --remote or --no-remote 25 | listCmd :: Bool -> Bool -> Maybe Packager -> [String] -> IO () 26 | listCmd force count mpackager pkgs = do 27 | unless (force || count || isJust mpackager || not (null pkgs)) $ 28 | error' "Please give a package pattern, --count, or --owner/--username" 29 | if null pkgs then listPackage Nothing 30 | else mapM_ (listPackage . Just) pkgs 31 | where 32 | -- FIXME add default --max-pages? 33 | listPackage :: Maybe String -> IO () 34 | listPackage mpattern = do 35 | let path = "projects" 36 | params = makeKey "short" "1" ++ fork ++ packager ++ makeKey "namespace" "rpms" ++ maybeKey "pattern" mpattern 37 | mnum <- queryPagureCount srcfpo path params "pagination" 38 | whenJust mnum $ \num -> 39 | if count 40 | then print num 41 | else do 42 | ok <- 43 | if num > 1000 && not force 44 | then yesNoDefault False $ show num +-+ "results, continue" 45 | else return True 46 | when ok $ do 47 | pages <- queryPagureCountPaged srcfpo False path params ("pagination", "page") 48 | mapM_ printPage pages 49 | where 50 | packager = 51 | case mpackager of 52 | Nothing -> makeKey "owner" "!orphan" 53 | Just (Owner o) -> makeKey "owner" o 54 | Just (Committer c) -> makeKey "username" c 55 | 56 | fork = makeKey "fork" "0" 57 | 58 | printPage :: Object -> IO () 59 | printPage result = 60 | let projects = lookupKey' "projects" result :: [Object] 61 | in 62 | mapM_ (T.putStrLn . lookupKey' "name") projects 63 | 64 | -- FIXME add --count 65 | listLocalCmd :: (Maybe Branch, [String]) -> IO () 66 | listLocalCmd = 67 | withPackagesMaybeBranch HeaderNone False dirtyGit listLocalPkg 68 | where 69 | listLocalPkg :: Package -> AnyBranch -> IO () 70 | listLocalPkg _ (OtherBranch _) = 71 | error' "other branches not supported yet" 72 | listLocalPkg pkg (RelBranch br) = do 73 | exists <- gitSwitchBranch' True br 74 | when exists $ 75 | whenM (isJust <$> maybeFindSpecfile) $ 76 | putStrLn $ unPackage pkg 77 | -------------------------------------------------------------------------------- /src/Cmd/Local.hs: -------------------------------------------------------------------------------- 1 | module Cmd.Local ( 2 | commandCmd, 3 | countCmd, 4 | installDepsCmd, 5 | localCmd, 6 | moveArtifactsCmd, 7 | nvrCmd, 8 | renameMasterCmd, 9 | srpmCmd, 10 | srpmSpecCmd 11 | ) where 12 | 13 | import qualified Data.ByteString.Lazy.Char8 as B 14 | import Data.Char (isDigit) 15 | import Safe (headMay) 16 | import System.Environment (getEnvironment) 17 | import qualified System.Process as P 18 | import qualified System.Process.Typed as TP 19 | import System.Exit 20 | import System.IO.Extra (withTempDir) 21 | 22 | import Branches 23 | import Common 24 | import Common.System 25 | import Git 26 | import Package 27 | import RpmBuild 28 | 29 | localCmd :: Bool -> Bool -> Bool -> Maybe Natural -> Maybe ForceShort 30 | -> [BCond] -> (BranchesReq, [String]) -> IO () 31 | localCmd quiet debug allowhead mjobs mforceshort bconds (breq,pkgs) = 32 | if allowhead 33 | then if breq == Branches [] 34 | then withPackagesMaybeBranch HeaderNone False dirtyGitHEAD localBuildPkgNoBranch (Nothing, pkgs) 35 | else error' "--detached-head only supported without specific branch(es)" 36 | else 37 | withPackagesByBranches HeaderNone False Nothing ZeroOrOne localBuildPkg (breq,pkgs) 38 | where 39 | localBuildPkg :: Package -> AnyBranch -> IO () 40 | localBuildPkg pkg br = do 41 | spec <- localBranchSpecFile pkg br 42 | rpms <- if isJust mforceshort 43 | then return [] 44 | else builtRpms br spec 45 | -- FIXME backup BUILD tree to .prev 46 | void $ buildRPMs quiet debug True mjobs mforceshort bconds rpms br spec 47 | -- FIXME mark BUILD dir complete 48 | 49 | localBuildPkgNoBranch :: Package -> AnyBranch -> IO () 50 | localBuildPkgNoBranch _pkg _ = do 51 | spec <- findSpecfile 52 | void $ buildRPMsNoBranch quiet debug True mjobs mforceshort bconds spec 53 | 54 | installDepsCmd :: (Maybe Branch,[String]) -> IO () 55 | installDepsCmd = 56 | withPackagesMaybeBranch HeaderNone False Nothing installDepsPkg 57 | where 58 | installDepsPkg :: Package -> AnyBranch -> IO () 59 | installDepsPkg pkg br = 60 | localBranchSpecFile pkg br >>= installDeps False 61 | 62 | srpmCmd :: Bool -> (Maybe Branch,[String]) -> IO () 63 | srpmCmd force = 64 | withPackagesMaybeBranchNoHeadergit srpmBuildPkg 65 | where 66 | srpmBuildPkg :: Package -> AnyBranch -> IO () 67 | srpmBuildPkg pkg br = do 68 | spec <- localBranchSpecFile pkg br 69 | void $ generateSrpm' force (Just br) spec 70 | 71 | nvrCmd :: (BranchesReq, [String]) -> IO () 72 | nvrCmd = 73 | withPackagesByBranches HeaderNone False Nothing AnyNumber nvrBranch 74 | where 75 | nvrBranch :: Package -> AnyBranch -> IO () 76 | nvrBranch pkg br = do 77 | spec <- localBranchSpecFile pkg br 78 | case br of 79 | RelBranch rbr -> 80 | pkgNameVerRel' rbr spec 81 | OtherBranch _obr -> do 82 | sbr <- systemBranch 83 | pkgNameVerRel' sbr spec 84 | >>= putStrLn . showNVR 85 | 86 | -- FIXME option to require spec file? 87 | commandCmd :: Bool -> Bool -> Bool -> String -> (BranchesReq,[String]) 88 | -> IO () 89 | commandCmd ifoutput compact continue cs = 90 | withPackagesByBranches (boolHeader (not ifoutput)) False Nothing AnyNumber cmdBranch 91 | where 92 | cmdBranch :: Package -> AnyBranch -> IO () 93 | cmdBranch pkg br = 94 | unlessM (doesFileExist "dead.package") $ do 95 | curEnv <- getEnvironment 96 | ret <- 97 | if ifoutput then do 98 | (ret,out) <- TP.readProcessInterleaved $ 99 | TP.setEnv (("p",unPackage pkg):curEnv) $ 100 | TP.shell cs 101 | whenJust (B.unsnoc out) $ \(bs,l) -> do 102 | if compact 103 | then putStr $ unPackage pkg ++ ": " 104 | else putPkgAnyBrnchHdr pkg br 105 | B.putStrLn $ if l == '\n' then bs else out 106 | return ret 107 | else do 108 | let p = (P.shell cs) { P.env = Just (("p",unPackage pkg):curEnv) } 109 | (_,_,_,h) <- P.createProcess p 110 | P.waitForProcess h 111 | unless (continue || ret == ExitSuccess) 112 | exitFailure 113 | 114 | renameMasterCmd :: [String] -> IO () 115 | renameMasterCmd pkgs = 116 | withPackagesByBranches HeaderMay False dirtyGit Zero renameMasterBranch (Branches [], pkgs) 117 | where 118 | renameMasterBranch :: Package -> AnyBranch -> IO () 119 | renameMasterBranch _pkg _br = do 120 | locals <- gitLines "branch" ["--format=%(refname:short)"] 121 | -- FIXME dangling warning in current output: 122 | -- From ssh://pkgs.fedoraproject.org/rpms/hedgewars 123 | -- - [deleted] (none) -> origin/master 124 | -- (refs/remotes/origin/HEAD has become dangling) 125 | -- Branch 'rawhide' set up to track remote branch 'rawhide' from 'origin'. 126 | -- compare commands with github rename 127 | unless ("rawhide" `elem` locals) $ do 128 | git_ "fetch" ["--prune"] 129 | git_ "branch" ["--move", "master", "rawhide"] 130 | git_ "remote" ["set-head", "origin", "rawhide"] 131 | git_ "branch" ["--set-upstream-to", "origin/rawhide", "rawhide"] 132 | git_ "pull" [] 133 | 134 | countCmd :: (Maybe Branch,[String]) -> IO () 135 | countCmd (mbr,pkgs) = 136 | foldM countPkg 0 pkgs >>= print 137 | where 138 | -- FIXME dead.package? 139 | countPkg :: Int -> String -> IO Int 140 | countPkg n path = 141 | withExistingDirectory path $ do 142 | whenJust mbr $ gitSwitchBranch . RelBranch 143 | mspec <- if ".spec" `isExtensionOf` path 144 | then return $ Just $ takeFileName path 145 | else maybeFindSpecfile 146 | case mspec of 147 | Just spec -> do 148 | exists <- doesFileExist spec 149 | return $ n + if exists then 1 else 0 150 | Nothing -> return n 151 | 152 | srpmSpecCmd :: Bool -> [FilePath] -> IO () 153 | srpmSpecCmd diff srpms = 154 | if diff then 155 | case srpms of 156 | [] -> error' "impossible happened: no srpms given" 157 | [srpm] -> do 158 | withTempDir $ \tempdir -> do 159 | spec <- getSrpmSpecfile False srpm tempdir 160 | cmd_ "diff" ["-u", tempdir spec, spec] 161 | [srpm1, srpm2] -> 162 | withTempDir $ \tempdir -> do 163 | spec1 <- getSrpmSpecfile True srpm1 tempdir 164 | spec2 <- getSrpmSpecfile True srpm2 tempdir 165 | withCurrentDirectory tempdir $ 166 | void $ cmdBool "diff" ["-u", spec1, spec2] 167 | _ -> error' "too many srpm files" 168 | else 169 | forM_ srpms $ \srpm -> 170 | pipe_ ("rpm2cpio", [srpm]) ("cpio",["--extract", "--quiet", "--to-stdout", "*.spec"]) 171 | where 172 | getSrpmSpecfile :: Bool -> FilePath -> FilePath -> IO FilePath 173 | getSrpmSpecfile sub srpm tempdir = do 174 | exists <- doesFileExist srpm 175 | if exists 176 | then do 177 | let subdir = if sub then takeBaseName srpm else "" 178 | dir = tempdir subdir 179 | ok <- pipeBool ("rpm2cpio", [srpm]) ("cpio", ["--extract", "--quiet", "--make-directories", "-D", dir , "--preserve-modification-time", "*.spec"]) 180 | if ok 181 | then do 182 | mspec <- headMay <$> listDirectory dir 183 | case mspec of 184 | Nothing -> error' $ "no spec in" +-+ dir 185 | Just spec -> return $ subdir spec 186 | else error' "failed to extract spec file" 187 | else error' $ "no such file:" +-+ srpm 188 | 189 | moveArtifactsCmd :: Bool -> [String] -> IO () 190 | moveArtifactsCmd remove pkgs = 191 | withPackagesByBranches HeaderMay False Nothing Zero moveArtifactsPkg (Branches [], pkgs) 192 | where 193 | moveArtifactsPkg :: Package -> AnyBranch -> IO () 194 | moveArtifactsPkg pkg br = do 195 | cwd <- getCurrentDirectory 196 | whenJustM (rpmEval "%_rpmdir") $ \rpmdir -> 197 | unless (rpmdir == cwd) $ do 198 | -- FIXME hardcoding 199 | moveRPMS rpmdir "x86_64" 200 | moveRPMS rpmdir "noarch" 201 | ls <- listDirectory "." 202 | whenJustM (rpmEval "%_srcrpmdir") $ \srcrpmdir -> 203 | unless (srcrpmdir == cwd) $ do 204 | let srpms = filter ("src.rpm" `isExtensionOf`) ls 205 | forM_ srpms $ \srpm -> do 206 | exists <- doesFileExist $ srcrpmdir srpm 207 | if exists 208 | then if remove 209 | then removeFile srpm 210 | else putStrLn $ "duplicate:" +-+ srpm 211 | else do 212 | createDirectoryIfMissing False srcrpmdir 213 | renameFile srpm $ srcrpmdir srpm 214 | whenJustM (rpmEval "%_builddir") $ \builddir -> 215 | unless (builddir == cwd) $ do 216 | dirs <- filterM doesDirectoryExist ls 217 | spec <- localBranchSpecFile pkg br 218 | srcs <- map (takeWhile (not . isDigit) . takeBaseName) <$> cmdLines "spectool" ["-S", spec] 219 | let srctrees = 220 | case srcs of 221 | [] -> [] 222 | (src:_) -> filter (src `isPrefixOf`) dirs 223 | createDirectoryIfMissing False builddir 224 | forM_ srctrees $ \tree -> do 225 | exists <- doesDirectoryExist $ builddir tree 226 | if exists 227 | then if remove 228 | then removeDirectoryRecursive tree 229 | else putStrLn $ "duplicate:" +-+ tree 230 | else renameDirectory tree $ builddir tree 231 | 232 | moveRPMS :: FilePath -> FilePath -> IO () 233 | moveRPMS rpmdir archdir = 234 | whenM (doesDirectoryExist archdir) $ do 235 | haveRpmDir <- doesDirectoryExist (rpmdir archdir) 236 | if haveRpmDir 237 | then do 238 | rpms <- listDirectory archdir 239 | forM_ rpms $ \rpm -> do 240 | let file = archdir rpm 241 | exists <- doesFileExist $ rpmdir file 242 | if exists 243 | then if remove 244 | then removeFile file 245 | else putStrLn $ "duplicate:" +-+ file 246 | else renameFile file $ rpmdir file 247 | left <- listDirectory archdir 248 | when (null left) $ 249 | removeDirectory archdir 250 | else do 251 | createDirectoryIfMissing False rpmdir 252 | renameDirectory archdir $ rpmdir archdir 253 | -------------------------------------------------------------------------------- /src/Cmd/Merge.hs: -------------------------------------------------------------------------------- 1 | module Cmd.Merge ( 2 | mergeCmd, 3 | mergeBranch, 4 | getNewerBranch) 5 | where 6 | 7 | import Safe (tailSafe) 8 | 9 | import Common 10 | import Common.System 11 | import Branches 12 | import Git 13 | import Package 14 | import Patch 15 | 16 | mergeCmd :: Bool -> Bool -> Bool -> Maybe Natural -> Bool -> Maybe Branch 17 | -> (BranchesReq,[String]) -> IO () 18 | mergeCmd dryrun nofetch noprompt mnotrivial showall mfrom = 19 | withPackagesByBranches HeaderMay False (if nofetch then cleanGitActive else cleanGitFetchActive) AnyNumber runMergeBranch 20 | where 21 | runMergeBranch :: Package -> AnyBranch -> IO () 22 | runMergeBranch _ (OtherBranch _) = 23 | error' "merge only defined for release branches" 24 | -- FIXME should rawhide default to no-op 25 | runMergeBranch pkg (RelBranch br) = do 26 | exists <- gitSwitchBranch' False br 27 | when exists $ do 28 | mfrom' <- if isJust mfrom 29 | then return mfrom 30 | else getNewerBranch (unPackage pkg) br 31 | whenJust mfrom' $ \from -> do 32 | when (from == br) $ 33 | error' "cannot merge branch to itself" 34 | unless dryrun $ 35 | gitMergeOrigin br 36 | (ancestor,unmerged) <- mergeable from br 37 | unmerged' <- filterOutTrivial mnotrivial unmerged 38 | mergeBranch dryrun False noprompt showall pkg (ancestor,unmerged') from br 39 | where 40 | filterOutTrivial :: Maybe Natural -> [Commit] -> IO [Commit] 41 | filterOutTrivial Nothing cs = return cs 42 | filterOutTrivial _ [] = return [] 43 | filterOutTrivial (Just no) css@(c:cs) = 44 | if no == 0 45 | then return css 46 | else do 47 | -- drop oneline 48 | ls <- tailSafe <$> gitLines "show" ["-U1", "--pretty=oneline", commitRef c] 49 | if isTrivialRebuildCommit ls 50 | then filterOutTrivial (Just (no -1)) cs 51 | else return css 52 | 53 | -- FIXME maybe require local branch already here 54 | mergeable :: Branch -> Branch -> IO (Bool,[Commit]) 55 | mergeable _ Rawhide = return (False,[]) 56 | mergeable from _ = do 57 | locals <- localBranches True 58 | (mancestor, unmerged) <- gitMergeable (showBranch from `notElem` locals) from 59 | return (mancestor == Just True, unmerged) 60 | 61 | -- FIXME return merged ref 62 | mergeBranch :: Bool -> Bool -> Bool -> Bool -> Package 63 | -> (Bool,[Commit]) -- (ancestor,unmerged) 64 | -> Branch -> Branch -> IO () 65 | mergeBranch _ _ _ _ _ _ _ Rawhide = return () 66 | mergeBranch _ _ _ _ _ (_,[]) _ _ = return () 67 | mergeBranch dryrun build noprompt showall pkg (True, unmerged@(unmgd:_)) from br = do 68 | unless build $ putPkgBrnchHdr pkg br 69 | isnewrepo <- initialPkgRepo 70 | putStrLn $ (if isnewrepo || noprompt then "Merging from" else "New commits in") +-+ showBranch from ++ ":" 71 | displayCommits showall unmerged 72 | putNewLn 73 | unpushed <- gitOneLineLog $ "origin/" ++ showBranch br ++ "..HEAD" 74 | unless (null unpushed) $ do 75 | putStrLn "Local commits:" 76 | displayCommits showall unpushed 77 | putNewLn 78 | mmerge <- 79 | if isnewrepo && length unmerged == 1 || noprompt 80 | then return $ Just $ commitRef unmgd 81 | else refPrompt unmerged ("Press Enter to merge" +-+ showBranch from ++ 82 | (if build then " and build" else "") ++ 83 | (if length unmerged > 1 then "; or give ref to merge" else "") ++ 84 | "; or 'no' to skip merge") 85 | -- ensure still on same branch! 86 | gitSwitchBranch (RelBranch br) 87 | whenJust mmerge $ \ ref -> do 88 | locals <- localBranches True 89 | unless (showBranch from `elem` locals) $ 90 | git_ "fetch" ["origin", showBranch from ++ ":" ++ showBranch from] 91 | unless dryrun $ 92 | -- FIXME merge from origin by default not local branch 93 | git_ "merge" ["--quiet", ref] 94 | mergeBranch dryrun build noprompt showall pkg (False,unmerged) from br = do 95 | unless build $ putPkgBrnchHdr pkg br 96 | putStrLn $ showBranch from +-+ "branch is not directly mergeable:" 97 | displayCommits False unmerged 98 | putNewLn 99 | unpushed <- gitOneLineLog $ "origin/" ++ showBranch br ++ "..HEAD" 100 | unless (null unpushed) $ do 101 | putStrLn "Local commits:" 102 | displayCommits showall unpushed 103 | mmerge <- 104 | if noprompt then return Nothing 105 | else conflictPrompt unmerged $ "Press Enter to skip merge" ++ (if build then " and build" else "") ++ "; or give ref or 'HEAD' to attempt merge" 106 | -- ensure still on same branch! 107 | gitSwitchBranch (RelBranch br) 108 | whenJust mmerge $ \ ref -> 109 | unless dryrun $ 110 | git_ "merge" [ref] 111 | -------------------------------------------------------------------------------- /src/Cmd/Mock.hs: -------------------------------------------------------------------------------- 1 | module Cmd.Mock 2 | ( mockCmd, 3 | NoClean(..), 4 | MockShell(..) 5 | ) 6 | where 7 | 8 | import Data.RPM 9 | 10 | import Branches 11 | import Common 12 | import Common.System 13 | import Git 14 | import Package 15 | import RpmBuild (generateSrpm) 16 | 17 | data NoClean = NoCleanBefore | NoCleanAfter | NoCleanAll | MockShortCircuit 18 | deriving Eq 19 | 20 | data MockShell = ShellOnly | BuildShell 21 | deriving Eq 22 | 23 | -- FIXME add repo/copr for build 24 | -- FIXME handle non-release branches (on-branch works) 25 | -- FIXME option for --shell without rebuild 26 | mockCmd :: Bool -> Maybe NoClean -> Bool-> Maybe MockShell -> Maybe Branch 27 | -> Maybe String -> (BranchesReq, [String]) -> IO () 28 | mockCmd dryrun mnoclean network mockshell mroot march (breq, ps) = do 29 | pkggit <- isPkgGitRepo 30 | branches <- 31 | case breq of 32 | Branches [] -> 33 | pure <$> 34 | if null ps && pkggit 35 | then getReleaseBranch 36 | else systemBranch 37 | _ -> listOfBranches False False breq 38 | when (null branches && length ps > 1 && isNothing mroot) $ 39 | error' "Must specific branch or --root chroot" 40 | let packages = if null ps then ["."] else ps 41 | mapM_ (mockBuildPkgs pkggit (breq == Branches []) packages) branches 42 | where 43 | mockBuildPkgs :: Bool -> Bool -> [String] -> Branch -> IO () 44 | mockBuildPkgs pkggit noswitch pkgs br = do 45 | srpms <- mapM (prepSrpm (RelBranch br)) pkgs 46 | putNewLn 47 | -- FIXME? is it better just to fail asking for target branch? 48 | rootBr <- maybe (if pkggit then getReleaseBranch else systemBranch) return mroot 49 | let resultdir = 50 | case srpms of 51 | [] -> error' "cannot build zero packages" 52 | [srpm] -> 53 | let verrel = showPkgVerRel . readNVRA $ srpm 54 | in ["--resultdir=results" verrel] 55 | _ -> [] 56 | let command = if length pkgs > 1 then "--chain" else "--rebuild" 57 | noclean = case mnoclean of 58 | Nothing -> [] 59 | Just NoCleanBefore -> ["--no-clean"] 60 | Just NoCleanAfter -> ["--no-cleanup-after"] 61 | Just NoCleanAll -> ["--no-clean", "--no-cleanup-after"] 62 | Just MockShortCircuit -> ["--short-circuit", "install"] 63 | mockopts_common c = [c, "--root", mockRoot rootBr march] ++ noclean ++ ["--enable-network" | network] 64 | mockbuild_opts = mockopts_common command ++ ["--config-opts=cleanup_on_failure=False" | mnoclean `elem` [Nothing, Just NoCleanBefore]] ++ resultdir ++ srpms 65 | mockshell_opts = mockopts_common "--shell" ++ ["--no-clean" | "--no-clean" `notElem` noclean] 66 | if dryrun 67 | then do 68 | unless (mockshell == Just ShellOnly) $ 69 | cmdN "mock" mockbuild_opts 70 | when (isJust mockshell) $ cmdN "mock" mockshell_opts 71 | else do 72 | ok <- 73 | if mockshell == Just ShellOnly 74 | then return True 75 | else cmdBool "mock" mockbuild_opts 76 | when (isJust mockshell) $ cmd_ "mock" mockshell_opts 77 | unless ok $ error' "mockbuild failed" 78 | where 79 | prepSrpm :: AnyBranch -> FilePath -> IO FilePath 80 | prepSrpm rbr pkgdir = 81 | withExistingDirectory pkgdir $ do 82 | pkg <- getPackageName pkgdir 83 | putPkgHdr pkg 84 | whenM isPkgGitRepo $ 85 | unless noswitch $ 86 | gitSwitchBranch rbr 87 | spec <- findSpecfile 88 | generateSrpm Nothing spec 89 | -------------------------------------------------------------------------------- /src/Cmd/Override.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Cmd.Override ( 4 | overrideCmd, 5 | OverrideMode(..) 6 | ) 7 | where 8 | 9 | import Data.Aeson (Object) 10 | import Fedora.Bodhi (bodhiOverrides) 11 | import Fedora.Krb (krbTicket) 12 | import Network.HTTP.Query 13 | import SimplePrompt (yesNo) 14 | 15 | import Common 16 | import Common.System 17 | 18 | import Bodhi 19 | import Branches 20 | import Cmd.WaitRepo (waitrepoCmd, WaitFetch(WaitNoFetch)) 21 | import Git 22 | import Koji 23 | import Package 24 | 25 | data OverrideMode = OverrideCreate | OverrideList | OverrideExpire 26 | deriving Eq 27 | 28 | -- FIXME debug option? 29 | overrideCmd :: Bool -> OverrideMode -> Maybe Int -> Bool 30 | -> (BranchesReq, [String]) -> IO () 31 | overrideCmd dryrun OverrideCreate mduration nowait breqpkgs = do 32 | krbTicket 33 | unless nowait $ 34 | putStrLn "Overriding" 35 | withPackagesByBranches HeaderMay False cleanGitFetchActive AnyNumber overrideBranch breqpkgs 36 | unless nowait $ 37 | waitrepoCmd dryrun WaitNoFetch Nothing breqpkgs 38 | where 39 | overrideBranch :: Package -> AnyBranch -> IO () 40 | overrideBranch _ (OtherBranch _) = 41 | error' "override only defined for release branches" 42 | overrideBranch pkg rbr@(RelBranch br) = do 43 | gitSwitchBranch rbr 44 | let spec = packageSpec pkg 45 | checkForSpecFile spec 46 | nvr <- pkgNameVerRel' br spec 47 | putStrLn $ showNVR nvr 48 | tags <- kojiNVRTags nvr 49 | unless (any (`elem` tags) [showBranch br, showBranch br ++ "-updates", showBranch br ++ "-override"]) $ 50 | unlessM (checkAutoBodhiUpdate br) $ 51 | bodhiCreateOverride dryrun mduration nvr 52 | overrideCmd _dryrun OverrideList _mduration _nowait (_breq,pkgs) = 53 | withPackages pkgs $ 54 | packageOverrides >=> mapM_ showOverride 55 | where 56 | showOverride override = 57 | case (lookupKey "expired_date" override :: Maybe String) of 58 | Just _expiry -> return () 59 | Nothing -> 60 | whenJust (lookupKey "nvr" override) $ \nvr -> 61 | putStrLn $ nvr +-+ 62 | fromMaybe "" (lookupKey "expiration_date" override :: Maybe String) 63 | overrideCmd _dryrun OverrideExpire _mduration _nowait (_breq,pkgs) = 64 | withPackages pkgs $ 65 | packageOverrides >=> mapM_ expireOverride 66 | where 67 | expireOverride override = 68 | case (lookupKey "expired_date" override :: Maybe String) of 69 | Just _expired -> return () 70 | Nothing -> do 71 | whenJust (lookupKey "nvr" override) $ \nvr -> do 72 | ok <- yesNo $ "Expire override" +-+ nvr 73 | when ok $ 74 | cmd_ "bodhi" ["overrides", "edit", "--expire", nvr] 75 | 76 | withPackages :: [FilePath] -> (Package -> IO ()) -> IO () 77 | withPackages pkgs act = 78 | forM_ (if null pkgs then ["."] else pkgs) $ \pkgdir -> 79 | withExistingDirectory pkgdir $ 80 | getPackageName "." >>= act 81 | 82 | packageOverrides :: Package -> IO [Object] 83 | packageOverrides pkg = 84 | -- FIXME could filter by "releases" for Branch's 85 | bodhiOverrides [makeItem "packages" (unPackage pkg), 86 | makeItem "expired" "0"] 87 | -------------------------------------------------------------------------------- /src/Cmd/Owner.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Cmd.Owner ( 4 | ownerCmd 5 | ) 6 | where 7 | 8 | import Network.HTTP.Query (lookupKey) 9 | 10 | import Common 11 | import Common.System 12 | import Package 13 | import Pagure 14 | 15 | -- FIXME option for email 16 | -- FIXME option to output owner's packages on separate lines 17 | ownerCmd :: [String] -> IO () 18 | ownerCmd pkgs = do 19 | if null pkgs 20 | then void $ ownerPkg "." 21 | else do 22 | pkgowners <- mapM ownerPkg pkgs 23 | when (length pkgs > 1) $ do 24 | putNewLn 25 | let maintain = groupSort pkgowners 26 | forM_ maintain $ \(o,ps) -> 27 | putStrLn $ o ++ ":" +-+ unwords (map unPackage ps) 28 | where 29 | ownerPkg :: String -> IO (String,Package) 30 | ownerPkg path = do 31 | pkg <- getPackageName path 32 | when (length pkgs > 1) $ 33 | putStr $ unPackage pkg ++ " " 34 | epkginfo <- pagureProjectInfo srcfpo ("rpms" unPackage pkg) 35 | case epkginfo of 36 | Left err -> error' err 37 | Right pkginfo -> do 38 | case lookupKey "user" pkginfo of 39 | Nothing -> error' "user not found" 40 | Just user -> 41 | case userName user of 42 | Nothing -> error' "user name not found" 43 | Just (name,full) -> do 44 | putStr $ name +-+ "(" ++ full ++ ")" 45 | whenJust (lookupKey "access_users" pkginfo >>= lookupKey "admin") $ putStrLn . formatAdmins 46 | return (name,pkg) 47 | 48 | userName user = do 49 | name <- lookupKey "name" user 50 | full <- lookupKey "fullname" user 51 | return (name,full) 52 | 53 | formatAdmins :: [String] -> String 54 | formatAdmins [] = "" 55 | formatAdmins as = ' ' : unwords as 56 | -------------------------------------------------------------------------------- /src/Cmd/Prep.hs: -------------------------------------------------------------------------------- 1 | module Cmd.Prep ( 2 | prepCmd, 3 | PrepPre(..) 4 | ) where 5 | 6 | import Branches 7 | import Cmd.Clone 8 | import Common 9 | import Common.System 10 | import Git 11 | import InterleaveOutput (cmdSilent') 12 | import Package 13 | import RpmBuild 14 | 15 | data PrepPre = PrepClone | PrepPull 16 | deriving Eq 17 | 18 | -- FIXME prompt for cloning 19 | -- FIXME to skip prep or deps (eg in broken toolbox when deps can't install;) 20 | prepCmd :: Maybe PrepPre -> Bool -> Bool -> Bool -> (Maybe Branch,[String]) 21 | -> IO () 22 | prepCmd mpre verbose deps allowhead (mbr,pkgs) = do 23 | when (mpre == Just PrepClone) $ 24 | cloneCmd mbr (ClonePkgs pkgs) 25 | withPackagesMaybeBranch HeaderNone False (if allowhead then dirtyGitHEAD else Nothing) prepPackage (mbr,pkgs) 26 | where 27 | prepPackage :: Package -> AnyBranch -> IO () 28 | prepPackage pkg br = do 29 | when (mpre == Just PrepPull) $ 30 | git_ "pull" [] 31 | dead <- doesFileExist "dead.package" 32 | if dead 33 | then do 34 | when (length pkgs > 1)$ 35 | putStr $ unPackage pkg ++ ": " 36 | putStrLn "dead.package" 37 | else do 38 | spec <- if allowhead then findSpecfile else localBranchSpecFile pkg br 39 | unlessM (doesFileExist spec) $ 40 | error' $ spec +-+ "not found" 41 | getSourcesMacros spec 42 | when deps $ 43 | installDeps False spec 44 | case br of 45 | RelBranch rbr -> do 46 | nvr <- pkgNameVerRel' rbr spec 47 | -- newline avoids error starting on same line 48 | putStr $ "Prepping" +-+ showNVR nvr ++ ": " 49 | _ -> return () 50 | sourcediropt <- do 51 | distgit <- isGitRepo 52 | if distgit 53 | then sourceDirCwdOpt 54 | else return [] 55 | timeIO $ 56 | (if verbose then cmdLog else cmdSilent') "rpmbuild" $ "-bp" : ["--nodeps" | not deps] ++ sourcediropt ++ [spec] 57 | putStrLn "done" 58 | -------------------------------------------------------------------------------- /src/Cmd/Pull.hs: -------------------------------------------------------------------------------- 1 | module Cmd.Pull ( 2 | pullPkgs, 3 | PullOpt(..) 4 | ) 5 | where 6 | 7 | import Branches 8 | import Common 9 | --import Common.System (error') 10 | import Git 11 | import Package 12 | 13 | data PullOpt = 14 | PullLenient | PullNoFetch | PullStash | PullRebase 15 | deriving Eq 16 | 17 | -- FIXME pulling more than one branch 18 | -- FIXME print nvr after pulling or old -> new 19 | pullPkgs :: Maybe PullOpt -> (BranchesReq, [String]) -> IO () 20 | pullPkgs pullopt (breq,args) = 21 | withPackagesByBranches 22 | (if length args > 1 then HeaderMust else HeaderMay) 23 | False 24 | (case pullopt of 25 | Just PullLenient -> Nothing 26 | Just PullRebase -> Nothing -- FIXME 27 | Just PullNoFetch -> cleanGit 28 | Just PullStash -> stashGitFetch 29 | Nothing -> cleanGitFetch) 30 | AnyNumber pullPkg (breq,args) 31 | where 32 | pullPkg :: Package -> AnyBranch -> IO () 33 | pullPkg pkg br = 34 | if pullopt == Just PullLenient 35 | then do 36 | haveGit <- isPkgGitRepo 37 | if haveGit 38 | then gitFetchSilent True 39 | else putStrLn $ "ignoring" +-+ unPackage pkg 40 | else doPullPkg 41 | where 42 | -- FIXME using rebase for branched may be risky 43 | doPullPkg :: IO () 44 | doPullPkg = do 45 | current <- getReleaseBranchWarn 46 | unless (breq == Branches [] || RelBranch current == br) $ 47 | gitSwitchBranch br 48 | if pullopt == Just PullRebase 49 | then git_ "pull" ["origin"] 50 | else gitMergeOrigin current 51 | when (pullopt == Just PullStash) $ do 52 | stashes <- git "stash" ["list"] 53 | case line1 stashes of 54 | (s0,_) | stashedWithFbrnch `isSuffixOf` s0 -> 55 | git_ "stash" ["pop", "--quiet"] 56 | _ -> return () 57 | -------------------------------------------------------------------------------- /src/Cmd/Push.hs: -------------------------------------------------------------------------------- 1 | module Cmd.Push ( 2 | pushPkgs 3 | ) 4 | where 5 | 6 | import Control.Monad.Extra (when, whenJustM) 7 | import Data.Maybe (isJust) 8 | import SimpleCmd (error') 9 | 10 | import Branches 11 | import Git 12 | import Package 13 | 14 | pushPkgs :: Bool -> Bool -> Maybe String -> (BranchesReq, [String]) -> IO () 15 | pushPkgs dryrun nofetch mref (breq, pkgs) = do 16 | when (isJust mref && length pkgs > 1) $ 17 | error' "can only specify ref for single package" 18 | withPackagesByBranches HeaderMust False (if nofetch then cleanGit else cleanGitFetch) AnyNumber pushPkg (breq, pkgs) 19 | where 20 | pushPkg :: Package -> AnyBranch -> IO () 21 | pushPkg _pkg br = do 22 | whenJustM (gitShortLog1 $ Just $ "origin/" ++ show br ++ "..HEAD") $ putStrLn . showCommit 23 | if dryrun 24 | then checkOnBranch 25 | else gitPush False mref 26 | -------------------------------------------------------------------------------- /src/Cmd/Repoquery.hs: -------------------------------------------------------------------------------- 1 | module Cmd.Repoquery 2 | (repoqueryCmd) 3 | where 4 | 5 | import Branches 6 | import Common.System 7 | import Repoquery 8 | 9 | import qualified Data.List as L 10 | 11 | repoqueryCmd :: (BranchesReq, [String]) -> IO () 12 | repoqueryCmd (breq, pkgs) = do 13 | query <- if null pkgs 14 | then pure <$> getDirectoryName 15 | else return pkgs 16 | brs <- listOfBranches True False breq 17 | sysbr <- systemBranch 18 | mapM_ (repoquery_ sysbr query) brs 19 | where 20 | repoquery_ :: Branch -> [String] -> Branch -> IO () 21 | repoquery_ sysbr query br = do 22 | let qf = ["--queryformat=%{repoid}: %{name}-%{version}-%{release}.%{arch}" 23 | | not (any ("--qf" `L.isPrefixOf`) query)] 24 | repoquery sysbr br (qf ++ query) >>= putStrLn 25 | -------------------------------------------------------------------------------- /src/Cmd/RequestBranch.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, OverloadedStrings #-} 2 | 3 | module Cmd.RequestBranch ( 4 | requestBranchesCmd, 5 | requestPkgBranches 6 | ) where 7 | 8 | import Fedora.Krb (fasIdFromKrb) 9 | import Network.HTTP.Query (lookupKey') 10 | import SimplePrompt (promptEnter) 11 | import System.Time.Extra (sleep) 12 | 13 | import Common 14 | import Common.System 15 | 16 | import Branches 17 | import Bugzilla 18 | import Cmd.SrcDeps (srcDeps) 19 | import Git 20 | import Koji (fedoraHub, kojiBuildTarget') 21 | import ListReviews 22 | import Package 23 | import Pagure 24 | 25 | -- FIXME option to do koji scratch build instead of mock 26 | requestBranchesCmd :: Bool -> Bool -> Maybe Branch -> Bool 27 | -> (BranchesReq,[String]) -> IO () 28 | requestBranchesCmd quiet reviews mrecursebr mock (breq, ps) = do 29 | if null ps 30 | then do 31 | when (isJust mrecursebr) $ 32 | error' "please specify a package dir when using --recurse-deps" 33 | isPkgGit <- isPkgGitSshRepo 34 | if reviews 35 | then do 36 | pkgs <- map reviewBugToPackage <$> listReviews ReviewUnbranched 37 | mapM_ (\ p -> withExistingDirectory p $ requestPkgBranches quiet (length pkgs > 1) mock breq (Package p)) pkgs 38 | else 39 | if isPkgGit 40 | then 41 | getDirectoryName >>= requestPkgBranches quiet False mock breq . Package 42 | else error' "not a dist-git dir: specify package(s)" 43 | else do 44 | pkgs <- 45 | case mrecursebr of 46 | Just br -> do 47 | -- FIXME --rpmopt 48 | deps <- concat <$> srcDeps False [] (br,ps) 49 | putStrLn $ unwords deps 50 | unless quiet $ 51 | promptEnter "\nPress Enter to check these packages for branches" 52 | return deps 53 | Nothing -> return ps 54 | forM_ pkgs $ \ p -> 55 | withExistingDirectory p $ do 56 | pkg <- getDirectoryName 57 | requestPkgBranches quiet (length pkgs > 1) mock breq (Package pkg) 58 | 59 | requestPkgBranches :: Bool -> Bool -> Bool -> BranchesReq -> Package -> IO () 60 | requestPkgBranches quiet multiple mock breq pkg = do 61 | when (breq == Branches []) $ 62 | putPkgHdr pkg 63 | brs <- localBranches False 64 | branches <- getRequestedBranches brs breq 65 | if null branches 66 | then 67 | unless quiet $ do 68 | when multiple $ putStr $ unPackage pkg ++ " " 69 | case breq of 70 | Branches [_] -> putStrLn "exists" 71 | _ -> putStrLn "branches exist" 72 | else do 73 | when multiple $ putStr $ unPackage pkg ++ " " 74 | gitFetchSilent True 75 | brs' <- localBranches False 76 | branches' <- getRequestedBranches brs' (Branches branches) 77 | whenM (havePkgAccess pkg) $ do 78 | newbranches <- filterExistingBranchRequests branches' 79 | unless (null newbranches) $ do 80 | mbidsession <- bzReviewSession 81 | urls <- forM newbranches $ \ br -> do 82 | when mock $ fedpkg_ "mockbuild" ["--root", mockRoot br Nothing] 83 | when (length branches' > 1) $ putStr $ showBranch br ++ " " 84 | -- 1. Can timeout like this: 85 | -- Could not execute request_branch: HTTPSConnectionPool(host='pagure.io', port=443): Read timed out. (read timeout=60) 86 | -- fbrnch: readCreateProcess: fedpkg "request-branch" "epel9" (exit 1): failed 87 | -- & 88 | -- 2. Can fail like this: 89 | -- Could not execute request_branch: The following error occurred while trying to get the active release branches in PDC: 90 | -- 500 Internal Server Error 91 | --

The server encountered an internal error or 92 | -- misconfiguration and was unable to complete 93 | -- your request.

[...] 94 | -- fbrnch: readCreateProcess: fedpkg "request-branch" "epel9" (exit 1): failed 95 | u <- fedpkg "request-branch" [showBranch br] 96 | putStrLn u 97 | return u 98 | whenJust mbidsession $ \(bid,session) -> 99 | commentBug session bid $ unlines urls 100 | forM_ newbranches $ \ br -> do 101 | putStrLn $ "waiting for" +-+ unPackage pkg +-+ "to be added to" +-+ showBranch br ++ "-build" 102 | (buildtag,_desttag) <- kojiBuildTarget' fedoraHub (showBranch br) 103 | waitForPkgBuildTag pkg buildtag 104 | where 105 | -- doRequestBr :: Bool -> Branch -> IO String 106 | -- doRequestBr multibr br = do 107 | -- when mock $ fedpkg_ "mockbuild" ["--root", mockRoot br] 108 | -- when multiple $ putStr (unPackage pkg ++ " ") 109 | -- when multibr $ putStr (show br) 110 | -- -- Can timeout like this: 111 | -- -- Could not execute request_branch: HTTPSConnectionPool(host='pagure.io', port=443): Read timed out. (read timeout=60) 112 | -- -- fbrnch: readCreateProcess: fedpkg "request-branch" "epel9" (exit 1): failed 113 | -- u <- fedpkg "request-branch" [show br] 114 | -- putStrLn $ ' ' : u 115 | -- return $ show br +-+ u 116 | 117 | filterExistingBranchRequests :: [Branch] -> IO [Branch] 118 | filterExistingBranchRequests branches = do 119 | existing <- fedoraBranchesNoRawhide (localBranches True) 120 | let pkgPrefix = if multiple then unPackage pkg ++ ": " else "" 121 | forM_ branches $ \ br -> 122 | when (br `elem` existing) $ 123 | putStrLn $ pkgPrefix ++ showBranch br +-+ "branch already exists" 124 | let brs' = branches \\ existing 125 | if null brs' 126 | then return [] 127 | else do 128 | current <- fedoraBranchesNoRawhide $ pagurePkgBranches (unPackage pkg) 129 | forM_ brs' $ \ br -> 130 | when (br `elem` current) $ 131 | putStrLn $ pkgPrefix ++ showBranch br +-+ "remote branch already exists" 132 | let newbranches = brs' \\ current 133 | if null newbranches 134 | then return [] 135 | else do 136 | fasid <- fasIdFromKrb 137 | -- FIXME retry on HttpExceptionRequest ... ConnectionTimeout 138 | erecent <- pagureListProjectIssueTitlesStatus "pagure.io" 139 | "releng/fedora-scm-requests" 140 | [makeItem "author" fasid, makeItem "status" "all", 141 | makeItem "per_page" "100"] 142 | case erecent of 143 | Left err -> error' err 144 | Right recent -> filterM (notExistingRequest recent) newbranches 145 | 146 | -- FIXME print invalid requests? 147 | notExistingRequest :: [IssueTitleStatus] -> Branch -> IO Bool 148 | notExistingRequest requests br = do 149 | let processed = filter processedIssueFilter requests 150 | unless (null processed) $ do 151 | putStrLn $ "Branch request already exists for" +-+ unPackage pkg ++ ":" ++ showBranch br 152 | mapM_ printScmIssue processed 153 | return $ null processed 154 | where 155 | processedIssueFilter issue = 156 | pagureIssueTitle issue == ("New Branch \"" ++ showBranch br ++ "\" for \"rpms/" ++ unPackage pkg ++ "\"") 157 | && 158 | pagureIssueCloseStatus issue == Just "Processed" 159 | 160 | havePkgAccess :: Package -> IO Bool 161 | havePkgAccess pkg = do 162 | -- check have access 163 | fasid <- fasIdFromKrb 164 | epkginfo <- pagureProjectInfo srcfpo ("rpms" unPackage pkg) 165 | case epkginfo of 166 | Left err -> error' err 167 | Right pkginfo -> do 168 | let (admins, committers) = usersWithAccess pkginfo :: ([String],[String]) 169 | access = fasid `elem` admins ++ committers 170 | unless access $ 171 | warning $ "-" +-+ fasid +-+ "does not have access, ask:" +-+ unwords admins 172 | return access 173 | where 174 | usersWithAccess pkginfo = 175 | let access = lookupKey' "access_users" pkginfo 176 | owners = lookupKey' "owner" access 177 | admins = lookupKey' "admin" access 178 | collabs = lookupKey' "collaborator" access 179 | in (owners ++ admins, collabs) 180 | 181 | waitForPkgBuildTag :: Package -> String -> IO () 182 | waitForPkgBuildTag pkg buildtag = do 183 | sleep 30 -- wait first to avoid "(undefined package)" 184 | ok <- cmdBool "koji" ["list-pkgs", "--quiet", "--package=" ++ unPackage pkg, "--tag=" ++ buildtag] 185 | unless ok $ waitForPkgBuildTag pkg buildtag 186 | -------------------------------------------------------------------------------- /src/Cmd/RequestRepo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Cmd.RequestRepo (requestRepos) where 4 | 5 | import Control.Exception.Extra (retry) 6 | import Fedora.Krb (fasIdFromKrb) 7 | import Network.HTTP.Directory (httpExists, httpManager) 8 | import Safe (headMay) 9 | import SimplePrompt (promptEnter, promptInitial, yesNo) 10 | import System.Time.Extra (sleep) 11 | 12 | import Branches 13 | import Bugzilla 14 | import Cmd.Import (importCmd) 15 | import Common 16 | import Common.System (error') 17 | import qualified Common.Text as T 18 | import ListReviews 19 | import Package 20 | import Pagure 21 | 22 | -- FIXME separate pre-checked listReviews and direct pkg call, which needs checks 23 | requestRepos :: Bool -> Bool -> Bool -> Bool -> (BranchesReq, [String]) 24 | -> IO () 25 | requestRepos mock allstates skipcheck resubmit (breq, ps) = do 26 | when (resubmit && length ps /= 1) $ 27 | error' "can only --resubmit for a single package" 28 | pkgs <- if null ps 29 | then map reviewBugToPackage <$> listReviewsAll allstates ReviewWithoutRepoReq 30 | else return ps 31 | if null pkgs 32 | then error' "No approved package reviews found" 33 | else mapM_ (requestRepo mock skipcheck resubmit breq) pkgs 34 | 35 | -- FIXME also accept bugid instead 36 | requestRepo :: Bool -> Bool -> Bool -> BranchesReq -> String -> IO () 37 | requestRepo mock skipcheck resubmit breq pkg = do 38 | putStrLn pkg 39 | (bug,session) <- approvedReviewBugSession pkg 40 | putBug bug 41 | let bid = bugId bug 42 | if bugAssignedTo bug == "nobody@fedoraproject.org" then 43 | putStrLn "Review bug needs to be assigned to reviewer first" 44 | else do 45 | created <- checkRepoCreatedComment session bid 46 | if created 47 | then putStrLn "scm repo was already created" 48 | else do 49 | requests <- 50 | if skipcheck then return [] else existingRepoRequests 51 | whenJust (headMay requests) $ \request -> do 52 | putStrLn "Request exists:" 53 | mapM_ printScmIssue requests 54 | -- don't resubmit if succeeded 55 | when (resubmit && pagureIssueCloseStatus request == Just "Processed") $ 56 | error' "The last repo request was already successfully Processed" 57 | when (null requests || resubmit) $ do 58 | checkNoPagureRepo 59 | -- may be truncated with "" 60 | comments <- getComments session bid 61 | mapM_ showComment comments 62 | putNewLn 63 | putBugId $ bugId bug 64 | putNewLn 65 | promptEnter "Press Enter to continue" 66 | -- FIXME check api key is still valid or open pagure ticket directly 67 | fedpkg_ "request-repo" [pkg, show bid] 68 | putNewLn 69 | let draft = "Thank you for the review" ++ maybe "" ("," +-+) (assigneeFirstname $ bugAssignedToDetail bug) 70 | input <- promptInitial "Enter comment" draft 71 | unless (null input) $ 72 | commentBug session bid input 73 | putNewLn 74 | branches <- getRequestedBranches [] breq 75 | forM_ branches $ \ br -> do 76 | when mock $ fedpkg_ "mockbuild" ["--root", mockRoot br Nothing] 77 | putStr $ showBranch br ++ " " 78 | fedpkg_ "request-branch" ["--repo", pkg, showBranch br] 79 | putNewLn 80 | ok <- yesNo $ "Import" +-+ pkg 81 | when ok $ do 82 | waitForPagureRepo 83 | importCmd True False False (Branches [],[pkg]) 84 | where 85 | existingRepoRequests :: IO [IssueTitleStatus] 86 | existingRepoRequests = do 87 | fasid <- fasIdFromKrb 88 | erecent <- 89 | retry 2 $ 90 | pagureListProjectIssueTitlesStatus pagureio 91 | "releng/fedora-scm-requests" 92 | [makeItem "author" fasid, makeItem "status" "all", 93 | makeItem "per_page" "100"] 94 | case erecent of 95 | Left err -> error' err 96 | Right recent -> 97 | -- don't mention "New Repo" here, since Branch requests also imply repo already exists 98 | return $ filter (((" for \"rpms/" ++ pkg ++ "\"") `isSuffixOf`) . pagureIssueTitle) recent 99 | 100 | checkNoPagureRepo :: IO () 101 | checkNoPagureRepo = do 102 | mgr <- httpManager 103 | exists <- httpExists mgr $ "https://" ++ srcfpo +/+ "rpms" +/+ pkg 104 | when exists $ 105 | error' $ "Repo for" +-+ pkg +-+ "already exists" 106 | 107 | -- FIXME handle "email name" 108 | assigneeFirstname :: User -> Maybe String 109 | assigneeFirstname assignee = 110 | case T.words $ userRealName assignee of 111 | [] -> Nothing 112 | first:_ -> 113 | if "@" `T.isInfixOf` first 114 | then Nothing 115 | else Just (T.unpack first) 116 | 117 | waitForPagureRepo :: IO () 118 | waitForPagureRepo = do 119 | ebrs <- pagureListGitBranches srcfpo $ "rpms/" ++ pkg 120 | case ebrs of 121 | Left _err -> do 122 | putChar '.' 123 | sleep 10 124 | waitForPagureRepo 125 | Right brs -> 126 | when (null brs) $ 127 | error' $ "no branches in dist-git for" +-+ pkg 128 | -------------------------------------------------------------------------------- /src/Cmd/ReviewPackage.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, OverloadedStrings #-} 2 | 3 | module Cmd.ReviewPackage ( 4 | reviewPackage 5 | ) where 6 | 7 | import Common 8 | import Common.System 9 | 10 | import Data.Char 11 | import Data.Tuple.Extra (second) 12 | import Safe (headDef, headMay, tailSafe) 13 | import SelectRPMs (selectDefault) 14 | import SimplePrompt (promptEnter, yesNoDefault) 15 | 16 | import Branches 17 | import Bugzilla 18 | import Cmd.Import (downloadReviewSRPM, upstreamDir) 19 | import Cmd.Install (installCmd) 20 | import Cmd.Local (localCmd) 21 | import Git (isGitRepo, git_, gitBool) 22 | import Package 23 | import RpmBuild 24 | 25 | -- FIXME does not work with pkg dir/spec: 'fbrnch: No spec file found' 26 | -- FIXME --user to download all user's review requests 27 | reviewPackage :: Bool -> Maybe String -> IO () 28 | reviewPackage interactive Nothing = do 29 | -- FIXME catch no spec file 30 | spec <- findSpecfile 31 | srpm <- generateSrpm Nothing spec 32 | if interactive 33 | then doInteractiveReview False (Just spec) srpm 34 | else do 35 | cmd_ "fedora-review" ["-rn", srpm] 36 | reviewPackage interactive (Just pkgbug) = do 37 | let epkgbid = 38 | if all isDigit pkgbug 39 | then Right $ read pkgbug 40 | else Left pkgbug 41 | (bugs,session) <- bugsSession $ 42 | case epkgbid of 43 | Right bid -> packageReview .&&. statusNewAssigned .&&. bugIdIs bid 44 | Left pkg -> pkgReviews pkg .&&. statusNewAssigned 45 | case bugs of 46 | [bug] -> do 47 | putReviewBug False bug 48 | let bid = bugId bug 49 | pkg = reviewBugToPackage bug 50 | if interactive 51 | then reviewPackageInteractive bid pkg session bug 52 | else do 53 | promptEnter "Press Enter to run fedora-review" 54 | -- FIXME support copr build 55 | -- FIXME if toolbox set REVIEW_NO_MOCKGROUP_CHECK 56 | cmd_ "fedora-review" ["-b", show bid] 57 | [] -> error' $ "No package review found for" +-+ pkgbug 58 | _ -> error' $ "More than one review bug found for" +-+ pkgbug 59 | 60 | reviewPackageInteractive :: Int -> String -> BugzillaSession -> Bug -> IO () 61 | reviewPackageInteractive bid pkg session bug = do 62 | let dir = show bid ++ '-' : pkg 63 | -- FIXME check if current directory 64 | exists <- doesDirectoryExist dir 65 | unless exists $ 66 | createDirectory dir 67 | setCurrentDirectory dir 68 | srpm <- downloadReviewSRPM True False pkg bid session 69 | importsrpm <- 70 | if exists 71 | then do 72 | putStrLn $ "in" +-+ dir ":\n" 73 | cmd_ "ls" ["-F"] 74 | putNewLn 75 | -- FIXME default to no if nvr unchanged? 76 | yesNoDefault True "Press Enter to install/prep srpm" 77 | else return True 78 | -- review and package name may be different (eg ramalama) 79 | doInteractiveReview importsrpm Nothing srpm 80 | putNewLn 81 | putReviewBug False bug 82 | putNewLn 83 | putStrLn $ "Review dir is" +-+ dir 84 | 85 | doInteractiveReview :: Bool -> Maybe FilePath -> FilePath -> IO () 86 | doInteractiveReview importsrpm mspec srpm = do 87 | when importsrpm $ do 88 | isgit <- isGitRepo 89 | unless isgit $ git_ "init" [] 90 | -- FIXME override %_sourcedir so it doesn't put elsewhere? 91 | sourcediropt <- sourceDirCwdOpt 92 | putStrLn "installing srpm:" 93 | cmd_ "rpm" $ ["-i", srpm] ++ sourcediropt 94 | spec <- maybe findSpecfile return mspec 95 | git_ "add" [spec] 96 | allsrcs <- map sourceFieldFile <$> cmdLines "spectool" [spec] 97 | forM_ allsrcs $ \src -> 98 | unless (isArchiveFile src) $ 99 | git_ "add" [src] 100 | putStrLn $ "# Diff with" +-+ upstreamDir 101 | cmd_ "diff" ["-u", spec, upstreamDir spec] 102 | withCurrentDirectory upstreamDir $ 103 | void $ getSources spec 104 | diff <- lines <$> cmdIgnoreErr "diff" ["--brief", ".", upstreamDir] "" 105 | let filterdiff = filter (\d -> not (any (`isSuffixOf` d) ["SPEC","SRPMS","RPMS","BUILD","BUILDROOT","src.rpm",".log", ".git", upstreamDir])) diff 106 | if null filterdiff 107 | then putStrLn $ "no difference with" +-+ upstreamDir ++ "/" 108 | else mapM_ putStrLn filterdiff 109 | unlessM (gitBool "diff" ["--quiet", "--cached"]) $ 110 | git_ "commit" ["-m", srpm] 111 | putNewLn 112 | putStrLn "# Build" 113 | -- FIXME or download rpms 114 | build <- yesNoDefault importsrpm "Build package locally" 115 | when build $ 116 | localCmd False False False Nothing Nothing [] (Branches [],[]) 117 | putNewLn 118 | putStrLn "# RpmLint" 119 | void $ cmdBool "rpmlint" ["."] -- FIXME $ spec:srpm:rpms 120 | spec <- maybe findSpecfile return mspec 121 | whenM (yesNoDefault importsrpm "Install packages locally") $ do 122 | installCmd False False Nothing Nothing Nothing [] False True True selectDefault Nothing (Nothing,[]) 123 | rpms <- cmdLines "rpmspec" ["-q", "--rpms", "--qf", "%{name}\n", spec] 124 | whenM (yesNoDefault importsrpm "Rpmlint installed packages") $ do 125 | (_ok, out, err) <- cmdFull "rpmlint" ("-i" : rpms) "" 126 | let rpmlintout = "rpmlint.output" 127 | writeFile rpmlintout out 128 | let ls = lines out 129 | nolines = length ls 130 | if nolines > 20 131 | then do 132 | mapM_ putStrLn $ takeEnd 10 ls 133 | putNewLn 134 | putStrLn "RpmLint summary:" 135 | mapM_ (putStrLn . renderLintSummary) $ summarizeErrors ls 136 | putStrLn $ show nolines +-+ "lines saved to" +-+ rpmlintout 137 | else putStrLn out 138 | unless (null err) $ warning $ "rpmlint stderr:\n" ++ err 139 | putNewLn 140 | putStrLn "# Licensing" 141 | -- FIXME use build subdir 142 | -- FIXME filter out files not in tarball or prep 143 | cmdLines "licensecheck" ["-r", "BUILD"] >>= 144 | -- handle "FILEPATH: *No copyright* UNKNOWN [generated file]" 145 | mapM_ putStrLn . filter (not . (" UNKNOWN" `isInfixOf`)) 146 | cmd_ "rpmspec" ["-q", "--srpm", "--qf", "Spec license: %{license}\n", spec] 147 | 148 | summarizeErrors :: [String] -> [(String,Int)] 149 | summarizeErrors = 150 | sortOn fst . map (second length) . groupOnKey (headDef "''") . map tailSafe . filter ((Just "E:" ==) . headMay) . map (tailSafe . words) 151 | 152 | renderLintSummary :: (String,Int) -> String 153 | renderLintSummary (err,n) = err ++ ":" +-+ show n 154 | 155 | #if !MIN_VERSION_extra(1,7,11) 156 | groupOnKey :: Eq k => (a -> k) -> [a] -> [(k, [a])] 157 | groupOnKey _ [] = [] 158 | groupOnKey f (x:xs) = (fx, x:yes) : groupOnKey f no 159 | where 160 | fx = f x 161 | (yes, no) = span (\y -> fx == f y) xs 162 | #endif 163 | -------------------------------------------------------------------------------- /src/Cmd/Reviews.hs: -------------------------------------------------------------------------------- 1 | module Cmd.Reviews ( 2 | reviewsCmd, 3 | findReview) 4 | where 5 | 6 | import Bugzilla 7 | import Common 8 | import ListReviews 9 | 10 | -- FIXME add --state or --new, --modified, etc 11 | -- FIXME display time of last update 12 | reviewsCmd :: Bool -> Bool -> Maybe (Maybe String) -> Maybe (Maybe String) 13 | -> Maybe String -> ReviewStatus -> IO () 14 | reviewsCmd short allstates Nothing Nothing Nothing status = 15 | reviewsCmd short allstates Nothing (Just Nothing) Nothing status 16 | reviewsCmd short allstates mmassignee mmreporter mpat status = do 17 | listReviewsFull mmassignee mmreporter mpat allstates status >>= 18 | mapM_ (putReviewBug short) . sortBugsByStatus . sortBugsByID 19 | when short putNewLn 20 | 21 | findReview :: String -> IO () 22 | findReview pkg = do 23 | bugIdsAnon (pkgReviews pkg) 24 | >>= mapM_ putBugId 25 | -------------------------------------------------------------------------------- /src/Cmd/Scratch.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Cmd.Scratch ( 4 | scratchCmd, 5 | scratchCmdAarch64, 6 | scratchCmdX86_64, 7 | Archs(..), 8 | ScratchSource(..) 9 | ) where 10 | 11 | import Data.RPM.NVR (NVR) 12 | import Safe (tailSafe) 13 | 14 | import Branches 15 | import Common 16 | import Common.System 17 | import Git 18 | import Koji 19 | import Package 20 | import RpmBuild (generateSrpm) 21 | import Types (Archs(..),SideTagTarget) 22 | 23 | data ScratchSource = ScratchRef String | ScratchSRPM String 24 | 25 | showScratchSource :: Bool -> NVR -> Maybe ScratchSource -> String 26 | showScratchSource pushed nvr Nothing = 27 | showNVR nvr ++ (if pushed then "" else ".src.rpm") 28 | showScratchSource _ _ (Just (ScratchRef ref)) = ref 29 | showScratchSource _ _ (Just (ScratchSRPM srpm)) = srpm 30 | 31 | -- FIXME --no-tail 32 | -- FIXME --with --without ? 33 | -- FIXME allow parallel targets 34 | -- FIXME append timestamp after %release (to help identify scratch builds) 35 | -- FIXME FIXME use option type: 36 | scratchCmd :: Bool -> Bool -> Bool -> Bool -> Bool -> Maybe Archs 37 | -> [SideTagTarget] -> Maybe ScratchSource -> (BranchesReq, [String]) 38 | -> IO () 39 | scratchCmd dryrun stagger rebuildSrpm nofailfast allowHEAD marchopts sidetagTargets msource (breq,pkgs) = 40 | withPackagesByBranches HeaderMust False Nothing AnyNumber scratchBuild (breq,pkgs) 41 | where 42 | anyTarget (RelBranch b) = showBranch b 43 | anyTarget _ = "rawhide" 44 | 45 | scratchBuild :: Package -> AnyBranch -> IO () 46 | scratchBuild pkg br = do 47 | when (isJust msource && length pkgs > 1) $ 48 | error' "source override is not supported for multiple packages" 49 | pkggit <- isPkgGitRepo 50 | when (not pkggit && breq == Branches [] && null sidetagTargets) $ 51 | error' "please specify a branch or target for non dist-git" 52 | spec <- localBranchSpecFile pkg br 53 | targets <- 54 | if null sidetagTargets 55 | then return [anyTarget br] 56 | else mapM (targetMaybeSidetag dryrun False True (onlyRelBranch br) . Just) sidetagTargets 57 | forM_ targets $ \target -> do 58 | archs <- 59 | case marchopts of 60 | Nothing -> return [] 61 | Just archopts -> 62 | case archopts of 63 | Archs as -> return as 64 | ExcludedArchs as -> do 65 | (buildtag,_desttag) <- kojiBuildTarget' fedoraHub target 66 | tagArchs <- kojiTagArchs buildtag 67 | excludedarchs <- do 68 | excluded <- map words . filter ("ExcludeArch:" `isPrefixOf`) <$> cmdLines "rpmspec" ["-P", spec] 69 | return $ 70 | if null excluded 71 | then return [] 72 | else concatMap tailSafe excluded 73 | return $ tagArchs \\ (as ++ excludedarchs) 74 | if stagger 75 | then do 76 | archlist <- 77 | if null archs 78 | then do 79 | (buildtag,_desttag) <- kojiBuildTarget' fedoraHub target 80 | tagArchs <- kojiTagArchs buildtag 81 | -- prioritize preferred archs 82 | return $ nub $ priorityArchs ++ tagArchs 83 | else return $ nub $ filter (`elem` archs) priorityArchs ++ archs 84 | forM_ archlist $ \arch -> do 85 | putStrLn $ arch +-+ "scratch build" 86 | doScratchBuild pkggit spec target [arch] 87 | else doScratchBuild pkggit spec target archs 88 | where 89 | priorityArchs = ["x86_64", "aarch64", "ppc64le"] 90 | 91 | doScratchBuild pkggit spec target archs = do 92 | let kojiargs = ["--arch-override=" ++ intercalate "," archs | notNull archs] ++ ["--fail-fast" | not nofailfast && length archs /= 1] ++ ["--no-rebuild-srpm" | not rebuildSrpm] 93 | if pkggit 94 | then do 95 | gitSwitchBranchVerbose False allowHEAD br 96 | pushed <- do 97 | case msource of 98 | Just (ScratchRef ref) -> 99 | if length ref < 6 100 | then error' $ "please use a longer ref:" +-+ ref 101 | -- FIXME print commit log 102 | else return True 103 | Just (ScratchSRPM _) -> return False 104 | Nothing -> do 105 | clean <- isGitDirClean 106 | if clean && isRelBranch br 107 | then 108 | null <$> gitOneLineLog ("origin/" ++ show br ++ "..HEAD") 109 | else return False 110 | rbr <- anyBranchToRelease br 111 | nvr <- pkgNameVerRel' rbr spec 112 | putStrLn $ target +-+ "scratch build of" +-+ showScratchSource pushed nvr msource 113 | unless dryrun $ 114 | case msource of 115 | Just (ScratchSRPM srpm) -> 116 | void $ kojiScratchBuild target kojiargs srpm 117 | Nothing -> 118 | if pushed 119 | then kojiBuildBranch target pkg Nothing $ "--scratch" : kojiargs 120 | else srpmBuild kojiargs 121 | Just (ScratchRef ref) -> 122 | kojiBuildBranch target pkg (Just ref) $ "--scratch" : kojiargs 123 | else srpmBuild kojiargs 124 | where 125 | srpmBuild :: [String] -> IO () 126 | srpmBuild kojiargs = do 127 | putStrLn $ "Target:" +-+ target 128 | void $ generateSrpm (Just br) spec >>= kojiScratchBuild target kojiargs 129 | 130 | scratchCmdX86_64 :: Bool -> Bool -> Bool -> Bool -> [SideTagTarget] 131 | -> Maybe ScratchSource -> (BranchesReq, [String]) -> IO () 132 | scratchCmdX86_64 dryrun rebuildSrpm allowHEAD excludeArch = 133 | scratchCmd dryrun False rebuildSrpm True allowHEAD (Just (excludeArchs excludeArch ["x86_64"])) 134 | 135 | scratchCmdAarch64 :: Bool -> Bool -> Bool -> Bool -> [SideTagTarget] 136 | -> Maybe ScratchSource -> (BranchesReq, [String]) -> IO () 137 | scratchCmdAarch64 dryrun rebuildSrpm allowHEAD excludeArch = 138 | scratchCmd dryrun False rebuildSrpm True allowHEAD (Just (excludeArchs excludeArch ["aarch64"])) 139 | 140 | excludeArchs :: Bool -> [String] -> Archs 141 | excludeArchs excl = if excl then ExcludedArchs else Archs 142 | -------------------------------------------------------------------------------- /src/Cmd/SideTags.hs: -------------------------------------------------------------------------------- 1 | module Cmd.SideTags ( 2 | sideTagsCmd, 3 | SidetagMode(..)) 4 | where 5 | 6 | import Fedora.Krb (krbTicket) 7 | import SimpleCmd (cmd_, cmdN, error') 8 | import SimplePrompt (yesNo) 9 | 10 | import Branches 11 | import Common 12 | import Git (isPkgGitRepo) 13 | import Koji 14 | 15 | data SidetagMode = SidetagAdd | SidetagRemove | SidetagTagged 16 | deriving Eq 17 | 18 | sideTagsCmd :: Bool -> Maybe SidetagMode -> [Branch] -> IO () 19 | sideTagsCmd dryrun mmode brs = do 20 | branches <- 21 | if null brs && isJust mmode 22 | then do 23 | pkggit <- isPkgGitRepo 24 | if pkggit 25 | then do 26 | br <- getReleaseBranch 27 | return [br] 28 | else error' "please specify a branch" 29 | else return brs 30 | sidetags <- 31 | if null branches 32 | then kojiUserSideTags Nothing 33 | else concat <$> mapM (kojiUserSideTags . Just) branches 34 | unless (isNothing mmode) 35 | krbTicket 36 | case mmode of 37 | Nothing -> mapM_ putStrLn sidetags 38 | Just SidetagTagged -> mapM_ taggedSideTag sidetags 39 | Just SidetagRemove -> mapM_ removeSideTag sidetags 40 | Just SidetagAdd -> do 41 | putStrLn "existing tags:" 42 | mapM_ putStrLn sidetags 43 | putNewLn 44 | mapM_ addSideTag branches 45 | where 46 | removeSideTag :: String -> IO () 47 | removeSideTag tag = 48 | whenM (yesNo $ "Remove" +-+ tag) $ 49 | (if dryrun then cmdN else cmd_) "fedpkg" ["remove-side-tag", tag] 50 | 51 | addSideTag :: Branch -> IO () 52 | addSideTag br = 53 | whenM (yesNo $ "Create" +-+ indefinite (showBranch br) +-+ "user sidetag") $ 54 | void $ createKojiSidetag dryrun br 55 | 56 | -- FIXME can we get koji-hs to do this? 57 | taggedSideTag :: String -> IO () 58 | taggedSideTag tag = do 59 | putStrLn $ "#" +-+ tag 60 | cmd_ "koji" ["list-tagged", tag] 61 | -------------------------------------------------------------------------------- /src/Cmd/Sort.hs: -------------------------------------------------------------------------------- 1 | module Cmd.Sort ( 2 | sortCmd, 3 | RpmWith(..), 4 | graphCmd, 5 | SortDisplay(..) 6 | ) 7 | where 8 | 9 | import Control.Monad.Extra 10 | import Data.List (intercalate) 11 | import Distribution.RPM.Build.Graph 12 | import Distribution.RPM.Build.Order (dependencySortRpmOpts, 13 | dependencySortParallel, 14 | dependencyLayers) 15 | import System.Directory (doesFileExist) 16 | 17 | import Branches 18 | import Git 19 | import Package 20 | import RpmBuild (distRpmOptions, getDynSourcesMacros) 21 | 22 | data RpmWith = RpmWith String | RpmWithout String 23 | 24 | data SortDisplay = SortParallel | SortChain | SortLayers | SortPlain 25 | 26 | -- FIXME ghc-attempt f37 branch does not exist! (coming from f29) 27 | sortCmd :: SortDisplay -> Maybe RpmWith -> (Branch,[String]) -> IO () 28 | sortCmd _ _ (_,[]) = return () 29 | sortCmd displaymode mrpmwith (br, pkgs) = do 30 | withPackagesBranch HeaderNone False Nothing setupPkg (br, pkgs) 31 | distopts <- distRpmOptions br 32 | let rpmopts = maybe [] toRpmOption mrpmwith ++ distopts 33 | case displaymode of 34 | -- reverse because rpmbuild-order reverses the order of independent pkgs? 35 | SortParallel -> 36 | dependencySortParallel (reverse pkgs) >>= mapM_ (putStrLn . unwords) 37 | SortChain -> 38 | dependencyLayers pkgs >>= 39 | putStrLn . intercalate " : " . map unwords 40 | SortLayers -> 41 | dependencyLayers pkgs >>= 42 | mapM_ (putStrLn . unwords) 43 | SortPlain -> 44 | dependencySortRpmOpts rpmopts (reverse pkgs) >>= putStrLn . unwords 45 | 46 | setupPkg :: Package -> AnyBranch -> IO () 47 | setupPkg pkg br = do 48 | whenM isPkgGitRepo $ gitSwitchBranch br 49 | unlessM (doesFileExist "dead.package") $ 50 | getDynSourcesMacros $ packageSpec pkg 51 | 52 | toRpmOption :: RpmWith -> [String] 53 | toRpmOption (RpmWith opt) = ["--with=" ++ opt] 54 | toRpmOption (RpmWithout opt) = ["--without=" ++ opt] 55 | 56 | graphCmd :: Bool -> Maybe RpmWith -> (Maybe Branch,[FilePath]) -> IO () 57 | graphCmd dot mrpmwith (mbr, pkgs) = do 58 | withPackagesMaybeBranchNoHeadergit setupPkg (mbr, pkgs) 59 | let rpmopts = maybe [] toRpmOption mrpmwith 60 | createGraph4 False [] rpmopts False False True Nothing pkgs >>= 61 | if dot then printGraph else renderGraph 62 | -------------------------------------------------------------------------------- /src/Cmd/SrcDeps.hs: -------------------------------------------------------------------------------- 1 | module Cmd.SrcDeps ( 2 | srcDepsCmd, 3 | srcDeps 4 | ) 5 | where 6 | 7 | import Distribution.RPM.Build.Graph 8 | import Safe (headMay) 9 | 10 | import Branches 11 | import Common 12 | import Common.System 13 | import Git 14 | import Package 15 | 16 | srcDepsCmd :: Bool -> [String] -> (Branch,[String]) -> IO () 17 | srcDepsCmd rev macros (rbr,pkgs) = 18 | srcDeps rev macros (rbr,pkgs) >>= 19 | mapM_ (putStrLn . unwords) 20 | 21 | srcDeps :: Bool -> [String] -> (Branch,[String]) -> IO [[String]] 22 | srcDeps rev macros (rbr,pkgs) = do 23 | when (null pkgs) $ 24 | error' "please specify one or more package dirs" 25 | whenM isPkgGitRepo $ 26 | error' "please run from the directory containing the dependency package set" 27 | listDirectory "." >>= 28 | filterM checkPackage . filter ((/= Just '.') . headMay) >>= 29 | fmap (topsortGraph Combine) . depsGraphDeps rev (map ("-D" +-+) macros) False [] [] False Nothing pkgs 30 | where 31 | checkPackage :: FilePath -> IO Bool 32 | checkPackage p = do 33 | withExistingDirectory p $ do 34 | exists <- checkIfRemoteBranchExists (RelBranch rbr) 35 | if exists 36 | then do 37 | gitSwitchBranch (RelBranch rbr) 38 | isJust <$> maybeFindSpecfile 39 | else return False 40 | -------------------------------------------------------------------------------- /src/Cmd/Status.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Cmd.Status ( 5 | statusCmd 6 | ) 7 | where 8 | 9 | import Common 10 | import Common.System 11 | 12 | import Data.Fixed 13 | import Data.Time.Clock 14 | import Data.Time.LocalTime 15 | import Distribution.Fedora.Branch (branchDestTag) 16 | import Fedora.Bodhi 17 | 18 | import Bugzilla 19 | import Branches 20 | import Git 21 | import Koji 22 | import ListReviews 23 | import Package 24 | 25 | -- FIXME instead --pull? 26 | -- FIXME --pending 27 | -- FIXME handle not cloned (remote only) 28 | -- FIXME silence fetching of new branches? (for --reviews etc) 29 | statusCmd :: Bool -> Bool -> Bool -> (BranchesReq,[String]) -> IO () 30 | statusCmd nofetch reviews latestcommit (breq, pkgs) = do 31 | reviewpkgs <- 32 | if reviews 33 | then map reviewBugToPackage <$> listReviewsAll True ReviewRepoCreated 34 | else return [] 35 | -- FIXME dirty not okay for multiple branches? 36 | withPackagesByBranches HeaderMay False (if nofetch then dirtyGit else dirtyGitFetch) AnyNumber statusBranch (breq, pkgs ++ reviewpkgs) 37 | where 38 | -- FIXME note dirty when local changes 39 | statusBranch :: Package -> AnyBranch -> IO () 40 | statusBranch _ (OtherBranch _) = 41 | error' "status currently only defined for release branches" 42 | statusBranch pkg rbr@(RelBranch br) = 43 | if latestcommit 44 | then do 45 | putStr $ unPackage pkg ++ ": " 46 | whenJustM (gitShortLog1 Nothing) $ putStrLn . showCommit 47 | else do 48 | brExists <- checkIfRemoteBranchExists rbr 49 | if not brExists 50 | then do 51 | name <- getDirectoryName 52 | putStrLn $ name +-+ "has no branch" +-+ showBranch br 53 | else do 54 | gitSwitchBranch rbr 55 | let spec = packageSpec pkg 56 | exists <- doesFileExist spec 57 | if not exists 58 | then 59 | ifM initialPkgRepo 60 | (putStrLn $ showBranch br ++ ": initial repo") 61 | (putStrLn $ "missing" +-+ spec) 62 | else do 63 | mnvr <- pkgNameVerRel br spec 64 | case mnvr of 65 | Nothing -> do 66 | putStrLn "undefined NVR!\n" 67 | putStr "HEAD " 68 | whenJustM (gitShortLog1 Nothing) $ putStrLn . showCommit 69 | Just nvr -> do 70 | -- unless (br == Rawhide) $ do 71 | -- newerBr <- newerBranch br <$> getFedoraBranches 72 | -- ancestor <- gitBool "merge-base" ["--is-ancestor", "HEAD", show newerBr] 73 | -- when ancestor $ do 74 | -- unmerged <- gitOneLineLog $ "HEAD..origin/" ++ show newerBr 75 | -- unless (null unmerged) $ do 76 | -- putStrLn $ "Newer commits in" +-+ show newerBr ++ ":" 77 | -- mapM_ putStrLn unmerged 78 | munpushed <- gitShortLog1 $ Just $ "origin/" ++ showBranch br ++ "..HEAD" 79 | case munpushed of 80 | Nothing -> do 81 | mbuild <- kojiGetBuildID fedoraHub (showNVR nvr) 82 | case mbuild of 83 | Nothing -> do 84 | destTag <- branchDestTag br 85 | mlatest <- kojiLatestNVR destTag (unPackage pkg) 86 | case mlatest of 87 | Nothing -> putStrLn $ "new" +-+ showNVR nvr 88 | Just latest -> 89 | putStrLn $ if equivNVR nvr mlatest then showNVR latest +-+ "is latest modulo disttag" else showNVR latest +-+ "->\n" ++ showNVR nvr 90 | Just buildid -> do 91 | tags <- kojiBuildTags fedoraHub (buildIDInfo buildid) 92 | if null tags 93 | then do 94 | mstatus <- kojiBuildStatus nvr 95 | -- FIXME show pending archs building 96 | whenJust mstatus $ \ status -> 97 | -- FIXME better Show BuildStatus 98 | putStr $ showNVR nvr +-+ "(" ++ show status ++ ")" 99 | else do 100 | -- FIXME hide testing if ga/stable 101 | putStr $ showNVR nvr +-+ "(" ++ unwords tags ++ ")" 102 | -- FIXME use stable_tag 103 | unless (isStable tags) $ do 104 | updates <- bodhiUpdates 105 | [makeItem "display_user" "0", 106 | makeItem "builds" (showNVR nvr)] 107 | case updates of 108 | [] -> putStrLn "No update found" 109 | [update] -> do 110 | -- FIXME could show minus time left using stable_days? 111 | let msince = lookupKey "date_testing" update :: Maybe LocalTime 112 | case msince of 113 | Nothing -> return () 114 | Just date -> do 115 | let since = localTimeToUTC utc date 116 | current <- getCurrentTime 117 | let diff = diffUTCTime current since 118 | putAge diff 119 | _ -> putStrLn "More than one update found!" 120 | putNewLn 121 | Just unpushed -> 122 | let prefix = 123 | let pref = 124 | (if length pkgs > 1 then unPackage pkg else "") +-+ 125 | case breq of 126 | Branches brs | length brs <= 1 -> "" 127 | _ -> showBranch br 128 | in if null pref then "" else pref ++ ":" 129 | in putStrLn $ prefix +-+ showCommit unpushed 130 | where 131 | isStable :: [String] -> Bool 132 | isStable = not . all ("-testing" `isSuffixOf`) 133 | 134 | putAge :: NominalDiffTime -> IO () 135 | putAge diff = do 136 | -- FIXME time-1.10 has formatTime of NominalDiffTime 137 | let (days,nomRest) = diff `divMod'` nominalDay :: (Int,NominalDiffTime) 138 | nominalHour = 3600 :: NominalDiffTime 139 | hours = nomRest `div'` nominalHour :: Int 140 | putStr $ " " ++ plural days "day" +-+ plural hours "hour" 141 | 142 | #if !MIN_VERSION_time(1,8,0) 143 | nominalDay = 3600 * 24 :: NominalDiffTime 144 | #endif 145 | -------------------------------------------------------------------------------- /src/Cmd/Switch.hs: -------------------------------------------------------------------------------- 1 | module Cmd.Switch (switchCmd) where 2 | 3 | import Branches 4 | import Git 5 | import Package 6 | 7 | -- FIXME noop when on branch already or drop cleanGit 8 | switchCmd :: Bool -> AnyBranch -> [String] -> IO () 9 | switchCmd verbose br pkgs = 10 | -- FIXME use withBranchByPackages ? 11 | withPackagesByBranches HeaderNone False dirtyGit Zero dummy (Branches [],pkgs) 12 | where 13 | dummy _ _ = gitSwitchBranchVerbose verbose False br 14 | -------------------------------------------------------------------------------- /src/Cmd/Unpushed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Cmd.Unpushed ( 5 | unpushedCmd 6 | ) 7 | where 8 | 9 | 10 | import Branches 11 | import Cmd.Bump (bumpPkg) 12 | import Common 13 | import Common.System 14 | import Git 15 | import Package 16 | 17 | unpushedCmd :: Bool -> Bool -> Bool -> (BranchesReq,[String]) -> IO () 18 | unpushedCmd checknvr latest bump (breq, pkgs) = 19 | -- FIXME dirty not okay for multiple branches? 20 | withPackagesByBranches (if latest then HeaderMay else HeaderMust) False dirtyGit AnyNumber unpushedBranch (breq, pkgs) 21 | where 22 | -- FIXME note dirty when local changes 23 | unpushedBranch :: Package -> AnyBranch -> IO () 24 | unpushedBranch _ (OtherBranch _) = 25 | error' "status currently only defined for release branches" 26 | unpushedBranch pkg rbr@(RelBranch br) = do 27 | brExists <- checkIfRemoteBranchExists rbr 28 | if not brExists 29 | then do 30 | name <- getDirectoryName 31 | putStrLn $ name +-+ "has no branch" +-+ showBranch br 32 | else do 33 | gitSwitchBranch rbr 34 | let spec = packageSpec pkg 35 | prefix = 36 | let pref = 37 | (if length pkgs > 1 && latest 38 | then unPackage pkg else "") +-+ 39 | case breq of 40 | Branches brs | length brs <= 1 -> "" 41 | _ -> showBranch br 42 | in if null pref then "" else pref ++ ":" 43 | haveSpec <- doesFileExist spec 44 | if not haveSpec 45 | then 46 | ifM initialPkgRepo 47 | (putStrLn $ prefix +-+ "initial repo") $ 48 | unlessM (doesFileExist "dead.package") $ 49 | putStrLn $ prefix +-+ "missing" +-+ spec 50 | else do 51 | when (checknvr || length pkgs < 10) $ 52 | whenM (isNothing <$> pkgNameVerRel br spec) $ do 53 | putStrLn "undefined NVR!\n" 54 | putStr "HEAD " 55 | unpushed <- gitShortLogN (if latest then Just 1 else Nothing) $ 56 | Just $ "origin/" ++ showBranch br ++ "..HEAD" 57 | if null unpushed 58 | then 59 | when bump $ bumpPkg False False Nothing Nothing pkg rbr 60 | else 61 | if latest 62 | then whenJust (listToMaybe unpushed) $ putCommit prefix 63 | else mapM_ (putCommit prefix) unpushed 64 | 65 | putCommit prefix = putStrLn . (prefix +-+) . showCommit 66 | -------------------------------------------------------------------------------- /src/Cmd/Update.hs: -------------------------------------------------------------------------------- 1 | module Cmd.Update 2 | ( updateSourcesCmd, 3 | updateSourcesPkg 4 | ) 5 | where 6 | 7 | import Data.RPM.VerCmp 8 | import Data.Version (parseVersion) 9 | import Fedora.Krb (krbTicket) 10 | import SimplePrompt (promptEnter) 11 | import Text.ParserCombinators.ReadP (readP_to_S) 12 | 13 | import Branches 14 | import Common 15 | import Common.System 16 | import Git 17 | import InterleaveOutput (cmdSilent') 18 | import Package 19 | 20 | -- FIXME --no-prep to avoid overwriting ongoing build 21 | -- FIXME don't bump release if already bumped 22 | -- FIXME check EVR increased 23 | -- FIXME if multiple sources might need to bump release 24 | -- FIXME Haskell subpackages require release bump even with version bump 25 | updateSourcesCmd :: Bool -> Bool -> (Maybe Branch,[String]) -> IO () 26 | updateSourcesCmd force allowHEAD (mbr,args) = do 27 | (mver,pkgs) <- 28 | case args of 29 | [] -> return (Nothing,[]) 30 | (h:t) -> do 31 | exists <- doesDirectoryExist h 32 | if exists || not (isVersion h) 33 | then return (Nothing, args) 34 | else do 35 | havespec <- isJust <$> maybeFindSpecfile 36 | if null t && not havespec 37 | then error' "not a pkg dir" 38 | else return (Just h, t) 39 | pkgGit <- isPkgGitSshRepo 40 | let mgitops = 41 | let dirty = if allowHEAD then dirtyGitHEAD else dirtyGitFetch 42 | in if pkgGit 43 | then dirty 44 | else if null pkgs then Nothing else dirty 45 | withPackagesMaybeBranch HeaderMay False mgitops (updateSourcesPkg force allowHEAD pkgGit mver) (mbr, pkgs) 46 | where 47 | isVersion = not . null . readP_to_S parseVersion 48 | 49 | -- FIXME use tempdir or don't prep to prevent overwriting an ongoing build 50 | updateSourcesPkg :: Bool -> Bool -> Bool -> Maybe String -> Package 51 | -> AnyBranch -> IO () 52 | updateSourcesPkg force allowHEAD distgit mver pkg br = do 53 | when (distgit && br /= RelBranch Rawhide && isRelBranch br) $ 54 | promptEnter $ "Are you sure you want to update" +-+ show br +-+ "branch?! Press Enter to continue" 55 | spec <- if allowHEAD 56 | then findSpecfile 57 | else localBranchSpecFile pkg br 58 | -- FIXME detect uncommitted version bump, ie old committed version 59 | (curver,_) <- pkgVerRel spec 60 | vdiff <- filter ("+Version:" `isPrefixOf`) . filter (not . ("@@ " `isPrefixOf`)) <$> gitLines "diff" ["-U0", "HEAD", spec] 61 | when (length vdiff > 1) $ 62 | error' $ "diff contains complex multi-version changes:\n" ++ unlines vdiff 63 | case mver of 64 | Nothing -> do 65 | putStrLn $ "current version:" +-+ curver 66 | Just nver -> do 67 | when (length vdiff == 1) $ 68 | error' $ "spec version already bumped to" +-+ curver 69 | when (curver == nver) $ 70 | putStrLn $ "already new version" +-+ curver 71 | let moldnewver = 72 | case mver of 73 | Just nver -> Just (curver,nver) 74 | Nothing -> 75 | -- FIXME confused by fresh multiversion package (eg hadrian-0.1.0.0 make new ghcX.Y to 0.1.0.0 76 | case map (last . words) vdiff of 77 | [old,new] -> Just (old,new) 78 | _ -> Nothing 79 | when (isJust mver) $ 80 | when (isJust moldnewver) $ do 81 | let (oldver,newver) = 82 | fromMaybe (error' "complex version change") moldnewver 83 | -- FIXME take epoch into account 84 | when (rpmVerCompare oldver newver == GT) $ 85 | putStrLn $ "current" +-+ oldver +-+ "is newer!" 86 | putStrLn $ oldver +-+ "->\n" ++ newver 87 | when (curver /= newver) $ do 88 | editSpecField "Version" newver spec 89 | autorelease <- isAutoRelease spec 90 | if autorelease 91 | then do 92 | autobump <- autoReleaseBump spec 93 | when autobump $ 94 | editSpecField "Release" "%autorelease" spec 95 | -- FIXME if multiple versions need to bump release 96 | else editSpecField "Release" "0%{?dist}" spec 97 | -- FIXME should be sure sources exists for distgit 98 | whenM (doesFileExist "sources") $ 99 | cmd_ "sed" ["-i", "/" ++ unPackage pkg ++ "-" ++ oldver ++ "./d", "sources"] 100 | whenM isPkgGitSshRepo $ do 101 | -- FIXME forM_ 102 | sources <- map sourceFieldFile <$> cmdLines "spectool" ["-S", spec] 103 | existing <- filterM doesFileExist sources 104 | unless (existing == sources) $ do 105 | cmd_ "fedpkg" ["sources"] 106 | unless force $ 107 | -- FIXME only if not all exist 108 | cmd_ "spectool" ["-g", "-S", spec] 109 | patches <- map sourceFieldFile <$> cmdLines "spectool" ["-P", spec] 110 | forM_ patches $ \patch -> do 111 | unlessM (doesFileExist patch) $ 112 | cmd_ "spectool" ["-g", "-P", spec] 113 | git_ "add" [patch] 114 | when force $ do 115 | let archives = filter isArchiveFile existing 116 | forM_ archives removeFile 117 | cmd_ "spectool" ["-g", "-S", spec] 118 | krbTicket 119 | cmd_ "fedpkg" $ "new-sources" : filter isArchiveFile sources 120 | whenJust moldnewver $ \(_old,newver) -> do 121 | versions <- changelogVersions spec 122 | let missing = 123 | case versions of 124 | [] -> True 125 | (h:_) -> not $ (newver ++ "-") `isPrefixOf` h 126 | when missing $ do 127 | cmd_ "rpmdev-bumpspec" ["-c", "Update to" +-+ newver, spec] 128 | git_ "commit" ["-a", "-m", "Update to" +-+ newver] 129 | putStr "Prepping... " 130 | sourcediropt <- sourceDirCwdOpt 131 | cmdSilent' "rpmbuild" $ "-bp" : sourcediropt ++ ["--nodeps", spec] 132 | putStrLn "done" 133 | -- FIXME git amend (if previous commit was update) 134 | 135 | pkgVerRel :: FilePath -> IO (String,String) 136 | pkgVerRel spec = do 137 | --dist <- branchDist br 138 | -- workaround dist with bootstrap 139 | --hostdist <- cmd "rpm" ["--eval", "%{dist}"] 140 | mvr <- cmdMaybe "rpmspec" ["-q", "--srpm", "--qf", "%{version}-%{release}", spec] 141 | case mvr of 142 | Nothing -> error' $ "Failed to read package ver-rel:" +-+ spec 143 | Just vr -> return $ splitBy "-" vr 144 | 145 | splitBy :: String -> String -> (String,String) 146 | splitBy sep xs = 147 | let ws = splitOn sep xs in 148 | case ws of 149 | [f,v] -> (f,v) 150 | _ -> error $ "inconsistent field:" +-+ xs 151 | 152 | changelogVersions :: FilePath -> IO [String] 153 | changelogVersions spec = do 154 | ns <- cmdLines "rpmspec" ["-q", "--srpm", "--qf", "%{changelogname}", spec] 155 | return $ map (removePrefix "- " . dropWhile (/= '-')) ns 156 | -------------------------------------------------------------------------------- /src/Cmd/UpdateReview.hs: -------------------------------------------------------------------------------- 1 | module Cmd.UpdateReview ( 2 | updateReviewCmd 3 | ) 4 | where 5 | 6 | import Control.Monad (when) 7 | import SimpleCmd (cmd, error') 8 | import System.FilePath (takeFileName) 9 | 10 | import Bugzilla 11 | --import Common 12 | import qualified Common.Text as T 13 | import Package 14 | import PkgReview 15 | import RpmBuild 16 | import Types (ChangeType(ChangeReview)) 17 | 18 | updateReviewCmd :: Maybe ScratchOption -> Bool -> Maybe FilePath -> IO () 19 | updateReviewCmd mscratchOpt mock mspec = do 20 | spec <- maybe findSpecfile checkLocalFile mspec 21 | pkg <- cmd "rpmspec" ["-q", "--srpm", "--qf", "%{name}", spec] 22 | (bid,session) <- reviewBugIdSession pkg 23 | putBugId bid 24 | srpm <- generateSrpm Nothing spec 25 | submitted <- checkForComment session bid (T.pack srpm) 26 | when submitted $ 27 | error' "This NVR was already posted on the review bug: please bump" 28 | mockRpmLint mock pkg spec srpm 29 | (mkojiurl,specSrpmUrls) <- buildAndUpload mscratchOpt srpm pkg spec 30 | changelog <- changeLogPrompt ChangeReview spec 31 | commentBug session bid (specSrpmUrls <> (if null changelog then "" else "\n\n" <> changelog) <> maybe "" ("\n\nKoji scratch build: " <>) mkojiurl) 32 | putBugId bid 33 | where 34 | checkLocalFile :: FilePath -> IO FilePath 35 | checkLocalFile f = 36 | if takeFileName f == f then return f 37 | else error' "Please run in the directory of the spec file" 38 | -------------------------------------------------------------------------------- /src/Cmd/WaitRepo.hs: -------------------------------------------------------------------------------- 1 | module Cmd.WaitRepo ( 2 | waitrepoCmd, 3 | WaitFetch(..) 4 | ) 5 | where 6 | 7 | import Common.System 8 | 9 | import Branches 10 | import Git 11 | import Koji 12 | import Package 13 | import Types 14 | 15 | data WaitFetch = WaitNoFetch | WaitDirty | WaitFetch 16 | 17 | -- FIXME first check/wait for build to actually exist 18 | waitrepoCmd :: Bool -> WaitFetch -> Maybe SideTagTarget 19 | -> (BranchesReq, [String]) -> IO () 20 | waitrepoCmd dryrun fetch msidetagTarget = do 21 | withPackagesByBranches HeaderMay False 22 | (case fetch of 23 | WaitFetch -> cleanGitFetchActive 24 | WaitNoFetch -> cleanGitActive 25 | WaitDirty -> dirtyGitActive) 26 | AnyNumber waitrepoBranch 27 | where 28 | waitrepoBranch :: Package -> AnyBranch -> IO () 29 | waitrepoBranch _ (OtherBranch _) = 30 | error' "waitrepo only defined for release branches" 31 | waitrepoBranch pkg rbr@(RelBranch br) = do 32 | gitSwitchBranch rbr 33 | let spec = packageSpec pkg 34 | nvr <- pkgNameVerRel' br spec 35 | target <- targetMaybeSidetag dryrun True False br msidetagTarget 36 | kojiWaitRepoNVR dryrun False target nvr 37 | -------------------------------------------------------------------------------- /src/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Common ( 4 | module Control.Monad.Extra, 5 | module Data.List.Extra, 6 | module Data.Maybe, 7 | Natural, 8 | #if !MIN_VERSION_base(4,11,0) 9 | (<>), 10 | #endif 11 | (+/+), 12 | (+-+), 13 | indefinite, 14 | plural, 15 | pluralOnly, 16 | pluralException, 17 | singularVerb, 18 | putNewLn, 19 | reverseSort, 20 | showNVR 21 | ) where 22 | 23 | import Control.Monad.Extra -- hiding (loop) 24 | import Data.List.Extra hiding (list, merge, 25 | #if MIN_VERSION_extra(1,6,19) 26 | headDef 27 | #endif 28 | ) 29 | import Data.Maybe 30 | import Data.Ord (comparing, Down(Down)) 31 | import Data.RPM.NVR (showNVR) 32 | 33 | #if !MIN_VERSION_base(4,11,0) 34 | import Data.Semigroup ((<>)) 35 | #endif 36 | 37 | import Network.HTTP.Query ((+/+)) 38 | import Numeric.Natural (Natural) 39 | import SimpleCmd ((+-+)) 40 | 41 | pluralOnly :: [a] -> String -> String 42 | pluralOnly xs ns = 43 | ns ++ if length xs > 1 then "s" else "" 44 | 45 | plural :: Int -> String -> String 46 | plural i ns = 47 | pluralException i Nothing ns (ns ++ "s") 48 | 49 | pluralException :: Int -> Maybe String -> String -> String -> String 50 | pluralException 0 (Just z) _ _ = z 51 | pluralException i _ ns ps = 52 | mconcat 53 | [ 54 | if i == 0 then "no" else show i, 55 | " ", 56 | if i == 1 then ns else ps 57 | ] 58 | 59 | singularVerb :: Bool -> String -> String 60 | singularVerb singular v = v ++ if singular then "s" else "" 61 | 62 | indefinite :: String -> String 63 | indefinite "" = "" 64 | indefinite w@(c:_) = 65 | (if c `elem` "aeiou" then "an" else "a") +-+ w 66 | 67 | putNewLn :: IO () 68 | putNewLn = putChar '\n' 69 | 70 | reverseSort :: Ord a => [a] -> [a] 71 | reverseSort = sortBy (comparing Down) 72 | -------------------------------------------------------------------------------- /src/Common/System.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Common.System ( 4 | module SimpleCmd, 5 | module System.Directory, 6 | module System.FilePath, 7 | getDirectoryName, 8 | isTty, 9 | setNoBuffering, 10 | #if !MIN_VERSION_filepath(1,4,2) 11 | isExtensionOf, 12 | #endif 13 | #if !MIN_VERSION_simple_cmd(0,2,8) 14 | cmdFull, 15 | #endif 16 | #if !MIN_VERSION_simple_cmd(0,2,5) 17 | timeIO, 18 | #endif 19 | timeIODesc 20 | ) where 21 | 22 | #if !MIN_VERSION_filepath(1,4,2) 23 | import Data.List 24 | #endif 25 | #if MIN_VERSION_time(1,9,0) 26 | import Data.Time.Format (formatTime, defaultTimeLocale) 27 | #endif 28 | import Safe 29 | import SimpleCmd hiding ( 30 | #if !MIN_VERSION_simple_cmd(0,2,8) 31 | cmdFull, 32 | #endif 33 | #if MIN_VERSION_simple_cmd(0,2,1) 34 | ifM,whenM 35 | #endif 36 | ) 37 | #if !MIN_VERSION_simple_cmd(0,2,8) 38 | import System.Exit 39 | import System.Process 40 | #endif 41 | import System.Directory 42 | import System.FilePath 43 | import System.IO 44 | 45 | import Control.Exception 46 | import Data.Time.Clock 47 | 48 | #if !MIN_VERSION_simple_cmd(0,2,5) 49 | timeIO :: IO a -> IO a 50 | timeIO = timeIOHelper "took" 51 | #endif 52 | 53 | timeIODesc :: String -> IO a -> IO a 54 | timeIODesc thing = timeIOHelper (thing +-+ "took") 55 | 56 | timeIOHelper :: String -> IO a -> IO a 57 | timeIOHelper msg action = do 58 | bracket 59 | getCurrentTime 60 | (\start -> do 61 | end <- getCurrentTime 62 | let duration = diffUTCTime end start 63 | putStrLn $ msg +-+ renderDuration duration) 64 | (const action) 65 | where 66 | #if MIN_VERSION_time(1,9,0) 67 | renderDuration dur = 68 | let fmtstr 69 | | dur < 60 = "%s sec" 70 | | dur < 3600 = "%m min %S sec" 71 | | otherwise = "%h hours %M min" 72 | in formatTime defaultTimeLocale fmtstr dur 73 | #else 74 | renderDuration = show 75 | #endif 76 | 77 | isTty :: IO Bool 78 | isTty = hIsTerminalDevice stdin 79 | 80 | setNoBuffering :: IO () 81 | setNoBuffering = do 82 | hSetBuffering stdout NoBuffering 83 | hSetBuffering stderr NoBuffering 84 | 85 | getDirectoryName :: IO String 86 | getDirectoryName = 87 | takeFileName <$> getCurrentDirectory 88 | 89 | -- bugfix for lazy stderr 90 | #if !MIN_VERSION_simple_cmd(0,2,8) 91 | cmdFull :: String -> [String] -> String -> IO (Bool, String, String) 92 | cmdFull c args input = do 93 | (ret, out, err) <- readProcessWithExitCode c args input 94 | return (ret == ExitSuccess, removeTrailingNewline out, removeTrailingNewline err) 95 | where 96 | removeTrailingNewline :: String -> String 97 | removeTrailingNewline str = 98 | if lastMay str == Just '\n' 99 | then init str 100 | else str 101 | #endif 102 | 103 | #if !MIN_VERSION_filepath(1,4,2) 104 | isExtensionOf :: String -> FilePath -> Bool 105 | isExtensionOf ext@('.':_) = isSuffixOf ext . takeExtensions 106 | isExtensionOf ext = isSuffixOf ('.':ext) . takeExtensions 107 | #endif 108 | -------------------------------------------------------------------------------- /src/Common/Text.hs: -------------------------------------------------------------------------------- 1 | module Common.Text ( 2 | module Data.Text, 3 | module Data.Text.IO 4 | ) where 5 | 6 | import Data.Text 7 | import Data.Text.IO 8 | -------------------------------------------------------------------------------- /src/Git.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Git ( 4 | #if !MIN_VERSION_simple_cmd(0,2,2) 5 | gitBool, 6 | #endif 7 | gitLines, 8 | gitMergeable, 9 | gitMergeOrigin, 10 | getNewerBranch, 11 | newerMergeable, 12 | gitFetchSilent, 13 | gitPush, 14 | gitRepoName, 15 | Commit(commitRef,commitLog), 16 | showCommit, 17 | displayCommits, 18 | gitOneLineLog, 19 | gitShortLogN, 20 | gitShortLog1, 21 | gitSwitchBranch, 22 | gitSwitchBranch', 23 | gitSwitchBranchVerbose, 24 | -- checkIsPkgGitDir, 25 | isGitRepo, 26 | isPkgGitRepo, 27 | isPkgGitSshRepo, 28 | checkWorkingDirClean, 29 | stashedWithFbrnch, 30 | isGitDirClean, 31 | checkIfRemoteBranchExists, 32 | CommitOpt (..), 33 | refPrompt, 34 | conflictPrompt, 35 | module SimpleCmd.Git 36 | ) where 37 | 38 | import Data.Char (isSpace) 39 | import Distribution.Fedora.Branch (newerBranch) 40 | import Safe (tailSafe) 41 | import Say (sayString) 42 | import SimpleCmd.Git 43 | import SimplePrompt 44 | 45 | import Branches 46 | import Common 47 | import Common.System 48 | 49 | #if !MIN_VERSION_simple_cmd(0,2,2) 50 | -- | 'gitBool c args' runs git command and return result 51 | gitBool :: String -- ^ git command 52 | -> [String] -- ^ arguments 53 | -> IO Bool -- ^ result 54 | gitBool c args = 55 | cmdBool "git" (c:args) 56 | #endif 57 | 58 | -- Just True => ancestor 59 | -- Nothing => neither ancestor 60 | -- Just False => reverse ancestor 61 | gitMergeable :: Bool -> Branch -> IO (Maybe Bool,[Commit]) 62 | gitMergeable origin br = do 63 | let ref = (if origin then "origin/" else "") ++ showBranch br 64 | mancestor <- do 65 | ancestor <- gitBool "merge-base" ["--is-ancestor", "HEAD", ref] 66 | if ancestor 67 | then return $ Just True 68 | else do 69 | revancestor <- gitBool "merge-base" ["--is-ancestor", ref, "HEAD"] 70 | if revancestor 71 | then return $ Just False 72 | else 73 | if not origin 74 | then do 75 | origancestor <- gitBool "merge-base" ["--is-ancestor", "HEAD", "origin/" ++ showBranch br] 76 | if origancestor 77 | then error $ "origin/" ++ showBranch br +-+ "is ancestor but not" +-+ showBranch br 78 | else return Nothing 79 | else return Nothing 80 | commits <- gitOneLineLog ("HEAD.." ++ ref) 81 | when (not origin && null commits && mancestor /= Just True) $ 82 | if mancestor == Just False 83 | then do 84 | diff <- git "diff" [ref] 85 | unless (null diff) $ do 86 | putStrLn $ "current branch is ahead of newer" +-+ showBranch br +-+ "!!" 87 | promptEnter "Press Enter if you want to continue" 88 | else putStrLn $ "current branch" +-+ "is diverged from" +-+ showBranch br 89 | return (mancestor, commits) 90 | 91 | -- FIXME use Package 92 | getNewerBranch :: String -> Branch -> IO (Maybe Branch) 93 | getNewerBranch _ Rawhide = return Nothing 94 | getNewerBranch pkg br = do 95 | localbrs <- fedoraBranches (localBranches False) 96 | case newerBranch br localbrs of 97 | Just newer -> 98 | if newer `elem` localbrs 99 | then return $ Just newer 100 | else do 101 | remotebrs <- fedoraBranches (pagurePkgBranches pkg) 102 | if newer `elem` remotebrs 103 | then do 104 | gitFetchSilent False 105 | return $ Just newer 106 | else return $ newerBranch br remotebrs 107 | Nothing -> return Nothing 108 | 109 | gitMergeOrigin :: Branch -> IO () 110 | gitMergeOrigin br = do 111 | (mancestor,commits) <- gitMergeable True br 112 | when (mancestor == Just True) $ 113 | unless (null commits) $ do 114 | pull <- git "pull" [] 115 | unless ("Already up to date." `isPrefixOf` pull) $ 116 | putStrLn pull 117 | 118 | -- FIXME maybe require local branch already here 119 | newerMergeable :: String -> Branch -> IO (Bool,[Commit],Maybe Branch) 120 | newerMergeable pkg br = 121 | if br == Rawhide 122 | then return (False,[],Nothing) 123 | else do 124 | mnewer <- getNewerBranch pkg br 125 | locals <- localBranches True 126 | case mnewer of 127 | Just newer -> do 128 | (mancestor,commits) <- gitMergeable (showBranch newer `notElem` locals) newer 129 | return (mancestor == Just True, commits, Just newer) 130 | Nothing -> return (False,[],Nothing) 131 | 132 | data Commit = Commit 133 | { commitRef :: String, 134 | commitLog :: String, 135 | commitDate :: String } 136 | 137 | showCommit :: Commit -> String 138 | showCommit c = 139 | take 7 (commitRef c) +-+ commitLog c +-+ "(" ++ commitDate c ++ ")" 140 | 141 | displayCommits :: Bool -> [Commit] -> IO () 142 | displayCommits showall = 143 | mapM_ putStrLn . showAll showall . map showCommit 144 | where 145 | showAll :: Bool -> [String] -> [String] 146 | showAll False cs = 147 | if length cs > 20 then take 20 cs ++ [":"] else cs 148 | showAll True cs = cs 149 | 150 | gitOneLineLog :: String -> IO [Commit] 151 | gitOneLineLog range = 152 | map mkCommit <$> gitLines "log" ["--pretty=format:%H (%s, %cs)", range] 153 | 154 | gitShortLogN :: Maybe Int -> Maybe String -> IO [Commit] 155 | gitShortLogN mnum mrange = 156 | map mkCommit <$> gitLines "log" (["--max-count=" ++ show num | num <- maybeToList mnum] ++ "--pretty=reference": maybeToList mrange) 157 | 158 | gitShortLog1 :: Maybe String -> IO (Maybe Commit) 159 | gitShortLog1 mrange = do 160 | cs <- git "log" (["--max-count=1", "--pretty=reference"] ++ maybeToList mrange) 161 | return $ 162 | if null cs 163 | then Nothing 164 | else Just $ mkCommit cs 165 | 166 | -- assumes reference style pretty format: "hash (title, date)" 167 | mkCommit :: String -> Commit 168 | mkCommit cs = 169 | case word1 cs of 170 | ("",_) -> error' "empty commit log line!" 171 | (hash,rest) -> 172 | case breakEnd isSpace rest of 173 | -- "(msg txt, date)" 174 | (plogcs,datep) -> 175 | Commit hash (init $ tailSafe $ trim plogcs) (init datep) 176 | 177 | gitPush :: Bool -> Maybe String -> IO () 178 | gitPush quiet mref = do 179 | -- FIXME also check ref on branch 180 | checkOnBranch 181 | when quiet $ 182 | sayString "git pushing" 183 | -- Can error like this: 184 | -- kex_exchange_identification: Connection closed by remote host 185 | -- Connection closed by 38.145.60.17 port 22 186 | -- fatal: Could not read from remote repository. 187 | let args = ["push"] ++ ["--quiet" | quiet] ++ ["origin"] ++ maybeToList mref 188 | (ok, _out, err) <- cmdFull "git" args "" 189 | if ok 190 | then unless quiet $ 191 | putStrLn $ last (lines err) 192 | else do 193 | when quiet putNewLn 194 | putStrLn $ unwords ("git" : args) +-+ "failed with\n" ++ err 195 | yes <- yesNo "Retry git push" 196 | -- FIXME going to fail if ref no longer on branch 197 | when yes $ gitPush quiet mref 198 | 199 | -- FIXME use this in more places 200 | gitRepoName :: IO String 201 | gitRepoName = 202 | dropSuffix ".git" . takeFileName <$> git "remote" ["get-url", "origin"] 203 | 204 | -- FIXME use Verbose 205 | gitFetchSilent :: Bool -> IO () 206 | gitFetchSilent quiet = do 207 | name <- gitRepoName 208 | unless quiet $ 209 | putStr $ "git fetching" +-+ name ++ "... " 210 | (ok, out, err) <- cmdFull "git" ["fetch"] "" 211 | unless quiet $ 212 | unless (null out) $ putStrLn out 213 | unless ok $ error' err 214 | -- could keep From if no header 215 | let filtered = case lines err of 216 | [] -> [] 217 | (hd:tl) -> filter (/= "Already up to date.") $ 218 | if "From " `isPrefixOf` hd then tl else hd:tl 219 | if null filtered 220 | then unless quiet $ putStrLn "done" 221 | else putStrLn $ '\r' : intercalate "\n" filtered 222 | 223 | stashedWithFbrnch :: String 224 | stashedWithFbrnch = "Saved by fbrnch" 225 | 226 | checkWorkingDirClean :: Bool -> IO () 227 | checkWorkingDirClean stash = do 228 | clean <- isGitDirClean 229 | unless clean $ 230 | if stash 231 | then git_ "stash" ["-m", stashedWithFbrnch] 232 | else do 233 | dir <- getCurrentDirectory 234 | error' $ "Working dir is not clean:" +-+ dir 235 | 236 | isGitDirClean :: IO Bool 237 | isGitDirClean = 238 | gitBool "diff" ["--quiet", "--exit-code", "HEAD"] 239 | 240 | -- checkIsPkgGitDir :: IO () 241 | -- checkIsPkgGitDir = do 242 | -- pkgGit <- isPkgGitRepo 243 | -- unless pkgGit $ error' "Not a pkg git dir" 244 | 245 | isGitRepo :: IO Bool 246 | isGitRepo = isGitDir "." ||^ doesFileExist ".git" 247 | 248 | isPkgGitRepo :: IO Bool 249 | isPkgGitRepo = grepGitConfig' "\\(https://\\|@\\)\\(pkgs\\|src\\)\\." 250 | &&^ 251 | (not . ("/forks/" `isInfixOf`) <$> 252 | git "config" ["--get", "remote.origin.url"]) 253 | 254 | isPkgGitSshRepo :: IO Bool 255 | isPkgGitSshRepo = grepGitConfig' "@\\(pkgs\\|src\\)\\." 256 | 257 | -- adapted from SimpleCmd.Git 258 | grepGitConfig' :: String -> IO Bool 259 | grepGitConfig' key = do 260 | isgit <- isGitDir "." 261 | if isgit 262 | then egrep_ key ".git/config" 263 | else do 264 | -- could be a worktree or absorbed submodule (#8) 265 | exists <- doesFileExist ".git" 266 | if not exists 267 | then return False 268 | else do 269 | gitdir <- last . words <$> readFile ".git" 270 | if "/worktrees/" `isInfixOf` gitdir 271 | then egrep_ key (takeDirectory (takeDirectory gitdir) "config") 272 | else 273 | -- absorbed submodule: "gitdir: ../.git/modules/R-bit" 274 | if "/modules/" `isInfixOf` gitdir then 275 | egrep_ key $ gitdir "config" 276 | else return False 277 | 278 | gitSwitchBranchVerbose :: Bool -> Bool -> AnyBranch -> IO () 279 | gitSwitchBranchVerbose _ allowHEAD (OtherBranch "HEAD") = do 280 | dir <- getDirectoryName 281 | (if allowHEAD then putStrLn else error') $ dir ++ ": HEAD is not a branch" 282 | gitSwitchBranchVerbose verbose _ br = do 283 | localbranches <- gitLines "branch" ["--format=%(refname:short)"] 284 | let verb = ["-q" | not verbose] 285 | if show br `elem` localbranches 286 | then do 287 | current <- gitCurrentBranch 288 | when (current /= br) $ 289 | git_ "switch" $ verb ++ [show br] 290 | else do 291 | -- check remote branch exists 292 | remotebranch <- do 293 | exists <- checkIfRemoteBranchExists br 294 | if exists 295 | then return True 296 | else gitFetchSilent False >> checkIfRemoteBranchExists br 297 | if not remotebranch 298 | then do 299 | name <- getDirectoryName 300 | error' $ name +-+ show br +-+ "branch does not exist!" 301 | else 302 | git_ "checkout" $ verb ++ ["-b", show br, "--track", "origin/" ++ show br] 303 | 304 | gitSwitchBranch :: AnyBranch -> IO () 305 | gitSwitchBranch = gitSwitchBranchVerbose False False 306 | 307 | -- similar to gitSwitchBranch but does not error 308 | gitSwitchBranch' :: Bool -> Branch -> IO Bool 309 | gitSwitchBranch' quiet br = do 310 | localbranches <- gitLines "branch" ["--format=%(refname:short)"] 311 | if showBranch br `elem` localbranches 312 | then do 313 | current <- gitCurrentBranch 314 | when (current /= RelBranch br) $ 315 | git_ "switch" ["-q", showBranch br] 316 | return True 317 | else do 318 | -- check remote branch exists 319 | remotebranch <- do 320 | exists <- checkIfRemoteBranchExists (RelBranch br) 321 | if exists 322 | then return True 323 | -- FIXME this is redundant if we already fetched (eg for merge cmd) 324 | else gitFetchSilent quiet >> checkIfRemoteBranchExists (RelBranch br) 325 | if not remotebranch 326 | then do 327 | name <- getDirectoryName 328 | unless quiet $ 329 | warning $ name +-+ showBranch br +-+ "branch does not exist!" 330 | return False 331 | else do 332 | git_ "checkout" ["-q", "-b", showBranch br, "--track", "origin/" ++ showBranch br] 333 | return True 334 | 335 | checkIfRemoteBranchExists :: AnyBranch -> IO Bool 336 | checkIfRemoteBranchExists br = 337 | gitBool "show-ref" ["--verify", "--quiet", "refs/remotes/origin/" ++ show br] 338 | 339 | data CommitOpt = CommitMsg String | CommitAmend 340 | 341 | -- FIXME select ref by number 342 | -- FIXME minimum length of hash 343 | refPrompt :: [Commit] -> String -> IO (Maybe String) 344 | refPrompt commits txt = do 345 | case map commitRef commits of 346 | [] -> error' "empty commits list" 347 | (c:cs) -> do 348 | -- FIXME use promptMap 349 | ref <- prompt txt 350 | case lower ref of 351 | "" -> return $ Just c 352 | "y" -> return $ Just c 353 | "yes" -> return $ Just c 354 | "no" -> return Nothing 355 | "n" -> return Nothing 356 | _ -> 357 | case find (ref `isPrefixOf`) cs of 358 | Just cref -> return $ Just cref 359 | Nothing -> refPrompt commits txt 360 | 361 | -- FIXME also include branch 362 | -- FIXME minimum length of hash 363 | conflictPrompt :: [Commit] -> String -> IO (Maybe String) 364 | conflictPrompt commits txt = do 365 | case map commitRef commits of 366 | [] -> error' "empty commits list" 367 | commitrefs@(c:_) -> do 368 | ref <- prompt txt 369 | if null ref 370 | then return Nothing 371 | else 372 | case find (ref `isPrefixOf`) commitrefs of 373 | Just cref -> return $ Just cref 374 | Nothing -> 375 | if lower ref == "head" 376 | then return $ Just c 377 | else conflictPrompt commits txt 378 | -------------------------------------------------------------------------------- /src/InterleaveOutput.hs: -------------------------------------------------------------------------------- 1 | module InterleaveOutput (cmdSilent', cmdSilentBool) where 2 | 3 | import Data.ByteString.Lazy.UTF8 as B 4 | import GHC.IO.Exception (ExitCode(ExitSuccess)) 5 | import System.Process.Typed (proc, readProcessInterleaved) 6 | import Common 7 | import Common.System 8 | 9 | cmdSilent' :: String -> [String] -> IO () 10 | cmdSilent' c args = do 11 | ok <- cmdSilentBool c args 12 | unless ok $ error' $ unwords (c:args) ++ ": failed" 13 | 14 | -- currently unused 15 | cmdSilentBool :: String -> [String] -> IO Bool 16 | cmdSilentBool c args = do 17 | (ret, out) <- readProcessInterleaved (proc c args) 18 | let ok = ret == ExitSuccess 19 | unless ok $ do 20 | putNewLn 21 | putStrLn (B.toString out) 22 | return ok 23 | -------------------------------------------------------------------------------- /src/Koji.hs: -------------------------------------------------------------------------------- 1 | module Koji ( 2 | kojiNVRTags, 3 | kojiBuildStatus, 4 | kojiBuildTags, 5 | kojiGetBuildID, 6 | kojiGetBuildTaskID, 7 | kojiLatestNVR, 8 | kojiOpenTasks, 9 | kojiScratchBuild, 10 | kojiUserSideTags, 11 | buildIDInfo, 12 | BuildState(..), 13 | kojiBuildBranch, 14 | kojiBuildBranchNoWait, 15 | kojiSource, 16 | kojiBuildTarget', 17 | kojiTagArchs, 18 | kojiWaitRepoNVR, 19 | kojiWaitRepoNVRs, 20 | kojiWatchTask, 21 | kojiWaitTask, 22 | putTaskinfoUrl, 23 | TaskID, 24 | displayID, 25 | fedoraHub, 26 | maybeTimeout, 27 | createKojiSidetag, 28 | targetMaybeSidetag 29 | ) where 30 | 31 | import Data.Char (isDigit) 32 | 33 | import qualified Data.ByteString.Lazy.Char8 as B 34 | import Data.Fixed (Micro) 35 | import Data.RPM.NVR (NVR, maybeNVR) 36 | import Data.Time.Clock 37 | import Data.Time.Format 38 | import Data.Time.LocalTime 39 | import Distribution.Koji 40 | import qualified Distribution.Koji.API as Koji 41 | import Distribution.Fedora.Branch (branchRelease) 42 | import Distribution.Fedora.Release (releaseDistTag) 43 | import Fedora.Krb (fasIdFromKrb, krbTicket) 44 | import Safe (headMay, tailSafe) 45 | import Say (sayString) 46 | import SimplePrompt (promptEnter, yesNo) 47 | import System.Exit 48 | import System.Process.Typed 49 | import System.Timeout (timeout) 50 | import System.Time.Extra (sleep) 51 | 52 | import Branches 53 | import Common 54 | import Common.System 55 | import Git 56 | import Package (fedpkg, Package, unPackage) 57 | import Pagure 58 | import Types 59 | 60 | fedoraHub :: String 61 | fedoraHub = fedoraKojiHub 62 | 63 | kojiNVRTags :: NVR -> IO [String] 64 | kojiNVRTags nvr = do 65 | mbldid <- kojiGetBuildID fedoraHub $ showNVR nvr 66 | case mbldid of 67 | Nothing -> error' $ showNVR nvr +-+ "koji build not found" 68 | Just bldid -> kojiBuildTags fedoraHub (buildIDInfo bldid) 69 | 70 | kojiBuildStatus :: NVR -> IO (Maybe BuildState) 71 | kojiBuildStatus nvr = 72 | kojiGetBuildState fedoraHub (BuildInfoNVR (showNVR nvr)) 73 | 74 | kojiLatestNVR :: String -> String -> IO (Maybe NVR) 75 | kojiLatestNVR tag pkg = do 76 | mbld <- kojiLatestBuild fedoraHub tag pkg 77 | return $ case mbld of 78 | Nothing -> Nothing 79 | Just bld -> lookupStruct "nvr" bld >>= maybeNVR 80 | 81 | 82 | kojiOpenTasks :: Package -> Maybe String -> String -> IO [TaskID] 83 | kojiOpenTasks pkg mref target = do 84 | user <- fasIdFromKrb 85 | muserid <- kojiGetUserID fedoraHub user 86 | let userid = fromMaybe (error' $ "Koji failed to return userid for '" ++ user ++ "'") muserid 87 | commit <- maybe (git "rev-parse" ["HEAD"]) return mref 88 | let source = kojiSource pkg commit 89 | kojiUserBuildTasks fedoraHub userid (Just source) (Just target) 90 | 91 | -- * Koji building 92 | 93 | kojiScratchBuild :: String -> [String] -> FilePath -> IO String 94 | kojiScratchBuild target args srpm = do 95 | Right url <- kojiBuild' True target $ args ++ ["--scratch", "--no-rebuild-srpm", srpm] 96 | return url 97 | 98 | type KojiBuildTask = Either TaskID String 99 | 100 | -- FIXME setTermTitle nvr 101 | kojiBuild' :: Bool -> String -> [String] -> IO KojiBuildTask 102 | kojiBuild' wait target args = do 103 | krbTicket 104 | let srpm = if null args 105 | then error' "no args passed to koji build" 106 | else ".src.rpm" `isSuffixOf` last args 107 | -- FIXME use tee functionality 108 | when srpm $ putStrLn "koji srpm build: uploading..." 109 | -- can fail like: 110 | -- [ERROR] koji: Request error: POST::https://koji.fedoraproject.org/kojihub/ssllogin:: 111 | -- [ERROR] koji: AuthError: unable to obtain a session 112 | -- readCreateProcess: koji "build" "--nowait" "f33-build-side-25385" "--fail-fast" "--background" ... (exit 1): failed 113 | (ret,out) <- readProcessStdout $ proc "koji" $ ["build", "--nowait", target] ++ args 114 | -- for srpm: drop uploading line until doing tee 115 | -- for git: drop "Created task: " 116 | -- init to drop final newline 117 | unless (B.null out) $ 118 | -- FIXME include output example here 119 | logMsg $ (dropPrefix "Task info: " . B.unpack . B.init . B.unlines . tailSafe . B.lines) out 120 | if ret == ExitSuccess 121 | then do 122 | let kojiurl = B.unpack $ last $ B.words out 123 | task = (TaskId . read) $ takeWhileEnd isDigit kojiurl 124 | when wait $ do 125 | -- FIXME get actual build time 126 | timeIO $ kojiWatchTask task 127 | cmd_ "date" ["+%T"] 128 | return $ if wait then Right kojiurl else Left task 129 | else do 130 | promptEnter "Press Enter to resubmit Koji build" 131 | kojiBuild' wait target args 132 | 133 | -- kojiBuild :: String -> [String] -> IO String 134 | -- kojiBuild target args = do 135 | -- Right url <- kojiBuild' True target args 136 | -- return url 137 | 138 | -- FIXME filter/simplify output 139 | -- FIXME implement native watchTask 140 | kojiWatchTask :: TaskID -> IO () 141 | kojiWatchTask task = do 142 | -- FIXME can error: 143 | -- eg1 [ERROR] koji: HTTPError: 503 Server Error: Service Unavailable for url: https://koji.fedoraproject.org/kojihub 144 | -- eg2 [ERROR] koji: ServerOffline: database outage: - user error (Error 1014: database outage) 145 | -- eg3 [ERROR] koji: ReadTimeout: HTTPSConnectionPool(host='koji.fedoraproject.org', port=443): Read timed out. (read timeout=43200) 146 | -- This might error with exit 0 occasionally so we check the taskstate always 147 | void $ cmdBool "koji" ["watch-task", displayID task] 148 | mst <- kojiGetTaskState fedoraHub task 149 | case mst of 150 | Just TaskClosed -> return () 151 | Just TaskFailed -> do 152 | whenJustM (findExecutable "koji-tool") $ \kojitool -> do 153 | -- FIXME cmdLog deprecated 154 | cmdLog kojitool ["tasks", "--children", displayID task, "--tail", "-s", "fail"] 155 | putTaskinfoUrl fedoraHub task 156 | error' "Task failed!" 157 | Just TaskCanceled -> return () 158 | _ -> kojiWatchTask task 159 | 160 | putTaskinfoUrl :: String -> TaskID -> IO () 161 | putTaskinfoUrl hub tid = 162 | putStrLn $ dropSuffix "hub" hub +/+ "taskinfo?taskID=" ++ show (getID tid) 163 | 164 | -- FIXME during network disconnection: 165 | -- Connection timed out: retrying 166 | -- Connection timed out: retrying 167 | -- Network.Socket.connect: : does not exist (No route to host) 168 | kojiWaitTask :: TaskID -> IO Bool 169 | kojiWaitTask task = do 170 | -- FIXME can error: 171 | -- eg1 [ERROR] koji: HTTPError: 503 Server Error: Service Unavailable for url: https://koji.fedoraproject.org/kojihub 172 | -- eg2 [ERROR] koji: ServerOffline: database outage: - user error (Error 1014: database outage) 173 | mst <- maybeTimeout 45 $ kojiGetTaskState fedoraHub task 174 | case mst of 175 | Just ts -> 176 | if ts `elem` openTaskStates 177 | then do 178 | sleep 20 179 | kojiWaitTask task 180 | else return $ ts == TaskClosed 181 | Nothing -> do 182 | error $ "failed to get info for koji task" +-+ displayID task 183 | 184 | kojiSource :: Package -> String -> String 185 | kojiSource pkg ref = 186 | "git+https://" ++ srcfpo ++ "/rpms" +/+ unPackage pkg ++ ".git#" ++ ref 187 | 188 | kojiBuildBranch' :: Bool -> String -> Package -> Maybe String -> [String] 189 | -> IO KojiBuildTask 190 | kojiBuildBranch' wait target pkg mref args = do 191 | commit <- maybe (git "rev-parse" ["HEAD"]) return mref 192 | kojiBuild' wait target $ args ++ [kojiSource pkg commit] 193 | 194 | kojiBuildBranch :: String -> Package -> Maybe String -> [String] -> IO () 195 | kojiBuildBranch target pkg mref args = 196 | checkResult <$> kojiBuildBranch' True target pkg mref args 197 | where 198 | checkResult = either (\ task -> error' (displayID task +-+ "not completed")) (const ()) 199 | 200 | kojiBuildBranchNoWait ::String -> Package -> Maybe String -> [String] -> IO TaskID 201 | kojiBuildBranchNoWait target pkg mref args = do 202 | Left task <- kojiBuildBranch' False target pkg mref args 203 | return task 204 | 205 | -- remove once in koji-hs 206 | kojiBuildTarget' :: String -- ^ hubUrl 207 | -> String -- ^ target 208 | -> IO (String, String) -- ^ (build-tag,dest-tag) 209 | kojiBuildTarget' hub target = do 210 | mres <- kojiBuildTarget hub target 211 | case mres of 212 | Nothing -> error' $ "failed to get BuildTarget for" +-+ target 213 | Just res -> return res 214 | 215 | -- FIXME should be NonEmpty 216 | -- FIXME add back knowntag? 217 | kojiWaitRepoNVRs :: Bool -> Bool -> String -> [NVR] -> IO () 218 | kojiWaitRepoNVRs _ _ _ [] = error' "no NVRs given to wait for" 219 | kojiWaitRepoNVRs dryrun quiet target nvrs = do 220 | (buildtag,_desttag) <- kojiBuildTarget' fedoraHub target 221 | unless dryrun $ do 222 | tz <- getCurrentTimeZone 223 | unless quiet $ 224 | logSay tz $ "Waiting for" +-+ buildtag +-+ "to have" +-+ 225 | case nvrs of 226 | [nvr] -> showNVR nvr 227 | _ -> "builds" 228 | -- FIXME use knowntag to quieten output: for override outputs, eg 229 | -- "nvr ghc-rpm-macros-2.7.5-1.fc41 is not current in tag f41-build 230 | -- latest build is ghc-rpm-macros-2.7.2-4.fc41" 231 | void $ timeIO $ cmd "koji" (["wait-repo", "--request", "--quiet"] ++ ["--build=" ++ showNVR nvr | nvr <- nvrs] ++ [buildtag]) 232 | 233 | kojiWaitRepoNVR :: Bool -> Bool -> String -> NVR -> IO () 234 | kojiWaitRepoNVR dryrun quiet target nvr = 235 | kojiWaitRepoNVRs dryrun quiet target [nvr] 236 | 237 | kojiTagArchs :: String -> IO [String] 238 | kojiTagArchs tag = do 239 | st <- Koji.getTag fedoraHub (Koji.InfoString tag) Nothing 240 | return $ maybe [] words $ lookupStruct "arches" st 241 | 242 | kojiUserSideTags :: Maybe Branch -> IO [String] 243 | kojiUserSideTags mbr = do 244 | user <- fasIdFromKrb 245 | mapMaybe (headMay . words) <$> 246 | case mbr of 247 | Nothing -> do 248 | maybeTimeout 55 $ kojiListSideTags fedoraKojiHub Nothing (Just user) 249 | Just br -> do 250 | mtags <- kojiBuildTarget fedoraHub (showBranch br) 251 | case mtags of 252 | Nothing -> return [] 253 | Just (buildtag,_desttag) -> 254 | kojiListSideTags fedoraKojiHub (Just buildtag) (Just user) 255 | 256 | maybeTimeout :: Micro -> IO a -> IO a 257 | maybeTimeout secs act = do 258 | mres <- timeout (fromEnum secs) act 259 | case mres of 260 | Nothing -> do 261 | warning "Connection timed out: retrying" 262 | maybeTimeout (secs + 5) act 263 | Just res -> return res 264 | 265 | createKojiSidetag :: Bool -> Branch -> IO String 266 | createKojiSidetag dryrun br = do 267 | (buildtag,_desttag) <- kojiBuildTarget' fedoraHub (showBranch br) 268 | out <- 269 | if dryrun 270 | then return $ "Side tag '" ++ buildtag ++ "'" 271 | else do 272 | ls <- lines <$> fedpkg "request-side-tag" ["--base-tag", buildtag] 273 | case ls of 274 | [] -> error' "no output from request-side-tag" 275 | (l:_) -> return l 276 | if "Side tag '" `isPrefixOf` out 277 | then do 278 | putNewLn 279 | let sidetag = 280 | init . dropWhileEnd (/= '\'') $ dropPrefix "Side tag '" out 281 | putStrLn $ "Sidetag" +-+ sidetag +-+ "created" 282 | -- logMsg $ "Waiting for" +-+ sidetag +-+ "repo" 283 | -- unless dryrun $ 284 | -- cmd_ "koji" ["wait-repo", sidetag] 285 | return sidetag 286 | else error' "'fedpkg request-side-tag' failed" 287 | 288 | -- FIXME offer choice of existing sidetags 289 | targetMaybeSidetag :: Bool -> Bool -> Bool -> Branch -> Maybe SideTagTarget 290 | -> IO String 291 | targetMaybeSidetag dryrun strict create br msidetagTarget = 292 | case msidetagTarget of 293 | Nothing -> return $ showBranch br 294 | Just (Target t) -> do 295 | disttag <- releaseDistTag <$> branchRelease br 296 | if t == "rawhide" && br == Rawhide 297 | then return disttag 298 | else do 299 | unless (disttag `isPrefixOf` t) $ do 300 | let msg = "Branch" +-+ showBranch br +-+ "does not match target" +-+ t in 301 | if strict 302 | then do 303 | ok <- yesNo $ msg ++ "! Are you sure?" 304 | unless ok $ error' "aborted" 305 | else 306 | whenM isPkgGitRepo $ 307 | warning ("Note:" +-+ msg) 308 | return t 309 | Just SideTag -> do 310 | tags <- kojiUserSideTags (Just br) 311 | case tags of 312 | [] -> 313 | if create 314 | then createKojiSidetag dryrun br 315 | else error' "incorrect side-tag create request" 316 | [tag] -> return tag 317 | sidetags -> error' $ show (length sidetags) +-+ "user side-tags found for" +-+ showBranch br ++ ":\n" +-+ unwords sidetags 318 | 319 | logSay :: TimeZone -> String -> IO () 320 | logSay tz str = do 321 | now <- utcToLocalTime tz <$> getCurrentTime 322 | sayString $ formatTime defaultTimeLocale "%T" now +-+ str 323 | -------------------------------------------------------------------------------- /src/ListReviews.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module ListReviews ( 4 | ReviewStatus(..), 5 | listReviews, 6 | listReviewsAll, 7 | listReviewsFull 8 | ) where 9 | 10 | import SimpleCmd (error') 11 | 12 | import Common 13 | 14 | import Branches 15 | import Bugzilla 16 | 17 | data ReviewStatus = ReviewAllOpen 18 | | ReviewUnApproved 19 | | ReviewApproved 20 | | ReviewWithoutRepoReq 21 | | ReviewRepoRequested 22 | | ReviewRepoCreated 23 | | ReviewUnbranched 24 | | ReviewBranched 25 | 26 | listReviews :: ReviewStatus -> IO [Bug] 27 | listReviews = listReviewsAll False 28 | 29 | listReviewsAll :: Bool -> ReviewStatus -> IO [Bug] 30 | listReviewsAll = listReviewsFull Nothing (Just Nothing) Nothing 31 | 32 | -- FIXME: --unassigned 33 | listReviewsFull :: Maybe (Maybe String) -> Maybe (Maybe String) 34 | -> Maybe String -> Bool -> ReviewStatus -> IO [Bug] 35 | listReviewsFull Nothing Nothing Nothing _ _ = 36 | error' "please specify either report, assignee, or package name pattern" 37 | listReviewsFull mmassignee mmreporter mpat allopen status = do 38 | session <- bzApiKeySession 39 | massignedto <- 40 | case mmassignee of 41 | Nothing -> return Nothing 42 | Just massignee -> 43 | Just <$> getBzAccountId session massignee 44 | mreporter <- 45 | case mmreporter of 46 | Nothing -> return Nothing 47 | Just mreporter -> 48 | Just <$> getBzAccountId session mreporter 49 | let reviews = maybe id (\a -> (assigneeIs a .&&.)) massignedto $ 50 | maybe id (\r -> (reporterIs r .&&.)) mreporter $ 51 | maybe packageReview pkgReviewsPrefix mpat 52 | open = if allopen 53 | then statusOpen else 54 | case status of 55 | ReviewAllOpen -> statusOpen 56 | ReviewUnApproved -> statusOpen 57 | ReviewApproved -> statusNewPost 58 | ReviewRepoCreated -> statusRelPrep 59 | ReviewUnbranched -> statusNewModified 60 | ReviewBranched -> statusNewModified 61 | _ -> statusNewPost 62 | query = case status of 63 | ReviewAllOpen -> reviews 64 | ReviewUnApproved -> reviews .&&. not' reviewApproved 65 | _ -> reviews .&&. reviewApproved 66 | -- FIXME sort by status, bid (default?) / pkg? 67 | bugs <- searchBugs session (query .&&. open) 68 | case status of 69 | ReviewWithoutRepoReq -> 70 | filterM (fmap not . checkRepoRequestedComment session . bugId) bugs 71 | ReviewRepoRequested -> 72 | filterM (checkRepoRequestedComment session . bugId) bugs >>= 73 | filterM (fmap not . checkRepoCreatedComment session . bugId) 74 | ReviewRepoCreated -> 75 | filterM (checkRepoCreatedComment session . bugId) bugs 76 | ReviewUnbranched -> 77 | filterM (checkRepoCreatedComment session . bugId) bugs >>= 78 | filterM (notBranched . reviewBugToPackage) 79 | ReviewBranched -> 80 | filterM (checkRepoCreatedComment session . bugId) bugs >>= 81 | filterM (branched . reviewBugToPackage) 82 | _ -> return bugs 83 | where 84 | checkRepoRequestedComment :: BugzillaSession -> BugId -> IO Bool 85 | checkRepoRequestedComment session bid = 86 | checkForComment session bid 87 | "https://pagure.io/releng/fedora-scm-requests/issue/" 88 | 89 | branched :: String -> IO Bool 90 | branched pkg = not <$> notBranched pkg 91 | 92 | notBranched :: String -> IO Bool 93 | notBranched pkg = null <$> fedoraBranchesNoRawhide (pagurePkgBranches pkg) 94 | -------------------------------------------------------------------------------- /src/Pagure.hs: -------------------------------------------------------------------------------- 1 | module Pagure ( 2 | srcfpo, 3 | pagureio, 4 | pagureGroupRepos, 5 | pagureListGitBranches, 6 | pagureListProjectIssueTitlesStatus, 7 | IssueTitleStatus(..), 8 | pagureProjectInfo, 9 | pagureUserRepos, 10 | makeItem, 11 | printScmIssue 12 | ) where 13 | 14 | import Common ((+/+), (+-+)) 15 | import qualified Common.Text as T 16 | 17 | import Fedora.Pagure 18 | 19 | srcfpo :: String 20 | srcfpo = "src.fedoraproject.org" 21 | 22 | pagureio :: String 23 | pagureio = "pagure.io" 24 | 25 | printScmIssue :: IssueTitleStatus -> IO () 26 | printScmIssue issue = 27 | putStrLn $ "https://" ++ pagureio +/+ "releng/fedora-scm-requests" +/+ "issue" +/+ show (pagureIssueId issue) +-+ "(" ++ T.unpack (pagureIssueStatus issue) ++ mclosed ++ "):" +-+ pagureIssueTitle issue 28 | where 29 | mclosed = maybe "" (\s-> ":" ++ T.unpack s) $ pagureIssueCloseStatus issue 30 | -------------------------------------------------------------------------------- /src/Patch.hs: -------------------------------------------------------------------------------- 1 | module Patch ( 2 | simplifyMinimalDiff, 3 | dropChangelog, 4 | isTrivialRebuildCommit, 5 | removeDiffContext 6 | ) 7 | where 8 | 9 | import Common 10 | 11 | import Safe (headMay) 12 | 13 | simplifyMinimalDiff :: [String] -> [String] 14 | simplifyMinimalDiff = 15 | maybeRemoveDiffGit . filterCommon 16 | where 17 | filterCommon = 18 | filter (not . 19 | -- FIXME a/ and b/ 20 | matchPreds (map isPrefixOf ["--- ", "+++ ", "index ", "@@ -"])) 21 | 22 | maybeRemoveDiffGit ls = 23 | let gitDiffs = filter ("diff --git " `isPrefixOf`) ls in 24 | if length gitDiffs == 1 25 | then ls \\ gitDiffs 26 | else ls 27 | 28 | -- adapted from flist in swish 29 | matchPreds :: [a -> Bool] -> a -> Bool 30 | matchPreds fs a = any ($ a) fs 31 | 32 | -- adapted from cabal-rpm PackageUtils 33 | dropChangelog :: [String] -> [String] 34 | dropChangelog ls = 35 | if " %changelog" `elem` ls 36 | then 37 | let rest = (dropWhileEnd ("@@ " `isPrefixOf`) . dropWhileEnd (== " ") . takeWhile (/= " %changelog")) ls in 38 | if length rest > 2 then rest else [] 39 | else ls 40 | 41 | isTrivialRebuildCommit :: [String] -> Bool 42 | isTrivialRebuildCommit ls = 43 | let nontrivial = 44 | (simplifyMinimalDiff . removeDiffContext . dropChangelog) ls 45 | in 46 | length nontrivial `elem` [0,2] && 47 | all (matchPreds (map isPrefixOf ["-Release:", "+Release:"])) nontrivial 48 | 49 | -- not 50 | -- (any 51 | -- (not . matchPreds (map isPrefixOf ["-Release:", "+Release:"])) ls) 52 | -- (all . matchPreds (map isPrefixOf ["-Release:", "+Release:"])) ls 53 | 54 | removeDiffContext :: [String] -> [String] 55 | removeDiffContext = filter ((/= Just ' ') . headMay) 56 | -------------------------------------------------------------------------------- /src/PkgReview.hs: -------------------------------------------------------------------------------- 1 | module PkgReview ( 2 | ScratchOption(..), 3 | buildAndUpload, 4 | mockRpmLint, 5 | uploadPkgFiles 6 | ) 7 | where 8 | 9 | import Common 10 | import Common.System 11 | 12 | import Fedora.Krb (fasIdFromKrb) 13 | import Network.HTTP.Directory (httpExists, httpManager) 14 | import SimplePrompt (promptEnter, yesNoDefault) 15 | 16 | import Branches 17 | import Koji 18 | import RpmBuild 19 | 20 | data ScratchOption = ScratchBuild | ScratchTask Int | SkipScratch 21 | deriving Eq 22 | 23 | buildAndUpload :: Maybe ScratchOption -> String -> String -> FilePath 24 | -> IO (Maybe String, String) 25 | buildAndUpload mscratchOpt srpm pkg spec = do 26 | scratch <- 27 | if isNothing mscratchOpt 28 | then yesNoDefault False "Would you like to do a koji scratch build before submitting" 29 | else do 30 | let doscratch = mscratchOpt == Just ScratchBuild 31 | promptEnter $ "Press Enter to" +-+ if doscratch 32 | then "submit" 33 | else "upload" 34 | return doscratch 35 | mkojiurl <- case mscratchOpt of 36 | Just (ScratchTask tid) -> return $ Just ("https://koji.fedoraproject.org/koji/taskinfo?taskID=" ++ show tid) 37 | _ -> 38 | if scratch 39 | then Just <$> kojiScratchBuild "rawhide" [] srpm 40 | else return Nothing 41 | specSrpmUrls <- uploadPkgFiles pkg spec srpm 42 | return (mkojiurl, specSrpmUrls) 43 | 44 | uploadPkgFiles :: String -> FilePath -> FilePath -> IO String 45 | uploadPkgFiles pkg spec srpm = do 46 | fasid <- fasIdFromKrb 47 | -- read ~/.config/fedora-create-review 48 | let sshhost = "fedorapeople.org" 49 | sshpath = "public_html/reviews/" ++ pkg 50 | cmd_ "ssh" [fasid ++ "@" ++ sshhost, "mkdir", "-p", sshpath] 51 | cmd_ "scp" [spec, srpm, fasid ++ "@" ++ sshhost ++ ":" ++ sshpath] 52 | getCheckedFileUrls $ "https://" <> fasid <> ".fedorapeople.org" +/+ removePrefix "public_html/" sshpath 53 | where 54 | getCheckedFileUrls :: String -> IO String 55 | getCheckedFileUrls uploadurl = do 56 | let specUrl = uploadurl +/+ takeFileName spec 57 | srpmUrl = uploadurl +/+ takeFileName srpm 58 | mgr <- httpManager 59 | checkUrlOk mgr specUrl 60 | checkUrlOk mgr srpmUrl 61 | return $ "Spec URL: " <> specUrl <> "\nSRPM URL: " <> srpmUrl 62 | where 63 | checkUrlOk mgr url = do 64 | okay <- httpExists mgr url 65 | unless okay $ error' $ "Could not access:" +-+ url 66 | 67 | mockRpmLint :: Bool -> String -> FilePath -> FilePath -> IO () 68 | mockRpmLint mock pkg spec srpm = do 69 | rpms <- 70 | if mock then do 71 | -- FIXME check that mock is installed 72 | let resultsdir = "results_" ++ pkg 73 | cmd_ "mock" ["--root", mockRoot Rawhide Nothing, "--resultdir=" ++ resultsdir, srpm] 74 | map (resultsdir ) . filter ((== ".rpm") . takeExtension) <$> listDirectory resultsdir 75 | else 76 | builtRpms (RelBranch Rawhide) spec >>= filterM doesFileExist 77 | -- print rpms 78 | -- FIXME parse # of errors/warnings 79 | void $ cmdBool "rpmlint" $ spec:srpm:rpms 80 | -------------------------------------------------------------------------------- /src/Repoquery.hs: -------------------------------------------------------------------------------- 1 | module Repoquery ( 2 | repoquery 3 | ) 4 | where 5 | 6 | import Data.Maybe (isJust) 7 | import SimpleCmd (cmd) 8 | 9 | import Bodhi (bodhiTestingRepoTag) 10 | import Branches 11 | 12 | -- FIXME use fedora-repoquery library 13 | -- FIXME default to package 14 | repoquery :: Branch -> Branch -> [String] -> IO String 15 | repoquery sysbr br args = do 16 | mtesting <- bodhiTestingRepoTag br 17 | let brOpts = 18 | if sysbr == br 19 | then [] 20 | else do 21 | case br of 22 | Rawhide -> ["--disablerepo=*", "--enablerepo=rawhide"] 23 | Fedora _ -> ["--disablerepo=*", "--enablerepo=fedora"] ++ 24 | ["--enablerepo=updates-testing" | isJust mtesting] ++ 25 | ["--releasever=" ++ branchVersion br] 26 | EPEL _ -> ["--disablerepo=*", "--enablerepo=epel"] ++ 27 | ["--enablerepo=epel-testing" | isJust mtesting] ++ 28 | ["--releasever=" ++ branchVersion br] 29 | EPELNext _ -> ["--disablerepo=*", "--enablerepo=epel-next"] ++ 30 | ["--enablerepo=epel-next-testing" | isJust mtesting] ++ 31 | ["--releasever=" ++ branchVersion br] 32 | cmd "dnf" (["repoquery", "--quiet"] ++ brOpts ++ args) 33 | -------------------------------------------------------------------------------- /src/Types.hs: -------------------------------------------------------------------------------- 1 | module Types ( 2 | Archs(..), 3 | SideTagTarget(..), 4 | maybeTarget, 5 | ChangeType(..) 6 | ) 7 | where 8 | 9 | data Archs = Archs [String] | ExcludedArchs [String] 10 | 11 | -- FIXME: --new-sidetag ? 12 | data SideTagTarget = SideTag | Target String 13 | deriving Eq 14 | 15 | maybeTarget :: Maybe SideTagTarget -> Maybe String 16 | maybeTarget (Just (Target t)) = Just t 17 | maybeTarget _ = Nothing 18 | 19 | data ChangeType = ChangeBodhi | ChangeCommit | ChangeReview 20 | deriving Eq 21 | -------------------------------------------------------------------------------- /src/json/invalidtoken.json: -------------------------------------------------------------------------------- 1 | {"result":false} 2 | -------------------------------------------------------------------------------- /src/json/login.json: -------------------------------------------------------------------------------- 1 | { 2 | "token": "786-OLaWfBisMY", 3 | "id": 786 4 | } 5 | -------------------------------------------------------------------------------- /src/json/result.json: -------------------------------------------------------------------------------- 1 | {"id":1803348} 2 | -------------------------------------------------------------------------------- /stack-lts12.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-12.27 2 | 3 | extra-deps: 4 | - http-directory-0.1.5 5 | - typed-process-0.2.4.0 6 | - simple-cmd-0.2.3 7 | - HaXml-1.25.5 8 | - polyparse-1.12.1 9 | - haxr-3000.11.4 10 | - simple-cmd-args-0.1.8 11 | - koji-0.0.1 12 | - rpmbuild-order-0.4.12 13 | - pretty-terminal-0.1.0.0 14 | - http-query-0.1.2 15 | - rpm-nvr-0.1.2 16 | - pdc-0.1.1 17 | - bodhi-0.1.0 18 | - pagure-0.2.1 19 | - copr-api-0.2.0 20 | - cached-json-file-0.1.0 21 | - bugzilla-redhat-1.0.1 22 | - HsOpenSSL-0.11.7.2 23 | - simple-prompt-0.2.3 24 | - haskeline-0.8.0.0 25 | - fedora-krb-0.1.0 26 | - fedora-releases-0.2.0 27 | - select-rpms-0.2.0 28 | -------------------------------------------------------------------------------- /stack-lts13.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-13.30 2 | extra-deps: 3 | - config-ini-0.2.4.0 4 | - simple-cmd-0.2.3 5 | - HaXml-1.25.5 6 | - haxr-3000.11.4 7 | - simple-cmd-args-0.1.8 8 | - koji-0.0.1 9 | - rpmbuild-order-0.4.12 10 | - pretty-terminal-0.1.0.0 11 | - http-query-0.1.2 12 | - graphviz-2999.20.0.3 13 | - rpm-nvr-0.1.2 14 | - pdc-0.1.1 15 | - bodhi-0.1.0 16 | - pagure-0.2.1 17 | - copr-api-0.2.0 18 | - cached-json-file-0.1.0 19 | - bugzilla-redhat-1.0.1 20 | - HsOpenSSL-0.11.7.2 21 | - simple-prompt-0.2.3 22 | - haskeline-0.8.0.0 23 | - fedora-krb-0.1.0 24 | - fedora-releases-0.2.0 25 | - select-rpms-0.2.0 26 | -------------------------------------------------------------------------------- /stack-lts14.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.27 2 | extra-deps: 3 | - simple-cmd-args-0.1.8 4 | - koji-0.0.1 5 | - rpmbuild-order-0.4.12 6 | - pretty-terminal-0.1.0.0 7 | - http-query-0.1.2 8 | - rpm-nvr-0.1.2 9 | - pdc-0.1.1 10 | - bodhi-0.1.0 11 | - pagure-0.2.1 12 | - copr-api-0.2.0 13 | - cached-json-file-0.1.0 14 | - bugzilla-redhat-1.0.1 15 | - HsOpenSSL-0.11.7.2 16 | - simple-cmd-0.2.3 17 | - simple-prompt-0.2.3 18 | - haskeline-0.8.0.0 19 | - fedora-krb-0.1.0 20 | - fedora-releases-0.2.0 21 | - select-rpms-0.2.0 22 | -------------------------------------------------------------------------------- /stack-lts16.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-16.31 2 | extra-deps: 3 | - koji-0.0.1 4 | - rpmbuild-order-0.4.12 5 | - rpm-nvr-0.1.2 6 | - pdc-0.1.1 7 | - bodhi-0.1.0 8 | - pagure-0.2.1 9 | - copr-api-0.2.0 10 | - cached-json-file-0.1.1 11 | - bugzilla-redhat-1.0.1 12 | - HsOpenSSL-0.11.7.2 13 | - simple-cmd-args-0.1.8 14 | - simple-prompt-0.2.3 15 | - haskeline-0.8.0.0 16 | - http-query-0.1.2 17 | - fedora-krb-0.1.0 18 | - fedora-releases-0.2.0 19 | - select-rpms-0.2.0 20 | -------------------------------------------------------------------------------- /stack-lts18.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-18.28 2 | extra-deps: 3 | - bugzilla-redhat-1.0.1 4 | - rpm-nvr-0.1.2 5 | - rpmbuild-order-0.4.12 6 | - simple-cmd-args-0.1.8 7 | - simple-prompt-0.2.3 8 | - pagure-0.2.1 9 | - copr-api-0.2.0 10 | - fedora-krb-0.1.0 11 | - fedora-releases-0.2.0 12 | - select-rpms-0.2.0 13 | -------------------------------------------------------------------------------- /stack-lts19.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-19.33 2 | extra-deps: 3 | - bugzilla-redhat-1.0.1 4 | - simple-prompt-0.2.3 5 | - rpmbuild-order-0.4.12 6 | - pagure-0.2.1 7 | - copr-api-0.2.0 8 | - fedora-krb-0.1.0 9 | - fedora-releases-0.2.0 10 | - select-rpms-0.2.0 11 | -------------------------------------------------------------------------------- /stack-lts20.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-20.26 2 | ghc-options: 3 | HsOpenSSL: -optc=-Wno-incompatible-pointer-types 4 | extra-deps: 5 | - simple-prompt-0.2.3 6 | - rpmbuild-order-0.4.12 7 | - pagure-0.2.1 8 | - copr-api-0.2.0 9 | - fedora-krb-0.1.0 10 | - fedora-releases-0.2.0 11 | - select-rpms-0.2.0 12 | -------------------------------------------------------------------------------- /stack-lts21.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-21.25 2 | ghc-options: 3 | HsOpenSSL: -optc=-Wno-incompatible-pointer-types 4 | extra-deps: 5 | - rpmbuild-order-0.4.12 6 | - pagure-0.2.1 7 | - copr-api-0.2.0 8 | - simple-prompt-0.2.3 9 | - fedora-krb-0.1.0 10 | - fedora-releases-0.2.0 11 | - select-rpms-0.2.0 12 | -------------------------------------------------------------------------------- /stack-lts22.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-22.43 2 | ghc-options: 3 | HsOpenSSL: -optc=-Wno-incompatible-pointer-types 4 | extra-deps: 5 | - pagure-0.2.1 6 | - fedora-krb-0.1.0 7 | - fedora-releases-0.2.0 8 | - select-rpms-0.2.0 9 | # workaround local email-validate failure: 10 | - os-string-2.0.6 11 | -------------------------------------------------------------------------------- /stack-nightly.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2025-03-05 2 | ghc-options: 3 | HsOpenSSL: -optc=-Wno-incompatible-pointer-types 4 | extra-deps: 5 | - fedora-krb-0.1.0 6 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-23.11 2 | ghc-options: 3 | HsOpenSSL: -optc=-Wno-incompatible-pointer-types 4 | extra-deps: 5 | - fedora-krb-0.1.0 6 | --------------------------------------------------------------------------------