-- | -- Module : Packages -- Copyright : (C) 2017-2019 Jens Petersen -- -- Maintainer : Jens Petersen -- 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 #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 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(..), hIsTerminalDevice, hSetBuffering, stdout) --import System.Posix.Env (getEnv) import Text.CSV (parseCSV) import FedoraDists (Dist(..), distBranch, distRepo, distUpdates, rawhide) 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, hackageRelease, ltsStream) 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 "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") <*> distArg <*> pkgArgs , Subcommand "diff-origin" "git diff origin" $ gitDiffOrigin <$> distArg <*> pkgArgs , Subcommand "diff-branch" "compare branch with master" $ 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" "packages with head in sync with origin" $ headOrigin <$> distArg <*> pkgArgs , Subcommand "leaf" "list leaf packages (slow!)" $ leaves <$> switchWith 'v' "deps" "show also deps" <*> distArg <*> 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" "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" $ 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 "subpkgs" "list subpackages" $ 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") , ("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 = flagWith' DiffShort '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" streamOpt = strOptionalWith 's' "stream" "STACKAGESTREAM" ("Stackage stream [" ++ ltsStream ++ "]") ltsStream data DiffFormat = DiffShort | DiffContext Int deriving (Eq) 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 = 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 (Output 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 return $ if null out then "" else if short then pkg else out gitDiffOrigin :: Dist -> [Package] -> IO () gitDiffOrigin dist = repoAction False (Output (const (git "diff" [distRemote dist]))) 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"] stkg <- cmdMaybe "stackage" ["package", stream, removePrefix "ghc-" p] let same = isJust stkg && (fromJust stkg ++ "-") `isInfixOf` nvr unless same $ if missingOnly then when (isNothing stkg) $ putStrLn p else 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 refreshData = 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" | refreshData] ++ 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 (Header 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 True (Header verb 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 $ putStrList 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 (Output checkForMissingDeps) dist where checkForMissingDeps :: Package -> IO String 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 unlines <$> filterM (noPkgDir top) deps else putStrLn ("no " ++ pkg ++ ".spec file found!") >> return "" where noPkgDir :: FilePath -> Package -> IO Bool noPkgDir top dep = not <$> doesDirectoryExist (top dep) oldPackages :: Dist -> [Package] -> IO () oldPackages dist pkgs = do repopkgs <- repoqueryHaskellPkgs True dist putStrList (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 False (Output (const commitChanges)) dist where commitChanges :: IO String commitChanges = do nochgs <- gitDiffQuiet [] if nochgs then return "" else cmd (rpkg dist) ["commit", "-m", logmsg] unpushed :: Bool -> Dist -> [Package] -> IO () unpushed nolog dist = repoAction True (Header False 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 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" | refreshData] ++ 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 $ 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-*"]) 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 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 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 <- haveSshKey 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 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 (showHeader action) $ putStrLn $ "\n==" +-+ pkg ++ ":" ++ branch +-+ "==" -- muser <- getEnv "USER" haveSSH <- haveSshKey fileExists <- doesFileExist 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 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 showHeader action then "" else pkg ++ ": ") ++ "No spec file!" unless (needsSpec && not hasSpec) $ 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 needsSpec (Header header (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 (Header 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 :: 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 >>= 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 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 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]