Skip to content

Commit

Permalink
Solver: Enforce dependencies on executables (fixes haskell#4781).
Browse files Browse the repository at this point in the history
This commit adds two checks to the validation phase of the solver:

1. It checks that each newly chosen package instance contains all executables
   that are required from that package so far.

2. It checks that each new build tool dependency that refers to a previously
   chosen package can be satisfied by the executables in that package.

This commit also fixes a TODO related to solver log messages. Previously, it was
possible for the log to associate an incorrect executable name with a
dependency.
  • Loading branch information
grayjay committed Nov 12, 2017
1 parent 7712505 commit e86f838
Show file tree
Hide file tree
Showing 4 changed files with 123 additions and 50 deletions.
2 changes: 2 additions & 0 deletions cabal-install/Distribution/Solver/Modular/Message.hs
Original file line number Diff line number Diff line change
Expand Up @@ -131,6 +131,8 @@ showFR _ (UnsupportedLanguage lang) = " (conflict: requires " ++ display l
showFR _ (MissingPkgconfigPackage pn vr) = " (conflict: pkg-config package " ++ display pn ++ display vr ++ ", not found in the pkg-config database)"
showFR _ (NewPackageDoesNotMatchExistingConstraint d) = " (conflict: " ++ showConflictingDep d ++ ")"
showFR _ (ConflictingConstraints d1 d2) = " (conflict: " ++ L.intercalate ", " (L.map showConflictingDep [d1, d2]) ++ ")"
showFR _ (NewPackageIsMissingRequiredExe exe dr) = " (does not contain executable " ++ unUnqualComponentName exe ++ ", which is required by " ++ showDependencyReason dr ++ ")"
showFR _ (PackageRequiresMissingExe qpn exe) = " (requires executable " ++ unUnqualComponentName exe ++ " from " ++ showQPN qpn ++ ", but the executable does not exist)"
showFR _ CannotInstall = " (only already installed instances can be used)"
showFR _ CannotReinstall = " (avoiding to reinstall a package with same version but new dependencies)"
showFR _ Shadowed = " (shadowed by another installed package with same version)"
Expand Down
2 changes: 2 additions & 0 deletions cabal-install/Distribution/Solver/Modular/Tree.hs
Original file line number Diff line number Diff line change
Expand Up @@ -100,6 +100,8 @@ data FailReason = UnsupportedExtension Extension
| MissingPkgconfigPackage PkgconfigName VR
| NewPackageDoesNotMatchExistingConstraint ConflictingDep
| ConflictingConstraints ConflictingDep ConflictingDep
| NewPackageIsMissingRequiredExe UnqualComponentName (DependencyReason QPN)
| PackageRequiresMissingExe QPN UnqualComponentName
| CannotInstall
| CannotReinstall
| Shadowed
Expand Down
157 changes: 113 additions & 44 deletions cabal-install/Distribution/Solver/Modular/Validate.hs
Original file line number Diff line number Diff line change
Expand Up @@ -107,6 +107,15 @@ data ValidateState = VS {
saved :: Map QPN (FlaggedDeps QPN),

pa :: PreAssignment,

-- Map from package name to the executables that are provided by the chosen
-- instance of that package.
availableExes :: Map QPN [UnqualComponentName],

-- Map from package name to the executables that are required from that
-- package.
requiredExes :: Map QPN ExeDeps,

qualifyOptions :: QualifyOptions
}

Expand All @@ -127,17 +136,28 @@ type PPreAssignment = Map QPN MergedPkgDep
-- | A dependency on a package, including its DependencyReason.
data PkgDep = PkgDep (DependencyReason QPN) (Maybe UnqualComponentName) QPN CI

-- | Map from executable name to one of the reasons that the executable is
-- required.
type ExeDeps = Map UnqualComponentName (DependencyReason QPN)

-- | MergedPkgDep records constraints about the instances that can still be
-- chosen, and in the extreme case fixes a concrete instance. Otherwise, it is a
-- list of version ranges paired with the goals / variables that introduced
-- them. It also records whether a package is a build-tool dependency, for use
-- in log messages.
-- them. It also records whether a package is a build-tool dependency, for each
-- reason that it was introduced.
--
-- It is important to store the executable name with the version constraint, for
-- error messages, because whether something is a build-tool dependency affects
-- its qualifier, which affects which constraint is applied.
data MergedPkgDep =
MergedDepFixed (Maybe UnqualComponentName) (DependencyReason QPN) I
| MergedDepConstrained (Maybe UnqualComponentName) [VROrigin]
| MergedDepConstrained [VROrigin]

-- | Version ranges paired with origins.
type VROrigin = (VR, DependencyReason QPN)
type VROrigin = (VR, Maybe UnqualComponentName, DependencyReason QPN)

-- | The information needed to create a 'Fail' node.
type Conflict = (ConflictSet, FailReason)

validate :: Tree d c -> Validate (Tree d c)
validate = cata go
Expand Down Expand Up @@ -184,9 +204,11 @@ validate = cata go
pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs
idx <- asks index -- obtain the index
svd <- asks saved -- obtain saved dependencies
aExes <- asks availableExes
rExes <- asks requiredExes
qo <- asks qualifyOptions
-- obtain dependencies and index-dictated exclusions introduced by the choice
let (PInfo deps _ _ mfr) = idx ! pn ! i
let (PInfo deps exes _ mfr) = idx ! pn ! i
-- qualify the deps in the current scope
let qdeps = qualifyDeps qo qpn deps
-- the new active constraints are given by the instance we have chosen,
Expand All @@ -200,11 +222,22 @@ validate = cata go
case mfr of
Just fr -> -- The index marks this as an invalid choice. We can stop.
return (Fail (varToConflictSet (P qpn)) fr)
_ -> case mnppa of
Left (c, fr) -> -- We have an inconsistency. We can stop.
return (Fail c fr)
Right nppa -> -- We have an updated partial assignment for the recursive validation.
local (\ s -> s { pa = PA nppa pfa psa, saved = nsvd }) r
Nothing ->
let newDeps :: Either Conflict (PPreAssignment, Map QPN ExeDeps)
newDeps = do
nppa <- mnppa
rExes' <- extendRequiredExes aExes rExes newactives
checkExesInNewPackage rExes qpn exes
return (nppa, rExes')
in case newDeps of
Left (c, fr) -> -- We have an inconsistency. We can stop.
return (Fail c fr)
Right (nppa, rExes') -> -- We have an updated partial assignment for the recursive validation.
local (\ s -> s { pa = PA nppa pfa psa
, saved = nsvd
, availableExes = M.insert qpn exes aExes
, requiredExes = rExes'
}) r

-- What to do for flag nodes ...
goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
Expand All @@ -213,7 +246,9 @@ validate = cata go
extSupported <- asks supportedExt -- obtain the supported extensions
langSupported <- asks supportedLang -- obtain the supported languages
pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs
svd <- asks saved -- obtain saved dependencies
svd <- asks saved -- obtain saved dependencies
aExes <- asks availableExes
rExes <- asks requiredExes
-- Note that there should be saved dependencies for the package in question,
-- because while building, we do not choose flags before we see the packages
-- that define them.
Expand All @@ -226,10 +261,13 @@ validate = cata go
-- We now try to get the new active dependencies we might learn about because
-- we have chosen a new flag.
let newactives = extractNewDeps (F qfn) b npfa psa qdeps
mNewRequiredExes = extendRequiredExes aExes rExes newactives
-- As in the package case, we try to extend the partial assignment.
case extend extSupported langSupported pkgPresent newactives ppa of
Left (c, fr) -> return (Fail c fr) -- inconsistency found
Right nppa -> local (\ s -> s { pa = PA nppa npfa psa }) r
let mnppa = extend extSupported langSupported pkgPresent newactives ppa
case liftM2 (,) mnppa mNewRequiredExes of
Left (c, fr) -> return (Fail c fr) -- inconsistency found
Right (nppa, rExes') ->
local (\ s -> s { pa = PA nppa npfa psa, requiredExes = rExes' }) r

-- What to do for stanza nodes (similar to flag nodes) ...
goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c)
Expand All @@ -238,7 +276,9 @@ validate = cata go
extSupported <- asks supportedExt -- obtain the supported extensions
langSupported <- asks supportedLang -- obtain the supported languages
pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs
svd <- asks saved -- obtain saved dependencies
svd <- asks saved -- obtain saved dependencies
aExes <- asks availableExes
rExes <- asks requiredExes
-- Note that there should be saved dependencies for the package in question,
-- because while building, we do not choose flags before we see the packages
-- that define them.
Expand All @@ -251,10 +291,28 @@ validate = cata go
-- We now try to get the new active dependencies we might learn about because
-- we have chosen a new flag.
let newactives = extractNewDeps (S qsn) b pfa npsa qdeps
mNewRequiredExes = extendRequiredExes aExes rExes newactives
-- As in the package case, we try to extend the partial assignment.
case extend extSupported langSupported pkgPresent newactives ppa of
Left (c, fr) -> return (Fail c fr) -- inconsistency found
Right nppa -> local (\ s -> s { pa = PA nppa pfa npsa }) r
let mnppa = extend extSupported langSupported pkgPresent newactives ppa
case liftM2 (,) mnppa mNewRequiredExes of
Left (c, fr) -> return (Fail c fr) -- inconsistency found
Right (nppa, rExes') ->
local (\ s -> s { pa = PA nppa pfa npsa, requiredExes = rExes' }) r

-- | Check that a newly chosen package instance contains all executables that
-- are required from that package so far.
checkExesInNewPackage :: Map QPN ExeDeps
-> QPN
-> [UnqualComponentName]
-> Either Conflict ()
checkExesInNewPackage required qpn providedExes =
case M.toList $ deleteKeys providedExes (M.findWithDefault M.empty qpn required) of
(missingExe, dr) : _ -> let cs = CS.insert (P qpn) $ dependencyReasonToCS dr
in Left (cs, NewPackageIsMissingRequiredExe missingExe dr)
[] -> Right ()
where
deleteKeys :: Ord k => [k] -> Map k v -> Map k v
deleteKeys ks m = L.foldr M.delete m ks

-- | We try to extract as many concrete dependencies from the given flagged
-- dependencies as possible. We make use of all the flag knowledge we have
Expand Down Expand Up @@ -314,12 +372,11 @@ extend :: (Extension -> Bool) -- ^ is a given extension supported
-> (PkgconfigName -> VR -> Bool) -- ^ is a given pkg-config requirement satisfiable
-> [LDep QPN]
-> PPreAssignment
-> Either (ConflictSet, FailReason) PPreAssignment
-> Either Conflict PPreAssignment
extend extSupported langSupported pkgPresent newactives ppa = foldM extendSingle ppa newactives
where

extendSingle :: PPreAssignment -> LDep QPN
-> Either (ConflictSet, FailReason) PPreAssignment
extendSingle :: PPreAssignment -> LDep QPN -> Either Conflict PPreAssignment
extendSingle a (LDep dr (Ext ext )) =
if extSupported ext then Right a
else Left (dependencyReasonToCS dr, UnsupportedExtension ext)
Expand All @@ -330,18 +387,16 @@ extend extSupported langSupported pkgPresent newactives ppa = foldM extendSingle
if pkgPresent pn vr then Right a
else Left (dependencyReasonToCS dr, MissingPkgconfigPackage pn vr)
extendSingle a (LDep dr (Dep mExe qpn ci)) =
let mergedDep = M.findWithDefault (MergedDepConstrained Nothing []) qpn a
let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn a
in case (\ x -> M.insert qpn x a) <$> merge mergedDep (PkgDep dr mExe qpn ci) of
Left (c, (d, d')) -> Left (c, ConflictingConstraints d d')
Right x -> Right x

-- | Extend a package preassignment with a package choice. For example, when
-- the solver chooses foo-2.0, it tries to add the constraint foo==2.0.
extendWithPackageChoice :: PI QPN
-> PPreAssignment
-> Either (ConflictSet, FailReason) PPreAssignment
extendWithPackageChoice :: PI QPN -> PPreAssignment -> Either Conflict PPreAssignment
extendWithPackageChoice (PI qpn i) ppa =
let mergedDep = M.findWithDefault (MergedDepConstrained Nothing []) qpn ppa
let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn ppa
newChoice = PkgDep (DependencyReason qpn [] []) Nothing qpn (Fixed i)
in case (\ x -> M.insert qpn x ppa) <$> merge mergedDep newChoice of
Left (c, (d, _d')) -> -- Don't include the package choice in the
Expand Down Expand Up @@ -372,48 +427,60 @@ merge ::
#endif
MergedPkgDep -> PkgDep -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
merge (MergedDepFixed mExe1 vs1 i1) (PkgDep vs2 mExe2 p ci@(Fixed i2))
| i1 == i2 = Right $ MergedDepFixed (mergeExes mExe1 mExe2) vs1 i1
| i1 == i2 = Right $ MergedDepFixed mExe1 vs1 i1
| otherwise =
Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2
, ( ConflictingDep vs1 mExe1 p (Fixed i1)
, ConflictingDep vs2 mExe2 p ci ) )

merge (MergedDepFixed mExe1 vs1 i@(I v _)) (PkgDep vs2 mExe2 p ci@(Constrained vr))
| checkVR vr v = Right $ MergedDepFixed (mergeExes mExe1 mExe2) vs1 i
| checkVR vr v = Right $ MergedDepFixed mExe1 vs1 i
| otherwise =
Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2
, ( ConflictingDep vs1 mExe1 p (Fixed i)
, ConflictingDep vs2 mExe2 p ci ) )

merge (MergedDepConstrained mExe1 vrOrigins) (PkgDep vs2 mExe2 p ci@(Fixed i@(I v _))) =
merge (MergedDepConstrained vrOrigins) (PkgDep vs2 mExe2 p ci@(Fixed i@(I v _))) =
go vrOrigins -- I tried "reverse vrOrigins" here, but it seems to slow things down ...
where
go :: [VROrigin] -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep
go [] = Right (MergedDepFixed (mergeExes mExe1 mExe2) vs2 i)
go ((vr, vs1) : vros)
go [] = Right (MergedDepFixed mExe2 vs2 i)
go ((vr, mExe1, vs1) : vros)
| checkVR vr v = go vros
| otherwise =
Left ( (CS.union `on` dependencyReasonToCS) vs1 vs2
, ( ConflictingDep vs1 mExe1 p (Constrained vr)
, ConflictingDep vs2 mExe2 p ci ) )

merge (MergedDepConstrained mExe1 vrOrigins) (PkgDep vs2 mExe2 _ (Constrained vr)) =
Right (MergedDepConstrained (mergeExes mExe1 mExe2) $
merge (MergedDepConstrained vrOrigins) (PkgDep vs2 mExe2 _ (Constrained vr)) =
Right (MergedDepConstrained $

-- TODO: This line appends the new version range, to preserve the order used
-- before a refactoring. Consider prepending the version range, if there is
-- no negative performance impact.
vrOrigins ++ [(vr, vs2)])

-- TODO: This function isn't correct, because cabal may need to build libs
-- and/or multiple exes for a package. The merged value is only used to
-- determine whether to print the name of an exe next to conflicts in log
-- message, though. It should be removed when component-based solving is
-- implemented.
mergeExes :: Maybe UnqualComponentName
-> Maybe UnqualComponentName
-> Maybe UnqualComponentName
mergeExes = (<|>)
vrOrigins ++ [(vr, mExe2, vs2)])

-- | Takes a list of new dependencies and uses it to try to update the map of
-- known executable dependencies. It returns a failure when a new dependency
-- requires an executable that is missing from one of the previously chosen
-- packages.
extendRequiredExes :: Map QPN [UnqualComponentName]
-> Map QPN ExeDeps
-> [LDep QPN]
-> Either Conflict (Map QPN ExeDeps)
extendRequiredExes available = foldM extendSingle
where
extendSingle :: Map QPN ExeDeps -> LDep QPN -> Either Conflict (Map QPN ExeDeps)
extendSingle required (LDep dr (Dep (Just exe) qpn _)) =
let exeDeps = M.findWithDefault M.empty qpn required
in -- Only check for the existence of the exe if its package has already
-- been chosen.
case M.lookup qpn available of
Just exes
| L.notElem exe exes -> let cs = CS.insert (P qpn) (dependencyReasonToCS dr)
in Left (cs, PackageRequiresMissingExe qpn exe)
_ -> Right $ M.insertWith' M.union qpn (M.insert exe dr exeDeps) required
extendSingle required _ = Right required

-- | Interface.
validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree d c -> Tree d c
Expand All @@ -428,5 +495,7 @@ validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS {
, index = idx
, saved = M.empty
, pa = PA M.empty M.empty M.empty
, availableExes = M.empty
, requiredExes = M.empty
, qualifyOptions = defaultQualifyOptions idx
}
Original file line number Diff line number Diff line change
Expand Up @@ -1239,7 +1239,7 @@ dbBJ8 = [
-------------------------------------------------------------------------------}
dbBuildTools1 :: ExampleDb
dbBuildTools1 = [
Right $ exAv "alex" 1 [],
Right $ exAv "alex" 1 [] `withExe` ExExe "alex" [],
Right $ exAv "A" 1 [ExBuildToolAny "alex"]
]

Expand All @@ -1253,8 +1253,8 @@ dbBuildTools2 = [
-- Test that we can solve for different versions of executables
dbBuildTools3 :: ExampleDb
dbBuildTools3 = [
Right $ exAv "alex" 1 [],
Right $ exAv "alex" 2 [],
Right $ exAv "alex" 1 [] `withExe` ExExe "alex" [],
Right $ exAv "alex" 2 [] `withExe` ExExe "alex" [],
Right $ exAv "A" 1 [ExBuildToolFix "alex" 1],
Right $ exAv "B" 1 [ExBuildToolFix "alex" 2],
Right $ exAv "C" 1 [ExAny "A", ExAny "B"]
Expand All @@ -1263,7 +1263,7 @@ dbBuildTools3 = [
-- Test that exe is not related to library choices
dbBuildTools4 :: ExampleDb
dbBuildTools4 = [
Right $ exAv "alex" 1 [ExFix "A" 1],
Right $ exAv "alex" 1 [ExFix "A" 1] `withExe` ExExe "alex" [],
Right $ exAv "A" 1 [],
Right $ exAv "A" 2 [],
Right $ exAv "B" 1 [ExBuildToolFix "alex" 1, ExFix "A" 2]
Expand All @@ -1272,8 +1272,8 @@ dbBuildTools4 = [
-- Test that build-tools on build-tools works
dbBuildTools5 :: ExampleDb
dbBuildTools5 = [
Right $ exAv "alex" 1 [],
Right $ exAv "happy" 1 [ExBuildToolAny "alex"],
Right $ exAv "alex" 1 [] `withExe` ExExe "alex" [],
Right $ exAv "happy" 1 [ExBuildToolAny "alex"] `withExe` ExExe "happy" [],
Right $ exAv "A" 1 [ExBuildToolAny "happy"]
]

Expand Down

0 comments on commit e86f838

Please sign in to comment.