Commit b75a1624 authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Planning and building phases use the new store functions

This should mean that concurrent updates to the store are now safe.
In practice it means working on separate projects at the same time is
safe, not concurrent builds within the same project.
parent 0a3c9623
......@@ -41,6 +41,7 @@ import Distribution.Client.ProjectConfig
import Distribution.Client.ProjectPlanning
import Distribution.Client.ProjectPlanning.Types
import Distribution.Client.ProjectBuilding.Types
import Distribution.Client.Store
import Distribution.Client.Types
hiding (BuildOutcomes, BuildOutcome,
......@@ -64,15 +65,15 @@ import Distribution.Package hiding (InstalledPackageId, installedPacka
import qualified Distribution.PackageDescription as PD
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import qualified Distribution.InstalledPackageInfo as Installed
import qualified Distribution.Simple.InstallDirs as InstallDirs
import Distribution.Types.BuildType
import Distribution.Simple.Program
import qualified Distribution.Simple.Setup as Cabal
import Distribution.Simple.Command (CommandUI)
import qualified Distribution.Simple.Register as Cabal
import qualified Distribution.Simple.InstallDirs as InstallDirs
import Distribution.Simple.LocalBuildInfo (ComponentName)
import Distribution.Simple.Compiler
( Compiler, PackageDB(..) )
( Compiler, compilerId, PackageDB(..) )
import Distribution.Simple.Utils hiding (matchFileGlob)
import Distribution.Version
......@@ -512,6 +513,7 @@ invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} =
--
rebuildTargets :: Verbosity
-> DistDirLayout
-> StoreDirLayout
-> ElaboratedInstallPlan
-> ElaboratedSharedConfig
-> BuildStatusMap
......@@ -519,6 +521,7 @@ rebuildTargets :: Verbosity
-> IO BuildOutcomes
rebuildTargets verbosity
distDirLayout@DistDirLayout{..}
storeDirLayout
installPlan
sharedPackageConfig@ElaboratedSharedConfig {
pkgConfigCompiler = compiler,
......@@ -567,6 +570,7 @@ rebuildTargets verbosity
rebuildTarget
verbosity
distDirLayout
storeDirLayout
buildSettings downloadMap
registerLock cacheLock
sharedPackageConfig
......@@ -605,6 +609,7 @@ createPackageDBIfMissing _ _ _ _ = return ()
--
rebuildTarget :: Verbosity
-> DistDirLayout
-> StoreDirLayout
-> BuildTimeSettings
-> AsyncFetchMap
-> Lock -> Lock
......@@ -615,6 +620,7 @@ rebuildTarget :: Verbosity
-> IO BuildResult
rebuildTarget verbosity
distDirLayout@DistDirLayout{distBuildDirectory}
storeDirLayout
buildSettings downloadMap
registerLock cacheLock
sharedPackageConfig
......@@ -667,7 +673,7 @@ rebuildTarget verbosity
buildAndInstall srcdir builddir =
buildAndInstallUnpackedPackage
verbosity distDirLayout
verbosity distDirLayout storeDirLayout
buildSettings registerLock cacheLock
sharedPackageConfig
rpkg
......@@ -861,6 +867,7 @@ moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory}
buildAndInstallUnpackedPackage :: Verbosity
-> DistDirLayout
-> StoreDirLayout
-> BuildTimeSettings -> Lock -> Lock
-> ElaboratedSharedConfig
-> ElaboratedReadyPackage
......@@ -868,6 +875,9 @@ buildAndInstallUnpackedPackage :: Verbosity
-> IO BuildResult
buildAndInstallUnpackedPackage verbosity
DistDirLayout{distTempDirectory}
storeDirLayout@StoreDirLayout {
storePackageDBStack
}
BuildTimeSettings {
buildSettingNumJobs,
buildSettingLogFile
......@@ -914,43 +924,54 @@ buildAndInstallUnpackedPackage verbosity
-- Install phase
annotateFailure mlogFile InstallFailed $ do
--TODO: [required eventually] need to lock installing this ipkig so other processes don't
-- stomp on our files, since we don't have ABI compat, not safe to replace
-- TODO: [required eventually] note that for nix-style installations it is not necessary to do
-- the 'withWin32SelfUpgrade' dance, but it would be necessary for a
-- shared bin dir.
let copyPkgFiles tmpDir = do
setup Cabal.copyCommand (copyFlags tmpDir)
-- Note that the copy command has put the files into
-- @$tmpDir/$prefix@ so we need to return this dir so
-- the store knows which dir will be the final store entry.
let prefix = dropDrive (InstallDirs.prefix (elabInstallDirs pkg))
entryDir = tmpDir </> prefix
LBS.writeFile
(entryDir </> "cabal-hash.txt")
(renderPackageHashInputs (packageHashInputs pkgshared pkg))
-- here's where we could keep track of the installed files ourselves
-- if we wanted to by making a manifest of the files in the tmp dir
return entryDir
registerPkg
| not (elabRequiresRegistration pkg) = return ()
| otherwise = do
-- We register ourselves rather than via Setup.hs. We need to
-- grab and modify the InstalledPackageInfo. We decide what
-- the installed package id is, not the build system.
ipkg0 <- generateInstalledPackageInfo
let ipkg = ipkg0 { Installed.installedUnitId = uid }
assert ( elabRegisterPackageDBStack pkg
== storePackageDBStack compid) (return ())
criticalSection registerLock $
Cabal.registerPackage
verbosity compiler progdb
(storePackageDBStack compid) ipkg
Cabal.defaultRegisterOptions {
Cabal.registerMultiInstance = True,
Cabal.registerSuppressFilesCheck = True
}
-- Actual installation
setup Cabal.copyCommand copyFlags
LBS.writeFile
(InstallDirs.prefix (elabInstallDirs pkg) </> "cabal-hash.txt") $
(renderPackageHashInputs (packageHashInputs pkgshared pkg))
-- here's where we could keep track of the installed files ourselves if
-- we wanted by calling copy to an image dir and then we would make a
-- manifest and move it to its final location
--TODO: [nice to have] we should actually have it make an image in store/incomming and
-- then when it's done, move it to its final location, to reduce problems
-- with installs failing half-way. Could also register and then move.
if elabRequiresRegistration pkg
then do
-- We register ourselves rather than via Setup.hs. We need to
-- grab and modify the InstalledPackageInfo. We decide what
-- the installed package id is, not the build system.
ipkg0 <- generateInstalledPackageInfo
let ipkg = ipkg0 { Installed.installedUnitId = uid }
criticalSection registerLock $
Cabal.registerPackage verbosity compiler progdb
(elabRegisterPackageDBStack pkg) ipkg
Cabal.defaultRegisterOptions {
Cabal.registerMultiInstance = True
}
else return ()
void $ newStoreEntry verbosity storeDirLayout
compid uid
copyPkgFiles registerPkg
--TODO: [nice to have] we currently rely on Setup.hs copy to do the right
-- thing. Although we do copy into an image dir and do the move into the
-- final location ourselves, perhaps we ought to do some sanity checks on
-- the image dir first.
-- TODO: [required eventually] note that for nix-style installations it is not necessary to do
-- the 'withWin32SelfUpgrade' dance, but it would be necessary for a
-- shared bin dir.
--TODO: [required feature] docs and test phases
let docsResult = DocsNotTried
......@@ -964,7 +985,8 @@ buildAndInstallUnpackedPackage verbosity
where
pkgid = packageId rpkg
uid = installedUnitId rpkg
uid = installedUnitId rpkg
compid = compilerId compiler
isParallelBuild = buildSettingNumJobs >= 2
......@@ -987,7 +1009,8 @@ buildAndInstallUnpackedPackage verbosity
pkgConfDest
setup Cabal.registerCommand registerFlags
copyFlags _ = setupHsCopyFlags pkg pkgshared verbosity builddir
copyFlags destdir _ = setupHsCopyFlags pkg pkgshared verbosity
builddir destdir
scriptOptions = setupHsScriptOptions rpkg pkgshared srcdir builddir
isParallelBuild cacheLock
......
......@@ -290,6 +290,7 @@ runProjectBuildPhase verbosity
fmap (Map.union (previousBuildOutcomes pkgsBuildStatus)) $
rebuildTargets verbosity
distDirLayout
(cabalStoreDirLayout cabalDirLayout)
elaboratedPlanToExecute
elaboratedShared
pkgsBuildStatus
......
......@@ -64,6 +64,7 @@ import Distribution.Client.Compat.Prelude
import Distribution.Client.ProjectPlanning.Types as Ty
import Distribution.Client.PackageHash
import Distribution.Client.RebuildMonad
import Distribution.Client.Store
import Distribution.Client.ProjectConfig
import Distribution.Client.ProjectPlanOutput
......@@ -642,7 +643,7 @@ rebuildInstallPlan verbosity
phaseImprovePlan elaboratedPlan elaboratedShared = do
liftIO $ debug verbosity "Improving the install plan..."
storePkgIdSet <- getInstalledStorePackages (storeDirectory compid)
storePkgIdSet <- getStoreEntries cabalStoreDirLayout compid
let improvedPlan = improveInstallPlanWithInstalledPackages
storePkgIdSet
elaboratedPlan
......@@ -653,7 +654,6 @@ rebuildInstallPlan verbosity
-- matches up as expected, e.g. no dangling deps, files deleted.
return improvedPlan
where
StoreDirLayout{storeDirectory} = cabalStoreDirLayout
compid = compilerId (pkgConfigCompiler elaboratedShared)
......@@ -705,20 +705,6 @@ getPackageDBContents verbosity compiler progdb platform packagedb = do
packagedb progdb
-}
-- | Return the 'UnitId's of all packages\/components already installed in the
-- store.
--
getInstalledStorePackages :: FilePath -- ^ store directory
-> Rebuild (Set UnitId)
getInstalledStorePackages storeDirectory = do
paths <- getDirectoryContentsMonitored storeDirectory
return $ Set.fromList [ newSimpleUnitId (mkComponentId path)
| path <- paths, valid path ]
where
valid ('.':_) = False
valid "package.db" = False
valid _ = True
getSourcePackages :: Verbosity -> (forall a. (RepoContext -> IO a) -> IO a)
-> Maybe IndexUtils.IndexState -> Rebuild SourcePackageDb
getSourcePackages verbosity withRepoCtx idxState = do
......@@ -3124,14 +3110,12 @@ setupHsCopyFlags :: ElaboratedConfiguredPackage
-> ElaboratedSharedConfig
-> Verbosity
-> FilePath
-> FilePath
-> Cabal.CopyFlags
setupHsCopyFlags _ _ verbosity builddir =
setupHsCopyFlags _ _ verbosity builddir destdir =
Cabal.CopyFlags {
--TODO: [nice to have] we currently just rely on Setup.hs copy to always do the right
-- thing, but perhaps we ought really to copy into an image dir and do
-- some sanity checks and move into the final location ourselves
copyArgs = [], -- TODO: could use this to only copy what we enabled
copyDest = toFlag InstallDirs.NoCopyDest,
copyDest = toFlag (InstallDirs.CopyTo destdir),
copyDistPref = toFlag builddir,
copyVerbosity = toFlag verbosity
}
......
......@@ -1538,7 +1538,7 @@ planProject testdir cliConfig = do
elaboratedShared)
executePlan :: PlanDetails -> IO (ElaboratedInstallPlan, BuildOutcomes)
executePlan ((distDirLayout, _, _, _, buildSettings),
executePlan ((distDirLayout, cabalDirLayout, _, _, buildSettings),
elaboratedPlan,
elaboratedShared) = do
......@@ -1565,6 +1565,7 @@ executePlan ((distDirLayout, _, _, _, buildSettings),
buildOutcomes <-
rebuildTargets verbosity
distDirLayout
(cabalStoreDirLayout cabalDirLayout)
elaboratedPlan''
elaboratedShared
pkgsBuildStatus
......
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