diff --git a/Src/Database.hs b/Src/Database.hs new file mode 100644 --- /dev/null +++ b/Src/Database.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} +module Database + ( AvailablePackages + -- * load method + , loadAvailablePackages + -- * query methods + , getPackageDescription + , getPackageLatestMajorVersion + , getPackageVersions + , getAllPackageName + ) where + +import Control.Applicative + +import Distribution.PackageDescription.Parse +import Distribution.PackageDescription hiding (options) +import Distribution.Package + +import qualified Data.Map as M +import Data.List +import Data.Maybe +import Data.String + +import System.Environment +import System.Directory +import System.FilePath + +import qualified Codec.Archive.Tar as Tar +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.UTF8 as UTF8 + +import Ver + +-- FIXME use cabal's Version type. +newtype AvailablePackages = AvailablePackages (M.Map PackageName [(Ver,L.ByteString)]) + +-- | Load the available packages from the tarball then append +-- an extra list of packages that are directly refered by filepath to their .cabal +loadAvailablePackages :: [String] -> IO AvailablePackages +loadAvailablePackages extras = do + tarFile <- readCabalConfig + + m1 <- foldr mkMap (AvailablePackages M.empty) . listTar . Tar.read <$> L.readFile tarFile + foldr mkMap m1 <$> mapM (\f -> L.readFile f >>= \l -> return (cabalFileToPkgName f, l)) extras + + where listTar :: Show e => Tar.Entries e -> [([FilePath],L.ByteString)] + listTar (Tar.Next ent nents) = + case Tar.entryContent ent of + Tar.NormalFile bs _ -> (splitPath $ Tar.entryPath ent, bs) : listTar nents + _ -> listTar nents + listTar Tar.Done = [] + listTar (Tar.Fail err) = error ("failed: " ++ show err) + + mkMap :: ([FilePath], L.ByteString) -> AvailablePackages -> AvailablePackages + mkMap ([(dropTrailingPathSeparator -> packagename),packageVer,_],entBS) (AvailablePackages acc) + | packagename == "." = AvailablePackages acc + | otherwise = AvailablePackages $ tweak (PackageName packagename) + (fromString $ dropTrailingPathSeparator packageVer) + entBS acc + where tweak !pname !pver !cfile !m = M.alter alterF pname m + where alterF Nothing = Just [(pver,cfile)] + alterF (Just z) = Just ((pver,cfile) : z) + mkMap _ nacc = nacc + +cabalFileToPkgName f = [takeBaseName f, "10000", ""] + +-- | return cabal 00-index.tar filepath +readCabalConfig = do + cfgEnv <- lookup "CABAL_CONFIG" <$> getEnvironment + cabalAppDir <- getAppUserDataDirectory "cabal" + let cabalAppConfig = cabalAppDir "config" + let configFile = fromMaybe cabalAppConfig cfgEnv + + cfg <- parseConfig . preParse <$> readFile configFile + case (lookup "remote-repo" cfg, lookup "remote-repo-cache" cfg) of + (Just rrepo, Just rcache) -> + let (name,_) = fromMaybe (error "cannot parse remote-repo") $ parseOneLine rrepo in + return (rcache name "00-index.tar") + _ -> error ("cannot find 'remote-repo' and 'remote-repo-cache' in config file " ++ configFile) + where + parseConfig = catMaybes . map parseOneLine + preParse = filter (not . isPrefixOf " ") -- filter all spaces leading line + . filter (not . isPrefixOf "--") -- filter comments out + . filter (not . null) -- filter null line out + . lines + parseOneLine line = let (a,b) = break (== ':') line + in if null b + then Nothing + else Just (a, dropWhile (== ' ') $ drop 1 b) + +getPackageDescription :: AvailablePackages -> PackageName -> Maybe Ver -> Maybe GenericPackageDescription +getPackageDescription (AvailablePackages apkgs) pn mver = + M.lookup pn apkgs >>= resolveVer mver >>= packageDescOfBS + where resolveVer Nothing pdescs = lookup (last $ sortVers $ map fst pdescs) pdescs + resolveVer (Just v) pdescs = lookup v pdescs + + packageDescOfBS bs = + case parsePackageDescription $ UTF8.toString bs of + ParseFailed _ -> Nothing + ParseOk _ a -> Just a + + -- | sort versions, lowest first + sortVers :: [Ver] -> [Ver] + sortVers = sort + +getPackageLatestMajorVersion :: AvailablePackages -> PackageName -> Maybe (Int,Int) +getPackageLatestMajorVersion apkgs pn = versionMajor =<< last <$> getPackageVersions apkgs pn + +getPackageVersions :: AvailablePackages -> PackageName -> Maybe [Ver] +getPackageVersions (AvailablePackages apkgs) pn = + sort . map fst <$> M.lookup pn apkgs + +getAllPackageName :: AvailablePackages -> [PackageName] +getAllPackageName (AvailablePackages apkgs) = M.keys apkgs diff --git a/Src/Main.hs b/Src/Main.hs --- a/Src/Main.hs +++ b/Src/Main.hs @@ -1,7 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE CPP #-} -import Distribution.PackageDescription.Parse import Distribution.PackageDescription.Configuration import Distribution.PackageDescription hiding (options) import Distribution.Package @@ -17,20 +16,14 @@ import qualified Control.Exception as E import Control.Monad -import System.Environment -import qualified Codec.Archive.Tar as Tar - import System.IO.Error import System.Process import System.Exit import System.Directory -import System.FilePath -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.UTF8 as UTF8 import qualified Data.Map as M +import Data.Either import Data.List -import Data.Maybe import Data.Tuple (swap) import Data.String @@ -39,65 +32,11 @@ import Env import Ver import Printing +import Policy +import Database import qualified Text.PrettyPrint.ANSI.Leijen as PP --- FIXME use cabal's Version type. -newtype AvailablePackages = AvailablePackages (M.Map PackageName [(Ver,L.ByteString)]) - -data Policy = - Policy_Any -- ^ no bounds - | Policy_LowerBoundOnly -- ^ only a lower specified - | Policy_Bounded -- ^ when both bounds specified but not following the pvp as the version is not correct - | Policy_StrictPVP -- ^ follow the PVP, lower bound, and higher bounds not greater to one that exist. - | Policy_Other -- ^ unspecified - | Policy_Many [Policy] -- ^ multiple policy in the same file. something probably went wrong in cabal-db :) - deriving (Show,Eq,Ord) - -showPolicy :: Policy -> PP.Doc -- String -showPolicy Policy_Any = PP.green $ PP.text "any" -showPolicy Policy_LowerBoundOnly = PP.yellow $ PP.text "lower-bound" -showPolicy Policy_StrictPVP = PP.red $ PP.text "strict-pvp" -showPolicy Policy_Bounded = PP.blue $ PP.text "bounded" -showPolicy Policy_Other = PP.blue $ PP.text "other" -showPolicy (Policy_Many _) = PP.blue $ PP.text "many" - -getPolicy :: AvailablePackages -> VersionRange -> Policy -getPolicy (AvailablePackages _apkgs) vr - | isAnyVersion vr = Policy_Any - | otherwise = - let vi = asVersionIntervals vr - in if and $ map isBounded vi - then Policy_StrictPVP - else Policy_LowerBoundOnly - where - isBounded (_, NoUpperBound) = False - isBounded (_, UpperBound _ _) = True - --- | return cabal 00-index.tar filepath -readCabalConfig = do - cfgEnv <- lookup "CABAL_CONFIG" <$> getEnvironment - cabalAppDir <- getAppUserDataDirectory "cabal" - let cabalAppConfig = cabalAppDir "config" - let configFile = fromMaybe cabalAppConfig cfgEnv - - cfg <- parseConfig . preParse <$> readFile configFile - case (lookup "remote-repo" cfg, lookup "remote-repo-cache" cfg) of - (Just rrepo, Just rcache) -> - let (name,_) = fromMaybe (error "cannot parse remote-repo") $ parseOneLine rrepo in - return (rcache name "00-index.tar") - _ -> error ("cannot find 'remote-repo' and 'remote-repo-cache' in config file " ++ configFile) - where - parseConfig = catMaybes . map parseOneLine - preParse = filter (not . isPrefixOf " ") -- filter all spaces leading line - . filter (not . isPrefixOf "--") -- filter comments out - . filter (not . null) -- filter null line out - . lines - parseOneLine line = let (a,b) = break (== ':') line - in if null b - then Nothing - else Just (a, dropWhile (== ' ') $ drop 1 b) - unPackageName :: PackageName -> String unPackageName (PackageName n) = n @@ -112,18 +51,6 @@ showVerconstr c = render $ Distribution.Text.disp c -packageDescOfBS bs = - case parsePackageDescription $ UTF8.toString bs of - ParseFailed _ -> Nothing - ParseOk _ a -> Just a - -getAllPackageName :: AvailablePackages -> [PackageName] -getAllPackageName (AvailablePackages apkgs) = M.keys apkgs - -getPackageVersions :: AvailablePackages -> PackageName -> Maybe [Ver] -getPackageVersions (AvailablePackages apkgs) pn = - sort . map fst <$> M.lookup pn apkgs - getPackageDependencies :: AvailablePackages -> PackageName -> IO [Dependency] getPackageDependencies apkgs pn = do let desc = finPkgDesc <$> getPackageDescription apkgs pn Nothing @@ -134,18 +61,17 @@ getPackageDependencyNames apkgs pn = map dependencyName <$> getPackageDependencies apkgs pn --- | sort versions, lowest first -sortVers :: [Ver] -> [Ver] -sortVers = sort - -getPackageDescription :: AvailablePackages -> PackageName -> Maybe Ver -> Maybe GenericPackageDescription -getPackageDescription (AvailablePackages apkgs) pn mver = - M.lookup pn apkgs >>= resolveVer mver >>= packageDescOfBS - where resolveVer Nothing pdescs = lookup (last $ sortVers $ map fst pdescs) pdescs - resolveVer (Just v) pdescs = lookup v pdescs - -getPackageLatestMajorVersion :: AvailablePackages -> PackageName -> Maybe (Int,Int) -getPackageLatestMajorVersion apkgs pn = versionMajor =<< last <$> getPackageVersions apkgs pn +-- | partiion a list of arguments that refer to package +-- either by their package name, or directly to a cabal file +packageArgs :: [String] -> IO ([PackageName], [FilePath]) +packageArgs args = partitionEithers <$> mapM classifyArgs args + where classifyArgs :: String -> IO (Either PackageName FilePath) + classifyArgs arg = do + existingFile <- doesFileExist arg + return $ if existingFile && hasCabalExtension + then Right arg + else Left $ PackageName arg + where hasCabalExtension = ".cabal" `isSuffixOf` arg foldallLatest :: Monad m => AvailablePackages -> a -> (a -> PackageName -> PackageDescription -> m a) -> m a foldallLatest apkgs acc f = foldM process acc (getAllPackageName apkgs) @@ -153,31 +79,6 @@ Just (Right (pd, _)) -> f a pn pd _ -> return a -loadAvailablePackages :: IO AvailablePackages -loadAvailablePackages = do - tarFile <- readCabalConfig - - foldl' mkMap (AvailablePackages M.empty) . listTar . Tar.read <$> L.readFile tarFile - - where listTar :: Show e => Tar.Entries e -> [([FilePath],L.ByteString)] - listTar (Tar.Next ent nents) = - case Tar.entryContent ent of - Tar.NormalFile bs _ -> (splitPath $ Tar.entryPath ent, bs) : listTar nents - _ -> listTar nents - listTar Tar.Done = [] - listTar (Tar.Fail err) = error ("failed: " ++ show err) - - mkMap :: AvailablePackages -> ([FilePath], L.ByteString) -> AvailablePackages - mkMap (AvailablePackages acc) ([(dropTrailingPathSeparator -> packagename),packageVer,_],entBS) - | packagename == "." = AvailablePackages acc - | otherwise = AvailablePackages $ tweak (PackageName packagename) - (fromString $ dropTrailingPathSeparator packageVer) - entBS acc - where tweak !pname !pver !cfile !m = M.alter alterF pname m - where alterF Nothing = Just [(pver,cfile)] - alterF (Just z) = Just ((pver,cfile) : z) - mkMap nacc _ = nacc - ----------------------------------------------------------------------- generateDotM boxToColor f = do @@ -219,13 +120,14 @@ return [] ----------------------------------------------------------------------- -runCmd (CmdGraph (map PackageName -> hidden) hidePlatform (map PackageName -> pkgs)) = do - availablePackages <- loadAvailablePackages - run availablePackages hidePlatform hidden pkgs +runCmd (CmdGraph (map PackageName -> hidden) hidePlatform rawArgs) = do + (pkgNames, pkgFileNames) <- packageArgs rawArgs + availablePackages <- loadAvailablePackages pkgFileNames + run availablePackages hidePlatform hidden pkgNames ----------------------------------------------------------------------- runCmd (CmdBumpable pkgs) = do - apkgs <- loadAvailablePackages + apkgs <- loadAvailablePackages [] let getPkg n = (fmap fst . finPkgDesc) <$> getPackageDescription apkgs (PackageName n) Nothing bumpables = filter (not . null . snd) $ map checkBump pkgs checkBump pname = case getPkg pname of @@ -243,7 +145,7 @@ ----------------------------------------------------------------------- runCmd (CmdDiff (PackageName -> pname) (fromString -> v1) (fromString -> v2)) = runDiff where runDiff = do - availablePackages <- loadAvailablePackages + availablePackages <- loadAvailablePackages [] let mvers = getPackageVersions availablePackages pname case mvers of Nothing -> error ("no such package : " ++ show pname) @@ -283,23 +185,25 @@ return () ----------------------------------------------------------------------- -runCmd (CmdRevdeps (map PackageName -> args)) - | null args = exitSuccess +runCmd (CmdRevdeps rawArgs) + | null rawArgs = exitSuccess | otherwise = do - availablePackages <- loadAvailablePackages + (pkgNames, pkgFileNames) <- packageArgs rawArgs + availablePackages <- loadAvailablePackages pkgFileNames + founds <- foldallLatest availablePackages [] $ \a pkgname pkgDesc -> do - let found = any (\(Dependency n _) -> n `elem` args) (buildDepends pkgDesc) + let found = any (\(Dependency n _) -> n `elem` pkgNames) (buildDepends pkgDesc) if found then return ((pkgname, pkgDesc):a) else return a forM_ founds $ \(pkgname,pdesc) -> do - let deps = filter (\(Dependency n _) -> n `elem` args) $ buildDepends pdesc + let deps = filter (\(Dependency n _) -> n `elem` pkgNames) $ buildDepends pdesc putStrLn (unPackageName pkgname ++ ": " ++ intercalate ", " (map showDep deps)) where showDep (Dependency p v) = unPackageName p ++ " (" ++ showVerconstr v ++ ")" ----------------------------------------------------------------------- runCmd (CmdInfo (map PackageName -> args)) = do - availablePackages <- loadAvailablePackages + availablePackages <- loadAvailablePackages [] forM_ args $ \arg -> do let vers = maybe (error ("no package " ++ show arg)) id $ getPackageVersions availablePackages arg let pdesc = finPkgDesc <$> getPackageDescription availablePackages arg Nothing @@ -313,11 +217,14 @@ _ -> error "cannot resolve package" ----------------------------------------------------------------------- -runCmd (CmdLicense printTree printSummary (map PackageName -> args)) = do - availablePackages <- loadAvailablePackages - t <- M.fromList . unindexify <$> withGraph (mapM_ (graphLoop (getPackageDependencyNames availablePackages)) args) - foundLicenses <- foldM (loop availablePackages t 0) M.empty args +runCmd (CmdLicense printTree printSummary rawArgs) = do + (pkgNames, pkgFileNames) <- packageArgs rawArgs + availablePackages <- loadAvailablePackages pkgFileNames + + t <- M.fromList . unindexify <$> withGraph (mapM_ (graphLoop (getPackageDependencyNames availablePackages)) pkgNames) + foundLicenses <- foldM (loop availablePackages t 0) M.empty pkgNames + when ((not printTree && not printSummary) || printSummary) $ do putStrLn "== license summary ==" forM_ (map nameAndLength $ group $ sortBy licenseCmp $ map snd $ M.toList foundLicenses) $ \(licenseName, licenseNumb) -> do @@ -362,7 +269,7 @@ ----------------------------------------------------------------------- runCmd (CmdSearch term vals) = do - availablePackages <- loadAvailablePackages + availablePackages <- loadAvailablePackages [] founds <- foldallLatest availablePackages [] $ \a pkgname pkgDesc -> do let found = any (\arg -> contains arg (accessor pkgDesc)) vals if found @@ -376,12 +283,13 @@ ----------------------------------------------------------------------- -runCmd (CmdCheckRevdepsPolicy (map PackageName -> pkgs)) = do - availablePackages <- loadAvailablePackages +runCmd (CmdCheckRevdepsPolicy rawArgs) = do + (pkgNames, pkgFileNames) <- packageArgs rawArgs + availablePackages <- loadAvailablePackages pkgFileNames ret <- foldallLatest availablePackages M.empty $ \accOuter pkgname pkgDesc -> do let deps = buildDepends pkgDesc - foldM (accOnDep availablePackages pkgname) accOuter deps + foldM (accOnDep pkgNames availablePackages pkgname) accOuter deps forM_ (M.toList ret) $ \(p, z) -> do let sums = map (\l -> (head l, length l)) $ group $ sort $ map snd $ M.toList z putStrLn ("== " ++ show p) @@ -390,8 +298,8 @@ forM_ sums $ \(policy, n) -> ppLine 0 $ PP.hcat [PP.string (show n), PP.string " packages have a constraint set to ", showPolicy policy ] return () - where accOnDep allPackages pkg a dep = - case find (== dependencyName dep) pkgs of + where accOnDep pkgNames allPackages pkg a dep = + case find (== dependencyName dep) pkgNames of Nothing -> return a Just packageMatching -> let vr = dependencyConstraints dep @@ -416,18 +324,22 @@ _ | actualPol == pol -> Just actualPol | otherwise -> Just $ Policy_Many (pol:[actualPol]) -runCmd (CmdCheckPolicy (map PackageName -> pkgs)) = do - availablePackages <- loadAvailablePackages - matched <- foldallLatest availablePackages M.empty $ \acc pkgName pkgDesc -> - if pkgName `elem` pkgs - then return $ M.insert pkgName pkgDesc acc +runCmd (CmdCheckPolicy rawArgs) = do + (pkgNames, pkgFileNames) <- packageArgs rawArgs + + availablePackages <- loadAvailablePackages pkgFileNames + + matched <- foldallLatest availablePackages M.empty $ \acc name pkgDesc -> + if name `elem` pkgNames + then return $ M.insert name pkgDesc acc else return acc - forM_ (M.toList matched) $ \(pkgName, pkgDesc) -> do - putStrLn ("== " ++ unPackageName pkgName) - let depends = map (\d -> (dependencyName d, getPolicy availablePackages $ dependencyConstraints d)) - $ buildDepends pkgDesc - let sums = map (\l -> (head l, length l)) $ group $ sort $ map snd depends - forM_ depends $ \(n,p) -> + forM_ (M.toList matched) $ \(name, pkgDesc) -> do + putStrLn ("== " ++ unPackageName name) + let packageDepends = map (\d -> (dependencyName d, getPolicy availablePackages $ dependencyConstraints d)) + $ buildDepends pkgDesc + let sums = map (\l -> (head l, length l)) $ group $ sort $ map snd packageDepends + + forM_ packageDepends $ \(n,p) -> ppLine 4 $ PP.hcat [ PP.string "* ", PP.string (unPackageName n), PP.string " = ", showPolicy p] forM_ sums $ \(policy, n) -> ppLine 2 $ PP.hcat [ showPolicy policy, PP.string " = ", PP.string (show n), PP.string " packages"] diff --git a/Src/Policy.hs b/Src/Policy.hs new file mode 100644 --- /dev/null +++ b/Src/Policy.hs @@ -0,0 +1,39 @@ +module Policy + ( Policy(..) + , getPolicy + , showPolicy + ) where + +import Database +import qualified Text.PrettyPrint.ANSI.Leijen as PP +import Distribution.Version + +data Policy = + Policy_Any -- ^ no bounds + | Policy_LowerBoundOnly -- ^ only a lower specified + | Policy_Bounded -- ^ when both bounds specified but not following the pvp as the version is not correct + | Policy_StrictPVP -- ^ follow the PVP, lower bound, and higher bounds not greater to one that exist. + | Policy_Other -- ^ unspecified + | Policy_Many [Policy] -- ^ multiple policy in the same file. something probably went wrong in cabal-db :) + deriving (Show,Eq,Ord) + +showPolicy :: Policy -> PP.Doc -- String +showPolicy Policy_Any = PP.green $ PP.text "any" +showPolicy Policy_LowerBoundOnly = PP.yellow $ PP.text "lower-bound" +showPolicy Policy_StrictPVP = PP.red $ PP.text "strict-pvp" +showPolicy Policy_Bounded = PP.blue $ PP.text "bounded" +showPolicy Policy_Other = PP.blue $ PP.text "other" +showPolicy (Policy_Many _) = PP.blue $ PP.text "many" + +getPolicy :: AvailablePackages -> VersionRange -> Policy +getPolicy _apkgs vr + | isAnyVersion vr = Policy_Any + | otherwise = + let vi = asVersionIntervals vr + in if and $ map isBounded vi + then Policy_StrictPVP + else Policy_LowerBoundOnly + where + isBounded (_, NoUpperBound) = False + isBounded (_, UpperBound _ _) = True + diff --git a/cabal-db.cabal b/cabal-db.cabal --- a/cabal-db.cabal +++ b/cabal-db.cabal @@ -1,5 +1,5 @@ Name: cabal-db -Version: 0.1.10 +Version: 0.1.11 Synopsis: query tools for the local cabal database Description: Query tool for the local cabal database @@ -38,6 +38,8 @@ Other-modules: Graph , Options , Printing + , Policy + , Database , Env , Ver ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures