diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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: diff --git a/Src/Main.hs b/Src/Main.hs --- a/Src/Main.hs +++ b/Src/Main.hs @@ -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 " - (_,_,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 [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 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.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