module Debian.GenBuildDeps
( DepInfo
, SrcPkgName(..)
, BinPkgName(..)
, buildDependencies
, RelaxInfo(..)
, relaxDeps
, BuildableInfo(..)
, buildable
, compareSource
, orderSource
, genDeps
, failPackage
, getSourceOrder
) where
import Control.Monad (filterM)
import Debian.Control
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 Extra.Either (concatEithers)
import System.Directory (getDirectoryContents, doesFileExist)
import System.IO
newtype SrcPkgName = SrcPkgName PkgName deriving (Show, Eq)
newtype BinPkgName = BinPkgName PkgName deriving (Show, Eq)
type DepInfo = (SrcPkgName,
Relations,
[BinPkgName])
buildDependencies :: Control -> Either String DepInfo
buildDependencies (Control []) = error "Control file seems to be empty"
buildDependencies (Control (source:binaries)) =
either (Left . concat) (\ deps -> Right (sourcePackage, deps, 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 RelaxInfo = RelaxInfo [(BinPkgName, Maybe SrcPkgName)] deriving Show
relaxDeps :: RelaxInfo -> [DepInfo] -> [DepInfo]
relaxDeps relaxInfo deps =
map (relaxDep relaxInfo) deps
where
relaxDep :: RelaxInfo -> DepInfo -> DepInfo
relaxDep relaxInfo (sourceName, relations, binaryNames) =
(sourceName, filteredDependencies, binaryNames)
where
filteredDependencies :: Relations
filteredDependencies = filter (/= []) (map (filter keepDep) relations)
keepDep :: Relation -> Bool
keepDep (Rel name _ _) = not (elem (BinPkgName name) ignored)
ignored = ignoredForSourcePackage sourceName relaxInfo
ignoredForSourcePackage :: SrcPkgName -> RelaxInfo -> [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 :: Show a => (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 (_, depends1, bins1) (_, depends2, 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 _ _) (BinPkgName 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 ( \(pkgName,_,_) -> pkgName) . 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)