-- |
-- 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', option, switch, strOption)
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 Koji (kojiListPkgs, rpkg)
import Options (distArg)
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 <$> strOption (optionMods '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 <$> strOption (optionMods 'c' "cmd" "CMD" "command to execute") <*> distArg <*> pkgArgs
, Subcommand "count" "count number of packages" $
(repoqueryHaskell False >=> (print . length)) <$> distArg
, Subcommand "diff" "git diff" $
gitDiff <$> optional gitFormat
<*> optional (strOption (optionMods '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 <$> switch (switchMods 'm' "missing" "only list missing packages") <*> distArg <*> pkgArgs
, Subcommand "hackage" "generate Hackage distro data" $
pure $ repoqueryHackageCSV hackageRelease
, Subcommand "hackage-compare" "compare with Hackage distro data" $
pure hackageCompare
, Subcommand "head-origin" "head in sync with origin" $
headOrigin <$> distArg <*> pkgArgs
, Subcommand "leaf" "list leaf packages" $
leaves <$> switch (switchMods 'v' "deps" "show also deps") <*> distArg <*> pkgArgs
, Subcommand "list" "list packages" $ mapM_ putStrLn <$> pkgArgs
, Subcommand "merge" "git merge" $
merge <$> strOption (optionMods '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 <$> strOption (optionMods '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 refresh <$> distArg <*> pkgArgs
, Subcommand "remaining" "remaining packages to be built in TAG" $
remaining <$> strArg "TAG" <*> pkgArgs
, Subcommand "unpushed" "show unpushed commits" $
unpushed <$> switch (switchMods 's' "short" "no log") <*> distArg <*> pkgArgs
, Subcommand "update" "cabal-rpm update" $
update <$> strOption (optionMods '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_ <$> switch (switchMods '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 = switch (switchMods 'B' "branches" "clone branch dirs (fedpkg clone -B)")
gitFormat :: Parser DiffFormat
gitFormat =
flag' DiffShort (switchMods 's' "short" "Just output package name") <|>
DiffContext <$> option auto (optionMods 'u' "unified" "CONTEXT" "Lines of context")
buildCmd cwd (c, desc) =
Subcommand c desc $
build cwd Nothing Nothing False (readBuildCmd c) <$> distArg <*> pkgArgs
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" ["origin/" ++ show 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 :: IO ()
hackageCompare =
repoqueryHaskell False 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
fedora <- sort . map mungeRepo . lines <$> repoquery dist (["--repo=fedora", "--repo=updates", "--latest-limit=1", "--qf=%{name},%{version}"] ++ pkgs')
compareSets True hackage fedora
mungeHackage :: [String] -> PkgVer
mungeHackage [_,v,u] = PV (takeFileName u) v
mungeHackage _ = error "Malformed Hackage csv"
mungeRepo :: String -> PkgVer
mungeRepo s | ',' `elem` s =
let (p,v) = break (== ',') s in
PV 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", "origin/" ++ show 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 <- repoqueryHaskell 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" ["origin/" ++ show 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 -> IO ()
repoqueryHackageCSV dist = do
pkgs <- repoqueryHaskell False 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://src.fedoraproject.org/rpms/%{name}\""] ++ 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 _ _ [] = []
repoqueryHaskell :: Bool -> Dist -> IO [Package]
repoqueryHaskell verbose dist = do
when verbose $ putStrLn "Getting packages from repoquery"
let repo = distRepo dist
updates = maybeToList $ distUpdates dist
bin <- words <$> repoquery dist (["--repo=" ++ repo] ++ ["--repo=" ++ u | u <- updates] ++ ["--qf=%{source_name}", "--whatrequires", "libHSbase-*-ghc*.so()(64bit)"])
when (null bin) $ error "No libHSbase consumers found!"
return $ sort $ nub bin
newPackages :: Dist -> IO [Package]
newPackages dist = do
ps <- repoqueryHaskell 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"
refresh :: Package -> IO ()
refresh 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 :: String -> [Package] -> IO ()
remaining tag pkgs = do
built <- listTagged True tag
cmd_ "rpmbuild-order" $ ["sort", "-p"] ++ (pkgs \\ built)