diff --git a/Distribution/Gentoo/GHC.hs b/Distribution/Gentoo/GHC.hs --- a/Distribution/Gentoo/GHC.hs +++ b/Distribution/Gentoo/GHC.hs @@ -30,7 +30,8 @@ -- Other imports import Data.Char(isDigit) import Data.Either(partitionEithers) -import Data.Maybe(fromJust) +import Data.Maybe +import qualified Data.List as L import qualified Data.Map as Map import Data.Map(Map) import qualified Data.ByteString.Char8 as BS @@ -38,7 +39,7 @@ import System.Directory( canonicalizePath , doesDirectoryExist , findExecutable) -import Control.Monad(foldM, liftM) +import Control.Monad import Output @@ -89,14 +90,15 @@ ghcPkgLoc = liftM fromJust $ findExecutable "ghc-pkg" -- Return the Gentoo .conf files found in this GHC libdir -confFiles :: FilePath -> IO [FilePath] -confFiles dir = do let gDir = dir "gentoo" - exists <- doesDirectoryExist gDir - if exists - then do conts <- getDirectoryContents' gDir - return $ map (gDir ) - $ filter isConf conts - else return [] +confFiles :: FilePath -> FilePath -> IO [FilePath] +confFiles subdir dir = do + let gDir = dir subdir + exists <- doesDirectoryExist gDir + if exists + then do conts <- getDirectoryContents' gDir + return $ map (gDir ) + $ filter isConf conts + else return [] where isConf file = takeExtension file == ".conf" @@ -114,7 +116,7 @@ -- Read in all Gentoo .conf files from the current GHC version and -- create a Map readConf :: Verbosity -> IO ConfMap -readConf v = ghcLibDir >>= confFiles >>= foldM (addConf v) Map.empty +readConf v = ghcLibDir >>= confFiles "gentoo" >>= foldM (addConf v) Map.empty -- cabal package text format -- "[InstalledPackageInfo {installedPackageId = Insta..." @@ -151,8 +153,10 @@ case ( parse_as_ghc_package cont , parse_as_cabal_package (BS.unpack cont) ) of - (Just dn, _) -> return $ Map.insert dn conf cmp - (_, Just dn) -> return $ Map.insert dn conf cmp + (Just dn, _) -> do vsay v $ unwords [conf, "resolved as ghc package:", dn] + return $ Map.insert dn conf cmp + (_, Just dn) -> do vsay v $ unwords [conf, "resolved as cabal package:", dn] + return $ Map.insert dn conf cmp -- empty files are created for -- phony packages like CABAL_CORE_LIB_GHC_PV -- and binary-only packages. @@ -168,9 +172,16 @@ checkPkgs :: Verbosity -> ([CabalPV], [FilePath]) -> IO ([Package],[CabalPV],[FilePath]) -checkPkgs _v (pns,cnfs) - = do pkgs <- haveFiles cnfs - return (pkgs, pns, []) +checkPkgs v (pns, gentoo_cnfs) = do + files_to_pkgs <- resolveFiles gentoo_cnfs + let (gentoo_files, pkgs) = unzip files_to_pkgs + orphan_gentoo_files = gentoo_cnfs L.\\ gentoo_files + vsay v $ unwords [ "checkPkgs: searching for gentoo .conf orphans" + , show (length orphan_gentoo_files) + , "of" + , show (length gentoo_cnfs) + ] + return (pkgs, pns, orphan_gentoo_files) -- ----------------------------------------------------------------------------- @@ -232,22 +243,49 @@ brokenConfs :: Verbosity -> IO ([CabalPV], [FilePath]) brokenConfs v = do vsay v "brokenConfs: getting broken output from 'ghc-pkg'" - brkn <- getBroken + ghc_pkg_brokens <- getBroken -- Check if we actually have to go look up files and -- do IO. - vsay v $ "brokenConfs: resolving package names to gentoo equivalents. " ++ show (length brkn) ++ " are broken" - if null brkn - then return ([], []) - else do vsay v "brokenConfs: reading '*.conf' files" - cnfs <- readConf v - vsay v $ "brokenConfs: got " ++ show (Map.size cnfs) ++ " '*.conf' files" - return $ partitionEithers $ map (matchConf cnfs) brkn + vsay v $ unwords ["brokenConfs: resolving package names to gentoo equivalents." + , show (length ghc_pkg_brokens) + , "are broken:" + , L.intercalate " " ghc_pkg_brokens + ] + (orphan_broken, orphan_confs) <- getOrphanBroken + vsay v $ unwords [ "checkPkgs: ghc .conf orphans:" + , show (length orphan_broken) + , "are orphan:" + , L.intercalate " " orphan_broken + ] + + let all_broken = ghc_pkg_brokens ++ orphan_broken + + vsay v "brokenConfs: reading '*.conf' files" + cnfs <- readConf 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 ++ orphans) + -- Return the closure of all packages affected by breakage -- in format of ["name-version", ... ] getBroken :: IO [CabalPV] getBroken = liftM words $ ghcPkgRawOut ["check", "--simple-output"] + +getOrphanBroken :: IO ([CabalPV], [FilePath]) +getOrphanBroken = do + -- 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 <- ghcLibDir >>= confFiles "package.conf.d" + confs_to_pkgs <- resolveFiles registered_confs + let (conf_files, _conf_pkgs) = unzip confs_to_pkgs + orphan_conf_files = registered_confs L.\\ conf_files + orphan_packages <- liftM catMaybes $ + forM orphan_conf_files $ + liftM parse_as_ghc_package . BS.readFile + return (orphan_packages, orphan_conf_files) -- ----------------------------------------------------------------------------- diff --git a/Distribution/Gentoo/Packages.hs b/Distribution/Gentoo/Packages.hs --- a/Distribution/Gentoo/Packages.hs +++ b/Distribution/Gentoo/Packages.hs @@ -12,26 +12,23 @@ , Content , notGHC , printPkg - , haveFiles + , resolveFiles , pkgsHaveContent - , hasContentMatching , hasDirMatching - , hasObjMatching ) where -import Distribution.Gentoo.Util - import Data.Char(isDigit, isAlphaNum) -import Data.List(delete) -import Data.Maybe(mapMaybe, listToMaybe) +import Data.Maybe import qualified Data.ByteString.Char8 as BS import Data.ByteString.Char8(ByteString) import qualified Data.Set as S import System.Directory( doesDirectoryExist , doesFileExist) import System.FilePath(()) -import Control.Monad(filterM, liftM) +import Control.Monad +import Distribution.Gentoo.Util + -- ----------------------------------------------------------------------------- -- Representation of a cat/pkgname in Gentoo. Note that this is @@ -107,7 +104,7 @@ isVerFront _ = False pkgPath :: VCatPkg -> FilePath -pkgPath (c,vp) = pkgDBDir c vp +pkgPath (c, vp) = pkgDBDir c vp pkgDBDir :: FilePath pkgDBDir = "/var/db/pkg" @@ -119,16 +116,12 @@ -- Representation of individual lines in a CONTENTS file. data Content = Dir BSFilePath | Obj BSFilePath - deriving (Eq, Show) + deriving (Eq, Show, Ord) isDir :: Content -> Bool isDir (Dir _) = True isDir _ = False -isObj :: Content -> Bool -isObj (Obj _) = True -isObj _ = False - pathOf :: Content -> BSFilePath pathOf (Dir dir) = dir pathOf (Obj obj) = obj @@ -141,9 +134,6 @@ hasDirMatching :: (BSFilePath -> Bool) -> [Content] -> Bool hasDirMatching p = hasContentMatching p . filter isDir -hasObjMatching :: (BSFilePath -> Bool) -> [Content] -> Bool -hasObjMatching p = hasContentMatching p . filter isObj - -- Parse the CONTENTS file. parseContents :: VCatPkg -> IO [Content] parseContents cp = do ex <- doesFileExist cFile @@ -177,20 +167,40 @@ -- ----------------------------------------------------------------------------- --- Find all the packages that contain any of the given files. -haveFiles :: [FilePath] -> IO [Package] -haveFiles fps = pkgsHaveContent p +-- Find all the packages that contain given files. +resolveFiles :: [FilePath] -> IO [(FilePath, Package)] +resolveFiles fps = liftM expand $ forPkg grep where - fps' = S.fromList $ map BS.pack fps - p = hasObjMatching (`S.member` fps') + fps' = S.fromList $ map (Obj . BS.pack) fps + expand pfs = [ (BS.unpack fn, pn) + | (pn, conts) <- pfs + , Obj fn <- conts + ] + grep pn cont = Just (pn, filter (\e -> S.member e fps') cont) +-- | Run predecate 'p' for each installed package +-- and gather all 'Just' values +forPkg :: (Package -> [Content] -> Maybe a) -> IO [a] +forPkg p = do + categories <- installedCats + liftM catMaybes $ do + (flip concatMapM) categories $ \cat -> do + maybe_pkgs <- getDirectoryContents' (pkgDBDir cat) + packages <- filterM (\pn' -> doesDirectoryExist $ pkgPath (cat, pn')) maybe_pkgs + forM packages $ \pkg -> do + let cp = (cat, pkg) + cpn <- toPackage cp + cont <- parseContents cp + return $ p cpn cont + -- Find which packages have Content information that matches the -- provided predicate; to be used with the searching predicates -- above. pkgsHaveContent :: ([Content] -> Bool) -> IO [Package] -pkgsHaveContent p = do cs <- installedCats' - cps <- concatMapM (catHasContent p) cs - mapM toPackage cps +pkgsHaveContent p = forPkg p' + where p' pn cont = if p cont + then Just pn + else Nothing -- Determine if this is a valid Category (such that at least one -- package in that category has been installed). @@ -205,27 +215,3 @@ -- Return all Categories known in this system. installedCats :: IO [Category] installedCats = filterM isCat =<< getDirectoryContents' pkgDBDir - --- We are most likely to need to look in dev-haskell, so put that --- first in our list. -installedCats' :: IO [Category] -installedCats' = do cats <- installedCats - return $ if haskCat `elem` cats - then haskCat : delete haskCat cats - else cats - where - haskCat = "dev-haskell" - --- Return all packages in this category whose contents match the --- provided predicate. -catHasContent :: ([Content] -> Bool) -> Category -> IO [VCatPkg] -catHasContent p c = do inDir <- getDirectoryContents' cfp - let psbl = map ((,) c) inDir - pkgs <- filterM (doesDirectoryExist . pkgPath) psbl - filterM (hasContent p) pkgs - where - cfp = pkgDBDir c - --- Determine if this package matches the predicate. -hasContent :: ([Content] -> Bool) -> VCatPkg -> IO Bool -hasContent p = liftM p . parseContents diff --git a/haskell-updater.cabal b/haskell-updater.cabal --- a/haskell-updater.cabal +++ b/haskell-updater.cabal @@ -1,6 +1,6 @@ Name: haskell-updater Homepage: http://haskell.org/haskellwiki/Gentoo#haskell-updater -Version: 1.2.5 +Version: 1.2.6 Synopsis: Rebuild Haskell dependencies in Gentoo Description: haskell-updater rebuilds Haskell packages on Gentoo after a GHC upgrade or a dependency upgrade.