module Debian.GenBuildDeps
( DepInfo(..)
, sourceName'
, relations'
, binaryNames'
, buildDependencies
, RelaxInfo
, relaxDeps
, BuildableInfo(..)
, ReadyTarget(..)
, buildable
, compareSource
, orderSource
, genDeps
, failPackage
, getSourceOrder
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Exception (throw)
import Control.Monad (filterM)
import Data.Graph (Graph, Edge, Vertex, buildG, topSort, reachable, transposeG, edges, scc)
import Data.List
import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Set as Set
import Data.Tree as Tree (Tree(Node, rootLabel, subForest))
import Debian.Control (parseControlFromFile)
import Debian.Control.Policy (HasDebianControl, DebianControl, ControlFileError(..), validateDebianControl, debianSourcePackageName, debianBinaryPackageNames, debianBuildDeps, debianBuildDepsIndep)
import Debian.Loc (__LOC__)
import Debian.Relation
import Debian.Relation.Text ()
import System.Directory (getDirectoryContents, doesFileExist)
data DepInfo = DepInfo {
sourceName :: SrcPkgName
, relations :: Relations
, binaryNames :: [BinPkgName]
} deriving Show
instance Eq DepInfo where
a == b = (sourceName a == sourceName b) &&
Set.fromList (map Set.fromList (relations a)) == Set.fromList (map Set.fromList (relations b)) &&
Set.fromList (binaryNames a) == Set.fromList (binaryNames b)
buildDependencies :: HasDebianControl control => control -> DepInfo
buildDependencies control = do
DepInfo { sourceName = debianSourcePackageName control
, relations = concat [fromMaybe [] (debianBuildDeps control),
fromMaybe [] (debianBuildDepsIndep control)]
, binaryNames = debianBinaryPackageNames control }
sourceName' :: HasDebianControl control => control -> SrcPkgName
sourceName' control = debianSourcePackageName control
relations' :: HasDebianControl control => control -> Relations
relations' control = concat [fromMaybe [] (debianBuildDeps control),
fromMaybe [] (debianBuildDepsIndep control)]
binaryNames' :: HasDebianControl control => control -> [BinPkgName]
binaryNames' control = debianBinaryPackageNames control
newtype OldRelaxInfo = RelaxInfo [(BinPkgName, Maybe SrcPkgName)] deriving Show
type RelaxInfo = SrcPkgName -> BinPkgName -> Bool
relaxDeps :: RelaxInfo -> [DepInfo] -> [DepInfo]
relaxDeps relaxInfo deps =
map relaxDep deps
where
relaxDep :: DepInfo -> DepInfo
relaxDep info = info {relations = filteredDependencies}
where
filteredDependencies :: Relations
filteredDependencies = filter (/= []) (map (filter keepDep) (relations info))
keepDep :: Relation -> Bool
keepDep (Rel name _ _) = not (relaxInfo (sourceName info) name)
data ReadyTarget a
= ReadyTarget { ready :: a
, waiting :: [a]
, other :: [a]
}
data BuildableInfo a
= BuildableInfo
{ readyTargets :: [ReadyTarget a]
, allBlocked :: [a] }
| CycleInfo
{ depPairs :: [(a, a)] }
buildable :: forall a. (a -> DepInfo) -> [a] -> BuildableInfo a
buildable relax packages =
case partition (\ x -> reachable hasDep x == [x]) verts of
([], _) -> CycleInfo {depPairs = map ofEdge $ head $ (allCycles hasDep)}
(allReady, blocked) ->
BuildableInfo { readyTargets = map (makeReady blocked allReady) allReady
, allBlocked = map ofVertex blocked }
where
makeReady :: [Vertex] -> [Vertex] -> Vertex -> ReadyTarget a
makeReady blocked ready thisReady =
let otherReady = filter (/= thisReady) ready
(directlyBlocked, otherBlocked) = partition (\ x -> elem x (reachable isDep thisReady)) blocked in
ReadyTarget { ready = ofVertex thisReady
, waiting = map ofVertex directlyBlocked
, other = map ofVertex (otherReady ++ otherBlocked) }
isDep :: Graph
isDep = transposeG hasDep
hasDep :: Graph
hasDep = buildG (0, length packages 1) hasDepEdges
hasDepEdges :: [(Int, Int)]
hasDepEdges =
nub (foldr f [] (tails vertPairs))
where f :: [(Int, DepInfo)] -> [(Int, Int)] -> [(Int, Int)]
f [] es = es
f (x : xs) es = catMaybes (map (toEdge x) xs) ++ es
toEdge :: (Int, DepInfo) -> (Int, DepInfo) -> Maybe Edge
toEdge (xv, xa) (yv, ya) =
case compareSource xa ya of
EQ -> Nothing
LT -> Just (yv, xv)
GT -> Just (xv, yv)
ofEdge :: Edge -> (a, a)
ofEdge (a, b) = (ofVertex a, ofVertex b)
ofVertex :: Int -> a
ofVertex n = fromJust (Map.findWithDefault Nothing n (Map.fromList (zip [0..] (map Just packages))))
verts :: [Int]
verts = map fst vertPairs
vertPairs :: [(Int, DepInfo)]
vertPairs = zip [0..] $ map relax packages
allCycles :: Graph -> [[Edge]]
allCycles g =
concatMap sccCycles (scc g)
where
sccCycles :: Tree Vertex -> [[Edge]]
sccCycles t = mapMaybe addBackEdge (treePaths t)
addBackEdge :: [Vertex] -> Maybe [Edge]
addBackEdge path@(root : _) =
let back = (last path, root) in
if elem back (edges g) then Just (pathEdges (path ++ [root])) else Nothing
treePaths :: Tree a -> [[a]]
treePaths (Node {rootLabel = r, subForest = []}) = [[r]]
treePaths (Node {rootLabel = r, subForest = ts}) = map (r :) (concatMap treePaths ts)
pathEdges :: [a] -> [(a, a)]
pathEdges (v1 : v2 : vs) = (v1, v2) : pathEdges (v2 : vs)
pathEdges _ = []
failPackage :: Eq a => (a -> a -> Ordering) -> a -> [a] -> ([a], [a])
failPackage cmp failed packages =
let graph = buildGraph cmp packages in
let root = elemIndex failed packages in
let victims = maybe [] (map (fromJust . vertex) . reachable graph) root in
partition (\ x -> not . elem x $ victims) packages
where
vertex n = Map.findWithDefault Nothing n vertexMap
vertexMap = Map.fromList (zip [0..] (map Just packages))
orderSource :: (a -> a -> Ordering) -> [a] -> [a]
orderSource cmp packages =
map (fromJust . vertex) (topSort graph)
where
graph = buildGraph cmp packages
vertex n = Map.findWithDefault Nothing n vertexMap
vertexMap = Map.fromList (zip [0..] (map Just packages))
buildGraph :: (a -> a -> Ordering) -> [a] -> Graph
buildGraph cmp packages =
let es = someEdges (zip packages [0..]) in
buildG (0, length packages 1) es
where
someEdges [] = []
someEdges (a : etc) = aEdges a etc ++ someEdges etc
aEdges (ap, an) etc =
concat (map (\ (bp, bn) ->
case cmp ap bp of
LT -> [(an, bn)]
GT -> [(bn, an)]
EQ -> []) etc)
compareSource :: DepInfo -> DepInfo -> Ordering
compareSource (DepInfo {relations = depends1, binaryNames = bins1}) (DepInfo {relations = depends2, binaryNames = bins2})
| any (\rel -> isJust (find (checkPackageNameReq rel) bins2)) (concat depends1) = GT
| any (\rel -> isJust (find (checkPackageNameReq rel) bins1)) (concat depends2) = LT
| otherwise = EQ
where
checkPackageNameReq :: Relation -> BinPkgName -> Bool
checkPackageNameReq (Rel rPkgName _ _) bPkgName = rPkgName == bPkgName
compareSource' :: HasDebianControl control => control -> control -> Ordering
compareSource' control1 control2
| any (\rel -> isJust (find (checkPackageNameReq rel) bins2)) (concat depends1) = GT
| any (\rel -> isJust (find (checkPackageNameReq rel) bins1)) (concat depends2) = LT
| otherwise = EQ
where
bins1 = binaryNames' control1
bins2 = binaryNames' control2
depends1 = relations' control1
depends2 = relations' control2
checkPackageNameReq :: Relation -> BinPkgName -> Bool
checkPackageNameReq (Rel rPkgName _ _) bPkgName = rPkgName == bPkgName
genDeps :: [FilePath] -> IO [DebianControl]
genDeps controlFiles = do
orderSource compareSource' <$> mapM genDep' controlFiles
where
genDep' controlPath = parseControlFromFile controlPath >>=
either (\ x -> throw (ParseRelationsError [$__LOC__] x))
(\ x -> validateDebianControl x >>= either throw return)
getSourceOrder :: FilePath -> IO [SrcPkgName]
getSourceOrder fp =
findControlFiles fp >>= genDeps >>= return . map sourceName'
where
findControlFiles :: FilePath -> IO [FilePath]
findControlFiles root =
getDirectoryContents root >>=
mapM (\ x -> return $ root ++ "/" ++ x ++ "/debian/control") >>=
filterM doesFileExist