Commit 5e469780 authored by idontgetoutmuch's avatar idontgetoutmuch Committed by Duncan Coutts
Browse files

Create hashes from the solver install plan and pass these to cabal so

that the exact packages are installed rather than letting cabal choose
for itself (potentially choosing the package with the incorrect
hash). Closes: https://github.com/haskell/cabal/issues/1460.
parent 2b108699
......@@ -146,17 +146,17 @@ new os' arch' comp (ConfiguredPackage pkg flags _ deps) result =
Left (BR.BuildFailed _) -> BuildFailed
Left (BR.TestsFailed _) -> TestsFailed
Left (BR.InstallFailed _) -> InstallFailed
Right (BR.BuildOk _ _) -> InstallOk
Right (BR.BuildOk _ _ _) -> InstallOk
convertDocsOutcome = case result of
Left _ -> NotTried
Right (BR.BuildOk BR.DocsNotTried _) -> NotTried
Right (BR.BuildOk BR.DocsFailed _) -> Failed
Right (BR.BuildOk BR.DocsOk _) -> Ok
Right (BR.BuildOk BR.DocsNotTried _ _) -> NotTried
Right (BR.BuildOk BR.DocsFailed _ _) -> Failed
Right (BR.BuildOk BR.DocsOk _ _) -> Ok
convertTestsOutcome = case result of
Left (BR.TestsFailed _) -> Failed
Left _ -> NotTried
Right (BR.BuildOk _ BR.TestsNotTried) -> NotTried
Right (BR.BuildOk _ BR.TestsOk) -> Ok
Right (BR.BuildOk _ BR.TestsNotTried _) -> NotTried
Right (BR.BuildOk _ BR.TestsOk _) -> Ok
cabalInstallID :: PackageIdentifier
cabalInstallID =
......
......@@ -83,7 +83,7 @@ configure verbosity packageDBs repos comp platform conf
configureCommand (const configFlags) extraArgs
Right installPlan -> case InstallPlan.ready installPlan of
[pkg@(ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _) _) _ _ _)] ->
[(pkg@(ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _) _) _ _ _), _)] ->
configurePackage verbosity
(InstallPlan.planPlatform installPlan)
(InstallPlan.planCompiler installPlan)
......
......@@ -492,12 +492,13 @@ linearizeInstallPlan installedPkgIndex plan =
where
next plan' = case InstallPlan.ready plan' of
[] -> Nothing
(pkg:_) -> Just ((pkg, status), plan'')
((pkg ,_):_) -> Just ((pkg, status), plan'')
where
pkgid = packageId pkg
status = packageStatus installedPkgIndex pkg
plan'' = InstallPlan.completed pkgid
(BuildOk DocsNotTried TestsNotTried)
-- FIXME: Should this be Nothing?
(BuildOk DocsNotTried TestsNotTried Nothing)
(InstallPlan.processing [pkg] plan')
--FIXME: This is a bit of a hack,
-- pretending that each package is installed
......@@ -751,7 +752,7 @@ regenerateHaddockIndex verbosity packageDBs comp platform conf
normalUserInstall = (UserPackageDB `elem` packageDBs)
&& all (not . isSpecificPackageDB) packageDBs
installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _)) = True
installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _ _)) = True
installedDocs _ = False
isSpecificPackageDB (SpecificPackageDB _) = True
isSpecificPackageDB _ = False
......@@ -887,14 +888,20 @@ performInstallations verbosity
installLock <- newLock -- serialise installation
cacheLock <- newLock -- serialise access to setup exe cache
executeInstallPlan verbosity jobControl useLogFile installPlan $ \cpkg ->
executeInstallPlan verbosity jobControl useLogFile installPlan $ \cpkg deps ->
installConfiguredPackage platform compid configFlags
cpkg $ \configFlags' src pkg pkgoverride ->
fetchSourcePackage verbosity fetchLimit src $ \src' ->
installLocalPackage verbosity buildLimit (packageId pkg) src' $ \mpath ->
let configFlags'' = configFlags' { configDependencies =
zip
(map packageName $
map Installed.sourcePackageId deps)
(map Installed.installedPackageId deps)
} in
installUnpackedPackage verbosity buildLimit installLock numJobs
(setupScriptOptions installedPkgIndex cacheLock)
miscOptions configFlags' installFlags haddockFlags
miscOptions configFlags'' installFlags haddockFlags
compid platform pkg pkgoverride mpath useLogFile
where
......@@ -994,7 +1001,7 @@ executeInstallPlan :: Verbosity
-> JobControl IO (PackageId, BuildResult)
-> UseLogFile
-> InstallPlan
-> (ConfiguredPackage -> IO BuildResult)
-> (ConfiguredPackage -> [Installed.InstalledPackageInfo] -> IO BuildResult)
-> IO InstallPlan
executeInstallPlan verbosity jobCtl useLogFile plan0 installPkg =
tryNewTasks 0 plan0
......@@ -1007,13 +1014,13 @@ executeInstallPlan verbosity jobCtl useLogFile plan0 installPkg =
sequence_
[ do info verbosity $ "Ready to install " ++ display pkgid
spawnJob jobCtl $ do
buildResult <- installPkg pkg
buildResult <- installPkg pkg deps
return (packageId pkg, buildResult)
| pkg <- pkgs
| (pkg, deps) <- pkgs
, let pkgid = packageId pkg]
let taskCount' = taskCount + length pkgs
plan' = InstallPlan.processing pkgs plan
plan' = InstallPlan.processing (map fst pkgs) plan
waitForTasks taskCount' plan'
waitForTasks taskCount plan = do
......@@ -1240,7 +1247,8 @@ installUnpackedPackage verbosity buildLimit installLock numJobs
withFileContents pkgConfFile $ \pkgConfText ->
case Installed.parseInstalledPackageInfo pkgConfText of
Installed.ParseFailed perror -> error (show perror)
Installed.ParseOk warnings pkgConf -> return (Just pkgConf)
-- FIXME: Should we something with warnings?
Installed.ParseOk _warnings pkgConf -> return (Just pkgConf)
else return Nothing
-- Actual installation
......@@ -1251,7 +1259,7 @@ installUnpackedPackage verbosity buildLimit installLock numJobs
setup Cabal.copyCommand copyFlags
when shouldRegister $ do
setup Cabal.registerCommand registerFlags
return (Right (BuildOk docsResult testsResult))
return (Right (BuildOk docsResult testsResult maybePkgConf))
where
pkgid = packageId pkg
......
......@@ -47,7 +47,8 @@ module Distribution.Client.InstallPlan (
import Distribution.Client.Types
( SourcePackage(packageDescription), ConfiguredPackage(..)
, InstalledPackage, BuildFailure, BuildSuccess, enableStanzas )
, InstalledPackage, BuildFailure, BuildSuccess(..), enableStanzas,
InstalledPackage (..) )
import Distribution.Package
( PackageIdentifier(..), PackageName(..), Package(..), packageName
, PackageFixedDeps(..), Dependency(..) )
......@@ -73,6 +74,7 @@ import Distribution.Client.Utils
( duplicates, duplicatesBy, mergeBy, MergeResult(..) )
import Distribution.Simple.Utils
( comparing, intercalate )
import qualified Distribution.InstalledPackageInfo as Installed
import Data.List
( sort, sortBy )
......@@ -204,15 +206,34 @@ remove shouldRemove plan =
-- configured state and have all their dependencies installed already.
-- The plan is complete if the result is @[]@.
--
ready :: InstallPlan -> [ConfiguredPackage]
ready :: InstallPlan -> [(ConfiguredPackage, [Installed.InstalledPackageInfo])]
ready plan = assert check readyPackages
where
check = if null readyPackages && null processingPackages
check = if null (map fst readyPackages) && null processingPackages
then null configuredPackages
else True
configuredPackages = [ pkg | Configured pkg <- toList plan ]
processingPackages = [ pkg | Processing pkg <- toList plan]
readyPackages = filter (all isInstalled . depends) configuredPackages
readyPackages :: [(ConfiguredPackage, [Installed.InstalledPackageInfo])]
readyPackages = [ (pkg, map getInstalledDeps deps)
| pkg <- configuredPackages
, let deps = depends pkg
, all isInstalled deps
]
getInstalledDeps :: PackageIdentifier -> Installed.InstalledPackageInfo
getInstalledDeps pkg =
case PackageIndex.lookupPackageId (planIndex plan) pkg of
Just (Configured _) -> internalError "guard failed"
Just (Processing _) -> internalError "guard failed"
Just (Failed _ _) -> internalError "guard failed"
Just (PreExisting (InstalledPackage instPkg _)) -> instPkg
Just (Installed _cfgPkg (BuildOk _ _ Nothing)) -> internalError "guard failed"
Just (Installed _cfgPkg (BuildOk _ _ (Just instPkg))) -> instPkg
Nothing -> internalError "guard failed"
isInstalled :: PackageIdentifier -> Bool
isInstalled pkg =
case PackageIndex.lookupPackageId (planIndex plan) pkg of
Just (Configured _) -> False
......
......@@ -187,7 +187,7 @@ data BuildFailure = DependentFailed PackageId
| BuildFailed SomeException
| TestsFailed SomeException
| InstallFailed SomeException
data BuildSuccess = BuildOk DocsResult TestsResult
data BuildSuccess = BuildOk DocsResult TestsResult (Maybe InstalledPackageInfo)
data DocsResult = DocsNotTried | DocsFailed | DocsOk
data TestsResult = TestsNotTried | TestsOk
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment