module Debian.GenBuildDeps
( DepInfo(..)
, buildDependencies
, RelaxInfo
, relaxDeps
, OldRelaxInfo(..)
, oldRelaxDeps
, BuildableInfo(..)
, ReadyTarget(..)
, buildable
, compareSource
, orderSource
, genDeps
, failPackage
, getSourceOrder
) where
import Control.Applicative ((<$>))
import Control.Exception (throw)
import Control.Monad (filterM)
import Data.Graph (Graph, Edge, buildG, topSort, reachable, transposeG, vertices, edges)
import Data.List
import qualified Data.Map as Map
import Data.Maybe
import qualified Data.Set as Set
import Debian.Control (parseControlFromFile)
import Debian.Control.Policy (HasDebianControl, ControlFileError(..), validateDebianControl, debianSourcePackageName, debianBinaryPackageNames, debianBuildDeps, debianBuildDepsIndep)
import Debian.Loc (__LOC__)
import Debian.Relation
import Debian.Relation.Text ()
import Language.Haskell.TH (Loc)
import System.Directory (getDirectoryContents, doesFileExist)
data DepInfo = DepInfo {
sourceName :: SrcPkgName
, relations :: Relations
, binaryNames :: [BinPkgName]
}
buildDependencies :: HasDebianControl control => control -> DepInfo
buildDependencies control = do
DepInfo { sourceName = debianSourcePackageName control
, relations = concat [fromMaybe [] (debianBuildDeps control),
fromMaybe [] (debianBuildDepsIndep control)]
, binaryNames = debianBinaryPackageNames control }
newtype OldRelaxInfo = RelaxInfo [(BinPkgName, Maybe SrcPkgName)] deriving Show
type RelaxInfo = SrcPkgName -> BinPkgName -> Bool
_makeRelaxInfo :: OldRelaxInfo -> RelaxInfo
_makeRelaxInfo (RelaxInfo xs) srcPkgName binPkgName =
Set.member binPkgName global || maybe False (Set.member binPkgName) (Map.lookup srcPkgName mp)
where
(global :: Set.Set BinPkgName, mp :: Map.Map SrcPkgName (Set.Set BinPkgName)) =
foldr (\ entry (global', mp') ->
case entry of
(b, Just s) -> (global', Map.insertWith Set.union s (Set.singleton b) mp')
(b, Nothing) -> (Set.insert b global', mp')) (Set.empty, Map.empty) xs
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)
oldRelaxDeps :: OldRelaxInfo -> [DepInfo] -> [DepInfo]
oldRelaxDeps 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 (elem name ignored)
ignored = ignoredForSourcePackage (sourceName info) relaxInfo
ignoredForSourcePackage :: SrcPkgName -> OldRelaxInfo -> [BinPkgName]
ignoredForSourcePackage source (RelaxInfo pairs) =
map fst . filter (maybe True (== source) . snd) $ pairs
data ReadyTarget a
= ReadyTarget { ready :: a
, waiting :: [a]
, other :: [a]
}
data BuildableInfo a
= BuildableInfo
{ readyTargets :: [ReadyTarget a]
, allBlocked :: [a] }
| CycleInfo
{ depPairs :: [(a, a)] }
buildable :: (a -> a -> Ordering) -> [a] -> BuildableInfo a
buildable cmp packages =
case partition (\ x -> reachable hasDep x == [x]) verts of
([], _) -> CycleInfo {depPairs = map ofEdge (cycleEdges hasDep)}
(allReady, blocked) ->
BuildableInfo { readyTargets = map (makeReady blocked allReady) allReady
, allBlocked = map ofVertex blocked }
where
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 = buildG (0, length packages 1) edges'
edges' = map (\ (a, b) -> (b, a)) edges''
hasDep = buildG (0, length packages 1) edges''
edges'' :: [(Int, Int)]
edges'' =
nub (foldr f [] (tails vertPairs))
where f [] es = es
f (x : xs) es = catMaybes (map (toEdge x) xs) ++ es
toEdge (xv, xa) (yv, ya) =
case cmp xa ya of
EQ -> Nothing
LT -> Just (yv, xv)
GT -> Just (xv, yv)
ofEdge (a, b) = (ofVertex a, ofVertex b)
ofVertex n = fromJust (Map.findWithDefault Nothing n (Map.fromList (zip [0..] (map Just packages))))
verts :: [Int]
verts = map fst vertPairs
vertPairs = zip [0..] packages
cycleEdges :: Graph -> [Edge]
cycleEdges g =
filter (`elem` (edges g))
(Set.toList (Set.intersection
(Set.fromList (closure g))
(Set.fromList (closure (transposeG g)))))
where
closure g' = concat (map (\ v -> (map (\ u -> (v, u)) (reachable g' v))) (vertices g'))
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
genDeps :: [FilePath] -> IO [DepInfo]
genDeps controlFiles = do
orderSource compareSource <$> mapM genDep' controlFiles
where
genDep' :: FilePath -> IO DepInfo
genDep' controlPath = parseControlFromFile controlPath >>=
either (\ x -> throw (ParseRelationsError [$__LOC__] x))
(\ x -> validateDebianControl x >>= either throw (return . buildDependencies))
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