diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,4 +1,17 @@ -* 0.8 (2019-04-26) +# 0.9 (2019-10-30) +- changes for Fedora 31 +- ghc now lives in ../ +- 'list' now repoqueries for Haskell packages +- new commands: 'cblrpm', 'depends', 'diffstat', 'fetch' +- 'refresh' gained -n +- rename 'diff-stackage' to 'stackage-compare' and improve output +- setTermTitle for Koji builds +- some commands now only print header if there's output +- fhbz: no longer assumes haskell-devel CC, and sets Fixed In: nvr +- hackageRelease moved from fedora-dists +- no longer cache overrides in .fhbuilt + +# 0.8 (2019-04-26) - remaining --counting option - make kojiWatchTask safe by checking taskinfo status - move distTag and distTarget from fedora-dists to Dist @@ -9,7 +22,7 @@ - use simple-cmd-opts-0.1.1 option wrappers - fix Hackage data generation repoqueries -* 0.7 (2019-02-28) +# 0.7 (2019-02-28) - merge fhbuild into fhpkg (please delete fhbuild) - use simple-cmd and fedora-dists - fhpkg: @@ -23,7 +36,7 @@ - new fhmock program - use Dist type -* 0.6 (2018-08-07) +# 0.6 (2018-08-07) - fhpkg - new commands: hackage-compare, merge, missing, count, leaf, unpushed, head-origin - command options including arguments and global options @@ -43,7 +56,7 @@ - ghc-8.4 - lot refactoring for utils etc -* 0.5 (2018-02-16) +# 0.5 (2018-02-16) - fhpkg - add commands for prep, refresh, diff-origin, push, and commit - only update hackages @@ -62,14 +75,14 @@ - repoquery koji build repo - add bump command -* 0.4 (2017-12-05) +# 0.4 (2017-12-05) - new commands: clone-new, diff-stackage, diff-branch - fix hackage distro data output - check spec file exists - fix cloning of missing branch dirs - allow no dist arg before pkg arg -* 0.3 (2017-10-24) +# 0.3 (2017-10-24) - initial release with fhbuild, fhbz, and fhpkg # Local Variables: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,13 +6,15 @@ # Fedora Haskell Tools +Tools for Fedora Haskell package maintainence. + ## fhpkg Git clones and pull, etc Fedora Haskell package repos. Can also generate Hackage distro meta data. Builds set of packages locally or in Koji or Mock. (fhbuild has been merged into fhpkg.) -For local builds unbuilt dependent packages are also built recursive. +For local builds unbuilt dependent packages are also built recursively. For updates built in Koji, buildroot overrides are created and waited for. Chain builds packages with wait-repo. diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -1,16 +1,19 @@ -split into separate packages or merge?? +- warn about unpushed commit(s) without any bump +- filter out ghc-prof & ghc-doc deps, ghc-rpm-macros removal?, ghc-srpm-macros +- filter xmonad and pandoc-pdf from install +- bodhi overrides not happening for chain deps +- check update deps in candidate tag + # fhpkg -- use optparse-applicative -- only print header if output - license-check command -* use pagure-cli to get new ghc-* packages +- -B dist is kind of nonsense +- library +- allow pkg/ or filter out '/' (from fhpkg.hs): - cache dist package lists? -- push subpackages to Hackage - compare branch versions -- compare with LTS - query-format string deps query tool @@ -21,8 +24,6 @@ allow master instead of rawhide -(`fhpkg clone -B branch pkg` doesn't really make sense) - check commands has all commands count: option to query without updates @@ -32,7 +33,6 @@ # support chain-build # git -- branch merging * merge a/next koji build - build new packages across branches diff --git a/fedora-haskell-tools.cabal b/fedora-haskell-tools.cabal --- a/fedora-haskell-tools.cabal +++ b/fedora-haskell-tools.cabal @@ -1,5 +1,5 @@ Name: fedora-haskell-tools -Version: 0.8 +Version: 0.9 Synopsis: Building and maintenance tools for Fedora Haskell Description: Tools for building and managing Fedora Haskell packages. @@ -15,7 +15,7 @@ Extra-source-files: README.md TODO ChangeLog Cabal-version: >=1.6 Tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, - GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.4 + GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5 source-repository head type: git @@ -29,11 +29,12 @@ fedora-dists, filepath, HTTP, + optparse-applicative, process, - simple-cmd >= 0.1.4, - simple-cmd-args >= 0.1.1, + simple-cmd >= 0.2.0, + simple-cmd-args >= 0.1.2, split, - time < 1.9, + time, unix Hs-Source-Dirs: src, . Other-modules: Build, Dist, Koji, Paths_fedora_haskell_tools, Utils @@ -47,7 +48,7 @@ fedora-dists, time Hs-Source-Dirs: src, . - Other-modules: Dist, Koji, RPM + Other-modules: Dist, Koji, RPM, Utils GHC-options: -fwarn-missing-signatures -Wall Extensions: CPP @@ -55,9 +56,8 @@ Main-is: fhmock.hs Build-depends: base < 5, fedora-dists, - optparse-applicative, - simple-cmd >= 0.1.1, - simple-cmd-args + simple-cmd >= 0.2.0, + simple-cmd-args >= 0.1.2 if impl(ghc<8.0) Build-depends: semigroups Hs-Source-Dirs: src, . diff --git a/fhbz.hs b/fhbz.hs --- a/fhbz.hs +++ b/fhbz.hs @@ -66,13 +66,14 @@ (_,_,errs) -> do prog <- getProgName error $ concat errs ++ usageInfo (header prog) options - where header prog = "Usage:" +-+ prog +-+ "[OPTION...] [package]..." + where header prog = "Usage:" +-+ prog +-+ "[OPTION...] [PACKAGE...]" main :: IO () main = do (opts, args) <- getArgs >>= parseOpts + when (null args) $ error "must give one or more packages" let state = fromMaybe "NEW" $ listToMaybe $ map (\ (State s) -> s) $ filter isState opts - bugs <- parseLines . lines <$> bugzillaQuery (["--cc=haskell-devel@lists.fedoraproject.org", "--bug_status=" ++ state, "--short_desc=is available", "--outputformat=%{id}\n%{component}\n%{bug_status}\n%{summary}\n%{status_whiteboard}"] ++ if null args then [] else ["--component=" ++ intercalate "," args]) + bugs <- parseLines . lines <$> bugzillaQuery (["--bug_status=" ++ state, "--short_desc=is available", "--outputformat=%{id}\n%{component}\n%{bug_status}\n%{summary}\n%{status_whiteboard}"] ++ ["--component=" ++ intercalate "," args]) mapM_ (checkBug opts) bugs bugzillaQuery :: [String] -> IO String @@ -148,7 +149,7 @@ when (nv == pkgver) $ do putStrLn $ "closing" +-+ bid ++ ":" +-+ nv +-+ "in rawhide" unless (DryRun `elem` opts) $ - bugzillaModify ["--close=RAWHIDE", "--comment=" ++ nvr, bid] + bugzillaModify ["--close=RAWHIDE", "--fixed_in=" ++ nvr, "--comment=Closed with fhbz from fedora-haskell-tools", bid] where removeRelease = init . dropWhileEnd (/= '-') @@ -161,7 +162,7 @@ then "No missing dependencies for" +-+ hkgver +-+ "\naccording to cblrpm missingdeps" {-++ (if null rebuilds then "\nwithout any other package rebuilds." else ".\n\nIt would require also rebuilding:\n" +-+ unwords rebuilds)-} else "cblrpm missingdeps output for" +-+ hkgver ++ ":\n\n" ++ missing bugzillaModify $ ["--whiteboard==" ++ hkgver ++ ":" ++ state] ++ - (if nocomment then [] else ["--comment=" ++ comment]) ++ [bid] + ["--comment=" ++ comment | not nocomment] ++ [bid] cabalUpdate :: IO () cabalUpdate = do diff --git a/fhmock.hs b/fhmock.hs --- a/fhmock.hs +++ b/fhmock.hs @@ -11,6 +11,10 @@ -- the Free Software Foundation, either version 3 of the License, or -- (at your option) any later version. +#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,13,0)) +#else +import Control.Applicative (many, pure, some) +#endif import Data.List (sort) import System.Environment (getArgs) @@ -20,7 +24,6 @@ import FedoraDists (Dist, distRepo, releaseVersion) import SimpleCmd (cmd_) import SimpleCmdArgs -import Options.Applicative #if (defined(MIN_VERSION_optparse_applicative) && MIN_VERSION_optparse_applicative(0,13,0)) --import Data.Semigroup ((<>)) #endif diff --git a/fhpkg.hs b/fhpkg.hs --- a/fhpkg.hs +++ b/fhpkg.hs @@ -14,19 +14,21 @@ module Main where +#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,13,0)) +#else import Control.Applicative (optional, some, (<|>) #if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,8,0)) #else , pure, (<$>), (<*>) #endif ) +#endif import Control.Monad (filterM, unless, when, (>=>)) import Data.Maybe import Data.List (intercalate, isInfixOf, isPrefixOf, nub, sort, (\\)) import Data.List.Split (splitOn) import Network.HTTP (getRequest, getResponseBody, simpleHTTP) -import Options.Applicative (Parser, auto, flag') import System.Directory (doesDirectoryExist, doesFileExist, getCurrentDirectory, getHomeDirectory, #if (defined(MIN_VERSION_directory) && MIN_VERSION_directory(1,2,5)) @@ -36,20 +38,19 @@ #endif setCurrentDirectory) import System.FilePath ((), (<.>), takeFileName) -import System.IO (BufferMode(..), hSetBuffering, stdout) +import System.IO (BufferMode(..), hIsTerminalDevice, hSetBuffering, stdout) --import System.Posix.Env (getEnv) import Text.CSV (parseCSV) -import FedoraDists (Dist(..), distBranch, distRepo, distUpdates, - hackageRelease, rawhide) +import FedoraDists (Dist(..), distBranch, distRepo, distUpdates, rawhide) -import SimpleCmd ((+-+), cmd, cmd_, cmdBool, cmdLines, cmdMaybe, cmdSilent, - grep_, removePrefix, shell_) -import SimpleCmd.Git (git, git_, gitBranch, isGitDir) +import SimpleCmd ((+-+), cmd, cmd_, cmdBool, cmdLines, cmdMaybe, cmdQuiet, + cmdSilent, grep_, removePrefix, shell_, warning) +import SimpleCmd.Git (git, git_, gitBranch, gitDiffQuiet, isGitDir) import SimpleCmdArgs import Build (build, readBuildCmd) -import Dist (distArg, distRemote) +import Dist (distArg, distRemote, hackageRelease, ltsStream) import Koji (kojiListPkgs, rpkg) import Paths_fedora_haskell_tools (version) import RPM (buildRequires, haskellSrcPkgs, Package, pkgDir, @@ -71,18 +72,20 @@ simpleCmdArgs (Just version) "Fedora Haskell packages tool" "Fedora packages maintenance tool" $ subcommands $ - [ Subcommand "bump" "bump package release" $ - bump <$> strOptionWith 'm' "message" "CHANGELOG" "changelog message" <*> distArg <*> pkgArgs - , Subcommand "checkout" "fedpkg switch-branch" $ + [ Subcommand "checkout" "fedpkg switch-branch" $ repoAction_ True False (return ()) <$> distArg <*> pkgArgs , Subcommand "clone" "clone repos" $ clone <$> branching <*> distArg <*> pkgArgs , Subcommand "clone-new" "clone new packages" $ cloneNew <$> branching <*> distArg + , Subcommand "cblrpm" "Run cblrpm command" $ + cblrpm <$> strOptionWith 'c' "cmd" "CMD" "command to execute" <*> distArg <*> pkgArgs , Subcommand "cmd" "arbitrary command (with args)" $ execCmd <$> strOptionWith 'c' "cmd" "CMD" "command to execute" <*> distArg <*> pkgArgs , Subcommand "count" "count number of packages" $ (repoqueryHaskellPkgs False >=> (print . length)) <$> distArg + , Subcommand "depends" "cabal-depends" $ + repoAction False (Output cabalDepends) <$> distArg <*> pkgArgs , Subcommand "diff" "git diff" $ gitDiff <$> optional gitFormat <*> optional (strOptionWith 'w' "with-branch" "BRANCH" "Branch to compare") @@ -90,46 +93,51 @@ , Subcommand "diff-origin" "git diff origin" $ gitDiffOrigin <$> distArg <*> pkgArgs , Subcommand "diff-branch" "compare branch with master" $ - repoAction False True compareRawhide <$> distArg <*> pkgArgs - , Subcommand "diff-stackage" "compare with stackage" $ - diffStackage <$> switchWith 'm' "missing" "only list missing packages" <*> distArg <*> pkgArgs + repoAction True (Header False compareRawhide) <$> distArg <*> pkgArgs + , Subcommand "diffstat" "Show diffstat output" $ + repoAction False (Output (const diffStat)) <$> distArg <*> pkgArgs , Subcommand "hackage" "generate Hackage distro data" $ repoqueryHackageCSV hackageRelease <$> switchRefresh , Subcommand "hackage-compare" "compare with Hackage distro data" $ hackageCompare <$> switchRefresh - , Subcommand "head-origin" "head in sync with origin" $ + , Subcommand "head-origin" "packages with head in sync with origin" $ headOrigin <$> distArg <*> pkgArgs - , Subcommand "leaf" "list leaf packages" $ + , Subcommand "leaf" "list leaf packages (slow!)" $ leaves <$> switchWith 'v' "deps" "show also deps" <*> distArg <*> pkgArgs - , Subcommand "list" "list packages" $ mapM_ putStrLn <$> pkgArgs + , Subcommand "list" "list packages that BR ghc-Cabal-devel" $ + (repoqueryHaskellPkgs False >=> putStrList) <$> distArg , Subcommand "merge" "git merge" $ merge <$> strOptionWith 'f' "from" "BRANCH" "specify branch to merge from" <*> distArg <*> pkgArgs , Subcommand "missing" "missing dependency source packages" $ missingDeps <$> distArg <*> pkgArgs - , Subcommand "new" "new unbuilt packages" $ - (newPackages >=> mapM_ putStrLn) <$> distArg + , Subcommand "new" "unbuilt packages" $ + (newPackages >=> putStrList) <$> distArg , Subcommand "old-packages" "packages not in repoquery" $ oldPackages <$> distArg <*> pkgArgs , Subcommand "prep" "fedpkg prep" $ prep <$> distArg <*> pkgArgs + , Subcommand "stackage-compare" "compare with stackage" $ + stackageCompare <$> streamOpt <*> switchWith 'm' "missing" "only list missing packages" <*> distArg <*> pkgArgs , Subcommand "commit" "fedpkg commit" $ commit <$> strOptionWith 'm' "message" "COMMITMSG" "commit message" <*> distArg <*> pkgArgs + , Subcommand "fetch" "git fetch repos" $ + repoAction_ True False (git_ "fetch" []) <$> distArg <*> pkgArgs , Subcommand "pull" "git pull repos" $ repoAction_ True False (git_ "pull" ["--rebase"]) <$> distArg <*> pkgArgs , Subcommand "push" "git push repos" $ repoAction_ True False (git_ "push" []) <$> distArg <*> pkgArgs , Subcommand "refresh" "cabal-rpm refresh" $ - repoAction True True refreshPkg <$> distArg <*> pkgArgs + refresh <$> switchWith 'n' "dry-run" "Show patch but don't apply" <*> distArg <*> pkgArgs , Subcommand "remaining" "remaining packages to be built in TAG" $ remaining <$> switchWith 'c' "count" "show many packages left" <*> strArg "TAG" <*> pkgArgs - , Subcommand "unpushed" "show unpushed commits" $ - unpushed <$> switchWith 's' "short" "no log" <*> distArg <*> pkgArgs - , Subcommand "update" "cabal-rpm update" $ - update <$> strOptionWith 's' "stream" "STACKAGESTREAM" "Stackage stream (lts-X)" <*> distArg <*> pkgArgs , Subcommand "subpkgs" "list subpackages" $ - repoAction True True (\ p -> rpmspec [] (Just "%{name}-%{version}") (p <.> "spec") >>= mapM_ putStrLn) <$> distArg <*> pkgArgs + repoAction True (Header True (\ p -> rpmspec [] (Just "%{name}-%{version}") (p <.> "spec") >>= putStrList)) <$> distArg <*> pkgArgs , Subcommand "tagged" "list koji DIST tagged builds" $ listTagged_ <$> switchWith 's' "short" "list packages not builds" <*> strArg "TAG" + , Subcommand "unpushed" "show unpushed commits" $ + unpushed <$> switchWith 's' "short" "no log" <*> distArg <*> pkgArgs + , Subcommand "update" "cabal-rpm update" $ + update <$> streamOpt <*> distArg <*> pkgArgs , Subcommand "verrel" "show nvr of packages" $ verrel <$> distArg <*> pkgArgs] ++ map (buildCmd cwd) [ ("install", "build locally and install") @@ -149,7 +157,7 @@ gitFormat :: Parser DiffFormat gitFormat = - flag' DiffShort (switchMods 's' "short" "Just output package name") <|> + flagWith' DiffShort 's' "short" "Just output package name" <|> DiffContext <$> optionWith auto 'u' "unified" "CONTEXT" "Lines of context" buildCmd cwd (c, desc) = @@ -158,17 +166,17 @@ switchRefresh = switchWith 'r' "refresh" "repoquery --refresh" + streamOpt = strOptionalWith 's' "stream" "STACKAGESTREAM" ("Stackage stream [" ++ ltsStream ++ "]") ltsStream + data DiffFormat = DiffShort | DiffContext Int deriving (Eq) -bump :: String -> Dist -> [Package] -> IO () -bump msg = - repoAction True False bumpspec - where - bumpspec pkg = - cmd_ "rpmdev-bumpspec" ["-c", msg, pkg <.> "spec"] +putStrList :: [String] -> IO () +putStrList = + putStr . unlines +-- should make separate rhel client so -B does not need dist clone :: Bool -> Dist -> [Package] -> IO () clone True dist pkgs = cloneAllBranches dist pkgs clone False dist pkgs = @@ -187,7 +195,7 @@ gitDiff :: Maybe DiffFormat -> Maybe String -> Dist -> [Package] -> IO () gitDiff fmt mbrnch = - repoAction False False doGitDiff + repoAction False (Output doGitDiff) where doGitDiff pkg = do let branch = maybeToList mbrnch @@ -196,32 +204,37 @@ _ -> [] short = fmt == Just DiffShort out <- git "diff" $ branch ++ contxt - unless (null out) $ do - putStrLn $ if short then pkg else "==" +-+ pkg +-+ "==" - unless short $ putStrLn out + return $ if null out then "" + else if short then pkg else out gitDiffOrigin :: Dist -> [Package] -> IO () gitDiffOrigin dist = - repoAction_ True False (git_ "diff" [distRemote dist]) dist + repoAction False (Output (const (git "diff" [distRemote dist]))) dist -diffStackage :: Bool -> Dist -> [Package] -> IO () -diffStackage missingOnly dist = - repoAction False True compareStackage dist +stackageCompare :: String -> Bool -> Dist -> [Package] -> IO () +stackageCompare stream missingOnly dist = + repoAction True (Header False compareStackage) dist where compareStackage :: Package -> IO () compareStackage p = do nvr <- cmd (rpkg dist) ["verrel"] - let stream = "lts-12" stkg <- cmdMaybe "stackage" ["package", stream, removePrefix "ghc-" p] - let same = isJust stkg && fromJust stkg `isInfixOf` nvr - unless missingOnly $ - putStrLn $ nvr +-+ "(fedora)" - if missingOnly then when (isNothing stkg) $ putStrLn p + let same = isJust stkg && (fromJust stkg ++ "-") `isInfixOf` nvr + unless same $ + if missingOnly + then when (isNothing stkg) $ putStrLn p else - putStrLn $ (if same then "same" else fromMaybe "none" stkg) +-+ "(" ++ stream ++ ")" + if isNothing stkg + then putStrLn $ stream ++ " missing: " ++ removePrefix "ghc-" p + else do + putStrLn nvr + putStrLn $ replicate (length (dropVerrel nvr) + 1) ' ' ++ fromJust stkg +-+ "(" ++ stream ++ ")" +diffStat :: IO String +diffStat = git "diff" ["--stat"] + hackageCompare :: Bool -> IO () -hackageCompare refresh = +hackageCompare refreshData = repoqueryHackages hackageRelease >>= compareHackage hackageRelease where @@ -229,7 +242,7 @@ compareHackage dist pkgs' = do hck <- simpleHTTP (getRequest "http://hackage.haskell.org/distro/Fedora/packages.csv") >>= getResponseBody let hackage = sort . either (error "Malformed Hackage csv") (map mungeHackage) $ parseCSV "packages.csv" hck - sort . map mungeRepo . lines <$> repoquery dist (["--repo=fedora", "--repo=updates", "--latest-limit=1", "--qf=%{name},%{version}"] ++ ["--refresh" | refresh] ++ pkgs') >>= + sort . map mungeRepo . lines <$> repoquery dist (["--repo=fedora", "--repo=updates", "--latest-limit=1", "--qf=%{name},%{version}"] ++ ["--refresh" | refreshData] ++ pkgs') >>= compareSets True hackage mungeHackage :: [String] -> PkgVer @@ -263,7 +276,7 @@ headOrigin :: Dist -> [Package] -> IO () headOrigin dist = - repoAction False False gitHeadAtOrigin dist + repoAction False (Header False gitHeadAtOrigin) dist where gitHeadAtOrigin :: Package -> IO () gitHeadAtOrigin pkg = do @@ -273,7 +286,7 @@ leaves :: Bool -> Dist -> [Package] -> IO () leaves verb = - repoAction verb True checkLeafPkg + repoAction True (Header verb checkLeafPkg) where -- FIXME: make a dependency cache checkLeafPkg :: Package -> IO () @@ -288,7 +301,7 @@ found <- filterM (dependsOn subpkgs) other if null found then putStrLn pkg - else when verb $ mapM_ putStrLn found + else when verb $ putStrList found where dependsOn :: [Package] -> Package -> IO Bool dependsOn subpkgs p = do @@ -305,9 +318,9 @@ missingDeps :: Dist -> [Package] -> IO () missingDeps dist = - repoAction True True checkForMissingDeps dist + repoAction True (Output checkForMissingDeps) dist where - checkForMissingDeps :: Package -> IO () + checkForMissingDeps :: Package -> IO String checkForMissingDeps pkg = do dir <- takeFileName <$> getCurrentDirectory let top = if dir == pkg then ".." else "../.." @@ -316,18 +329,17 @@ if hasSpec then do deps <- buildRequires (pkg <.> "spec") >>= haskellSrcPkgs top dist - mapM_ (checkMissing top) deps - else putStrLn "no spec file found!" + unlines <$> filterM (noPkgDir top) deps + else putStrLn ("no " ++ pkg ++ ".spec file found!") >> return "" where - checkMissing :: FilePath -> Package -> IO () - checkMissing top dep = do - exists <- doesDirectoryExist $ top dep - unless exists $ putStrLn $ "Missing" +-+ dep + noPkgDir :: FilePath -> Package -> IO Bool + noPkgDir top dep = + not <$> doesDirectoryExist (top dep) oldPackages :: Dist -> [Package] -> IO () oldPackages dist pkgs = do repopkgs <- repoqueryHaskellPkgs True dist - mapM_ putStrLn (pkgs \\ repopkgs) + putStrList (pkgs \\ repopkgs) prep :: Dist -> [Package] -> IO () prep dist = @@ -335,19 +347,18 @@ commit :: String -> Dist -> [Package] -> IO () commit logmsg dist = - repoAction_ True True commitChanges dist + repoAction False (Output (const commitChanges)) dist where - commitChanges :: IO () + commitChanges :: IO String commitChanges = do - -- use gitDiffQuiet - nochgs <- cmdBool "git" ["diff", "--quiet"] + nochgs <- gitDiffQuiet [] if nochgs - then putStrLn "no changes" - else cmd_ (rpkg dist) ["commit", "-m", logmsg] + then return "" + else cmd (rpkg dist) ["commit", "-m", logmsg] unpushed :: Bool -> Dist -> [Package] -> IO () unpushed nolog dist = - repoAction False True gitLogOneLine dist + repoAction True (Header False gitLogOneLine) dist where gitLogOneLine :: Package -> IO () gitLogOneLine pkg = do @@ -362,10 +373,10 @@ repoAction_ False True (cmd_ (rpkg dist) ["verrel"]) dist repoqueryHackageCSV :: Dist -> Bool -> IO () -repoqueryHackageCSV dist refresh = do +repoqueryHackageCSV dist refreshData = do pkgs <- repoqueryHackages dist -- Hackage csv chokes on final newline so remove it - init . unlines . sort . map (replace "\"ghc-" "\"") . lines <$> repoquery dist (["--repo=fedora", "--repo=updates", "--latest-limit=1", "--qf=\"%{name}\",\"%{version}\",\"https://apps.fedoraproject.org/packages/%{source_name}\""] ++ ["--refresh" | refresh] ++ pkgs) >>= putStr + init . unlines . sort . map (replace "\"ghc-" "\"") . lines <$> repoquery dist (["--repo=fedora", "--repo=updates", "--latest-limit=1", "--qf=\"%{name}\",\"%{version}\",\"https://apps.fedoraproject.org/packages/%{source_name}\""] ++ ["--refresh" | refreshData] ++ pkgs) >>= putStr data PkgVer = PV { pvPkg :: String, pvVer :: String} deriving (Eq) @@ -387,10 +398,12 @@ repoqueryHaskellPkgs :: Bool -> Dist -> IO [Package] repoqueryHaskellPkgs verbose dist = do - when verbose $ putStrLn "Getting packages from repoquery" + when verbose $ do + tty <- hIsTerminalDevice stdout + when tty $ warning "Getting packages from repoquery" let repo = distRepo dist updates = maybeToList $ distUpdates dist - bin <- words <$> repoquery dist (["--repo=" ++ repo ++ "-source"] ++ ["--repo=" ++ u ++ "-source" | u <- updates] ++ ["--qf=%{name}", "--whatrequires", "ghc-Cabal-devel"]) + bin <- words <$> repoquery dist (["--repo=" ++ repo ++ "-source"] ++ ["--repo=" ++ u ++ "-source" | u <- updates] ++ ["--qf=%{name}", "--whatrequires", "ghc-Cabal-*"]) when (null bin) $ error "No packages using ghc-Cabal-devel found!" return $ sort $ nub bin @@ -414,25 +427,28 @@ newPackages :: Dist -> IO [Package] newPackages dist = do ps <- repoqueryHaskellPkgs True dist - kps <- kojiListHaskell True dist - return $ kps \\ ps + pps <- cmdLines "pagure" ["list", "ghc*"] + filterM (\ d -> not <$> doesFileExist (d "dead.package")) $ pps \\ ps kojiListHaskell :: Bool -> Dist -> IO [Package] kojiListHaskell verbose dist = do when verbose $ putStrLn "Getting package list from Koji" - libs <- filter (\ p -> "ghc-" `isPrefixOf` p && p `notElem` ["ghc-rpm-macros", "ghc-srpm-macros"]) <$> kojiListPkgs dist + libs <- filter (\ p -> "ghc" `isPrefixOf` p && p `notElem` ["ghc-rpm-macros", "ghc-srpm-macros"]) <$> kojiListPkgs dist when (null libs) $ error "No library packages found" return $ sort $ nub libs +haveSshKey :: IO Bool +haveSshKey = do + home <- getHomeDirectory + doesFileExist $ home ".ssh/id_rsa" + cloneAllBranches :: Dist -> [Package] -> IO () cloneAllBranches _ [] = return () cloneAllBranches dist (pkg:rest) = do withCurrentDirectory "." $ do putStrLn $ "\n==" +-+ pkg +-+ "==" -- muser <- getEnv "USER" - haveSSH <- do - home <- getHomeDirectory - doesFileExist $ home ".ssh/id_rsa" + haveSSH <- haveSshKey dirExists <- doesDirectoryExist pkg unless dirExists $ cmd_ (rpkg dist) $ ["clone"] ++ ["-a" | not haveSSH] ++ ["-B", pkg] @@ -441,22 +457,26 @@ error "branch checkout already exists!" cloneAllBranches dist rest -repoAction :: Bool -> Bool -> (Package -> IO ()) -> Dist -> [Package] -> IO () -repoAction _ _ _ _ [] = return () -repoAction header needsSpec action dist (pkg:rest) = do +data Action = Output (Package -> IO String) | Header Bool (Package -> IO ()) + +showHeader :: Action -> Bool +showHeader (Header b _) = b +showHeader (Output _) = False + +repoAction :: Bool -> Action -> Dist -> [Package] -> IO () +repoAction _ _ _ [] = return () +repoAction needsSpec action dist (pkg:rest) = do withCurrentDirectory "." $ do let branch = distBranch dist - when header $ + when (showHeader action) $ putStrLn $ "\n==" +-+ pkg ++ ":" ++ branch +-+ "==" -- muser <- getEnv "USER" - haveSSH <- do - home <- getHomeDirectory - doesFileExist $ home ".ssh/id_rsa" + haveSSH <- haveSshKey fileExists <- doesFileExist pkg - dirExists <- doesDirectoryExist pkg if fileExists then error $ pkg +-+ "is a file" else do + dirExists <- doesDirectoryExist pkg unless dirExists $ cmd_ (rpkg dist) $ ["clone"] ++ ["-a" | not haveSSH] ++ ["-b", branch, pkg] singleDir <- isGitDir pkg @@ -483,15 +503,21 @@ let spec = pkg <.> "spec" hasSpec <- doesFileExist spec -- FIXME: silence for cmds that only output package names (eg unpushed -s) - unless hasSpec $ putStrLn $ (if header then "" else pkg ++ ": ") ++ "No spec file!" + unless hasSpec $ putStrLn $ (if showHeader action then "" else pkg ++ ": ") ++ "No spec file!" unless (needsSpec && not hasSpec) $ - action pkg - repoAction header needsSpec action dist rest + case action of + Header _ act -> act pkg + Output act -> do + out <- act pkg + unless (null out) $ do + putStrLn $ "\n==" +-+ pkg ++ ":" ++ branch +-+ "==" + putStrLn out + repoAction needsSpec action dist rest +-- io independent of package repoAction_ :: Bool -> Bool -> IO () -> Dist -> [Package] -> IO () repoAction_ header needsSpec action = - repoAction header needsSpec (const action) - + repoAction needsSpec (Header header (const action)) compareRawhide :: Package -> IO () compareRawhide p = do @@ -514,10 +540,9 @@ isFromHackage pkg = grep_ "hackage.haskell.org/package/" $ pkg <.> "spec" - update :: String -> Dist -> [Package] -> IO () update stream = - repoAction True True doUpdate + repoAction True (Header True doUpdate) where doUpdate :: Package -> IO () doUpdate pkg = do @@ -526,27 +551,31 @@ then cmd_ "cabal-rpm" ["update", "-s", stream] else putStrLn "skipping since not hackage" -refreshPkg :: Package -> IO () -refreshPkg pkg = do - hckg <- isFromHackage pkg - if hckg - then cmd_ "cabal-rpm" ["refresh"] - else putStrLn "skipping since not hackage" +refresh :: Bool -> Dist -> [Package] -> IO () +refresh dryrun = + repoAction True (Header True refreshPkg) + where + refreshPkg :: Package -> IO () + refreshPkg pkg = do + hckg <- isFromHackage pkg + if hckg + then cmd_ "cabal-rpm" $ "refresh" : ["--dry-run" | dryrun] + else putStrLn "skipping since not hackage" listTagged_ :: Bool -> String -> IO () listTagged_ short tag = - listTagged short tag >>= mapM_ putStrLn + listTagged short tag >>= putStrList listTagged :: Bool -> String -> IO [String] listTagged short tag = do builds <- map (head . words) <$> cmdLines "koji" ["list-tagged", "--quiet", tag] return $ nub $ map (if short then dropVerrel else id) builds - where - dropVerrel :: String -> String - dropVerrel nvr = - let parts = splitOn "-" nvr in - intercalate "-" $ take (length parts - 2) parts +dropVerrel :: String -> String +dropVerrel nvr = + let parts = splitOn "-" nvr in + intercalate "-" $ take (length parts - 2) parts + remaining :: Bool -> String -> [Package] -> IO () remaining count tag pkgs = do built <- listTagged True tag @@ -554,3 +583,24 @@ if count then print $ length left else cmd_ "rpmbuild-order" $ ["sort", "-p"] ++ left + +cabalDepends :: Package -> IO String +cabalDepends p = do + hckg <- isFromHackage p + if hckg then do + vr <- removePrefix "ghc-" . head <$> + rpmspec ["--srpm"] (Just "%{name}-%{version}") (p <.> "spec") + setCurrentDirectory vr + cmdQuiet "cabal-depends" ["--not-build", "--unique"] + else return "" + +cblrpm :: String -> Dist -> [Package] -> IO () +cblrpm "" = error "CMD string must be given" +cblrpm cs = + repoAction True (Header True doCblRpm) + where + doCblRpm :: Package -> IO () + doCblRpm p = do + hckg <- isFromHackage p + when hckg $ + cmd_ "cblrpm" [cs] diff --git a/src/Build.hs b/src/Build.hs --- a/src/Build.hs +++ b/src/Build.hs @@ -32,12 +32,13 @@ import System.FilePath ((), dropExtension) import FedoraDists (Dist, distBranch, distOverride, rpmDistTag) +import Dist (distRemote) import Koji (kojiBuilding, kojiCheckFHBuilt, kojiLatestPkg, kojiWaitPkg, notInKoji, rpkg, rpkgBuild) import RPM (buildRequires, derefSrcPkg, haskellSrcPkgs, Package, packageManager, pkgDir, rpmInstall, rpmspec) import SimpleCmd ((+-+), cmd, cmd_, cmdBool, cmdLines, cmdLog, cmdMaybe, - cmdSilent, grep_, removeStrictPrefix, sudo) + cmdSilent, grep_, removeStrictPrefix, sudo_) import SimpleCmd.Git (git_, gitBranch, isGitDir) import Utils (checkPkgsGit) @@ -54,7 +55,7 @@ readBuildCmd "changed" = Changed readBuildCmd "built" = Built readBuildCmd "bump" = Bump -readBuildCmd "notinstalled" = NotInstalled +readBuildCmd "not-installed" = NotInstalled readBuildCmd _ = error "Unknown command" -- commands :: [String] @@ -153,8 +154,8 @@ then rpmInstall rpms else do pkgmgr <- packageManager - sudo pkgmgr ("--setopt=clean_requirements_on_remove=no":"remove":"-y":instpkgs) - sudo pkgmgr ("install":"-y":rpms) + sudo_ pkgmgr ("--setopt=clean_requirements_on_remove=no":"remove":"-y":instpkgs) + sudo_ pkgmgr ("install":"-y":rpms) putStrLn "" putStrLn $ show (length rest) +-+ "packages left" build topdir Nothing Nothing False Install dist rest @@ -215,9 +216,10 @@ Bump -> do latest <- kojiLatestPkg dist pkg when (eqNVR nvr latest) $ do - putStrLn pkg - cmd_ "rpmdev-bumpspec" ["-c", "rebuild", spec] - cmd_ (rpkg dist) ["commit", "-m", "bump release"] + git_ "log" [distRemote dist ++ "..HEAD", "--pretty=oneline"] + cmd_ "rpmdev-bumpspec" ["-c", "add doc and prof subpackages (cabal-rpm-1.0.0)", spec] +-- cmd_ (rpkg dist) ["commit", "-m", "cabal-rpm-1.0.0: add doc and prof subpkgs"] + git_ "commit" ["-a", "--amend", "-m", "cabal-rpm-1.0.0: add doc and prof subpkgs"] build topdir Nothing Nothing False Bump dist rest NotInstalled -> do opkg <- head <$> rpmspec ["--builtrpms"] (Just "%{name}") spec @@ -232,8 +234,7 @@ if eqNVR nvr latest then do putStrLn $ fromJust latest +-+ "already built!" - unless (null rest) $ --do - --kojiWaitPkg topdir dist nvr + unless (null rest) $ build topdir Nothing Nothing False Chain dist rest else do git_ "diff" [] @@ -248,7 +249,6 @@ showChange pkg latest nvr putStrLn "" srcs <- buildRequires spec >>= haskellSrcPkgs topdir dist - --print srcs hmissing <- nub <$> filterM (notInKoji branch topdir dist) srcs putStrLn "" unless (null hmissing) $ do @@ -269,7 +269,7 @@ notInstalled :: String -> IO Bool notInstalled pkg = - not <$> cmdBool "rpm" ["--quiet", "-q", pkg] + not <$> cmdBool "rpm" ["--quiet", "-q", "--whatprovides", pkg] showChange :: Package -> Maybe String -> String -> IO () showChange pkg mlatest nvr = do @@ -290,7 +290,7 @@ bodhiOverride dist nvr = when (distOverride dist) $ -- FIXME: improve Notes with recursive info - cmd_ "bodhi" ["overrides", "save", "--notes", "Haskell stack", nvr] + cmdLog "bodhi" ["overrides", "save", "--notes", "Haskell stack", nvr] eqNVR :: String -> Maybe String -> Bool eqNVR p1 p2 = diff --git a/src/Dist.hs b/src/Dist.hs --- a/src/Dist.hs +++ b/src/Dist.hs @@ -2,17 +2,19 @@ (distArg, distRemote, distTag, - distTarget) + distTarget, + hackageRelease, + ltsStream) where import Data.Maybe (fromMaybe) import FedoraDists (Dist(..), distBranch) -import Options.Applicative +import SimpleCmdArgs (Parser, argumentWith, auto) -- | Used for Koji sidetag when needed. sidetag :: Dist -> Maybe String --- sidetag (Fedora n) | n == 31 = Just "ghc" +--sidetag (Fedora n) | n == 31 = Just "ghc" sidetag _ = Nothing -- | Maps `Dist` to build tag @@ -25,8 +27,16 @@ -- | optparse-application DIST arg distArg :: Parser Dist -distArg = argument auto (metavar "DIST") +distArg = argumentWith auto "DIST" -- | Maps `Dist` to remote branch: eg "origin/master" distRemote :: Dist -> String distRemote d = "origin/" ++ distBranch d + +-- | Fedora release being tracked in Hackage Distro data +hackageRelease :: Dist +hackageRelease = Fedora 31 + +-- | Stackage LTS stream major version +ltsStream :: String +ltsStream = "lts-13" diff --git a/src/Koji.hs b/src/Koji.hs --- a/src/Koji.hs +++ b/src/Koji.hs @@ -35,15 +35,14 @@ import System.Directory (doesFileExist) import System.Exit (ExitCode (..)) import System.FilePath ((), (<.>)) -import System.IO (hPutStrLn, stderr) import System.Process (readProcessWithExitCode, rawSystem) import FedoraDists (Dist, kojicmd, rpkg) import SimpleCmd (cmd, cmd_, cmdBool, cmdLines, grep_, logMsg, - removeStrictPrefix, (+-+)) + removePrefix, removeStrictPrefix, warning, (+-+)) import Dist (distTag, distTarget) import RPM (pkgDir) - +import Utils (setTermTitle) kojisafe :: Dist -> String -> [String] -> IO String kojisafe dist c as = @@ -60,9 +59,13 @@ tag = distTag dist already <- kojiCheckFHBuilt topdir nvr unless already $ do - putStrLn $ "Waiting for" +-+ nvr +-+ "in" +-+ tag + logMsg $ "Waiting for" +-+ nvr +-+ "in" +-+ tag + setTermTitle $ '*' : removePrefix "ghc-" nvr cmdFragile_ (kojicmd dist) ["wait-repo", tag, "--build=" ++ nvr] - appendFile fhbuilt $ nvr ++ "\n" + tags <- cmdLines (kojicmd dist) ["list-tags", "--build=" ++ nvr] + -- do not cache overrides + when (tag `elem` tags) $ + appendFile fhbuilt $ nvr ++ "\n" kojiCheckFHBuilt :: FilePath -> String -> IO Bool kojiCheckFHBuilt topdir nvr = do @@ -100,6 +103,7 @@ rpkgBuild :: FilePath -> Dist -> String -> Bool -> IO () rpkgBuild topdir dist nvr waitrepo = do giturl <- cmd (rpkg dist) ["giturl"] + setTermTitle $ removePrefix "ghc-" nvr out <- cmd (kojicmd dist) ["build", "--nowait", "--fail-fast", distTarget dist, giturl] putStrLn out let task = last . words . head $ lines out @@ -149,8 +153,8 @@ ExitFailure n -> do unless (null out) $ putStrLn out when (null (out ++ err)) $ - hPutStrLn stderr $ "\"" ++ c +-+ unwords as ++ "\"" +-+ "failed with status" +-+ show n - unless (null err) $ hPutStrLn stderr err + warning $ "\"" ++ c +-+ unwords as ++ "\"" +-+ "failed with status" +-+ show n + unless (null err) $ warning err threadDelay 2000000 cmdFragile c as @@ -160,7 +164,7 @@ case ret of ExitSuccess -> return () ExitFailure _ -> do - hPutStrLn stderr $ "retrying \"" ++ c +-+ unwords as ++ "\"" + warning $ "retrying \"" ++ c +-+ unwords as ++ "\"" threadDelay 2000000 cmdFragile_ c as diff --git a/src/RPM.hs b/src/RPM.hs --- a/src/RPM.hs +++ b/src/RPM.hs @@ -32,16 +32,15 @@ import System.FilePath (()) -- die is available in ghc-7.10 base-4.8 import System.Exit (ExitCode (..), exitFailure, exitWith) -import System.IO (hPutStrLn, stderr) import Dist (distTag) import FedoraDists (Dist, distBranch, dists, releaseVersion) -import SimpleCmd (cmd, removeStrictPrefix, removeSuffix, sudo, (+-+)) +import SimpleCmd (cmd, removeStrictPrefix, removeSuffix, sudo_, warning, (+-+)) import qualified SimpleCmd.Rpm as S -- @since base 4.8.0.0 die :: String -> IO a -die err = hPutStrLn stderr err >> exitFailure +die err = warning err >> exitFailure requireProgram :: String -> IO () requireProgram c = do @@ -62,7 +61,7 @@ rpmInstall rpms = do pkginstaller <- packageManager let (inst, arg) = if pkginstaller == "dnf" then ("dnf", "install") else ("yum", "localinstall") - sudo inst $ ["-y", "--nogpgcheck", arg] ++ rpms + sudo_ inst $ ["-y", "--nogpgcheck", arg] ++ rpms repoquery :: Dist -> [String] -> IO String repoquery dist args = do @@ -76,7 +75,7 @@ havednf <- optionalProgram "dnf" let srcflag = if havednf then ["--qf=%{source_name}"] else ["--qf", "%{base_package_name}"] repo = if dist `elem` dists - then ["--repo=koji-buildroot", "--repofrompath", "koji-buildroot,http://kojipkgs.fedoraproject.org/repos" distTag dist "latest/x86_64/"] + then ["--repo=koji-buildroot", "--repofrompath", "koji-buildroot,https://kojipkgs.fedoraproject.org/repos" distTag dist "latest/x86_64/"] else [] res <- words <$> repoquery dist (srcflag ++ repo ++ ["--whatprovides", key]) return $ case res of @@ -97,46 +96,60 @@ type Package = String derefSrcPkg :: FilePath -> Dist -> Bool -> Package -> IO Package -derefSrcPkg topdir dist verb pkg = - if isHaskellDevelPkg pkg - then - do let lib = removeSuffix "-devel" pkg - -- fixme: should check branch (dir) - libExists <- doesDirectoryExist $ topdir lib - if libExists - then return lib - else do - -- todo: check bin has lib - let bin = removeStrictPrefix "ghc-" lib - binExists <- doesDirectoryExist $ topdir bin - if binExists - then return bin - else derefSrcPkg topdir dist verb lib - else - do putStrLn $ "Repoquerying" +-+ pkg - res <- repoquerySrc dist pkg - case res of - Nothing -> - do putStrLn $ "Unknown package" +-+ removeSuffix "-devel" pkg - exitWith (ExitFailure 1) - Just s -> do - when (pkg /= s && verb) $ putStrLn $ pkg +-+ "->" +-+ s - return s +derefSrcPkg topdir dist verb pkg = do + res <- maybeDerefSrcPkg topdir dist verb pkg + case res of + Nothing -> do + putStrLn $ "Unknown package" +-+ removeSuffix "-devel" pkg + exitWith (ExitFailure 1) + Just s -> do + when (pkg /= s && verb) $ putStrLn $ pkg +-+ "->" +-+ s + return s +derefSrcPkgRelax :: FilePath -> Dist -> Package -> IO Package +derefSrcPkgRelax topdir dist pkg = do + res <- maybeDerefSrcPkg topdir dist False pkg + case res of + Nothing -> return pkg + Just s -> return s + +maybeDerefSrcPkg :: FilePath -> Dist -> Bool -> Package -> IO (Maybe Package) +maybeDerefSrcPkg topdir dist verb pkg = do + let lib = removeLibSuffix pkg + -- fixme: should check branch (dir) + libExists <- doesDirectoryExist $ topdir lib + if libExists + then return $ Just lib + else do + -- todo: check bin has lib + let bin = removeStrictPrefix "ghc-" lib + binExists <- doesDirectoryExist $ topdir bin + if binExists + then return $ Just bin + else do + when verb $ putStrLn $ "Repoquerying" +-+ pkg + repoquerySrc dist pkg + isHaskellDevelPkg :: Package -> Bool -isHaskellDevelPkg pkg = "ghc-" `isPrefixOf` pkg && ("-devel" `isSuffixOf` pkg) || pkg `elem`haskellTools +isHaskellDevelPkg pkg = "ghc-" `isPrefixOf` pkg && ("-devel" `isSuffixOf` pkg || "-prof" `isSuffixOf` pkg || "-static" `isSuffixOf` pkg) || pkg `elem`haskellTools +removeLibSuffix :: String -> String +removeLibSuffix p | "-devel" `isSuffixOf` p = removeSuffix "-devel" p + | "-prof" `isSuffixOf` p = removeSuffix "-prof" p + | "-static" `isSuffixOf` p = removeSuffix "-static" p + | otherwise = p + haskellTools :: [Package] -haskellTools = ["alex", "cabal-install", "gtk2hs-buildtools", "happy"] +haskellTools = ["alex", "cabal-install", "gtk2hs-buildtools", "happy", "hspec-discover"] haskellSrcPkgs :: FilePath -> Dist -> [Package] -> IO [Package] haskellSrcPkgs topdir dist brs = do ghcLibs <- do let branch = distBranch dist - ghcDir <- pkgDir "ghc" branch topdir - filter isHaskellDevelPkg <$> rpmspec [] (Just "%{name}") (ghcDir "ghc.spec") - let hdeps = filter (\ dp -> "ghc-" `isPrefixOf` dp || dp `elem` haskellTools) (brs \\ (["ghc-rpm-macros", "ghc-rpm-macros-extra"] ++ ghcLibs)) - nub <$> mapM (derefSrcPkg topdir dist False) hdeps + ghcDir <- pkgDir "ghc" branch (topdir "..") + map removeLibSuffix . filter isHaskellDevelPkg <$> rpmspec [] (Just "%{name}") (ghcDir "ghc.spec") + let hdeps = filter (\ dp -> "ghc-" `isPrefixOf` dp || dp `elem` haskellTools) (map removeLibSuffix brs \\ (["ghc-rpm-macros", "ghc-rpm-macros-extra"] ++ ghcLibs)) + nub <$> mapM (derefSrcPkgRelax topdir dist) hdeps pkgDir :: String -> String -> FilePath -> IO FilePath pkgDir dir branch top = do diff --git a/src/Utils.hs b/src/Utils.hs --- a/src/Utils.hs +++ b/src/Utils.hs @@ -14,18 +14,21 @@ -- (at your option) any later version. module Utils (checkPkgsGit, + setTermTitle, withCurrentDirectory) where +import Control.Monad (when) #if (defined(MIN_VERSION_directory) && MIN_VERSION_directory(1,2,3)) import System.Directory (withCurrentDirectory) #else import Control.Exception (bracket) import System.Directory (getCurrentDirectory, setCurrentDirectory) #endif +import System.Environment (getEnv) +import System.IO (BufferMode(..), hGetBuffering, hSetBuffering, stdout) import SimpleCmd.Git (grepGitConfig) - -- singleLine :: String -> String -- singleLine "" = "" -- singleLine s = (head . lines) s @@ -35,7 +38,7 @@ -- (ret, out, err) <- readProcessWithExitCode c as "" -- case ret of -- ExitSuccess -> return (True, out) --- ExitFailure n -> hPutStrLn stderr ("\"" ++ c +-+ unwords as ++ "\"" +-+ "failed with status" +-+ show n ++ "\n" ++ err) >> return (False, out) +-- ExitFailure n -> warning ("\"" ++ c +-+ unwords as ++ "\"" +-+ "failed with status" +-+ show n ++ "\n" ++ err) >> return (False, out) #if (defined(MIN_VERSION_directory) && MIN_VERSION_directory(1,2,3)) #else @@ -57,3 +60,12 @@ -- git_ :: String -> [String] -> IO () -- git_ c as = -- cmd_ "git" ("--no-pager":c:as) + +setTermTitle :: String -> IO () +setTermTitle ts = do + term <- getEnv "TERM" + when (term == "xterm-256color") $ do + buf <- hGetBuffering stdout + hSetBuffering stdout NoBuffering + putStr $ "\ESC]0;" ++ ts ++ "\a" + hSetBuffering stdout buf