-- |
-- Module : Packages
-- Copyright : (C) 2017-2019 Jens Petersen
--
-- Maintainer : Jens Petersen <petersen@fedoraproject.org>
-- Stability : alpha
--
-- Explanation: Cloning and pulling package git repos
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
module Main where
import Control.Applicative (optional, some, (<|>)
#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,8,0))
#else
, pure, (<$>), (<*>)
#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))
listDirectory,
#else
getDirectoryContents,
#endif
setCurrentDirectory)
import System.FilePath ((</>), (<.>), takeFileName)
import System.IO (BufferMode(..), hSetBuffering, stdout)
--import System.Posix.Env (getEnv)
import Text.CSV (parseCSV)
import FedoraDists (Dist(..), distBranch, distRepo, distUpdates,
hackageRelease, rawhide)
import SimpleCmd ((+-+), cmd, cmd_, cmdBool, cmdLines, cmdMaybe, cmdSilent,
grep_, removePrefix, shell_)
import SimpleCmd.Git (git, git_, gitBranch, isGitDir)
import SimpleCmdArgs
import Build (build, readBuildCmd)
import Dist (distArg, distRemote)
import Koji (kojiListPkgs, rpkg)
import Paths_fedora_haskell_tools (version)
import RPM (buildRequires, haskellSrcPkgs, Package, pkgDir,
repoquery, rpmspec)
import Utils (checkPkgsGit, withCurrentDirectory)
#if (defined(MIN_VERSION_directory) && MIN_VERSION_directory(1,2,5))
#else
listDirectory :: FilePath -> IO [FilePath]
listDirectory path =
filter f <$> getDirectoryContents path
where f filename = filename /= "." && filename /= ".."
#endif
main :: IO ()
main = do
hSetBuffering stdout LineBuffering
cwd <- getCurrentDirectory
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" $
repoAction_ True False (return ()) <$> distArg <*> pkgArgs
, Subcommand "clone" "clone repos" $
clone <$> branching <*> distArg <*> pkgArgs
, Subcommand "clone-new" "clone new packages" $
cloneNew <$> branching <*> distArg
, 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 "diff" "git diff" $
gitDiff <$> optional gitFormat
<*> optional (strOptionWith 'w' "with-branch" "BRANCH" "Branch to compare")
<*> distArg <*> pkgArgs
, 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
, 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" $
headOrigin <$> distArg <*> pkgArgs
, Subcommand "leaf" "list leaf packages" $
leaves <$> switchWith 'v' "deps" "show also deps" <*> distArg <*> pkgArgs
, Subcommand "list" "list packages" $ mapM_ putStrLn <$> pkgArgs
, 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 "old-packages" "packages not in repoquery" $
oldPackages <$> distArg <*> pkgArgs
, Subcommand "prep" "fedpkg prep" $
prep <$> distArg <*> pkgArgs
, Subcommand "commit" "fedpkg commit" $
commit <$> strOptionWith 'm' "message" "COMMITMSG" "commit message" <*> 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
, 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
, Subcommand "tagged" "list koji DIST tagged builds" $
listTagged_ <$> switchWith 's' "short" "list packages not builds" <*> strArg "TAG"
, Subcommand "verrel" "show nvr of packages" $
verrel <$> distArg <*> pkgArgs] ++
map (buildCmd cwd) [ ("install", "build locally and install")
, ("mock", "build in mock")
, ("chain", "build deps recursively in Koji")
, ("koji", "build in Koji (deprecated)")
, ("pending", "show planned changes")
, ("changed", "show changed pkgs")
, ("built", "show pkgs whose NVR already built")
, ("bump", "bump release for NVRs already built")
, ("not-installed", "list packages not locally installed")
]
where
pkgArgs = some (strArg "PKG...")
branching = switchWith 'B' "branches" "clone branch dirs (fedpkg clone -B)"
gitFormat :: Parser DiffFormat
gitFormat =
flag' DiffShort (switchMods 's' "short" "Just output package name") <|>
DiffContext <$> optionWith auto 'u' "unified" "CONTEXT" "Lines of context"
buildCmd cwd (c, desc) =
Subcommand c desc $
build cwd Nothing Nothing False (readBuildCmd c) <$> distArg <*> pkgArgs
switchRefresh = switchWith 'r' "refresh" "repoquery --refresh"
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"]
clone :: Bool -> Dist -> [Package] -> IO ()
clone True dist pkgs = cloneAllBranches dist pkgs
clone False dist pkgs =
repoAction_ True False (return ()) dist pkgs
cloneNew :: Bool -> Dist -> IO ()
cloneNew True dist =
newPackages rawhide >>= cloneAllBranches dist
cloneNew False dist =
newPackages dist >>= repoAction_ True False (return ()) dist
execCmd :: String -> Dist -> [Package] -> IO ()
execCmd "" _ _ = error "CMD string must be given"
execCmd cs dist pkgs =
repoAction_ True True (shell_ cs) dist pkgs
gitDiff :: Maybe DiffFormat -> Maybe String -> Dist -> [Package] -> IO ()
gitDiff fmt mbrnch =
repoAction False False doGitDiff
where
doGitDiff pkg = do
let branch = maybeToList mbrnch
contxt = case fmt of
(Just (DiffContext n)) -> ["-u", show n]
_ -> []
short = fmt == Just DiffShort
out <- git "diff" $ branch ++ contxt
unless (null out) $ do
putStrLn $ if short then pkg else "==" +-+ pkg +-+ "=="
unless short $ putStrLn out
gitDiffOrigin :: Dist -> [Package] -> IO ()
gitDiffOrigin dist =
repoAction_ True False (git_ "diff" [distRemote dist]) dist
diffStackage :: Bool -> Dist -> [Package] -> IO ()
diffStackage missingOnly dist =
repoAction False True 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
else
putStrLn $ (if same then "same" else fromMaybe "none" stkg) +-+ "(" ++ stream ++ ")"
hackageCompare :: Bool -> IO ()
hackageCompare refresh =
repoqueryHackages hackageRelease >>=
compareHackage hackageRelease
where
compareHackage :: Dist -> [Package] -> IO ()
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') >>=
compareSets True hackage
mungeHackage :: [String] -> PkgVer
mungeHackage [n,v,_] = PV n v
mungeHackage _ = error "Malformed Hackage csv"
mungeRepo :: String -> PkgVer
mungeRepo s | ',' `elem` s =
let (p,v) = break (== ',') s in
PV (removePrefix "ghc-" p) (tail v)
| otherwise = error "Malformed repoquery output"
compareSets :: Bool -> [PkgVer] -> [PkgVer] -> IO ()
compareSets _ [] [] = return ()
compareSets _ [] (f:fs) = do
putStrLn ("New:" +-+ show f)
compareSets False [] fs
compareSets all' (h:hs) [] = do
when all' $ putStrLn ("Removed:" +-+ show h)
compareSets all' hs []
compareSets all' (h:hs) (f:fs) | h == f = compareSets all' hs fs
| h < f = do
when all' $ putStrLn $ "Removed:" +-+ show h
compareSets all' hs (f:fs)
| h > f = do
putStrLn $ "New:" +-+ show f
compareSets all' (h:hs) fs
| otherwise = do
putStrLn $ pvPkg h ++ ":" +-+ pvVer h +-+ "->" +-+ pvVer f
compareSets all' hs fs
headOrigin :: Dist -> [Package] -> IO ()
headOrigin dist =
repoAction False False gitHeadAtOrigin dist
where
gitHeadAtOrigin :: Package -> IO ()
gitHeadAtOrigin pkg = do
-- use gitDiffQuiet
same <- cmdBool "git" ["diff", "--quiet", distRemote dist ++ "..HEAD"]
when same $ putStrLn pkg
leaves :: Bool -> Dist -> [Package] -> IO ()
leaves verb =
repoAction verb True checkLeafPkg
where
-- FIXME: make a dependency cache
checkLeafPkg :: Package -> IO ()
checkLeafPkg pkg = do
dir <- takeFileName <$> getCurrentDirectory
let branchdir = dir /= pkg
top = if branchdir then "../.." else ".."
spec = pkg <.> "spec"
subpkgs <- rpmspec ["--builtrpms"] (Just "%{name}") spec
allpkgs <- listDirectory top
let other = map (\ p -> top </> p </> (if branchdir then dir else "") </> p <.> "spec") $ allpkgs \\ [pkg]
found <- filterM (dependsOn subpkgs) other
if null found
then putStrLn pkg
else when verb $ mapM_ putStrLn found
where
dependsOn :: [Package] -> Package -> IO Bool
dependsOn subpkgs p = do
file <- doesFileExist p
if file
then do
deps <- buildRequires p
return $ any (`elem` deps) subpkgs
else return False
merge :: String -> Dist -> [Package] -> IO ()
merge branch =
repoAction_ True False (git_ "merge" [branch])
missingDeps :: Dist -> [Package] -> IO ()
missingDeps dist =
repoAction True True checkForMissingDeps dist
where
checkForMissingDeps :: Package -> IO ()
checkForMissingDeps pkg = do
dir <- takeFileName <$> getCurrentDirectory
let top = if dir == pkg then ".." else "../.."
spec = pkg <.> "spec"
hasSpec <- doesFileExist spec
if hasSpec
then do
deps <- buildRequires (pkg <.> "spec") >>= haskellSrcPkgs top dist
mapM_ (checkMissing top) deps
else putStrLn "no spec file found!"
where
checkMissing :: FilePath -> Package -> IO ()
checkMissing top dep = do
exists <- doesDirectoryExist $ top </> dep
unless exists $ putStrLn $ "Missing" +-+ dep
oldPackages :: Dist -> [Package] -> IO ()
oldPackages dist pkgs = do
repopkgs <- repoqueryHaskellPkgs True dist
mapM_ putStrLn (pkgs \\ repopkgs)
prep :: Dist -> [Package] -> IO ()
prep dist =
repoAction_ True True (cmd_ (rpkg dist) ["prep"]) dist
commit :: String -> Dist -> [Package] -> IO ()
commit logmsg dist =
repoAction_ True True commitChanges dist
where
commitChanges :: IO ()
commitChanges = do
-- use gitDiffQuiet
nochgs <- cmdBool "git" ["diff", "--quiet"]
if nochgs
then putStrLn "no changes"
else cmd_ (rpkg dist) ["commit", "-m", logmsg]
unpushed :: Bool -> Dist -> [Package] -> IO ()
unpushed nolog dist =
repoAction False True gitLogOneLine dist
where
gitLogOneLine :: Package -> IO ()
gitLogOneLine pkg = do
out <- git "log" [distRemote dist ++ "..HEAD", "--pretty=oneline"]
unless (null out) $
putStrLn $ pkg ++ if nolog then "" else (unwords . map replaceHash . words) out
where
replaceHash h = if length h /= 40 then h else ":"
verrel :: Dist -> [Package] -> IO ()
verrel dist =
repoAction_ False True (cmd_ (rpkg dist) ["verrel"]) dist
repoqueryHackageCSV :: Dist -> Bool -> IO ()
repoqueryHackageCSV dist refresh = 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
data PkgVer = PV { pvPkg :: String, pvVer :: String}
deriving (Eq)
instance Show PkgVer
where
show (PV p v) = p ++ "-" ++ v
instance Ord PkgVer
where
compare (PV p _) (PV p' _) = compare p p'
replace :: Eq a => [a] -> [a] -> [a] -> [a]
replace a b s@(x:xs) =
if a `isPrefixOf` s
then b ++ replace a b (drop (length a) s)
else x:replace a b xs
replace _ _ [] = []
repoqueryHaskellPkgs :: Bool -> Dist -> IO [Package]
repoqueryHaskellPkgs verbose dist = do
when verbose $ putStrLn "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"])
when (null bin) $ error "No packages using ghc-Cabal-devel found!"
return $ sort $ nub bin
repoqueryHackages :: Dist -> IO [Package]
repoqueryHackages dist = do
srcs <- repoqueryHaskellPkgs False dist
libs <- repoqueryHaskellLibs False
let binsrcs = filter (not . ("ghc-" `isPrefixOf`)) srcs
sublibs = libs \\ map ("ghc-" ++) binsrcs
return $ sort $ nub (srcs ++ sublibs)
where
repoqueryHaskellLibs :: Bool -> IO [Package]
repoqueryHaskellLibs verbose = do
when verbose $ putStrLn "Getting libraries from repoquery"
let repo = distRepo dist
updates = maybeToList $ distUpdates dist
bin <- words <$> repoquery dist (["--repo=" ++ repo] ++ ["--repo=" ++ u | u <- updates] ++ ["--qf=%{name}", "--whatprovides", "libHS*-ghc*.so()(64bit)"])
when (null bin) $ error "No libHS*.so providers found!"
return $ sort $ nub bin
newPackages :: Dist -> IO [Package]
newPackages dist = do
ps <- repoqueryHaskellPkgs True dist
kps <- kojiListHaskell True dist
return $ kps \\ 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
when (null libs) $ error "No library packages found"
return $ sort $ nub libs
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"
dirExists <- doesDirectoryExist pkg
unless dirExists $
cmd_ (rpkg dist) $ ["clone"] ++ ["-a" | not haveSSH] ++ ["-B", pkg]
singleDir <- isGitDir pkg
when singleDir $
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
withCurrentDirectory "." $ do
let branch = distBranch dist
when header $
putStrLn $ "\n==" +-+ pkg ++ ":" ++ branch +-+ "=="
-- muser <- getEnv "USER"
haveSSH <- do
home <- getHomeDirectory
doesFileExist $ home </> ".ssh/id_rsa"
fileExists <- doesFileExist pkg
dirExists <- doesDirectoryExist pkg
if fileExists
then error $ pkg +-+ "is a file"
else do
unless dirExists $
cmd_ (rpkg dist) $ ["clone"] ++ ["-a" | not haveSSH] ++ ["-b", branch, pkg]
singleDir <- isGitDir pkg
unless singleDir $ do
branchDir <- doesDirectoryExist $ pkg </> branch
unless branchDir $
withCurrentDirectory pkg $
cmd_ (rpkg dist) ["clone", "-b", branch, pkg, branch]
wd <- pkgDir pkg branch ""
setCurrentDirectory wd
pkggit <- do
gd <- isGitDir "."
if gd
then checkPkgsGit
else return False
unless pkggit $
error $ "not a Fedora pkg git dir!:" +-+ wd
when dirExists $ do
actual <- gitBranch
when (branch /= actual) $
cmd_ (rpkg dist) ["switch-branch", branch]
isDead <- doesFileExist "dead.package"
unless isDead $ do
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 (needsSpec && not hasSpec) $
action pkg
repoAction header needsSpec action dist rest
repoAction_ :: Bool -> Bool -> IO () -> Dist -> [Package] -> IO ()
repoAction_ header needsSpec action =
repoAction header needsSpec (const action)
compareRawhide :: Package -> IO ()
compareRawhide p = do
let spec = p <.> "spec"
nvr <- removeDisttag . unwords <$> rpmspec ["--srpm"] (Just "%{name}-%{version}-%{release}") spec
nvr' <- withCurrentDirectory "../master" $ do
haveSpec <- doesFileExist spec
unless haveSpec $ cmdSilent "git" ["pull"]
removeDisttag . unwords <$> rpmspec ["--srpm"] (Just "%{name}-%{version}-%{release}") spec
if nvr == nvr'
then putStrLn nvr
else do
putStrLn nvr
putStrLn nvr'
putStrLn ""
where
removeDisttag = reverse . tail . dropWhile (/= '.') . reverse
isFromHackage :: Package -> IO Bool
isFromHackage pkg =
grep_ "hackage.haskell.org/package/" $ pkg <.> "spec"
update :: String -> Dist -> [Package] -> IO ()
update stream =
repoAction True True doUpdate
where
doUpdate :: Package -> IO ()
doUpdate pkg = do
hckg <- isFromHackage pkg
if hckg
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"
listTagged_ :: Bool -> String -> IO ()
listTagged_ short tag =
listTagged short tag >>= mapM_ putStrLn
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
remaining :: Bool -> String -> [Package] -> IO ()
remaining count tag pkgs = do
built <- listTagged True tag
let left = pkgs \\ built
if count
then print $ length left
else cmd_ "rpmbuild-order" $ ["sort", "-p"] ++ left