Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

246 lines (211 sloc) 9.662 kb
module Status
( FileStatus(..)
, StatusDirection(..)
, fromStatus
, status
, runStatus
) where
import AnsiColor
import qualified Portage.Version as V (is_live)
import Portage.Overlay
import Portage.PackageId
import Portage.Resolve
import Control.Monad.State
import qualified Data.List as List
import qualified Data.ByteString.Char8 as BS
import Data.Char
import Data.Function (on)
import qualified Data.Map as Map
import Data.Map as Map (Map)
import qualified Data.Traversable as T
import Control.Applicative
-- cabal
import Distribution.Client.Types ( Repo, SourcePackageDb(..), SourcePackage(..) )
import Distribution.Verbosity
import Distribution.Package (pkgName)
import Distribution.Simple.Utils (comparing, die, equating)
import Distribution.Text ( display, simpleParse )
import qualified Distribution.Client.PackageIndex as CabalInstall
import qualified Distribution.Client.IndexUtils as CabalInstall
import Hackage (defaultRepo)
data StatusDirection
= PortagePlusOverlay
| OverlayToPortage
| HackageToOverlay
deriving Eq
data FileStatus a
= Same a
| Differs a a
| OverlayOnly a
| PortageOnly a
| HackageOnly a
deriving (Show,Eq)
instance Ord a => Ord (FileStatus a) where
compare = comparing fromStatus
instance Functor FileStatus where
fmap f st =
case st of
Same a -> Same (f a)
Differs a b -> Differs (f a) (f b)
OverlayOnly a -> OverlayOnly (f a)
PortageOnly a -> PortageOnly (f a)
HackageOnly a -> HackageOnly (f a)
fromStatus :: FileStatus a -> a
fromStatus fs =
case fs of
Same a -> a
Differs a _ -> a -- second status is lost
OverlayOnly a -> a
PortageOnly a -> a
HackageOnly a -> a
loadHackage :: Verbosity -> Distribution.Client.Types.Repo -> Overlay -> IO [[PackageId]]
loadHackage verbosity repo overlay = do
SourcePackageDb { packageIndex = pindex } <- CabalInstall.getSourcePackages verbosity [repo]
let get_cat cabal_pkg = case resolveCategories overlay (pkgName cabal_pkg) of
[] -> Category "dev-haskell"
[cat] -> cat
_ -> {- ambig -} Category "dev-haskell"
pkg_infos = map ( reverse . take 3 . reverse -- hackage usually has a ton of older versions
. map ((\p -> fromCabalPackageId (get_cat p) p)
. packageInfoId))
(CabalInstall.allPackagesByName pindex)
return pkg_infos
status :: Verbosity -> FilePath -> FilePath -> IO (Map PackageName [FileStatus ExistingEbuild])
status verbosity portdir overlaydir = do
let repo = defaultRepo overlaydir
overlay <- loadLazy overlaydir
hackage <- loadHackage verbosity repo overlay
portage <- filterByHerd ("haskell" `elem`) <$> loadLazy portdir
let (over, both, port) = portageDiff (overlayMap overlay) (overlayMap portage)
both' <- T.forM both $ mapM $ \e -> liftIO $ do
-- can't fail, we know the ebuild exists in both portagedirs
-- also, one of them is already bound to 'e'
let (Just e1) = lookupEbuildWith (overlayMap portage) (ebuildId e)
(Just e2) = lookupEbuildWith (overlayMap overlay) (ebuildId e)
eq <- equals (ebuildPath e1) (ebuildPath e2)
return $ if eq
then Same e1
else Differs e1 e2
let p_to_ee :: PackageId -> ExistingEbuild
p_to_ee p = ExistingEbuild p cabal_p ebuild_path
where Just cabal_p = toCabalPackageId p -- lame doubleconv
ebuild_path = packageIdToFilePath p
mk_fake_ee :: [PackageId] -> (PackageName, [ExistingEbuild])
mk_fake_ee ~pkgs@(p:_) = (packageId p, map p_to_ee pkgs)
map_diff = Map.differenceWith (\le re -> Just $ foldr (List.deleteBy (equating ebuildId)) le re)
hack = ((Map.fromList $ map mk_fake_ee hackage) `map_diff` overlayMap overlay) `map_diff` overlayMap portage
meld = Map.unionsWith (\a b -> List.sort (a++b))
[ Map.map (map PortageOnly) port
, both'
, Map.map (map OverlayOnly) over
, Map.map (map HackageOnly) hack
]
return meld
type EMap = Map PackageName [ExistingEbuild]
lookupEbuildWith :: EMap -> PackageId -> Maybe ExistingEbuild
lookupEbuildWith overlay pkgid = do
ebuilds <- Map.lookup (packageId pkgid) overlay
List.find (\e -> ebuildId e == pkgid) ebuilds
runStatus :: Verbosity -> FilePath -> FilePath -> StatusDirection -> [String] -> IO ()
runStatus verbosity portdir overlaydir direction pkgs = do
let pkgFilter = case direction of
OverlayToPortage -> toPortageFilter
PortagePlusOverlay -> id
HackageToOverlay -> fromHackageFilter
pkgs' <- forM pkgs $ \p ->
case simpleParse p of
Nothing -> die ("Could not parse package name: " ++ p ++ ". Format cat/pkg")
Just pn -> return pn
tree0 <- status verbosity portdir overlaydir
let tree = pkgFilter tree0
if (null pkgs')
then statusPrinter tree
else forM_ pkgs' $ \pkg -> statusPrinter (Map.filterWithKey (\k _ -> k == pkg) tree)
-- |Only return packages that seems interesting to sync to portage;
--
-- * Ebuild differs, or
-- * Newer version in overlay than in portage
toPortageFilter :: Map PackageName [FileStatus ExistingEbuild] -> Map PackageName [FileStatus ExistingEbuild]
toPortageFilter = Map.mapMaybe $ \ sts ->
let filter_out_lives = filter (not . V.is_live . pkgVersion . ebuildId . fromStatus)
inPortage = flip filter sts $ \st ->
case st of
OverlayOnly _ -> False
HackageOnly _ -> False
_ -> True
latestPortageVersion = List.maximum $ map (pkgVersion . ebuildId . fromStatus) inPortage
interestingPackages = flip filter sts $ \st ->
case st of
Differs _ _ -> True
_ | pkgVersion (ebuildId (fromStatus st)) > latestPortageVersion -> True
| otherwise -> False
in if not (null inPortage) && not (null $ filter_out_lives interestingPackages)
then Just sts
else Nothing
-- |Only return packages that exist in overlay or portage but look outdated
fromHackageFilter :: Map PackageName [FileStatus ExistingEbuild] -> Map PackageName [FileStatus ExistingEbuild]
fromHackageFilter = Map.mapMaybe $ \ sts ->
let inEbuilds = flip filter sts $ \st ->
case st of
HackageOnly _ -> False
_ -> True
-- treat live as oldest version not avoid masking hackage releases
mangle_live_versions v
| V.is_live v = v {versionNumber=[-1]}
| otherwise = v
latestVersion = List.maximumBy (compare `on` mangle_live_versions . pkgVersion . ebuildId . fromStatus) sts
in case latestVersion of
HackageOnly _ | not (null inEbuilds) -> Just sts
_ -> Nothing
statusPrinter :: Map PackageName [FileStatus ExistingEbuild] -> IO ()
statusPrinter packages = do
putStrLn $ toColor (Same "Green") ++ ": package in portage and overlay are the same"
putStrLn $ toColor (Differs "Yellow" "") ++ ": package in portage and overlay differs"
putStrLn $ toColor (OverlayOnly "Red") ++ ": package only exist in the overlay"
putStrLn $ toColor (PortageOnly "Magenta") ++ ": package only exist in the portage tree"
putStrLn $ toColor (HackageOnly "Cyan") ++ ": package only exist on hackage"
forM_ (zip [(1 :: Int) ..] $ Map.toAscList packages) $ \(ix, (pkg, ebuilds)) -> do
let (PackageName c p) = pkg
putStr (bold (show ix))
putStr " "
putStr $ display c ++ '/' : bold (display p)
putStr " "
forM_ ebuilds $ \e -> do
putStr $ toColor (fmap (display . pkgVersion . ebuildId) e)
putChar ' '
putStrLn ""
toColor :: FileStatus String -> String
toColor st = inColor c False Default (fromStatus st)
where
c = case st of
(Same _) -> Green
(Differs _ _) -> Yellow
(OverlayOnly _) -> Red
(PortageOnly _) -> Magenta
(HackageOnly _) -> Cyan
portageDiff :: EMap -> EMap -> (EMap, EMap, EMap)
portageDiff p1 p2 = (in1, ins, in2)
where ins = Map.filter (not . null) $ Map.intersectionWith (List.intersectBy $ equating ebuildId) p1 p2
in1 = difference p1 p2
in2 = difference p2 p1
difference x y = Map.filter (not . null) $
Map.differenceWith (\xs ys ->
let lst = foldr (List.deleteBy (equating ebuildId)) xs ys in
if null lst
then Nothing
else Just lst
) x y
-- | Compares two ebuilds, returns True if they are equal.
-- Disregards comments.
equals :: FilePath -> FilePath -> IO Bool
equals fp1 fp2 = do
-- don't leave halfopenfiles
f1 <- BS.readFile fp1
f2 <- BS.readFile fp2
return (equal' f1 f2)
equal' :: BS.ByteString -> BS.ByteString -> Bool
equal' = equating essence
where
essence = filter (not . isEmpty) . filter (not . isComment) . BS.lines
isComment = BS.isPrefixOf (BS.pack "#") . BS.dropWhile isSpace
isEmpty = BS.null . BS.dropWhile isSpace
Jump to Line
Something went wrong with that request. Please try again.