cabal-db 0.1.5 → 0.1.6
raw patch · 3 files changed
+131/−128 lines, 3 filesdep +optparse-applicative
Dependencies added: optparse-applicative
Files
- README.md +1/−0
- Src/Main.hs +126/−127
- cabal-db.cabal +4/−1
README.md view
@@ -12,6 +12,7 @@ * search-author: search all the database for match in the author field. * search-maintainer: search all the database for match in the maintainer field. * graph: generate a dot format graph of the dependency+* license: list all licenses used by packages and their dependencies Check the original blog post for more information:
Src/Main.hs view
@@ -5,19 +5,21 @@ import Distribution.PackageDescription hiding (options) import Distribution.Package import Distribution.Compiler+import Distribution.License import Distribution.System import Distribution.Version import Distribution.Text import Text.PrettyPrint import Control.Applicative+import Control.Exception (bracket)+import qualified Control.Exception as E import Control.Monad-import Control.Monad.State -import System.Console.GetOpt import System.Environment import qualified Codec.Archive.Tar as Tar +import System.IO.Error import System.Process import System.Exit import System.Directory@@ -28,7 +30,11 @@ import qualified Data.Map as M import Data.List import Data.Maybe+import Data.Tuple (swap) +import Options+import Graph+ platformPackages = map PackageName $ ["array" ,"base", "bytestring"@@ -90,6 +96,8 @@ finPkgDesc :: GenericPackageDescription -> Either [Dependency] (PackageDescription, FlagAssignment) finPkgDesc = finalizePackageDescription [] (const True) buildPlatform (CompilerId buildCompilerFlavor (Version []{-[7, 6, 2]-} [])) [] +showVerconstr c = render $ Distribution.Text.disp c+ packageDescOfBS bs = case parsePackageDescription $ UTF8.toString bs of ParseFailed _ -> Nothing@@ -155,125 +163,92 @@ ----------------------------------------------------------------------- -data St = St- { nextIndex :: !Int - , indexTable :: M.Map PackageName Int - , depsTable :: M.Map Int [Int]- } deriving (Show,Eq)--resolve pn = get >>= addOrGet- where addOrGet st = maybe (add st) return $ M.lookup pn (indexTable st)- add st = put (st { nextIndex = ni+1, indexTable = M.insert pn ni (indexTable st) }) >> return ni- where ni = nextIndex st--isProcessed pn = M.member pn <$> gets depsTable-modifyDepsTable k f = modify (\st -> st { depsTable = M.alter f k (depsTable st) })-insertDep i j = modifyDepsTable i f- where f Nothing = Just [j]- f (Just z) = Just (j:z)- generateDotM boxToColor f = do- st <- execStateT f (St 1 M.empty M.empty)+ (indexTable, depsTable) <- withGraph f putStrLn "digraph projects {"- forM_ (M.toList $ indexTable st) $ \((PackageName pn), i) -> do+ forM_ (M.toList indexTable) $ \((PackageName pn), i) -> do let extra = case boxToColor (PackageName pn) of Nothing -> "" Just c -> ", style=filled, fillcolor=" ++ c putStrLn (show i ++ " [label=\"" ++ pn ++ "\"" ++ extra ++ "];")- forM_ (M.toList $ depsTable st) $ \(src,dsts) ->+ forM_ (M.toList depsTable) $ \(src,dsts) -> mapM_ (\dst -> putStrLn (show src ++ " -> " ++ show dst ++ ";")) dsts putStrLn "}" -------------------------------------------------------------------------run apkgs hidePlatform hiddenPackages specifiedPackages = generateDotM colorize $ mapM_ (loop 0) specifiedPackages- where colorize pn- | pn `elem` specifiedPackages = Just "red"- | pn `elem` platformPackages = Just "green"- | otherwise = Nothing-- loop :: Int -> PackageName -> StateT St IO ()- loop !depth pn- | depth > 1000 = error "internal error: infinite loop detected"- | otherwise = do- pni <- resolve pn- processed <- isProcessed pni- --liftIO $ putStrLn ("loop: " ++ show pn ++ " processed: " ++ show processed ++ " depth: " ++ show depth)- unless processed $ do- let desc = finPkgDesc <$> getPackageDescription apkgs pn Nothing- case desc of- Just (Right (d,_)) -> do- let depNames = (if hidePlatform- then filter (not . flip elem platformPackages)- else id)- $ filter (/= pn)- $ filter (not . flip elem hiddenPackages)- $ map (\(Dependency n _) -> n) $ buildDepends d- mapM_ (loop (depth+1)) depNames- mapM_ (resolve >=> insertDep pni) depNames- _ -> do- --liftIO $ putStrLn ("warning cannot handle: " ++ show pn ++ " : " ++ show desc)- return ()+unindexify :: (M.Map a GraphIndex, M.Map GraphIndex [GraphIndex]) -> [(a, [a])]+unindexify (aTable, edgeTable) = map (resolveKeyValues resolveIndex) $ M.toList edgeTable+ where resolveKeyValues r (k,l) = (r k, map r l)+ resolveIndex i = maybe (error ("internal error: unknown index: " ++ show i)) id $ M.lookup i idxTable+ idxTable = M.fromList $ map swap $ M.toList aTable ------------------------------------------------------------------------data GraphFlag = Hide String | HidePlatform- deriving (Show,Eq)+run apkgs hidePlatform hiddenPackages specifiedPackages = generateDotM colorize $ mapM_ (graphLoop getDeps) specifiedPackages+ where colorize pn+ | pn `elem` specifiedPackages = Just "red"+ | pn `elem` platformPackages = Just "green"+ | otherwise = Nothing -graphOptions =- [ Option ['h'] ["hide"] (ReqArg Hide "hide package") "package to hide"- , Option [] ["hide-platform"] (NoArg HidePlatform) "hide all packages from the platform"- ]+ getDeps :: PackageName -> IO [PackageName]+ getDeps pn = do+ let desc = finPkgDesc <$> getPackageDescription apkgs pn Nothing+ case desc of+ Just (Right (d,_)) ->+ return+ $ (if hidePlatform then filter (not . flip elem platformPackages) else id)+ $ filter (not . flip elem hiddenPackages)+ $ map (\(Dependency n _) -> n) $ buildDepends d+ _ -> do+ --liftIO $ putStrLn ("warning cannot handle: " ++ show pn ++ " : " ++ show desc)+ return [] -doGraph args =- case getOpt Permute graphOptions args of- (o,n,[]) -> do availablePackages <- loadAvailablePackages- let hidden = foldl' (\acc f ->- case f of- Hide p -> PackageName p : acc- _ -> acc) [] o- let hidePlatform = HidePlatform `elem` o- run availablePackages hidePlatform hidden (map PackageName n)- (_,_,errs) -> putStrLn "error parsing arguments:" >> mapM_ putStrLn errs ------------------------------------------------------------------------diffOptions =- [- ]+runCmd (CmdGraph (map PackageName -> hidden) hidePlatform (map PackageName -> pkgs)) = do+ availablePackages <- loadAvailablePackages+ run availablePackages hidePlatform hidden pkgs -doDiff args =- case getOpt Permute diffOptions args of- (_,n,[]) -> case n of- [pname,v1,v2] -> runDiff (PackageName pname) v1 v2- _ -> error " diff <package-name> <ver1> <ver2>"- (_,_,errs) -> putStrLn "error parsing arguments:" >> mapM_ putStrLn errs- where runDiff pname v1 v2 = do- availablePackages <- loadAvailablePackages- let mvers = getPackageVersions availablePackages pname- case mvers of+-----------------------------------------------------------------------+runCmd (CmdDiff (PackageName -> pname) v1 v2) = runDiff+ where runDiff = do+ availablePackages <- loadAvailablePackages+ let mvers = getPackageVersions availablePackages pname+ case mvers of Nothing -> error ("no such package : " ++ show pname) Just vers -> do when (not $ elem v1 vers) $ error ("package doesn't have version " ++ show v1) when (not $ elem v2 vers) $ error ("package doesn't have version " ++ show v2)- cabalUnpack pname v1- cabalUnpack pname v2- diff pname v1 v2- cleanup pname v1 v2- - cabalUnpack (PackageName pn) v = do- ec <- rawSystem "cabal" ["unpack", pn ++ "-" ++ v]- case ec of- ExitSuccess -> return ()- ExitFailure i -> error ("cabal unpack failed with error code: " ++ show i)- diff (PackageName pn) v1 v2 = do- let dir1 = pn ++ "-" ++ v1- let dir2 = pn ++ "-" ++ v2- _ <- rawSystem "diff" ["-Naur", dir1, dir2]- return ()- cleanup (PackageName pn) v1 v2 = do- mapM_ removeDirectoryRecursive [pn ++ "-" ++ v1, pn ++ "-" ++ v2] -showVerconstr c = render $ Distribution.Text.disp c+ cd <- getCurrentDirectory+ bracket createTempDir (changeAndRemoveDirectory cd) $ \dir -> do+ putStrLn (cd ++ " " ++ dir)+ setCurrentDirectory dir+ cabalUnpack pname v1+ cabalUnpack pname v2+ diff pname+ createTempDir = do+ tmp <- getTemporaryDirectory+ loopCreateDir (tmp ++ "/cabal-db-diff-") (0 :: Int)+ where loopCreateDir prefix i = do+ let dir = prefix ++ show i+ r <- E.try (createDirectory dir)+ case r of+ Left e | isAlreadyExistsError e -> loopCreateDir prefix (i+1)+ | otherwise -> E.throwIO e+ Right () -> return dir+ changeAndRemoveDirectory cd dir =+ setCurrentDirectory cd >> removeDirectoryRecursive dir+ cabalUnpack (PackageName pn) v = do+ ec <- rawSystem "cabal" ["unpack", pn ++ "-" ++ v]+ case ec of+ ExitSuccess -> return ()+ ExitFailure i -> error ("cabal unpack failed with error code: " ++ show i)+ diff (PackageName pn) = do+ let dir1 = pn ++ "-" ++ v1+ let dir2 = pn ++ "-" ++ v2+ _ <- rawSystem "diff" ["-Naur", dir1, dir2]+ return () ------------------------------------------------------------------------doRevDeps (map PackageName -> args)+runCmd (CmdRevdeps (map PackageName -> args)) | null args = exitSuccess | otherwise = do availablePackages <- loadAvailablePackages@@ -288,7 +263,7 @@ where showDep (Dependency p v) = unPackageName p ++ " (" ++ showVerconstr v ++ ")" ------------------------------------------------------------------------doInfo (map PackageName -> args) = do+runCmd (CmdInfo (map PackageName -> args)) = do availablePackages <- loadAvailablePackages forM_ args $ \arg -> do let vers = maybe (error ("no package " ++ show arg)) id $ getPackageVersions availablePackages arg@@ -303,38 +278,62 @@ _ -> error "cannot resolve package" ------------------------------------------------------------------------doSearchBy accessor args = do+runCmd (CmdLicense printTree printSummary (map PackageName -> args)) = do availablePackages <- loadAvailablePackages+ t <- M.fromList . unindexify <$> withGraph (mapM_ (graphLoop (getDeps availablePackages)) args)+ foundLicenses <- foldM (loop availablePackages t 0) M.empty args++ when ((not printTree && not printSummary) || printSummary) $ do+ putStrLn "== license summary =="+ forM_ (map nameAndLength $ group $ sortBy licenseCmp $ map snd $ M.toList foundLicenses) $ \(licenseName, licenseNumb) ->+ putStrLn (ppLicense licenseName ++ ": " ++ show licenseNumb)+ where getDeps apkgs pn = do+ let desc = finPkgDesc <$> getPackageDescription apkgs pn Nothing+ case desc of+ Just (Right (d,_)) -> do+ let deps = map (\(Dependency n _) -> n) $ buildDepends d+ return deps+ _ ->+ return []+ loop apkgs tbl indentSpaces founds pn@(PackageName name)+ | M.member pn founds = return founds+ | otherwise = do+ let desc = finPkgDesc <$> getPackageDescription apkgs pn Nothing+ case desc of+ Just (Right (d,_)) -> do+ let found = license d+ when printTree $ putStrLn (replicate indentSpaces ' ' ++ name ++ ": " ++ ppLicense found)+ case M.lookup pn tbl of+ Just l -> foldM (loop apkgs tbl (indentSpaces + 2)) (M.insert pn found founds) l+ Nothing -> error "internal error"+ _ -> return founds+ licenseCmp l1 l2+ | l1 == l2 = EQ+ | otherwise = compare (show l1) (show l2)++ nameAndLength [] = error "empty group"+ nameAndLength l@(x:_) = (x, length l)++ ppLicense (GPL (Just (Version [v] []))) = "GPLv" ++ show v+ ppLicense (AGPL (Just (Version [v] []))) = "AGPLv" ++ show v+ ppLicense (LGPL (Just (Version [v] []))) = "LGPLv" ++ show v+ ppLicense (Apache (Just (Version [v] []))) = "Apache" ++ show v+ ppLicense (UnknownLicense s) = s+ ppLicense l = show l++-----------------------------------------------------------------------+runCmd (CmdSearch term vals) = do+ availablePackages <- loadAvailablePackages founds <- foldallLatest availablePackages [] $ \a pkgname pkgDesc -> do- let found = any (\arg -> contains arg (accessor pkgDesc)) args+ let found = any (\arg -> contains arg (accessor pkgDesc)) vals if found then return ((pkgname, pkgDesc):a) else return a mapM_ (putStrLn . unPackageName . fst) founds- where contains searching searched = maybe False (const True) $ find (isPrefixOf searching) $ tails searched+ where contains searching searched = maybe False (const True) $ find (isPrefixOf searching) $ tails searched+ accessor = toAccessor term+ toAccessor SearchMaintainer = maintainer+ toAccessor SearchAuthor = author ------------------------------------------------------------------------commands =- [ ("graph", doGraph)- , ("diff", doDiff)- , ("revdeps", doRevDeps)- , ("info", doInfo)- , ("search-author", doSearchBy author)- , ("search-maintainer", doSearchBy maintainer)- ]--usage = do- mapM_ putStrLn- (["usage: cabal-db <command> [args..]"- ,""- ,"known commands:"- ] ++ map ((" " ++) . fst ) commands)- exitFailure--main = do- args <- getArgs- case args of- [] -> usage- cmd:args' -> case lookup cmd commands of- Nothing -> usage- Just f -> f args'+main = getOptions >>= runCmd
cabal-db.cabal view
@@ -1,5 +1,5 @@ Name: cabal-db-Version: 0.1.5+Version: 0.1.6 Synopsis: query tools for the local cabal database (revdeps, graph, info, search-by) Description: Query tool for the local cabal database@@ -11,6 +11,8 @@ * Search by author or maintainer . * Generate graphs of dependencies in dot format+ .+ * List licenses of package and their dependencies License: BSD3 License-file: LICENSE@@ -39,6 +41,7 @@ , utf8-string , pretty , process+ , optparse-applicative Buildable: True source-repository head