cabal-db 0.1.10 → 0.1.11
raw patch · 4 files changed
+214/−146 lines, 4 files
Files
- Src/Database.hs +115/−0
- Src/Main.hs +57/−145
- Src/Policy.hs +39/−0
- cabal-db.cabal +3/−1
+ Src/Database.hs view
@@ -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
Src/Main.hs view
@@ -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"]
+ Src/Policy.hs view
@@ -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+
cabal-db.cabal view
@@ -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