module Debian.Apt.Dependencies
where
import Control.Arrow (second)
import qualified Data.ByteString.Char8 as C
import Data.List as List (find, union)
import Data.Tree(Tree(rootLabel, Node))
import Debian.Apt.Package(PackageNameMap, packageNameMap, lookupPackageByRel)
import Debian.Control.ByteString(ControlFunctions(stripWS, lookupP, parseControlFromFile),
Field'(Field, Comment), Control'(Control), Paragraph, Control)
import Debian.Relation (BinPkgName(..))
import Debian.Relation.ByteString(ParseRelations(..), Relation(..), OrRelation, AndRelation, Relations, checkVersionReq)
import Debian.Version(DebianVersion, parseDebianVersion, prettyDebianVersion)
import Text.PrettyPrint (render)
data Status
= Remaining AndRelation
| MissingDep Relation
| Complete
deriving (Eq)
type State a = (Status, [a])
complete :: State a -> Bool
complete (Complete, _) = True
complete _ = False
data CSP a
= CSP { pnm :: PackageNameMap a
, relations :: Relations
, depFunction :: (a -> Relations)
, conflicts :: a -> Relations
, packageVersion :: a -> (BinPkgName, DebianVersion)
}
controlCSP :: Control -> Relations -> (Paragraph -> Relations) -> CSP Paragraph
controlCSP (Control paragraphs) rels depF' =
CSP { pnm = packageNameMap getName paragraphs
, relations = rels
, depFunction = depF'
, conflicts = conflicts'
, packageVersion = packageVersionParagraph
}
where
getName :: Paragraph -> BinPkgName
getName p = case lookupP "Package" p of
Nothing -> error "Missing Package field"
Just (Field (_,n)) -> BinPkgName (C.unpack (stripWS n))
Just (Comment _) -> error "controlCSP"
conflicts' :: Paragraph -> Relations
conflicts' p =
case lookupP "Conflicts" p of
Nothing -> []
Just (Field (_, c)) -> either (error . show) id (parseRelations c)
Just (Comment _) -> error "controlCSP"
testCSP :: FilePath -> (Paragraph -> Relations) -> String -> (CSP Paragraph -> IO a) -> IO a
testCSP controlFile depf relationStr cspf =
do c' <- parseControlFromFile controlFile
case c' of
Left e -> error (show e)
Right control@(Control _) ->
case parseRelations relationStr of
Left e -> error (show e)
Right r ->
cspf (controlCSP control r depf)
depF :: Paragraph -> Relations
depF p =
let preDepends =
case lookupP "Pre-Depends" p of
Nothing -> []
Just (Field (_,pd)) ->
either (error . show) id (parseRelations pd)
Just (Comment _) -> error "depF"
depends =
case lookupP "Depends" p of
Nothing -> []
Just (Field (_,pd)) ->
either (error . show) id (parseRelations pd)
Just (Comment _) -> error "depF"
in
preDepends ++ depends
sidPackages = "/var/lib/apt/lists/ftp.debian.org_debian_dists_unstable_main_binary-i386_Packages"
gutsyPackages = "/var/lib/apt/lists/mirror.anl.gov_pub_ubuntu_dists_gutsy_main_binary-i386_Packages"
test controlFP rel labeler =
testCSP controlFP depF rel (mapM_ (\ (_,p) -> mapM_ (print . second (render . prettyDebianVersion) . packageVersionParagraph) p ) . take 1 . search labeler)
packageVersionParagraph :: Paragraph -> (BinPkgName, DebianVersion)
packageVersionParagraph p =
case lookupP "Package" p of
Nothing -> error $ "Paragraph missing Package field"
(Just (Field (_, name))) ->
case lookupP "Version" p of
Nothing -> error $ "Paragraph missing Version field"
(Just (Field (_, version))) -> (BinPkgName (C.unpack (stripWS name)), parseDebianVersion (C.unpack version))
(Just (Comment _)) -> error "packageVersionParagraph"
(Just (Comment _)) -> error "packageVersionParagraph"
conflict :: CSP p -> p -> p -> Bool
conflict csp p1 p2 =
let (name1, version1) = (packageVersion csp) p1
(name2, version2) = (packageVersion csp) p2
in
if name1 == name2
then version1 /= version2
else
any (conflict' (name1, version1)) (concat $ (conflicts csp) p2) ||
any (conflict' (name2, version2)) (concat $ (conflicts csp) p1)
conflict' :: (BinPkgName, DebianVersion) -> Relation -> Bool
conflict' (pName, pVersion) (Rel pkgName mVersionReq _) =
(pName == pkgName) && (checkVersionReq mVersionReq (Just pVersion))
mkTree :: a -> [Tree a] -> Tree a
mkTree = Node
label :: Tree a -> a
label = rootLabel
initTree :: (a -> [a]) -> a -> Tree a
initTree f a = Node a (map (initTree f) (f a))
mapTree :: (a -> b) -> Tree a -> Tree b
mapTree = fmap
foldTree :: (a -> [b] -> b) -> Tree a -> b
foldTree f (Node a ts) = f a (map (foldTree f) ts)
zipTreesWith :: (a -> b -> c) -> Tree a -> Tree b -> Tree c
zipTreesWith f (Node a ts) (Node b us) =
Node (f a b) (zipWith (zipTreesWith f) ts us)
prune :: (a -> Bool) -> Tree a -> Tree a
prune p = foldTree f
where f a ts = Node a (filter (not . p . label) ts)
leaves :: Tree a -> [a]
leaves = foldTree f
where f leaf [] = [leaf]
f _ ts = concat ts
inhTree :: (b -> a -> b) -> b -> Tree a -> Tree b
inhTree f b (Node a ts) = Node b' (map (inhTree f b') ts)
where b' = f b a
distrTree :: (a -> [b]) -> b -> Tree a -> Tree b
distrTree f b (Node a ts) = Node b (zipWith (distrTree f) (f a) ts)
mkSearchTree :: forall a. CSP a -> Tree (State a)
mkSearchTree csp =
Node (Remaining (relations csp),[]) (andRelation ([],[]) (relations csp))
where
andRelation :: ([a],AndRelation) -> AndRelation -> [Tree (State a)]
andRelation (candidates,[]) [] = [Node (Complete, candidates) []]
andRelation (candidates,remaining) [] = andRelation (candidates, []) remaining
andRelation (candidates, remaining) (x:xs) =
orRelation (candidates, xs ++ remaining) x
orRelation :: ([a],AndRelation) -> OrRelation -> [Tree (State a)]
orRelation acc x =
concat (fmap (relation acc) x)
relation :: ([a],AndRelation) -> Relation -> [Tree (State a)]
relation acc@(candidates,_) rel =
let packages = lookupPackageByRel (pnm csp) (packageVersion csp) rel in
case packages of
[] -> [Node (MissingDep rel, candidates) []]
_ -> map (package acc) packages
package :: ([a],AndRelation) -> a -> Tree (State a)
package (candidates, remaining) p =
if ((packageVersion csp) p) `elem` (map (packageVersion csp) candidates)
then if null remaining
then Node (Complete, candidates) []
else Node (Remaining remaining, candidates) (andRelation (candidates, []) remaining)
else Node (Remaining remaining, (p : candidates)) (andRelation ((p : candidates), remaining) ((depFunction csp) p))
earliestInconsistency :: CSP a -> State a -> Maybe ((BinPkgName, DebianVersion), (BinPkgName, DebianVersion))
earliestInconsistency _ (_,[]) = Nothing
earliestInconsistency _ (_,[_p]) = Nothing
earliestInconsistency csp (_,(p:ps)) =
case find ((conflict csp) p) (reverse ps) of
Nothing -> Nothing
(Just conflictingPackage) -> Just ((packageVersion csp) p, (packageVersion csp) conflictingPackage)
type ConflictSet = ([(BinPkgName, DebianVersion)],[Relation])
isConflict :: ConflictSet -> Bool
isConflict ([],[]) = False
isConflict _ = True
solutions :: Tree (State a, ConflictSet) -> [State a]
solutions = filter complete . map fst . leaves . prune (isConflict . snd)
type Labeler a = CSP a -> Tree (State a) -> Tree (State a, ConflictSet)
search :: Labeler a -> CSP a -> [State a]
search labeler csp = (solutions . (labeler csp) . mkSearchTree) csp
bt :: Labeler a
bt csp = mapTree f
where
f s@(status,_) =
case status of
(MissingDep rel) -> (s, ([], [rel]))
_ ->
(s,
case (earliestInconsistency csp) s of
Nothing -> ([],[])
Just (a,b) -> ([a,b], []))
bj :: CSP p -> Tree (State p, ConflictSet) -> Tree (State p, ConflictSet)
bj csp = foldTree f
where f (s, cs) ts
| isConflict cs = mkTree (s, cs) ts
| otherwise = mkTree (s, cs') ts
where cs' =
let set = combine csp (map label ts) [] in
set `seq` set
unionCS :: [ConflictSet] -> ConflictSet
unionCS css = foldr (\(c1, m1) (c2, m2) -> ((c1 `union` c2), (m1 `union` m2))) ([],[]) css
combine :: CSP p -> [(State p, ConflictSet)] -> [ConflictSet] -> ConflictSet
combine _ [] acc = unionCS acc
combine csp ((s,cs@(c,m)):ns) acc
| (not (lastvar `elem` c)) && null m = cs
| null c && null m = ([],[])
| otherwise = combine csp ns ((c, m):acc)
where lastvar =
let (_,(p:_)) = s in (packageVersion csp) p