{- |
Module : Main
Description : The haskell-updater executable
Copyright : (c) Ivan Lazar Miljenovic, Stephan Friedrichs, Emil Karlson 2010
License : GPL-2 or later
The executable module of haskell-updater, which finds Haskell
packages to rebuild after a dep upgrade or a GHC upgrade.
-}
{-# LANGUAGE LambdaCase #-}
module Main (main) where
import Distribution.Gentoo.CmdLine
import Distribution.Gentoo.GHC
import Distribution.Gentoo.Packages
import Distribution.Gentoo.PkgManager
import Distribution.Gentoo.PkgManager.Types
import Distribution.Gentoo.Types
import Control.Monad (unless)
import qualified Control.Monad as CM
import qualified Data.List as L
import qualified Data.Map as M
import qualified Data.Set as Set
import Data.Version (showVersion)
import qualified Paths_haskell_updater as Paths (version)
import System.Console.GetOpt
import System.Environment (getArgs, getProgName)
import System.Exit (ExitCode (..), exitSuccess, exitWith)
import System.IO (hPutStrLn, stderr)
import System.Process (rawSystem)
import Output
main :: IO ()
main = do args <- getArgs
defPM <- defaultPM
case parseArgs defPM args of
Left err -> die err
Right a -> runAction a
runAction :: RunModifier -> IO a
runAction rm
| showHelp rm = help
| showVer rm = version
| otherwise = runDriver rm
-- set of packages to rebuild at pass number
type DriverHistory = M.Map (Set.Set Package) Int
initialHistory :: DriverHistory
initialHistory = M.empty
dumpHistory :: Verbosity -> DriverHistory -> IO ()
dumpHistory v historyMap = do
say v "Updater's past history:"
CM.forM_ historyList $ \(n, entry) ->
say v $ unwords $ ["Pass", show n, ":"] ++ map printPkg (Set.toList entry)
where historyList :: [(Int, Set.Set Package)]
historyList = L.sort [ (n, entry) | (entry, n) <- M.toList historyMap ]
runDriver :: RunModifier -> IO a
runDriver rm = do
systemInfo v rm t md
updaterPass 1 initialHistory
success v "done!"
where
v = verbosity rm
t = target rm
md = mode rm
updaterPass :: Int -> DriverHistory -> IO ()
updaterPass n pastHistory = getPackageState rm >>= \case
ListModeState m -> do
mapM_ (putStrLn . printPkg) (targets m)
success v "done!"
DefaultModeState (Just (DefaultInvalid ts)) ->
continuePass (Left . DefaultInvalid) False ts
DefaultModeState (Just (DefaultAll ts)) ->
continuePass (Left . DefaultAll) True ts
DefaultModeState Nothing -> alertDone
RAModeState (Just (RAModeInvalid ps ts)) ->
continuePass (Right . RAModeInvalid ps) False ts
RAModeState (Just (RAModeAll ts)) ->
continuePass (Right . RAModeAll) True ts
RAModeState (Just (RAModeWorld ts)) ->
continuePass (Right . RAModeWorld) True ts
RAModeState Nothing -> alertDone
where
alertDone = success (verbosity rm) "\nNothing to build!"
continuePass
:: PackageList ts
=> (ts -> Either DefaultModePkgs RAModePkgs)
-> Bool
-> ts
-> IO ()
continuePass cnst allTarget ts = do
CM.when (Set.fromList (getPkgs ts) `M.member` pastHistory) $ do
dumpHistory v pastHistory
die "Updater stuck in the loop and can't progress"
exitCode <- buildPkgs rm (cnst ts)
-- don't try rerun rebuilder for cases where there
-- is no chance to converge to empty set
CM.when allTarget $ exitWith exitCode
updaterPass (n + 1) $ M.insert (Set.fromList (getPkgs ts)) n pastHistory
getPackageState :: RunModifier -> IO PackageState
getPackageState rm =
case (mode rm, target rm, pkgmgr rm) of
-- world target
(ReinstallAtomsMode, WorldTarget, Portage) ->
RAModeState . checkForNull RAModeWorld <$> getInvalid
(_, WorldTarget, Portage) -> die
"\"world\" target is only valid with reinstall-atoms mode"
(ReinstallAtomsMode, WorldTarget, _) -> die
"\"world\" target is only valid with portage package manager"
(_, WorldTarget, _) -> die $ unwords
["\"world\" target is only valid with reinstall-atoms mode and portage"
, "package manager"]
-- list mode
(ListMode, OnlyInvalid, _) ->
ListModeState . ListInvalid <$> getInvalid
(ListMode, AllInstalled, _) ->
ListModeState . ListAll <$> getAll
-- default mode
(BasicMode, OnlyInvalid, _) ->
DefaultModeState . checkForNull DefaultInvalid <$> getInvalid
(BasicMode, AllInstalled, _) ->
DefaultModeState . checkForNull DefaultAll <$> getAll
-- reinstall-atoms mode
(ReinstallAtomsMode, OnlyInvalid, Portage) -> getInvalid >>= \is ->
RAModeState <$> if null (getPkgs is)
then pure Nothing
else Just . flip RAModeInvalid is <$> getAll
(ReinstallAtomsMode, AllInstalled, Portage) ->
RAModeState . checkForNull RAModeAll <$> getAll
(ReinstallAtomsMode, _, _) -> die
"reinstall-atoms mode is only valid with portage package manager"
where
getInvalid = do
say v "Searching for packages installed with a different version of GHC."
say v ""
old <- oldGhcPkgs v
pkgListPrintLn v "old" old
say v "Searching for Haskell libraries with broken dependencies."
say v ""
(broken, unknown_packages, unknown_files) <- brokenPkgs v
printUnknownPackagesLn (map unCPV unknown_packages)
printUnknownFilesLn unknown_files
pkgListPrintLn v "broken" (notGHC broken)
return $ InvalidPkgs $ Set.toList $ Set.fromList $ old ++ broken
getAll = do
say v "Searching for packages installed with the current version of GHC."
say v ""
pkgs <- allInstalledPackages
pkgListPrintLn v "installed" pkgs
return $ AllPkgs pkgs
checkForNull :: PackageList ts => (ts -> b) -> ts -> Maybe b
checkForNull cnst l
| null (getPkgs l) = Nothing
| otherwise = Just (cnst l)
printUnknownPackagesLn [] = return ()
printUnknownPackagesLn ps = do
say v "The following packages are orphan (not installed by your package manager):"
printList v id ps
say v ""
printUnknownFilesLn [] = return ()
printUnknownFilesLn fs = do
say v $ "The following files are orphan (not installed by your package manager):"
printList v id fs
say v $ "It is strongly advised to remove orphans:"
say v $ " One of known sources of orphans is packages installed before 01 Jan 2015."
say v $ " If you know it's your case you can easily remove such files:"
say v $ " # rm -v -- `qfile -o $(ghc --print-libdir)/package.conf.d/*.conf $(ghc --print-libdir)/gentoo/*.conf`"
say v $ " # ghc-pkg recache"
say v $ " It will likely need one more 'haskell-updater' run."
say v ""
v = verbosity rm
runCmd :: WithCmd -> String -> [String] -> IO ExitCode
runCmd m cmd args = case m of
RunOnly -> runCommand cmd args
PrintOnly -> putStrLn cmd_line >> exitSuccess
PrintAndRun -> putStrLn cmd_line >> runCommand cmd args
where
cmd_line = unwords (cmd : (showArg <$> args))
showArg s
| words s == [s] = s
| otherwise = show s -- Put quotes around args with spaces in them
runCommand :: String -> [String] -> IO ExitCode
runCommand cmd args = rawSystem cmd args
buildPkgs :: RunModifier -> Either DefaultModePkgs RAModePkgs -> IO ExitCode
buildPkgs rm ts = runCmd (withCmd rm) cmd args
where
(cmd, args) = case ts of
Left (DefaultInvalid (InvalidPkgs ps)) ->
buildCmd (pkgmgr rm) (flags rm) (rawPMArgs rm) ps
Left (DefaultAll (AllPkgs ps)) ->
buildCmd (pkgmgr rm) (flags rm) (rawPMArgs rm) ps
Right (RAModeInvalid (AllPkgs allPs) (InvalidPkgs ps)) ->
buildAltCmd (flags rm) (rawPMArgs rm) ps (Just allPs)
Right (RAModeAll (AllPkgs allPs)) ->
buildAltCmd (flags rm) (rawPMArgs rm) allPs (Just allPs)
Right (RAModeWorld (InvalidPkgs ps)) ->
buildAltCmd (flags rm) (rawPMArgs rm) ps Nothing
-- -----------------------------------------------------------------------------
-- Printing information.
help :: IO a
help = progInfo >>= success Normal
version :: IO a
version = fmap (++ '-' : showVersion Paths.version) getProgName >>= success Normal
progInfo :: IO String
progInfo = do pName <- getProgName
return $ usageInfo (header pName) options
where
header pName = unlines [ pName ++ " -- Find and rebuild packages broken due to any of:"
, " * GHC upgrade"
, " * Haskell dependency upgrade"
, ""
, "Usage: " ++ pName ++ " [Options [-- [PM options]]"
, ""
, ""
, "Options:"]
systemInfo :: Verbosity -> RunModifier -> BuildTarget -> HackportMode -> IO ()
systemInfo v rm t m = do
ver <- ghcVersion
pName <- getProgName
let pVer = showVersion Paths.version
pLoc <- ghcLoc
libDir <- ghcLibDir
say v $ "Running " ++ pName ++ "-" ++ pVer ++ " using GHC " ++ ver
say v $ " * Executable: " ++ pLoc
say v $ " * Library directory: " ++ libDir
say v $ " * Package manager (PM): " ++ nameOfPM (pkgmgr rm)
unless (null (rawPMArgs rm)) $
say v $ " * PM auxiliary arguments: " ++ unwords (rawPMArgs rm)
say v $ " * Target: " ++ show t
say v $ " * Mode: " ++ show m
say v ""
-- -----------------------------------------------------------------------------
-- Utility functions
success :: Verbosity -> String -> IO a
success v msg = do say v msg
exitSuccess
die :: String -> IO a
die msg = do putErrLn ("ERROR: " ++ msg)
exitWith (ExitFailure 1)
putErrLn :: String -> IO ()
putErrLn = hPutStrLn stderr