{-# LANGUAGE LambdaCase #-}
module Main where
import qualified Distribution.Verbosity as Verbosity
import qualified Distribution.ReadE as ReadE
import System.Console.GetOpt
(getOpt, ArgOrder(..), OptDescr(..), ArgDescr(..), usageInfo)
import System.Exit (exitSuccess, exitFailure)
import qualified System.Environment as Env
import System.FilePath
import System.Directory (doesDirectoryExist, doesFileExist,
#if (defined(MIN_VERSION_directory) && MIN_VERSION_directory(1,2,5))
listDirectory
#else
getDirectoryContents
#endif
)
import System.IO (hPutStrLn, stderr)
import System.Process (readProcess)
import Data.Graph.Inductive.Query.DFS (xdfsWith, topsort', scc, components)
import Data.Graph.Inductive.Tree (Gr)
import qualified Data.Graph.Inductive.Graph as Graph
import qualified Control.Monad.Exception.Synchronous as E
import qualified Control.Monad.Trans.Class as T
import qualified Data.Set as Set
import Control.Monad (guard, when, unless)
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
import Data.List (delete, intersperse, stripPrefix)
#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,8,2))
#else
import Control.Applicative ((<$>))
#endif
#if (defined(MIN_VERSION_directory) && MIN_VERSION_directory(1,2,5))
#else
listDirectory :: FilePath -> IO [FilePath]
listDirectory path =
filter f <$> getDirectoryContents path
where f filename = filename /= "." && filename /= ".."
#endif
main :: IO ()
main =
E.resolveT handleException $ do
argv <- T.lift Env.getArgs
let (opts, args, errors) = getOpt Permute options argv
if length args < 2
then T.lift $ help >> exitFailure
else do
let (com:pkgs) = args
unless (null errors) $ E.throwT $ concat errors
unless (com `elem` ["sort", "deps", "rdeps"]) $
E.throwT $ "Unknown command " ++ com
flags <-
E.ExceptionalT $ return $
foldr (=<<)
(return
Flags {optHelp = False,
optVerbosity = Verbosity.silent,
optFormat = package,
optParallel = Nothing,
optBranch = Nothing})
opts
if optHelp flags
then T.lift $ help >> exitSuccess
else runCommand flags com $ map (removeSuffix "/") pkgs
where
help =
Env.getProgName >>= \programName ->
putStrLn
(usageInfo ("Usage: " ++ programName ++
" [OPTIONS] [sort|deps|rdeps] PKG-SPEC-OR-DIR ...") options)
handleException :: String -> IO ()
handleException msg = do
putStrLn $ "Aborted: " ++ msg
exitFailure
findSpec :: Maybe FilePath -> FilePath -> IO (Maybe FilePath)
findSpec mdir file =
if takeExtension file == ".spec"
then checkFile file
else do
dirp <- doesDirectoryExist file
if dirp
then
let dir = maybe file (file </>) mdir
pkg = takeBaseName file in
checkFile $ dir </> pkg ++ ".spec"
else return Nothing
where
checkFile :: FilePath -> IO (Maybe FilePath)
checkFile f = do
e <- doesFileExist f
if e
then return $ Just f
else return Nothing
data Flags =
Flags {
optHelp :: Bool,
optVerbosity :: Verbosity.Verbosity,
optFormat :: SourcePackage -> String,
optParallel :: Maybe String,
optBranch :: Maybe FilePath
}
options :: [OptDescr (Flags -> E.Exceptional String Flags)]
options =
[
Option ['h'] ["help"]
(NoArg (\flags -> return $ flags{optHelp = True}))
"Show options"
, Option ['p'] ["parallel"]
(OptArg
(\mstr flags ->
fmap (\cs -> flags{optParallel = Just cs})
(E.Success (fromMaybe "" mstr)))
"SEPARATOR")
"Display independently buildable groups of packages, optionally with separator"
, Option ['b'] ["branch"]
(ReqArg
(\str flags ->
fmap (\mb -> flags{optBranch = mb})
(E.Success (Just str)))
"BRANCHDIR")
"branch directory"
, Option ['f'] ["format"]
(ReqArg
(\str flags ->
fmap (\select -> flags{optFormat = select}) $
case str of
"package" -> E.Success package
"spec" -> E.Success location
"dir" -> E.Success (takeDirectory . location)
_ ->
E.Exception $
"unknown info type " ++ str)
"KIND")
"output format: 'package' (default), 'spec', or 'dir'"
, Option ['v'] ["verbose"]
(ReqArg
(\str flags ->
fmap (\n -> flags{optVerbosity = n}) $
E.fromEither $
ReadE.runReadE Verbosity.flagToVerbosity str)
"N")
"verbosity level: 0..3"
]
type Package = String
data SourcePackage =
SourcePackage {
location :: FilePath,
package :: Package,
dependencies :: [Package]
}
deriving (Show, Eq)
type Command = String
runCommand :: Flags -> Command -> [Package] -> E.ExceptionalT String IO ()
runCommand flags "sort" pkgs = sortSpecFiles flags pkgs
runCommand flags "deps" pkgs = depsSpecFiles False flags pkgs
runCommand flags "rdeps" pkgs = depsSpecFiles True flags pkgs
runCommand _ _ _ = E.throwT "impossible happened"
createGraphNodes :: Flags -> [Package] -> [Package] ->
E.ExceptionalT String IO (Gr SourcePackage (), [Graph.Node])
createGraphNodes flags pkgs subset = do
unless (all (`elem` pkgs) subset) $
E.throwT "Packages must be in the current directory"
specPaths <- T.lift $ catMaybes <$> mapM (findSpec (optBranch flags)) (filter (/= fromMaybe "" (optParallel flags)) pkgs)
let names = map takeBaseName specPaths
provs <-
T.lift $
mapM (readProvides (optVerbosity flags)) specPaths
let resolves = zip names provs
deps <-
T.lift $
mapM (getDepsSrcResolved (optVerbosity flags) resolves) specPaths
let spkgs = zipWith3 SourcePackage specPaths names deps
graph = getBuildGraph spkgs
checkForCycles graph
let nodes = Graph.labNodes graph
subnodes = mapMaybe (pkgNode nodes) subset
return (graph, subnodes)
where
pkgNode [] _ = Nothing
pkgNode ((i,l):ns) p = if p == package l then Just i else pkgNode ns p
sortSpecFiles :: Flags -> [Package] -> E.ExceptionalT String IO ()
sortSpecFiles flags pkgs = do
(graph, _) <- createGraphNodes flags pkgs []
T.lift $
case optParallel flags of
Just s ->
mapM_ ((putStrLn . unwords . (if null s then id else intersperse s) . map (optFormat flags)) . topsort' . subgraph graph)
(components graph)
Nothing ->
mapM_ (putStrLn . optFormat flags) $ topsort' graph
depsSpecFiles :: Bool -> Flags -> [Package] -> E.ExceptionalT String IO ()
depsSpecFiles rev flags pkgs = do
allpkgs <- T.lift $ listDirectory "."
(graph, nodes) <- createGraphNodes flags allpkgs pkgs
let dir = if rev then Graph.suc' else Graph.pre'
sortSpecFiles flags $ map package $ xdfsWith dir third nodes graph
where
third (_, _, c, _) = c
readProvides :: Verbosity.Verbosity -> FilePath -> IO [String]
readProvides verbose file = do
when (verbose >= Verbosity.verbose) $ hPutStrLn stderr file
pkgs <- lines <$>
rpmspec ["--rpms", "--qf=%{name}\n", "--define", "ghc_version any"] Nothing file
let pkg = takeBaseName file
return $ delete pkg pkgs
getDepsSrcResolved :: Verbosity.Verbosity -> [(String,[String])] -> FilePath -> IO [String]
getDepsSrcResolved verbose provides file =
map (resolveBase provides) <$> do
when (verbose >= Verbosity.verbose) $ hPutStrLn stderr file
-- ignore version bounds
map (head . words) . lines <$>
rpmspec ["--buildrequires", "--define", "ghc_version any"] Nothing file
where
resolveBase :: [(String,[String])] -> String -> String
resolveBase provs br =
case mapMaybe (\ (pkg,subs) -> if br `elem` subs then Just pkg else Nothing) provs of
[] -> br
[p] -> p
ps -> error $ br ++ "is provided by: " ++ unwords ps
removeSuffix :: String -> String -> String
removeSuffix suffix orig =
fromMaybe orig $ stripSuffix suffix orig
where
stripSuffix sf str = reverse <$> stripPrefix (reverse sf) (reverse str)
cmdStdIn :: String -> [String] -> String -> IO String
cmdStdIn c as inp = removeTrailingNewline <$> readProcess c as inp
where
removeTrailingNewline :: String -> String
removeTrailingNewline "" = ""
removeTrailingNewline str =
if last str == '\n'
then init str
else str
cmd :: String -> [String] -> IO String
cmd c as = cmdStdIn c as ""
rpmspec :: [String] -> Maybe String -> FilePath -> IO String
rpmspec args mqf spec = do
let qf = maybe [] (\ q -> ["--queryformat", q]) mqf
cmd "rpmspec" (["-q"] ++ args ++ qf ++ [spec])
getDeps :: Gr SourcePackage () -> [(SourcePackage, [SourcePackage])]
getDeps gr =
let c2dep :: Graph.Context SourcePackage () -> (SourcePackage, [SourcePackage])
c2dep ctx =
(Graph.lab' ctx,
map (Graph.lab' . Graph.context gr) (Graph.pre gr . Graph.node' $ ctx))
in Graph.ufold (\ctx ds -> c2dep ctx : ds) [] gr
getBuildGraph :: [SourcePackage] -> Gr SourcePackage ()
getBuildGraph srcPkgs =
let nodes = zip [0..] srcPkgs
nodeDict = zip (map package srcPkgs) [0..]
edges = do
(srcNode,srcPkg) <- nodes
dstNode <- mapMaybe (`lookup` nodeDict) (dependencies srcPkg)
guard (dstNode /= srcNode)
return (dstNode, srcNode, ())
in Graph.mkGraph nodes edges
checkForCycles ::
Monad m =>
Gr SourcePackage () ->
E.ExceptionalT String m ()
checkForCycles graph =
case getCycles graph of
[] -> return ()
cycles ->
E.throwT $ unlines $
"Cycles in dependencies:" :
map (unwords . map location . nodeLabels graph) cycles
nodeLabels :: Gr a b -> [Graph.Node] -> [a]
nodeLabels graph =
map (fromMaybe (error "node not found in graph") .
Graph.lab graph)
subgraph :: Gr a b -> [Graph.Node] -> Gr a b
subgraph graph nodes =
let nodeSet = Set.fromList nodes
edges = do
from <- nodes
(to, lab) <- Graph.lsuc graph from
guard $ Set.member from nodeSet && Set.member to nodeSet
return (from,to,lab)
in Graph.mkGraph (zip nodes $ nodeLabels graph nodes) edges
getCycles :: Gr a b -> [[Graph.Node]]
getCycles =
filter (\case
_:_:_ -> True
_ -> False)
. scc