module Debian.GenBuildDeps
( DepInfo(..)
, buildDependencies
, RelaxInfo
, relaxDeps
, OldRelaxInfo(..)
, oldRelaxDeps
, BuildableInfo(..)
, buildable
, compareSource
, orderSource
, genDeps
, failPackage
, getSourceOrder
) where
import Control.Monad (filterM)
import Debian.Control
import Data.Either
import Data.Graph (Graph,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.Relation
import System.Directory (getDirectoryContents, doesFileExist)
data DepInfo = DepInfo {
sourceName :: SrcPkgName
, relations :: Relations
, binaryNames :: [BinPkgName]
}
concatEithers :: [Either a b] -> Either [a] [b]
concatEithers xs =
case partitionEithers xs of
([], rs) -> Right rs
(ls, _) -> Left ls
buildDependencies :: Control -> Either String DepInfo
buildDependencies (Control []) = error "Control file seems to be empty"
buildDependencies (Control (source:binaries)) =
either (Left . concat) (\ deps -> Right (DepInfo {sourceName = sourcePackage, relations = deps, binaryNames = bins})) deps
where
sourcePackage = maybe (error "First Paragraph in control file lacks a Source field") SrcPkgName $ assoc "Source" source
deps = either Left (Right . concat) (concatEithers [buildDeps, buildDepsIndep])
buildDeps =
case assoc "Build-Depends" source of
Just v -> either (\ e -> Left ("Error parsing Build-Depends for" ++ show sourcePackage ++ ": " ++ show e)) Right (parseRelations v)
_ -> Right []
buildDepsIndep =
case assoc "Build-Depends-Indep" source of
(Just v) -> either (\ e -> Left ("Error parsing Build-Depends-Indep for" ++ show sourcePackage ++ ": " ++ show e)) Right (parseRelations v)
_ -> Right []
bins = mapMaybe lookupPkgName binaries
lookupPkgName :: Paragraph -> Maybe BinPkgName
lookupPkgName p = maybe Nothing (Just . BinPkgName) (assoc "Package" p)
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 BuildableInfo a
= BuildableInfo
{ readyTriples :: [(a, [a], [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
{ readyTriples = map (makeTriple blocked allReady) allReady,
allBlocked = map ofVertex blocked }
where
makeTriple blocked ready thisReady =
let otherReady = filter (/= thisReady) ready
(directlyBlocked, otherBlocked) = partition (\ x -> elem x (reachable isDep thisReady)) blocked in
(ofVertex thisReady, map ofVertex directlyBlocked, 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 [] edges = edges
f (x : xs) edges = catMaybes (map (toEdge x) xs) ++ edges
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 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 compare failed packages =
let graph = buildGraph compare 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 compare packages =
map (fromJust . vertex) (topSort graph)
where
graph = buildGraph compare packages
vertex n = Map.findWithDefault Nothing n vertexMap
vertexMap = Map.fromList (zip [0..] (map Just packages))
buildGraph :: (a -> a -> Ordering) -> [a] -> Graph
buildGraph compare packages =
let edges = someEdges (zip packages [0..]) in
buildG (0, length packages 1) edges
where
someEdges [] = []
someEdges (a : etc) = aEdges a etc ++ someEdges etc
aEdges (ap, an) etc =
concat (map (\ (bp, bn) ->
case compare 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 (Either String [DepInfo])
genDeps controlFiles =
mapM genDep' controlFiles >>=
return . either (Left . concat) (Right . orderSource compareSource) . concatEithers
where
genDep' :: FilePath -> IO (Either String DepInfo)
genDep' controlPath = parseControlFromFile controlPath >>=
return . either (Left . show) buildDependencies
getSourceOrder :: FilePath -> IO (Either String [SrcPkgName])
getSourceOrder fp =
findControlFiles fp >>=
genDeps >>=
return . either Left (Right . map sourceName . orderSource compareSource)
where
findControlFiles :: FilePath -> IO [FilePath]
findControlFiles root =
getDirectoryContents root >>=
mapM (\ x -> return $ root ++ "/" ++ x ++ "/debian/control") >>=
filterM doesFileExist
assoc :: String -> Paragraph -> Maybe String
assoc name fields = maybe Nothing (\ (Field (_, v)) -> Just (stripWS v)) (lookupP name fields)