debian-3.14: Debian/Repo/Dependencies.hs
{-# LANGUAGE ScopedTypeVariables, PatternSignatures #-}
-- |This dependency solver determines which binary packages to install
-- in order to satisfy a set of dependency relations. It uses a brute
-- force method, but tweaked to the point where it is usually able to
-- complete on real-world inputs.
--
-- Author: David Fox <dsf@seereason.com>
module Debian.Repo.Dependencies
( simplifyRelations
, solutions
, testArch
) where
import Debian.Control()
import qualified Debian.Control.String as S()
import Debian.Repo.Types
import Data.List
import qualified Data.Map as Map
import Data.Maybe
import Debian.Relation
import Extra.List (cartesianProduct)
type Excuse = String
type ProvidesMap = Map.Map String [BinaryPackage]
-- |A SimpleRelation just specifies a particular version of a package.
-- The Nothing relation is always satisified.
type SimpleRelation = Maybe PkgVersion
-- |Each element is an or-list of specific package versions.
type SimpleRelations = [[SimpleRelation]]
instance PackageVersion BinaryPackage where
pkgName = packageName . packageID
pkgVersion = packageVersion . packageID
-- Does this relation apply to this architecture?
testArch :: Arch -> Relation -> Bool
testArch _ (Rel _ _ Nothing) = True
testArch architecture (Rel _ _ (Just (ArchOnly archList))) = elem architecture (map Binary archList)
testArch architecture (Rel _ _ (Just (ArchExcept archList))) = not (elem architecture (map Binary archList))
-- |Turn the expressive inequality style relations to a set of simple
-- equality relations on only the packages in the available list.
simplifyRelations :: [BinaryPackage]
-> Relations
-> [String] -- ^ Given several alternative packages which satisfy
-- the relation, sort by name in this order.
-> Arch -- ^ The build architecture
-> SimpleRelations
simplifyRelations available relations preferred arch =
-- Sort the or-relations so that
-- 1. the packages named in the preferred list appear before other packages,
-- 2. the newest version appear before the older
map (sortBy prefOrder . reverse . sort) relationsSimplified
where
relationsSimplified = expandVirtual nameMap providesMap relationsOfArch
where
nameMap = listMap (map (\ package -> (packageName (packageID package), package)) available)
providesMap =
listMap (concat (map (\ package ->
let names = packageName (packageID package) : map provides (pProvides package) in
map (\ name -> (name, package)) names) available))
provides [Rel name Nothing Nothing] = name
provides bzzt = error ("Invalid relation in Provides: " ++ show bzzt)
relationsOfArch = filter (/= []) (map (nub . filter (testArch arch)) relations)
prefOrder a b = compare (isPreferred a) (isPreferred b)
where isPreferred = maybe False (flip elem preferred . getName)
-- |Replace all relations by sets of equality relations on the exact
-- package versions which are actually available in the current
-- environment and satisfy the original relation.
expandVirtual :: ProvidesMap -> ProvidesMap -> Relations -> SimpleRelations
expandVirtual nameMap providesMap relations =
map (nub . concat . map expand) relations
where
-- A relation with no version or architecture requirement
-- can be satisfied by a provides or a real package.
expand (Rel name Nothing Nothing) = map eqRel (Map.findWithDefault [] name providesMap)
expand rel@(Rel name _ _) = map eqRel (filter (satisfies rel) (Map.findWithDefault [] name nameMap))
eqRel :: BinaryPackage -> SimpleRelation
eqRel package =
Just (PkgVersion {getName = packageName p, getVersion = packageVersion p})
where p = packageID package
-- Does this package satisfy the relation?
satisfies :: PackageVersion a => Relation -> a -> Bool
satisfies rel pkg = testRel (pkgVersion pkg) rel
-- Does this version satisfy the relation?
testRel _ (Rel _ Nothing _) = True
testRel ver1 (Rel _ (Just (LTE ver2)) _) = not (compare ver1 ver2 == GT)
testRel ver1 (Rel _ (Just (GRE ver2)) _) = not (compare ver1 ver2 == LT)
testRel ver1 (Rel _ (Just (SLT ver2)) _) = compare ver1 ver2 == LT
testRel ver1 (Rel _ (Just (EEQ ver2)) _) = compare ver1 ver2 == EQ
testRel ver1 (Rel _ (Just (SGR ver2)) _) = compare ver1 ver2 == GT
-- |Given a root and a dependency list, return a list of possible
-- solutions to the dependency set. Each solution is a list of
-- package versions which satisfy all the dependencies. Note that if
-- a package is mentioned in two different clauses of the dependency
-- list, both clauses must be satisfied:
--
-- * a (>= 3.0), a (<< 4.0) | b (>= 2.0), c (>= 1.0) becomes
--
-- * a (>= 3.0), a (<< 4.0), c (>= 1.0) OR a (>= 3.0), b (>= 2.0), c (>= 1.0)
--
-- * [[a (>= 3.0)], [a (<< 4.0), b (>= 2.0)], [c (>= 1.0)]] becomes
--
-- * [[a (>= 3.0), a (<< 4.0), c (>= 1.0)], [a (>= 3.0), b (>= 2.0), c (>= 1.0)]]
--
-- So we can use each clause to eliminate packages which cannot
-- satisfy the dependency set.
solutions :: [BinaryPackage] -- ^ The packages available to satisfy dependencies
-> SimpleRelations -- ^ The dependency relations to be satisfied
-> Int -- ^ Give up after this many solutions are computed
-> (Either String [(Int, [BinaryPackage])])
-- ^ On success return the set of packages to install,
-- and the solution's sequence number. Also returns
-- the modified list of dependency relations, with all
-- inequalities replaced by equalities on the particular
-- versions of each package which are available.
solutions available relations limit =
-- Do any of the dependencies require packages that simply don't
-- exist? If so we don't have to search for solutions, there
-- aren't any.
case any (== []) relations of
True -> Left "Unsatisfiable dependencies"
False ->
-- Turn the And-of-Ors dependency list into Or-of-And-of-Ands.
-- Each element of the result represents a an alternative set of
-- constraints which a solution must satisfy. Each element of
-- the alternative is a list of relations on a single package,
-- all of which must be satisfied.
let alternatives = map (map nub . groupByName) (cartesianProduct relations) in
--let versions = map makeVersion available in
-- Find a set of packages that satisfies the dependencies
case solutions' 1 alternatives available of
-- Add more information about the failure to the error message.
Left message ->
let results = map (testAlternative available) (take 20 alternatives) in
let (errors :: [String]) = catMaybes (map (either Just (const Nothing)) results) in
Left (message ++ "\n" ++ intercalate "\n" errors)
Right x -> Right x
where
solutions' :: PackageVersion a => Int -> [[[SimpleRelation]]] -> [a] -> Either String [(Int, [a])]
solutions' _ [] _ = Left "All candidate solutions failed"
solutions' count (alternative : alternatives) available =
if count > limit then
Left ("No solutions found in first " ++ show limit ++ " candidates") else
case testAlternative available alternative of
Left _ ->
solutions' (count + 1) alternatives available
Right solution ->
Right ((count, solution)
: either (const []) id (solutions' (count + 1) alternatives available))
-- |The alternative argument is a possible solution to the dependency
-- problem. Each element of alternative represents the relations on a
-- particular package. So each one needs to be satisfied for the
-- alternative to be satisfied.
testAlternative :: PackageVersion a => [a] -> [[SimpleRelation]] -> Either Excuse [a]
testAlternative available alternative =
--
if all (/= []) solution then
Right (map head solution) else
Left ("Couldn't satisfy these conditions:\n " ++
intercalate "\n " (map show (mask (map (== []) solution) alternative)))
where
solution = map (testPackage available) alternative
mask bits elems = map fst (filter snd (zip elems bits))
-- |Return the list of versions of a package that satisfy all of the
-- relations.
testPackage :: PackageVersion a => [a] -> [SimpleRelation] -> [a]
testPackage available rels = foldl satisfies available rels
where
-- Which of these packages satisfy the relation?
satisfies :: PackageVersion a => [a] -> SimpleRelation -> [a]
satisfies available Nothing = available
satisfies available (Just pkg) = filter same available
where same x = pkgName x == pkgName pkg && pkgVersion x == pkgVersion pkg
groupByName :: [SimpleRelation] -> [[SimpleRelation]]
groupByName relations =
groupBy (\ a b -> compareNames a b == EQ) (sortBy compareNames relations)
where compareNames a b = compare (maybe Nothing (Just . getName) a) (maybe Nothing (Just . getName) b)
-- Turn a list of (k, a) pairs into a map from k -> [a].
listMap :: (Ord k) => [(k, a)] -> Map.Map k [a]
listMap pairs =
foldl insertPair Map.empty pairs
where insertPair m (k,a) = Map.insert k (a : (Map.findWithDefault [] k m)) m