diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,22 @@ +## v1.4.0.0 (2024-05-25) + +Release v1.4.0.0 + +- Add new options for portage invocation + + - Add `--mode=reinstall-atoms` (`-R`) + - Add `--world` (`-W`) + + This adds new functionality to haskell-updater which utilizes the + --reinstall-atoms flag for portage. This should bypass issues where + haskell-updater pulls in masked or unavailable packages and attempts to + pull them into the dependency graph. This will remain as optional pending + further testing. + +- Add new flags to the command line to help organize functionality: + + - `--target={invalid|all|world}` + - `--mode={basic|list|reinstall-atoms}` + +- Fix bug where some installed package `.conf` files do not get parsed + properly diff --git a/Distribution/Gentoo/CmdLine.hs b/Distribution/Gentoo/CmdLine.hs new file mode 100644 --- /dev/null +++ b/Distribution/Gentoo/CmdLine.hs @@ -0,0 +1,238 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Distribution.Gentoo.CmdLine + ( parseArgs + , options + ) where + +import Control.Monad ((>=>)) +import Data.Char (toLower) +import qualified Data.List as L +import Data.Proxy +import System.Console.GetOpt + +import Distribution.Gentoo.PkgManager +import Distribution.Gentoo.PkgManager.Types +import Distribution.Gentoo.Types +import Output + +-- ----------------------------------------------------------------------------- +-- Command-line flags + +-- | A class for multiple-choice options selected by an argument on the command +-- line +class (Eq a, Enum a, Bounded a) => CmdlineOpt a where + -- | Define the short name and an optional description for a constructor + argInfo :: a -> (String, Maybe String) + -- | Define the short name for the multiple-choice argument as a whole + -- + -- e.g. @"action"@ + optName :: Proxy a -> String + -- | Define the description for the multiple-choice argument as a whole + -- + -- e.g. @"Specify whether to run the PM command or just print it"@ + optDescription :: Proxy a -> String + -- | Define the default constructor for the multiple-choice argument + -- + -- e.g. 'PrintAndRun' + optDefault :: Proxy a -> a + +instance CmdlineOpt WithCmd where + argInfo PrintAndRun = ("print-and-run", Nothing) + argInfo PrintOnly = ("print", Nothing) + argInfo RunOnly = ("run", Nothing) + + optName _ = "action" + optDescription _ = + "Specify whether to run the PM command or just print it" + optDefault _ = PrintAndRun + +instance CmdlineOpt BuildTarget where + argInfo OnlyInvalid = ("invalid", Just "broken Haskell packages") + argInfo AllInstalled = ("all", Just "all installed Haskell packages") + argInfo WorldTarget = + ( "world" + , Just $ "@world set (only valid with portage package\n" + ++ "manager and reinstall-atoms mode)" + ) + + optName _ = "target" + optDescription _ = + "Choose the type of packages for the PM to target" + optDefault _ = OnlyInvalid + +instance CmdlineOpt HackportMode where + argInfo BasicMode = ("basic", Just "classic haskell-updater behavior") + argInfo ListMode = + ( "list" + , Just $ "just print a list of packages for rebuild,\n" + ++ "one package per line" + ) + argInfo ReinstallAtomsMode = + ( "reinstall-atoms" + , Just $ "experimental portage invocation using\n" + ++ "--reinstall-atoms (may be more useful in\n" + ++ "some situations)" ) + + optName _ = "mode" + optDescription _ = + "Mode of operation for haskell-updater" + optDefault _ = BasicMode + +argString :: CmdlineOpt a => a -> String +argString = fst . argInfo + +argDescription :: CmdlineOpt a => a -> Maybe String +argDescription = snd . argInfo + +argHelp :: forall a. CmdlineOpt a => Proxy a -> String +argHelp _ = unlines $ [mainDesc] ++ (args >>= argLine) + where + mainDesc = optDescription (Proxy @a) + argLine a = case (L.lookup a argFields, argDescription a) of + (Nothing, _) -> [] + (Just s, Nothing) -> [s] + (Just s, Just d) -> case lines d of + (l:ls) -> [paddedFst s l] ++ (paddedRest <$> ls) + _ -> [] + paddedFst s d = + s ++ replicate (padMax - length s) ' ' ++ " : " ++ d + paddedRest d = replicate (padMax + 3) ' ' ++ d + padMax = maximum $ length . snd <$> argFields + argFields = (\a -> (a, showArg a)) <$> args + showArg a = " * " ++ argString a ++ showDef a + showDef a + | optDefault (Proxy @a) == a = " (default)" + | otherwise = "" + args = [minBound :: a .. maxBound] + +fromCmdline + :: forall a. CmdlineOpt a + => (a -> RunModifier -> RunModifier) + -> String + -> RunModifier + -> Either String RunModifier +fromCmdline update s rm = + case L.find (\a -> argString a == lowerS) args of + Nothing -> Left $ "Unknown " ++ name ++ ": " ++ lowerS + Just a -> Right $ update a rm + where + lowerS = map toLower s + name = optName $ Proxy @a + args = [minBound :: a .. maxBound] + +parseArgs :: PkgManager -> [String] -> Either String RunModifier +parseArgs defPM args = case getOpt' Permute options args of + (_, _, _, errs@(_:_)) -> Left $ unwords $ "Errors in arguments:" : errs + (_, _, unk@(_:_), _) -> Left $ unwords $ "Unknown options:" : unk + (fs, raw, _, _) -> + postProcessRM <$> foldr (>=>) pure fs (defRunModifier defPM raw) + +defRunModifier :: PkgManager -> [String] -> RunModifier +defRunModifier defPM raw = RM + { pkgmgr = defPM + , flags = [] + , withCmd = optDefault $ Proxy @WithCmd + , rawPMArgs = raw + , verbosity = Normal + , showHelp = False + , showVer = False + , target = OnlyInvalid + , mode = BasicMode + } + +-- | Make sure there is at least one of 'UpdateAsNeeded' or 'UpdateDeep' +-- in 'flags'. +postProcessRM :: RunModifier -> RunModifier +postProcessRM rm = rm { flags = flags' } + where + flags' + | or $ [(==UpdateAsNeeded), (==UpdateDeep)] <*> nubFlags = nubFlags + | otherwise = UpdateDeep : nubFlags + nubFlags = L.nub (flags rm) + +options :: [OptDescr (RunModifier -> Either String RunModifier)] +options = + [ Option ['P'] ["package-manager"] + (ReqArg mkPM "PM") + $ "Use package manager PM, where PM can be one of:\n" + ++ pmList ++ defPM + , Option ['C'] ["custom-pm"] + (ReqArg (\s r -> pure $ r { pkgmgr = CustomPM s }) "command") + $ "Use custom command as package manager;\n" + ++ "ignores the --pretend and --no-deep flags." + , Option ['p'] ["pretend"] + (naUpdate $ \r -> r { flags = PretendBuild : flags r } ) + "Only pretend to build packages." + , Option [] ["no-deep"] + (naUpdate $ \r -> r { flags = UpdateAsNeeded : flags r } ) + "Don't pull deep dependencies (--deep with emerge)." + , Option ['V'] ["version"] + (naUpdate $ \r -> r { showVer = True }) + "Version information." + , Option [] ["action"] + (ReqArg (fromCmdline (\a r -> r { withCmd = a })) "action") + (argHelp (Proxy @WithCmd)) + , Option [] ["target"] + (ReqArg (fromCmdline (\a r -> r { target = a })) "target") + (argHelp (Proxy @BuildTarget)) + , Option ['c'] ["dep-check"] + (naUpdate $ \r -> r { target = OnlyInvalid }) + $ "alias for --target=" ++ argString OnlyInvalid + -- deprecated alias for 'dep-check' + , Option ['u'] ["upgrade"] + (naUpdate $ \r -> r { target = OnlyInvalid }) + $ "alias for --target=" ++ argString OnlyInvalid + , Option ['a'] ["all"] + (naUpdate $ \r -> r { target = AllInstalled }) + $ "alias for --target=" ++ argString AllInstalled + , Option ['W'] ["world"] + (naUpdate $ \r -> r + { pkgmgr = Portage + , target = WorldTarget + , mode = ReinstallAtomsMode + } + ) $ "alias for --package-manager=portage" + ++ " \\\n --target=" ++ argString WorldTarget + ++ " \\\n --mode=" ++ argString ReinstallAtomsMode + , Option [] ["mode"] + (ReqArg (fromCmdline (\a r -> r { mode = a })) "mode") + (argHelp (Proxy @HackportMode)) + , Option ['l'] ["list-only"] + (naUpdate $ \r -> r { mode = ListMode }) + $ "alias for --mode=" ++ argString ListMode + , Option ['R'] ["reinstall-atoms"] + (naUpdate $ \r -> r { mode = ReinstallAtomsMode }) + $ "alias for --mode=" ++ argString ReinstallAtomsMode + , Option ['q'] ["quiet"] + (naUpdate $ \r -> r { verbosity = Quiet }) + "Print only fatal errors (to stderr)." + , Option ['v'] ["verbose"] + (naUpdate $ \r -> r { verbosity = Verbose }) + "Be more elaborate (to stderr)." + , Option ['h', '?'] ["help"] + (naUpdate $ \r -> r { showHelp = True }) + "Print this help message." + ] + + where + naUpdate f = NoArg (pure . f) + + -- This touches some legacy code so we need a custom handler for it + mkPM :: String -> RunModifier -> Either String RunModifier + mkPM s rm = case choosePM s of + InvalidPM pm -> Left $ "Unknown package manager: " ++ pm + Portage -> Right $ rm { pkgmgr = Portage } + Paludis -> Right $ rm { pkgmgr = Paludis } + PkgCore -> Right $ rm { pkgmgr = PkgCore } + CustomPM _ -> undefined + + pmList = unlines . map (" * " ++) $ definedPMs + defPM = "The last valid value of PM specified is chosen.\n\ + \The default package manager is: " ++ defaultPMName ++ ",\n\ + \which can be overriden with the \"PACKAGE_MANAGER\"\n\ + \environment variable." + + + diff --git a/Distribution/Gentoo/GHC.hs b/Distribution/Gentoo/GHC.hs --- a/Distribution/Gentoo/GHC.hs +++ b/Distribution/Gentoo/GHC.hs @@ -24,16 +24,18 @@ -- Cabal imports import qualified Distribution.Simple.Utils as DSU import Distribution.Verbosity(silent) -import Distribution.Package(packageId) -import Distribution.InstalledPackageInfo(InstalledPackageInfo) +import Distribution.Package(mungedId) +import Distribution.InstalledPackageInfo + (InstalledPackageInfo(sourceLibName), parseInstalledPackageInfo) import Distribution.Text(display) +import Distribution.Types.LibraryName (LibraryName(..)) -- Other imports import Data.Char(isDigit) import Data.Either(partitionEithers) import Data.Maybe import qualified Data.List as L -import qualified Data.Map as Map +import qualified Data.Map.Strict as Map import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as BL8 import System.FilePath((), takeExtension, pathSeparator) @@ -109,20 +111,15 @@ ghcPkgLoc :: IO FilePath ghcPkgLoc = fromJust <$> findExecutable "ghc-pkg" -data ConfSubdir = GHCConfs - | GentooConfs - -subdirToDirname :: ConfSubdir -> FilePath -subdirToDirname subdir = - case subdir of - GHCConfs -> "package.conf.d" - GentooConfs -> "gentoo" +ghcConfsPath, gentooConfsPath :: FilePath +ghcConfsPath = "package.conf.d" +gentooConfsPath = "gentoo" -- Return the Gentoo .conf files found in this GHC libdir -listConfFiles :: ConfSubdir -> IO [FilePath] +listConfFiles :: FilePath -> IO [FilePath] listConfFiles subdir = do dir <- ghcLibDir - let gDir = dir subdirToDirname subdir + let gDir = dir subdir exists <- doesDirectoryExist gDir if exists then do conts <- listDirectory gDir @@ -132,23 +129,12 @@ where isConf file = takeExtension file == ".conf" -tryMaybe :: (a -> Maybe b) -> a -> Either a b -tryMaybe f a = maybe (Left a) Right $ f a - newtype CabalPV = CPV { unCPV :: String } -- serialized 'PackageIdentifier' deriving (Ord, Eq, Show) -- Unique (normal) or multiple (broken) mapping type ConfMap = Map.Map CabalPV [FilePath] -pushConf :: ConfMap -> CabalPV -> FilePath -> ConfMap -pushConf m k v = Map.insertWith (++) k [v] m - --- Attempt to match the provided broken package to one of the --- installed packages. -matchConf :: ConfMap -> CabalPV -> Either CabalPV [FilePath] -matchConf = tryMaybe . flip Map.lookup - -- Fold Gentoo .conf files from the current GHC version and -- create a Map foldConf :: Verbosity -> [FilePath] -> IO ConfMap @@ -156,16 +142,11 @@ -- cabal package text format -- "[InstalledPackageInfo {installedPackageId = Insta..." -parse_as_cabal_package :: String -> Maybe CabalPV +parse_as_cabal_package :: BS.ByteString -> Maybe InstalledPackageInfo parse_as_cabal_package cont = - case reads cont of - [] -> Nothing - -- ebuilds that have CABAL_CORE_LIB_GHC_PV set - -- for this version of GHC will have a .conf - -- file containing just [] - (([] ,_):_) -> Nothing - ((i:_,_):_) -> Just $ CPV $ display - $ packageId (i :: InstalledPackageInfo) + case parseInstalledPackageInfo cont of + Left _es -> Nothing + Right (_ws, ipi) -> Just ipi -- ghc package text format -- "name: zlib-conduit\n @@ -179,29 +160,49 @@ -> Just $ CPV $ BS.unpack bn ++ "-" ++ BS.unpack bv _ -> Nothing --- Add this .conf file to the Map +-- | Add this .conf file to the Map +-- +-- NOTE: It is important that the 'CabalPV's that are added to the 'ConfMap' +-- should be in their "munged form", which may be z-encoded +-- +-- See: +-- * +-- * addConf :: Verbosity -> ConfMap -> FilePath -> IO ConfMap addConf v cmp conf = do - cont <- BS.readFile conf - case ( parse_as_ghc_package cont - , parse_as_cabal_package (BS.unpack cont) - ) of - (Just dn, _) -> do vsay v $ unwords [conf, "resolved as ghc package:", show dn] - return $ pushConf cmp dn conf - (_, Just dn) -> do vsay v $ unwords [conf, "resolved as cabal package:", show dn] - return $ pushConf cmp dn conf - -- empty files are created for - -- phony packages like CABAL_CORE_LIB_GHC_PV - -- and binary-only packages. - _ | BS.null cont - -> return cmp - _ -> do say v $ unwords [ "failed to parse" - , show conf - , ":" - , show (BS.take 30 cont) - ] - return cmp + bs <- BS.readFile conf + case + ( BS.null bs + , parse_as_ghc_package bs + , parse_as_cabal_package bs + ) of + -- empty files are created for + -- phony packages like CABAL_CORE_LIB_GHC_PV + -- and binary-only packages. + (True, _ , _ ) -> pure cmp + -- 'parse_as_ghc_package' is more efficient, so try it first + (_ , Just dn, _ ) -> do + vsay v $ unwords [conf, "resolved as ghc package:", show dn] + pure $ pushConf cmp dn conf + -- 'parse_as_cabal_package' is more flexible, so use it as a fallback + (_ , _ , Just ipi) -> do + let cpv = toCPV ipi + vsay v $ unwords [conf, "resolved as cabal package:", show (cpv, ipi)] + pure $ pushConf cmp cpv conf + _ -> do + say v $ unwords + [ "failed to parse", show conf, ":", show (BS.take 30 bs)] + return cmp + where + pushConf :: ConfMap -> CabalPV -> FilePath -> ConfMap + pushConf m k fp = Map.insertWith (++) k [fp] m + -- 'MungedPackageId's get displayed using the z-encoded format, so are + -- compatible with ghc-pkg. This is important for resolving broken packages + -- (reported by ghc-pkg) to @.conf@ files! + toCPV :: InstalledPackageInfo -> CabalPV + toCPV = CPV . display . mungedId + checkPkgs :: Verbosity -> ([CabalPV], [FilePath]) -> IO ([Package],[CabalPV],[FilePath]) @@ -325,10 +326,18 @@ ] vsay v "brokenConfs: reading '*.conf' files" - cnfs <- listConfFiles GentooConfs >>= foldConf v + cnfs <- listConfFiles gentooConfsPath >>= foldConf v vsay v $ "brokenConfs: got " ++ show (Map.size cnfs) ++ " '*.conf' files" let (known_broken, orphans) = partitionEithers $ map (matchConf cnfs) all_broken return (known_broken, orphan_confs ++ L.concat orphans) + where + -- Attempt to match the provided broken package to one of the + -- installed packages. + matchConf :: ConfMap -> CabalPV -> Either CabalPV [FilePath] + matchConf cmp cpv = + case Map.lookup cpv cmp of + Just fps -> Right fps + Nothing -> Left cpv -- Return the closure of all packages affected by breakage -- in format of ["name-version", ... ] @@ -341,7 +350,7 @@ -- Around Jan 2015 we have started to install -- all the .conf files in 'src_install()' phase. -- Here we pick orphan ones and notify user about it. - registered_confs <- listConfFiles GHCConfs + registered_confs <- listConfFiles ghcConfsPath confs_to_pkgs <- resolveFiles registered_confs let (conf_files, _conf_pkgs) = unzip confs_to_pkgs orphan_conf_files = registered_confs L.\\ conf_files @@ -357,8 +366,8 @@ -- due to unregistration bugs in old eclass. getNotRegistered :: Verbosity -> IO [CabalPV] getNotRegistered v = do - installed_confs <- listConfFiles GentooConfs >>= foldConf v - registered_confs <- listConfFiles GHCConfs >>= foldConf v + installed_confs <- listConfFiles gentooConfsPath >>= foldConf v + registered_confs <- listConfFiles ghcConfsPath >>= foldConf v return $ Map.keys installed_confs L.\\ Map.keys registered_confs -- Return packages, that seem to have @@ -373,9 +382,37 @@ -- It's is easy to fix just by reinstalling transformers. getRegisteredTwice :: Verbosity -> IO [CabalPV] getRegisteredTwice v = do - registered_confs <- listConfFiles GHCConfs >>= foldConf v + registered_confs <- listConfFiles ghcConfsPath >>= foldConf v let registered_twice = Map.filter (\fs -> length fs > 1) registered_confs - return $ Map.keys registered_twice + + -- Double check that all of the "duplicates" are main libraries, since + -- a package may also have one or more sub-libraries registered as + -- well. + rtMainLibs <- foldM + (\m k -> Map.alterF onlyMultipleMains k m) + registered_twice + (Map.keys registered_twice) + + return $ Map.keys rtMainLibs + where + -- Filter out all but entries with multiple main libraries + onlyMultipleMains :: Maybe [FilePath] -> IO (Maybe [FilePath]) + onlyMultipleMains (Just fps@(_:_)) = do + fps' <- filterM filterMain fps + -- Remove entries with one or less elements, since they are no longer + -- relevant to the getRegisteredTwice function + pure $ if length fps' <= 1 then Nothing else Just fps' + onlyMultipleMains _ = pure Nothing + + -- Only keep conf files that correspond to main libraries. This runs + -- 'parse_as_cabal_package' to get + filterMain :: FilePath -> IO Bool + filterMain conf = do + bs <- BS.readFile conf + let ipi = parse_as_cabal_package bs + pure $ case sourceLibName <$> ipi of + Just LMainLibName -> True + _ -> False -- ----------------------------------------------------------------------------- diff --git a/Distribution/Gentoo/PkgManager.hs b/Distribution/Gentoo/PkgManager.hs --- a/Distribution/Gentoo/PkgManager.hs +++ b/Distribution/Gentoo/PkgManager.hs @@ -7,19 +7,19 @@ This module defines ways to use different Gentoo package managers. -} module Distribution.Gentoo.PkgManager - ( PkgManager - , definedPMs + ( definedPMs , choosePM , stringToCustomPM , isValidPM , defaultPM , defaultPMName , nameOfPM - , PMFlag(..) , buildCmd + , buildAltCmd ) where import Distribution.Gentoo.Packages +import Distribution.Gentoo.PkgManager.Types import Data.Char(toLower) import Data.Maybe(mapMaybe, fromMaybe) @@ -29,14 +29,6 @@ -- ----------------------------------------------------------------------------- --- | Defines the available Gentoo package managers. -data PkgManager = Portage - | PkgCore - | Paludis - | InvalidPM String - | CustomPM String - deriving (Eq, Ord, Show, Read) - -- | The default package manager. If the environment variable -- @PACKAGE_MANAGER@ exists, use that; otherwise default to -- "portage". Note that even if that environment variable is @@ -115,13 +107,32 @@ fs' = defaultPMFlags pm ++ mapMaybe (flagRep pm) fs ++ raw_pm_flags ps' = map printPkg ps --- ----------------------------------------------------------------------------- +-- | Alternative version of 'buildCmd' which uses experimental @emerge@ +-- invocation (using @--reinstall-atoms@). This is only to be used with the +-- 'Portage' 'PkgManager'. +-- +-- The rationale is that by marking broken packages by using +-- @--reinstall-atoms@, portage will pretend that they are not yet +-- installed, thus forcing their reinstallation. @--update@ is +-- used and all installed Haskell packages are targeted so that the entire +-- Haskell environment is examined. This has a side-effect of skipping +-- packages that are masked or otherwise unavailable while still rebuilding +-- needed dependencies that have been broken. +buildAltCmd + :: [PMFlag] -- ^ Basic flags + -> [String] -- ^ User-supplied flags + -> [Package] -- ^ List of packages to rebuild + -- | List of /all/ installed haskell packages ('Nothing' denotes a @world@ target) + -> Maybe [Package] + -> (String, [String]) +buildAltCmd fs rawPmFlags ps allPs = + (pmCommand Portage, fs' ++ reinst ++ rawPmFlags ++ allPs') + where + fs' = defaultPMFlags Portage ++ mapMaybe (flagRep Portage) fs ++ ["--update"] + reinst = ["--reinstall-atoms", unwords (map printPkg ps)] + allPs' = maybe ["@world"] (map printPkg) allPs --- | Different optional flags to be passed to the PM. -data PMFlag = PretendBuild - | UpdateDeep - | UpdateAsNeeded - deriving (Eq, Ord, Show, Read) +-- ----------------------------------------------------------------------------- flagRep :: PkgManager -> PMFlag -> Maybe String flagRep Portage = portagePMFlag diff --git a/Distribution/Gentoo/PkgManager/Types.hs b/Distribution/Gentoo/PkgManager/Types.hs new file mode 100644 --- /dev/null +++ b/Distribution/Gentoo/PkgManager/Types.hs @@ -0,0 +1,19 @@ + +module Distribution.Gentoo.PkgManager.Types + ( PkgManager(..) + , PMFlag(..) + ) where + +-- | Defines the available Gentoo package managers. +data PkgManager = Portage + | PkgCore + | Paludis + | InvalidPM String + | CustomPM String + deriving (Eq, Ord, Show, Read) + +-- | Different optional flags to be passed to the PM. +data PMFlag = PretendBuild + | UpdateDeep + | UpdateAsNeeded + deriving (Eq, Ord, Show, Read) diff --git a/Distribution/Gentoo/Types.hs b/Distribution/Gentoo/Types.hs new file mode 100644 --- /dev/null +++ b/Distribution/Gentoo/Types.hs @@ -0,0 +1,115 @@ + +module Distribution.Gentoo.Types + ( RunModifier(..) + , WithCmd(..) + , WithUserCmd + , BuildTarget(..) + , HackportMode(..) + , PackageState(..) + , DefaultModePkgs(..) + , ListModePkgs(..) + , RAModePkgs(..) + , HasTargets(..) + , InvalidPkgs(..) + , AllPkgs(..) + , PackageList(..) + ) where + +import Distribution.Gentoo.Packages +import Distribution.Gentoo.PkgManager.Types +import Output + +-- | Full haskell-updater state +data RunModifier = RM { pkgmgr :: PkgManager + , flags :: [PMFlag] + , withCmd :: WithCmd + , rawPMArgs :: [String] + , verbosity :: Verbosity + , showHelp :: Bool + , showVer :: Bool + , target :: BuildTarget + , mode :: HackportMode + } + deriving (Eq, Ord, Show) + +data WithCmd = PrintAndRun + | PrintOnly + | RunOnly + deriving (Eq, Ord, Show, Read, Enum, Bounded) + +type WithUserCmd = Either String WithCmd + +data BuildTarget + = OnlyInvalid -- ^ Default + | AllInstalled -- ^ Rebuild every haskell package + | WorldTarget -- ^ Target @world portage set + deriving (Eq, Ord, Show, Read, Enum, Bounded) + +data HackportMode + = BasicMode + | ListMode + | ReinstallAtomsMode + deriving (Show, Eq, Ord, Enum, Bounded) + +-- | The current package list(s) organized by mode and build target +data PackageState + = DefaultModeState (Maybe DefaultModePkgs) + | ListModeState ListModePkgs + | RAModeState (Maybe RAModePkgs) + deriving (Show, Eq, Ord) + +data DefaultModePkgs + = DefaultInvalid InvalidPkgs + | DefaultAll AllPkgs + deriving (Show, Eq, Ord) + +data ListModePkgs + = ListInvalid InvalidPkgs + | ListAll AllPkgs + deriving (Show, Eq, Ord) + +data RAModePkgs + = RAModeInvalid AllPkgs InvalidPkgs + | RAModeAll AllPkgs + | RAModeWorld InvalidPkgs + deriving (Show, Eq, Ord) + +class HasTargets t where + targets :: t -> [Package] + +instance HasTargets PackageState where + targets (DefaultModeState ps) = targets ps + targets (ListModeState ps) = targets ps + targets (RAModeState ps) = targets ps + +instance HasTargets DefaultModePkgs where + targets (DefaultInvalid ps) = getPkgs ps + targets (DefaultAll ps) = getPkgs ps + +instance HasTargets ListModePkgs where + targets (ListInvalid ps) = getPkgs ps + targets (ListAll ps) = getPkgs ps + +instance HasTargets RAModePkgs where + targets (RAModeInvalid _ ps) = getPkgs ps + targets (RAModeAll ps) = getPkgs ps + targets (RAModeWorld ps) = getPkgs ps + +instance HasTargets t => HasTargets (Maybe t) where + targets (Just ps) = targets ps + targets Nothing = [] + +newtype InvalidPkgs = InvalidPkgs [Package] + deriving (Show, Eq, Ord) + +newtype AllPkgs = AllPkgs [Package] + deriving (Show, Eq, Ord) + +class PackageList t where + getPkgs :: t -> [Package] + +instance PackageList InvalidPkgs where + getPkgs (InvalidPkgs ps) = ps + +instance PackageList AllPkgs where + getPkgs (AllPkgs ps) = ps diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -7,20 +7,22 @@ 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 Data.Char (toLower) -import Data.Either (partitionEithers) -import Data.Map (Map) import qualified Data.List as L import qualified Data.Map as M -import Data.Maybe (fromJust) import qualified Data.Set as Set import Data.Version (showVersion) import qualified Paths_haskell_updater as Paths (version) @@ -61,244 +63,163 @@ runDriver :: RunModifier -> IO a runDriver rm = do - systemInfo v rm t + systemInfo v rm t md updaterPass 1 initialHistory success v "done!" - where v = verbosity rm - t = target rm - updaterPass :: Int -> DriverHistory -> IO () - updaterPass n pastHistory = do - ps <- getTargetPackages v t - CM.when (listOnly rm) $ do - mapM_ (putStrLn . printPkg) ps - success v "done!" - CM.when (null ps) $ - success (verbosity rm) "\nNothing to build!" - CM.when (Set.fromList ps `M.member` pastHistory) $ do - dumpHistory v pastHistory - die "Updater stuck in the loop and can't progress" + where + v = verbosity rm + t = target rm + md = mode rm - exitCode <- buildPkgs rm ps + 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 - -- don't try rerun rebuilder for cases where there - -- is no chance to converge to empty set - CM.when (target rm == AllInstalled) $ - exitWith exitCode - -- continue rebuild attempts - updaterPass (n + 1) $ M.insert (Set.fromList ps) n pastHistory + where -data BuildTarget = OnlyInvalid - | AllInstalled -- Rebuild every haskell package - deriving (Eq, Ord, Show, Read) + alertDone = success (verbosity rm) "\nNothing to build!" -getTargetPackages :: Verbosity -> BuildTarget -> IO [Package] -getTargetPackages v t = - case t of - OnlyInvalid -> do say v "Searching for packages installed with a different version of GHC." - say v "" - old <- oldGhcPkgs v - pkgListPrintLn v "old" old + 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" - 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) + exitCode <- buildPkgs rm (cnst ts) - return $ Set.toList $ Set.fromList $ old ++ broken + -- don't try rerun rebuilder for cases where there + -- is no chance to converge to empty set + CM.when allTarget $ exitWith exitCode - AllInstalled -> do say v "Searching for packages installed with the current version of GHC." - say v "" - pkgs <- allInstalledPackages - pkgListPrintLn v "installed" pkgs - return pkgs + updaterPass (n + 1) $ M.insert (Set.fromList (getPkgs ts)) n pastHistory - where 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 "" +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 --- Full haskell-updater state -data RunModifier = RM { pkgmgr :: PkgManager - , flags :: [PMFlag] - , withCmd :: WithCmd - , rawPMArgs :: [String] - , verbosity :: Verbosity - , listOnly :: Bool - , showHelp :: Bool - , showVer :: Bool - , target :: BuildTarget - } - deriving (Eq, Ord, Show, Read) + 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) -data WithCmd = RunOnly - | PrintOnly - | PrintAndRun - deriving (Eq, Ord, Show, Read) + return $ InvalidPkgs $ Set.toList $ Set.fromList $ old ++ broken -type WithUserCmd = Either String WithCmd + 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 -withCmdMap :: Map String WithCmd -withCmdMap = M.fromList [ ("print", PrintOnly) - , ("run", RunOnly) - , ("print-and-run", PrintAndRun) - ] + checkForNull :: PackageList ts => (ts -> b) -> ts -> Maybe b + checkForNull cnst l + | null (getPkgs l) = Nothing + | otherwise = Just (cnst l) -defaultWithCmd :: String -defaultWithCmd = "print-and-run" + 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 mode cmd args = case mode of +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: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 -> [Package] -> IO ExitCode -buildPkgs rm ps = runCmd (withCmd rm) cmd args - where - (cmd, args) = buildCmd (pkgmgr rm) (flags rm) (rawPMArgs rm) ps - --- ----------------------------------------------------------------------------- --- Command-line flags - -data Flag = HelpFlag - | VersionFlag - | PM String - | CustomPMFlag String - | FixInvalid - | RebuildAll - | Pretend - | NoDeep - | QuietFlag - | VerboseFlag - | ListOnlyFlag - | Cmd String - deriving (Eq, Ord, Show, Read) - -parseArgs :: PkgManager -> [String] -> Either String RunModifier -parseArgs defPM args = argParser defPM $ getOpt' Permute options args - -argParser :: PkgManager - -> ([Flag], [String], [String], [String]) - -> Either String RunModifier -argParser dPM (fls, nonoptions, unrecognized, errs) - | (not . null) errs = Left $ unwords $ "Errors in arguments:" : errs - | (not . null) unrecognized = Left $ unwords $ "Unknown options:" : unrecognized - | (not . null) bPms = Left $ unwords $ "Unknown package managers:" : bPms - | (not . null) bCmds = Left $ unwords $ "Unknown action:" : bCmds - | otherwise = Right rm - where - (fls', ts) = partitionBy flagToTarget fls - (fls'', pms) = partitionBy flagToPM fls' - (bPms, pms') = partitionBy isValidPM pms - (opts, cmds') = partitionBy flagToCmd fls'' - (bCmds, cmds) = partitionBy isValidCmd cmds' - pm = emptyElse dPM last pms' - opts' = Set.fromList opts - cmd = emptyElse (fromJust $ M.lookup defaultWithCmd withCmdMap) last cmds - hasFlag = flip Set.member opts' - pmFlags = bool id (PretendBuild:) (hasFlag Pretend) - . return $ bool UpdateDeep UpdateAsNeeded (hasFlag NoDeep) - rm = RM { pkgmgr = pm - , flags = pmFlags - , withCmd = cmd - , rawPMArgs = nonoptions - , verbosity = case () of - _ | hasFlag VerboseFlag -> Verbose - _ | hasFlag QuietFlag -> Quiet - _ -> Normal - , listOnly = hasFlag ListOnlyFlag - , showVer = hasFlag VersionFlag - , showHelp = hasFlag HelpFlag - , target = last $ OnlyInvalid : ts - } - -flagToTarget :: Flag -> Either Flag BuildTarget -flagToTarget FixInvalid = Right OnlyInvalid -flagToTarget RebuildAll = Right AllInstalled -flagToTarget f = Left f - -flagToPM :: Flag -> Either Flag PkgManager -flagToPM (CustomPMFlag pm) = Right $ stringToCustomPM pm -flagToPM (PM pm) = Right $ choosePM pm -flagToPM f = Left f - -flagToCmd :: Flag -> Either Flag WithUserCmd -flagToCmd (Cmd cmd) = Right $ chooseCmd cmd -flagToCmd f = Left f - -chooseCmd :: String -> WithUserCmd -chooseCmd cmd = chooseCmd' $ map toLower cmd +buildPkgs :: RunModifier -> Either DefaultModePkgs RAModePkgs -> IO ExitCode +buildPkgs rm ts = runCmd (withCmd rm) cmd args where - chooseCmd' :: String -> WithUserCmd - chooseCmd' "run" = Right RunOnly - chooseCmd' "print" = Right PrintOnly - chooseCmd' "print-and-run" = Right PrintAndRun - chooseCmd' c = Left c - -isValidCmd :: WithUserCmd -> Either String WithCmd -isValidCmd = id - -options :: [OptDescr Flag] -options = - [ Option ['c'] ["dep-check"] (NoArg FixInvalid) - "Check dependencies of Haskell packages." - -- deprecated alias for 'dep-check' - , Option ['u'] ["upgrade"] (NoArg FixInvalid) - "Rebuild Haskell packages after a GHC upgrade." - , Option ['a'] ["all"] (NoArg RebuildAll) - "Rebuild all Haskell libraries built with current GHC." - , Option ['P'] ["package-manager"] (ReqArg PM "PM") - $ "Use package manager PM, where PM can be one of:\n" - ++ pmList ++ defPM - , Option ['C'] ["custom-pm"] (ReqArg CustomPMFlag "command") - "Use custom command as package manager;\n\ - \ignores the --pretend and --no-deep flags." - , Option ['p'] ["pretend"] (NoArg Pretend) - "Only pretend to build packages." - , Option [] ["no-deep"] (NoArg NoDeep) - "Don't pull deep dependencies (--deep with emerge)." - , Option ['l'] ["list-only"] (NoArg ListOnlyFlag) - "Output only list of packages for rebuild. One package per line." - , Option ['V'] ["version"] (NoArg VersionFlag) - "Version information." - , Option [] ["action"] (ReqArg Cmd "action") - $ "Specify whether to run the PM command or just print it\n" - ++ actionList ++ defAction - , Option ['q'] ["quiet"] (NoArg QuietFlag) - "Print only fatal errors (to stderr)." - , Option ['v'] ["verbose"] (NoArg VerboseFlag) - "Be more elaborate (to stderr)." - , Option ['h', '?'] ["help"] (NoArg HelpFlag) - "Print this help message." - ] - where - pmList = unlines . map (" * " ++) $ definedPMs - defPM = "The last valid value of PM specified is chosen.\n\ - \The default package manager is: " ++ defaultPMName ++ ",\n\ - \which can be overriden with the \"PACKAGE_MANAGER\"\n\ - \environment variable." - actionList = unlines . map (" * " ++) $ M.keys withCmdMap - defAction = "The last specified action is chosen.\n\ - \The default action is: " ++ defaultWithCmd + (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. @@ -322,8 +243,8 @@ , "" , "Options:"] -systemInfo :: Verbosity -> RunModifier -> BuildTarget -> IO () -systemInfo v rm t = do +systemInfo :: Verbosity -> RunModifier -> BuildTarget -> HackportMode -> IO () +systemInfo v rm t m = do ver <- ghcVersion pName <- getProgName let pVer = showVersion Paths.version @@ -335,7 +256,8 @@ say v $ " * Package manager (PM): " ++ nameOfPM (pkgmgr rm) unless (null (rawPMArgs rm)) $ say v $ " * PM auxiliary arguments: " ++ unwords (rawPMArgs rm) - say v $ " * Mode: " ++ show t + say v $ " * Target: " ++ show t + say v $ " * Mode: " ++ show m say v "" -- ----------------------------------------------------------------------------- @@ -351,14 +273,3 @@ putErrLn :: String -> IO () putErrLn = hPutStrLn stderr - -bool :: a -> a -> Bool -> a -bool f t b = if b then t else f - -partitionBy :: (a -> Either l r) -> [a] -> ([l], [r]) -partitionBy f = partitionEithers . map f - --- If the list is empty, return the provided value; otherwise use the function. -emptyElse :: b -> ([a] -> b) -> [a] -> b -emptyElse e _ [] = e -emptyElse _ f as = f as diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,36 @@ +# haskell-updater + +Rebuilds Haskell packages on Gentoo after a GHC upgrade or a dependency upgrade. + +Updating Haskell packages +========================= + +Sometimes: + +``` shell +emerge -auvDN --keep-going @world +``` + +has trouble figuring out how to update Haskell packages. Providing emerge +with the full list of dev-haskell packages that have upgrades available can +sometimes help: + +``` shell +emerge -avu --oneshot --keep-going --with-bdeps=y @world +haskell-updater -- --verbose-conflicts +``` + +Sometimes we have sub-slot blockers (when updating ghc or some specific package +there are a list of blockers). Subslot blockers are a portage limitation (bug). + +To find solution use larger `--backtrack=` with `emerge` and `haskell-updater`. + +Experimental portage invocation +=============================== + +If you run into errors where `haskell-updater` tries to reinstall a masked or +unavailable package, try `haskell-updater --mode=reinstall-atoms` or +`haskell-updater --world`. If you find any bugs, report them to the [bug +tracker](https://github.com/gentoo-haskell/haskell-updater/issues). + + diff --git a/haskell-updater.cabal b/haskell-updater.cabal --- a/haskell-updater.cabal +++ b/haskell-updater.cabal @@ -2,7 +2,7 @@ name: haskell-updater homepage: https://github.com/gentoo-haskell/haskell-updater#readme bug-reports: https://github.com/gentoo-haskell/haskell-updater/issues -version: 1.3.3 +version: 1.4.0.0 synopsis: Rebuild Haskell dependencies in Gentoo description: haskell-updater rebuilds Haskell packages on Gentoo @@ -28,9 +28,11 @@ maintainer: haskell@gentoo.org build-type: Simple -extra-source-files: - man/haskell-updater.1 - TODO +extra-doc-files: + , CHANGELOG.md + , man/haskell-updater.1 + , README.md + , TODO tested-with: , GHC ==9.0.2 @@ -58,9 +60,12 @@ import: all main-is: Main.hs other-modules: + Distribution.Gentoo.CmdLine Distribution.Gentoo.GHC Distribution.Gentoo.Packages Distribution.Gentoo.PkgManager + Distribution.Gentoo.PkgManager.Types + Distribution.Gentoo.Types Distribution.Gentoo.Util Output Paths_haskell_updater