diff --git a/cabal-install/cabal-install.cabal b/cabal-install/cabal-install.cabal index 3cb68deb661..7e2250c41ca 100644 --- a/cabal-install/cabal-install.cabal +++ b/cabal-install/cabal-install.cabal @@ -151,6 +151,8 @@ library Distribution.Client.PackageHash Distribution.Client.ParseUtils Distribution.Client.ProjectBuilding + Distribution.Client.ProjectBuilding.UnpackedPackage + Distribution.Client.ProjectBuilding.PackageFileMonitor Distribution.Client.ProjectBuilding.Types Distribution.Client.ProjectConfig Distribution.Client.ProjectConfig.Legacy diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs b/cabal-install/src/Distribution/Client/ProjectBuilding.hs index 84ae5da18e8..a0906686dd1 100644 --- a/cabal-install/src/Distribution/Client/ProjectBuilding.hs +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs @@ -44,18 +44,15 @@ module Distribution.Client.ProjectBuilding import Distribution.Client.Compat.Prelude import Prelude () -import Distribution.Client.PackageHash (renderPackageHashInputs) import Distribution.Client.ProjectBuilding.Types import Distribution.Client.ProjectConfig import Distribution.Client.ProjectConfig.Types import Distribution.Client.ProjectPlanning import Distribution.Client.ProjectPlanning.Types -import Distribution.Client.RebuildMonad import Distribution.Client.Store import Distribution.Client.DistDirLayout import Distribution.Client.FetchUtils -import Distribution.Client.FileMonitor import Distribution.Client.GlobalFlags (RepoContext) import Distribution.Client.InstallPlan ( GenericInstallPlan @@ -64,15 +61,6 @@ import Distribution.Client.InstallPlan ) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.JobControl -import Distribution.Client.Setup - ( filterConfigureFlags - , filterHaddockArgs - , filterHaddockFlags - , filterTestFlags - ) -import Distribution.Client.SetupWrapper -import Distribution.Client.SourceFiles -import Distribution.Client.SrcDist (allPackageSourceFiles) import qualified Distribution.Client.Tar as Tar import Distribution.Client.Types hiding ( BuildFailure (..) @@ -80,61 +68,37 @@ import Distribution.Client.Types hiding , BuildOutcomes , BuildResult (..) ) -import Distribution.Client.Utils - ( ProgressPhase (..) - , findOpenProgramLocation - , numberOfProcessors - , progressMessage - , removeExistingFile - ) -import Distribution.Compat.Lens -import Distribution.InstalledPackageInfo (InstalledPackageInfo) -import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Package -import qualified Distribution.PackageDescription as PD -import Distribution.Simple.BuildPaths (haddockDirName) -import Distribution.Simple.Command (CommandUI) import Distribution.Simple.Compiler ( Compiler , PackageDB (..) - , compilerId , jsemSupported ) -import qualified Distribution.Simple.InstallDirs as InstallDirs -import Distribution.Simple.LocalBuildInfo - ( ComponentName (..) - , LibraryName (..) - ) import Distribution.Simple.Program import qualified Distribution.Simple.Register as Cabal -import qualified Distribution.Simple.Setup as Cabal -import Distribution.Types.BuildType -import Distribution.Types.PackageDescription.Lens (componentModules) import Distribution.Compat.Graph (IsNode (..)) import Distribution.Simple.Utils import Distribution.Version -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Char8 as LBS.Char8 -import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map import qualified Data.Set as Set import qualified Text.PrettyPrint as Disp -import Control.Exception (Handler (..), SomeAsyncException, assert, bracket, catches, handle) -import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory) -import System.FilePath (dropDrive, makeRelative, normalise, takeDirectory, (<.>), ()) -import System.IO (Handle, IOMode (AppendMode), withFile) +import Control.Exception (assert, bracket, handle) +import System.Directory (doesDirectoryExist, doesFileExist, renameDirectory) +import System.FilePath (makeRelative, takeDirectory, (<.>), ()) import System.Semaphore (SemaphoreName (..)) import Distribution.Client.Errors -import Distribution.Compat.Directory (listDirectory) import Distribution.Simple.Flag (fromFlagOrDefault) +import Distribution.Client.ProjectBuilding.PackageFileMonitor +import Distribution.Client.ProjectBuilding.UnpackedPackage (annotateFailureNoLog, buildAndInstallUnpackedPackage, buildInplaceUnpackedPackage) +import Distribution.Client.Utils (numberOfProcessors) + ------------------------------------------------------------------------------ -- * Overall building strategy. @@ -344,271 +308,6 @@ improveInstallPlanWithUpToDatePackages pkgsBuildStatus = ++ prettyShow (packageId pkg) ++ " not in status map" ------------------------------ --- Package change detection --- - --- | As part of the dry run for local unpacked packages we have to check if the --- package config or files have changed. That is the purpose of --- 'PackageFileMonitor' and 'checkPackageFileMonitorChanged'. --- --- When a package is (re)built, the monitor must be updated to reflect the new --- state of the package. Because we sometimes build without reconfiguring the --- state updates are split into two, one for package config changes and one --- for other changes. This is the purpose of 'updatePackageConfigFileMonitor' --- and 'updatePackageBuildFileMonitor'. -data PackageFileMonitor = PackageFileMonitor - { pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage () - , pkgFileMonitorBuild :: FileMonitor (Set ComponentName) BuildResultMisc - , pkgFileMonitorReg :: FileMonitor () (Maybe InstalledPackageInfo) - } - --- | This is all the components of the 'BuildResult' other than the --- @['InstalledPackageInfo']@. --- --- We have to split up the 'BuildResult' components since they get produced --- at different times (or rather, when different things change). -type BuildResultMisc = (DocsResult, TestsResult) - -newPackageFileMonitor - :: ElaboratedSharedConfig - -> DistDirLayout - -> DistDirParams - -> PackageFileMonitor -newPackageFileMonitor - shared - DistDirLayout{distPackageCacheFile} - dparams = - PackageFileMonitor - { pkgFileMonitorConfig = - FileMonitor - { fileMonitorCacheFile = distPackageCacheFile dparams "config" - , fileMonitorKeyValid = (==) `on` normaliseConfiguredPackage shared - , fileMonitorCheckIfOnlyValueChanged = False - } - , pkgFileMonitorBuild = - FileMonitor - { fileMonitorCacheFile = distPackageCacheFile dparams "build" - , fileMonitorKeyValid = \componentsToBuild componentsAlreadyBuilt -> - componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt - , fileMonitorCheckIfOnlyValueChanged = True - } - , pkgFileMonitorReg = - newFileMonitor (distPackageCacheFile dparams "registration") - } - --- | Helper function for 'checkPackageFileMonitorChanged', --- 'updatePackageConfigFileMonitor' and 'updatePackageBuildFileMonitor'. --- --- It selects the info from a 'ElaboratedConfiguredPackage' that are used by --- the 'FileMonitor's (in the 'PackageFileMonitor') to detect value changes. -packageFileMonitorKeyValues - :: ElaboratedConfiguredPackage - -> (ElaboratedConfiguredPackage, Set ComponentName) -packageFileMonitorKeyValues elab = - (elab_config, buildComponents) - where - -- The first part is the value used to guard (re)configuring the package. - -- That is, if this value changes then we will reconfigure. - -- The ElaboratedConfiguredPackage consists mostly (but not entirely) of - -- information that affects the (re)configure step. But those parts that - -- do not affect the configure step need to be nulled out. Those parts are - -- the specific targets that we're going to build. - -- - - -- Additionally we null out the parts that don't affect the configure step because they're simply - -- about how tests or benchmarks are run - - -- TODO there may be more things to null here too, in the future. - - elab_config :: ElaboratedConfiguredPackage - elab_config = - elab - { elabBuildTargets = [] - , elabTestTargets = [] - , elabBenchTargets = [] - , elabReplTarget = [] - , elabHaddockTargets = [] - , elabBuildHaddocks = False - , elabTestMachineLog = Nothing - , elabTestHumanLog = Nothing - , elabTestShowDetails = Nothing - , elabTestKeepTix = False - , elabTestTestOptions = [] - , elabBenchmarkOptions = [] - } - - -- The second part is the value used to guard the build step. So this is - -- more or less the opposite of the first part, as it's just the info about - -- what targets we're going to build. - -- - buildComponents :: Set ComponentName - buildComponents = elabBuildTargetWholeComponents elab - --- | Do all the checks on whether a package has changed and thus needs either --- rebuilding or reconfiguring and rebuilding. -checkPackageFileMonitorChanged - :: PackageFileMonitor - -> ElaboratedConfiguredPackage - -> FilePath - -> [BuildStatus] - -> IO (Either BuildStatusRebuild BuildResult) -checkPackageFileMonitorChanged - PackageFileMonitor{..} - pkg - srcdir - depsBuildStatus = do - -- TODO: [nice to have] some debug-level message about file - -- changes, like rerunIfChanged - configChanged <- - checkFileMonitorChanged - pkgFileMonitorConfig - srcdir - pkgconfig - case configChanged of - MonitorChanged monitorReason -> - return (Left (BuildStatusConfigure monitorReason')) - where - monitorReason' = fmap (const ()) monitorReason - MonitorUnchanged () _ - -- The configChanged here includes the identity of the dependencies, - -- so depsBuildStatus is just needed for the changes in the content - -- of dependencies. - | any buildStatusRequiresBuild depsBuildStatus -> do - regChanged <- checkFileMonitorChanged pkgFileMonitorReg srcdir () - let mreg = changedToMaybe regChanged - return (Left (BuildStatusBuild mreg BuildReasonDepsRebuilt)) - | otherwise -> do - buildChanged <- - checkFileMonitorChanged - pkgFileMonitorBuild - srcdir - buildComponents - regChanged <- - checkFileMonitorChanged - pkgFileMonitorReg - srcdir - () - let mreg = changedToMaybe regChanged - case (buildChanged, regChanged) of - (MonitorChanged (MonitoredValueChanged prevBuildComponents), _) -> - return (Left (BuildStatusBuild mreg buildReason)) - where - buildReason = BuildReasonExtraTargets prevBuildComponents - (MonitorChanged monitorReason, _) -> - return (Left (BuildStatusBuild mreg buildReason)) - where - buildReason = BuildReasonFilesChanged monitorReason' - monitorReason' = fmap (const ()) monitorReason - (MonitorUnchanged _ _, MonitorChanged monitorReason) -> - -- this should only happen if the file is corrupt or been - -- manually deleted. We don't want to bother with another - -- phase just for this, so we'll reregister by doing a build. - return (Left (BuildStatusBuild Nothing buildReason)) - where - buildReason = BuildReasonFilesChanged monitorReason' - monitorReason' = fmap (const ()) monitorReason - (MonitorUnchanged _ _, MonitorUnchanged _ _) - | pkgHasEphemeralBuildTargets pkg -> - return (Left (BuildStatusBuild mreg buildReason)) - where - buildReason = BuildReasonEphemeralTargets - (MonitorUnchanged buildResult _, MonitorUnchanged _ _) -> - return $ - Right - BuildResult - { buildResultDocs = docsResult - , buildResultTests = testsResult - , buildResultLogFile = Nothing - } - where - (docsResult, testsResult) = buildResult - where - (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg - changedToMaybe :: MonitorChanged a b -> Maybe b - changedToMaybe (MonitorChanged _) = Nothing - changedToMaybe (MonitorUnchanged x _) = Just x - -updatePackageConfigFileMonitor - :: PackageFileMonitor - -> FilePath - -> ElaboratedConfiguredPackage - -> IO () -updatePackageConfigFileMonitor - PackageFileMonitor{pkgFileMonitorConfig} - srcdir - pkg = - updateFileMonitor - pkgFileMonitorConfig - srcdir - Nothing - [] - pkgconfig - () - where - (pkgconfig, _buildComponents) = packageFileMonitorKeyValues pkg - -updatePackageBuildFileMonitor - :: PackageFileMonitor - -> FilePath - -> MonitorTimestamp - -> ElaboratedConfiguredPackage - -> BuildStatusRebuild - -> [MonitorFilePath] - -> BuildResultMisc - -> IO () -updatePackageBuildFileMonitor - PackageFileMonitor{pkgFileMonitorBuild} - srcdir - timestamp - pkg - pkgBuildStatus - monitors - buildResult = - updateFileMonitor - pkgFileMonitorBuild - srcdir - (Just timestamp) - monitors - buildComponents' - buildResult - where - (_pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg - - -- If the only thing that's changed is that we're now building extra - -- components, then we can avoid later unnecessary rebuilds by saving the - -- total set of components that have been built, namely the union of the - -- existing ones plus the new ones. If files also changed this would be - -- the wrong thing to do. Note that we rely on the - -- fileMonitorCheckIfOnlyValueChanged = True mode to get this guarantee - -- that it's /only/ the value that changed not any files that changed. - buildComponents' = - case pkgBuildStatus of - BuildStatusBuild _ (BuildReasonExtraTargets prevBuildComponents) -> - buildComponents `Set.union` prevBuildComponents - _ -> buildComponents - -updatePackageRegFileMonitor - :: PackageFileMonitor - -> FilePath - -> Maybe InstalledPackageInfo - -> IO () -updatePackageRegFileMonitor - PackageFileMonitor{pkgFileMonitorReg} - srcdir - mipkg = - updateFileMonitor - pkgFileMonitorReg - srcdir - Nothing - [] - () - mipkg - -invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO () -invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} = - removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg) - ------------------------------------------------------------------------------ -- * Doing it: executing an 'ElaboratedInstallPlan' @@ -1135,756 +834,3 @@ moveTarballShippedDistDirectory where tarballDistDir = parentdir prettyShow pkgid "dist" targetDistDir = distBuildDirectory dparams - -buildAndInstallUnpackedPackage - :: Verbosity - -> DistDirLayout - -> StoreDirLayout - -> Maybe SemaphoreName - -- ^ Whether to pass a semaphore to build process - -- this is different to BuildTimeSettings because the - -- name of the semaphore is created freshly each time. - -> BuildTimeSettings - -> Lock - -> Lock - -> ElaboratedSharedConfig - -> ElaboratedInstallPlan - -> ElaboratedReadyPackage - -> FilePath - -> FilePath - -> IO BuildResult -buildAndInstallUnpackedPackage - verbosity - distDirLayout@DistDirLayout{distTempDirectory} - storeDirLayout@StoreDirLayout - { storePackageDBStack - } - maybe_semaphore - BuildTimeSettings - { buildSettingNumJobs - , buildSettingLogFile - } - registerLock - cacheLock - pkgshared@ElaboratedSharedConfig - { pkgConfigPlatform = platform - , pkgConfigCompiler = compiler - , pkgConfigCompilerProgs = progdb - } - plan - rpkg@(ReadyPackage pkg) - srcdir - builddir = do - createDirectoryIfMissingVerbose verbosity True (srcdir builddir) - initLogFile - - -- TODO: [code cleanup] deal consistently with talking to older - -- Setup.hs versions, much like we do for ghc, with a proper - -- options type and rendering step which will also let us - -- call directly into the lib, rather than always going via - -- the lib's command line interface, which would also allow - -- passing data like installed packages, compiler, and - -- program db for a quicker configure. - - -- TODO: [required feature] docs and tests - -- TODO: [required feature] sudo re-exec - - -- Configure phase - noticeProgress ProgressStarting - - annotateFailure mlogFile ConfigureFailed $ - setup' configureCommand configureFlags configureArgs - - -- Build phase - noticeProgress ProgressBuilding - - annotateFailure mlogFile BuildFailed $ - setup buildCommand buildFlags - - -- Haddock phase - whenHaddock $ do - noticeProgress ProgressHaddock - annotateFailureNoLog HaddocksFailed $ - setup haddockCommand haddockFlags - - -- Install phase - noticeProgress ProgressInstalling - annotateFailure mlogFile InstallFailed $ do - let copyPkgFiles tmpDir = do - let tmpDirNormalised = normalise tmpDir - setup Cabal.copyCommand (copyFlags tmpDirNormalised) - -- 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 = - normalise $ - dropDrive (InstallDirs.prefix (elabInstallDirs pkg)) - entryDir = tmpDirNormalised prefix - - -- if there weren't anything to build, it might be that directory is not created - -- the @setup Cabal.copyCommand@ above might do nothing. - -- https://github.com/haskell/cabal/issues/4130 - createDirectoryIfMissingVerbose verbosity True entryDir - - let hashFileName = entryDir "cabal-hash.txt" - outPkgHashInputs = renderPackageHashInputs (packageHashInputs pkgshared pkg) - - info verbosity $ - "creating file with the inputs used to compute the package hash: " ++ hashFileName - - LBS.writeFile hashFileName outPkgHashInputs - - debug verbosity "Package hash inputs:" - traverse_ - (debug verbosity . ("> " ++)) - (lines $ LBS.Char8.unpack outPkgHashInputs) - - -- Ensure that there are no files in `tmpDir`, that are - -- not in `entryDir`. While this breaks the - -- prefix-relocatable property of the libraries, it is - -- necessary on macOS to stay under the load command limit - -- of the macOS mach-o linker. See also - -- @PackageHash.hashedInstalledPackageIdVeryShort@. - -- - -- We also normalise paths to ensure that there are no - -- different representations for the same path. Like / and - -- \\ on windows under msys. - otherFiles <- - filter (not . isPrefixOf entryDir) - <$> listFilesRecursive tmpDirNormalised - -- 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, otherFiles) - where - listFilesRecursive :: FilePath -> IO [FilePath] - listFilesRecursive path = do - files <- fmap (path ) <$> (listDirectory path) - allFiles <- for files $ \file -> do - isDir <- doesDirectoryExist file - if isDir - then listFilesRecursive file - else return [file] - return (concat allFiles) - - registerPkg - | not (elabRequiresRegistration pkg) = - debug verbosity $ - "registerPkg: elab does NOT require registration for " - ++ prettyShow uid - | 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 - 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 - testsResult = TestsNotTried - - noticeProgress ProgressCompleted - - return - BuildResult - { buildResultDocs = docsResult - , buildResultTests = testsResult - , buildResultLogFile = mlogFile - } - where - pkgid = packageId rpkg - uid = installedUnitId rpkg - compid = compilerId compiler - - dispname :: String - dispname = case elabPkgOrComp pkg of - ElabPackage _ -> - prettyShow pkgid - ++ " (all, legacy fallback)" - ElabComponent comp -> - prettyShow pkgid - ++ " (" - ++ maybe "custom" prettyShow (compComponentName comp) - ++ ")" - - noticeProgress :: ProgressPhase -> IO () - noticeProgress phase = - when (isParallelBuild buildSettingNumJobs) $ - progressMessage verbosity phase dispname - - whenHaddock action - | hasValidHaddockTargets pkg = action - | otherwise = return () - - configureCommand = Cabal.configureCommand defaultProgramDb - configureFlags v = - flip filterConfigureFlags v $ - setupHsConfigureFlags - plan - rpkg - pkgshared - verbosity - builddir - configureArgs _ = setupHsConfigureArgs pkg - - buildCommand = Cabal.buildCommand defaultProgramDb - comp_par_strat = case maybe_semaphore of - Just sem_name -> Cabal.Flag (getSemaphoreName sem_name) - _ -> Cabal.NoFlag - buildFlags _ = setupHsBuildFlags comp_par_strat pkg pkgshared verbosity builddir - - haddockCommand = Cabal.haddockCommand - haddockFlags _ = - setupHsHaddockFlags - pkg - pkgshared - verbosity - builddir - - generateInstalledPackageInfo :: IO InstalledPackageInfo - generateInstalledPackageInfo = - withTempInstalledPackageInfoFile - verbosity - distTempDirectory - $ \pkgConfDest -> do - let registerFlags _ = - setupHsRegisterFlags - pkg - pkgshared - verbosity - builddir - pkgConfDest - setup Cabal.registerCommand registerFlags - - copyFlags destdir _ = - setupHsCopyFlags - pkg - pkgshared - verbosity - builddir - destdir - - scriptOptions = - setupHsScriptOptions - rpkg - plan - pkgshared - distDirLayout - srcdir - builddir - (isParallelBuild buildSettingNumJobs) - cacheLock - - setup :: CommandUI flags -> (Version -> flags) -> IO () - setup cmd flags = setup' cmd flags (const []) - - setup' - :: CommandUI flags - -> (Version -> flags) - -> (Version -> [String]) - -> IO () - setup' cmd flags args = - withLogging $ \mLogFileHandle -> - setupWrapper - verbosity - scriptOptions - { useLoggingHandle = mLogFileHandle - , useExtraEnvOverrides = - dataDirsEnvironmentForPlan - distDirLayout - plan - } - (Just (elabPkgDescription pkg)) - cmd - flags - args - - mlogFile :: Maybe FilePath - mlogFile = - case buildSettingLogFile of - Nothing -> Nothing - Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid) - - initLogFile :: IO () - initLogFile = - case mlogFile of - Nothing -> return () - Just logFile -> do - createDirectoryIfMissing True (takeDirectory logFile) - exists <- doesFileExist logFile - when exists $ removeFile logFile - - withLogging :: (Maybe Handle -> IO r) -> IO r - withLogging action = - case mlogFile of - Nothing -> action Nothing - Just logFile -> withFile logFile AppendMode (action . Just) - -hasValidHaddockTargets :: ElaboratedConfiguredPackage -> Bool -hasValidHaddockTargets ElaboratedConfiguredPackage{..} - | not elabBuildHaddocks = False - | otherwise = any componentHasHaddocks components - where - components :: [ComponentTarget] - components = - elabBuildTargets - ++ elabTestTargets - ++ elabBenchTargets - ++ elabReplTarget - ++ elabHaddockTargets - - componentHasHaddocks :: ComponentTarget -> Bool - componentHasHaddocks (ComponentTarget name _) = - case name of - CLibName LMainLibName -> hasHaddocks - CLibName (LSubLibName _) -> elabHaddockInternal && hasHaddocks - CFLibName _ -> elabHaddockForeignLibs && hasHaddocks - CExeName _ -> elabHaddockExecutables && hasHaddocks - CTestName _ -> elabHaddockTestSuites && hasHaddocks - CBenchName _ -> elabHaddockBenchmarks && hasHaddocks - where - hasHaddocks = not (null (elabPkgDescription ^. componentModules name)) - -buildInplaceUnpackedPackage - :: Verbosity - -> DistDirLayout - -> Maybe SemaphoreName - -> BuildTimeSettings - -> Lock - -> Lock - -> ElaboratedSharedConfig - -> ElaboratedInstallPlan - -> ElaboratedReadyPackage - -> BuildStatusRebuild - -> FilePath - -> FilePath - -> IO BuildResult -buildInplaceUnpackedPackage - verbosity - distDirLayout@DistDirLayout - { distTempDirectory - , distPackageCacheDirectory - , distDirectory - , distHaddockOutputDir - } - maybe_semaphore - BuildTimeSettings{buildSettingNumJobs, buildSettingHaddockOpen} - registerLock - cacheLock - pkgshared@ElaboratedSharedConfig - { pkgConfigCompiler = compiler - , pkgConfigCompilerProgs = progdb - , pkgConfigPlatform = platform - } - plan - rpkg@(ReadyPackage pkg) - buildStatus - srcdir - builddir = do - -- TODO: [code cleanup] there is duplication between the - -- distdirlayout and the builddir here builddir is not - -- enough, we also need the per-package cachedir - createDirectoryIfMissingVerbose verbosity True builddir - createDirectoryIfMissingVerbose - verbosity - True - (distPackageCacheDirectory dparams) - - -- Configure phase - -- - whenReConfigure $ do - annotateFailureNoLog ConfigureFailed $ - setup configureCommand configureFlags configureArgs - invalidatePackageRegFileMonitor packageFileMonitor - updatePackageConfigFileMonitor packageFileMonitor srcdir pkg - - -- Build phase - -- - let docsResult = DocsNotTried - testsResult = TestsNotTried - - buildResult :: BuildResultMisc - buildResult = (docsResult, testsResult) - - whenRebuild $ do - timestamp <- beginUpdateFileMonitor - annotateFailureNoLog BuildFailed $ - setup buildCommand buildFlags buildArgs - - let listSimple = - execRebuild srcdir (needElaboratedConfiguredPackage pkg) - listSdist = - fmap (map monitorFileHashed) $ - allPackageSourceFiles verbosity srcdir - ifNullThen m m' = do - xs <- m - if null xs then m' else return xs - monitors <- case PD.buildType (elabPkgDescription pkg) of - Simple -> listSimple - -- If a Custom setup was used, AND the Cabal is recent - -- enough to have sdist --list-sources, use that to - -- determine the files that we need to track. This can - -- cause unnecessary rebuilding (for example, if README - -- is edited, we will try to rebuild) but there isn't - -- a more accurate Custom interface we can use to get - -- this info. We prefer not to use listSimple here - -- as it can miss extra source files that are considered - -- by the Custom setup. - _ - | elabSetupScriptCliVersion pkg >= mkVersion [1, 17] -> - -- However, sometimes sdist --list-sources will fail - -- and return an empty list. In that case, fall - -- back on the (inaccurate) simple tracking. - listSdist `ifNullThen` listSimple - | otherwise -> - listSimple - - let dep_monitors = - map monitorFileHashed $ - elabInplaceDependencyBuildCacheFiles - distDirLayout - pkgshared - plan - pkg - updatePackageBuildFileMonitor - packageFileMonitor - srcdir - timestamp - pkg - buildStatus - (monitors ++ dep_monitors) - buildResult - - -- PURPOSELY omitted: no copy! - - whenReRegister $ annotateFailureNoLog InstallFailed $ do - -- Register locally - mipkg <- - if elabRequiresRegistration pkg - then do - ipkg0 <- generateInstalledPackageInfo - -- 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. - let ipkg = ipkg0{Installed.installedUnitId = ipkgid} - criticalSection registerLock $ - Cabal.registerPackage - verbosity - compiler - progdb - (elabRegisterPackageDBStack pkg) - ipkg - Cabal.defaultRegisterOptions - return (Just ipkg) - else return Nothing - - updatePackageRegFileMonitor packageFileMonitor srcdir mipkg - - whenTest $ do - annotateFailureNoLog TestsFailed $ - setup testCommand testFlags testArgs - - whenBench $ - annotateFailureNoLog BenchFailed $ - setup benchCommand benchFlags benchArgs - - -- Repl phase - -- - whenRepl $ - annotateFailureNoLog ReplFailed $ - setupInteractive replCommand replFlags replArgs - - -- Haddock phase - whenHaddock $ - annotateFailureNoLog HaddocksFailed $ do - setup haddockCommand haddockFlags haddockArgs - let haddockTarget = elabHaddockForHackage pkg - when (haddockTarget == Cabal.ForHackage) $ do - let dest = distDirectory name <.> "tar.gz" - name = haddockDirName haddockTarget (elabPkgDescription pkg) - docDir = - distBuildDirectory distDirLayout dparams - "doc" - "html" - Tar.createTarGzFile dest docDir name - notice verbosity $ "Documentation tarball created: " ++ dest - - when (buildSettingHaddockOpen && haddockTarget /= Cabal.ForHackage) $ do - let dest = docDir "index.html" - name = haddockDirName haddockTarget (elabPkgDescription pkg) - docDir = case distHaddockOutputDir of - Nothing -> distBuildDirectory distDirLayout dparams "doc" "html" name - Just dir -> dir - exe <- findOpenProgramLocation platform - case exe of - Right open -> runProgramInvocation verbosity (simpleProgramInvocation open [dest]) - Left err -> dieWithException verbosity $ FindOpenProgramLocationErr err - - return - BuildResult - { buildResultDocs = docsResult - , buildResultTests = testsResult - , buildResultLogFile = Nothing - } - where - ipkgid = installedUnitId pkg - dparams = elabDistDirParams pkgshared pkg - - comp_par_strat = case maybe_semaphore of - Just sem_name -> Cabal.toFlag (getSemaphoreName sem_name) - _ -> Cabal.NoFlag - - packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams - - whenReConfigure action = case buildStatus of - BuildStatusConfigure _ -> action - _ -> return () - - whenRebuild action - | null (elabBuildTargets pkg) - , -- NB: we have to build the test/bench suite! - null (elabTestTargets pkg) - , null (elabBenchTargets pkg) = - return () - | otherwise = action - - whenTest action - | null (elabTestTargets pkg) = return () - | otherwise = action - - whenBench action - | null (elabBenchTargets pkg) = return () - | otherwise = action - - whenRepl action - | null (elabReplTarget pkg) = return () - | otherwise = action - - whenHaddock action - | hasValidHaddockTargets pkg = action - | otherwise = return () - - whenReRegister action = - case buildStatus of - -- We registered the package already - BuildStatusBuild (Just _) _ -> - info verbosity "whenReRegister: previously registered" - -- There is nothing to register - _ - | null (elabBuildTargets pkg) -> - info verbosity "whenReRegister: nothing to register" - | otherwise -> action - - configureCommand = Cabal.configureCommand defaultProgramDb - configureFlags v = - flip filterConfigureFlags v $ - setupHsConfigureFlags - plan - rpkg - pkgshared - verbosity - builddir - configureArgs _ = setupHsConfigureArgs pkg - - buildCommand = Cabal.buildCommand defaultProgramDb - buildFlags _ = - setupHsBuildFlags - comp_par_strat - pkg - pkgshared - verbosity - builddir - buildArgs _ = setupHsBuildArgs pkg - - testCommand = Cabal.testCommand -- defaultProgramDb - testFlags v = - flip filterTestFlags v $ - setupHsTestFlags - pkg - verbosity - builddir - testArgs _ = setupHsTestArgs pkg - - benchCommand = Cabal.benchmarkCommand - benchFlags _ = - setupHsBenchFlags - pkg - pkgshared - verbosity - builddir - benchArgs _ = setupHsBenchArgs pkg - - replCommand = Cabal.replCommand defaultProgramDb - replFlags _ = - setupHsReplFlags - pkg - pkgshared - verbosity - builddir - replArgs _ = setupHsReplArgs pkg - - haddockCommand = Cabal.haddockCommand - haddockFlags v = - flip filterHaddockFlags v $ - setupHsHaddockFlags - pkg - pkgshared - verbosity - builddir - haddockArgs v = - flip filterHaddockArgs v $ - setupHsHaddockArgs pkg - - scriptOptions = - setupHsScriptOptions - rpkg - plan - pkgshared - distDirLayout - srcdir - builddir - (isParallelBuild buildSettingNumJobs) - cacheLock - - setupInteractive - :: CommandUI flags - -> (Version -> flags) - -> (Version -> [String]) - -> IO () - setupInteractive cmd flags args = - setupWrapper - verbosity - scriptOptions{isInteractive = True} - (Just (elabPkgDescription pkg)) - cmd - flags - args - - setup - :: CommandUI flags - -> (Version -> flags) - -> (Version -> [String]) - -> IO () - setup cmd flags args = - setupWrapper - verbosity - scriptOptions - (Just (elabPkgDescription pkg)) - cmd - flags - args - - generateInstalledPackageInfo :: IO InstalledPackageInfo - generateInstalledPackageInfo = - withTempInstalledPackageInfoFile - verbosity - distTempDirectory - $ \pkgConfDest -> do - let registerFlags _ = - setupHsRegisterFlags - pkg - pkgshared - verbosity - builddir - pkgConfDest - setup Cabal.registerCommand registerFlags (const []) - -withTempInstalledPackageInfoFile - :: Verbosity - -> FilePath - -> (FilePath -> IO ()) - -> IO InstalledPackageInfo -withTempInstalledPackageInfoFile verbosity tempdir action = - withTempDirectory verbosity tempdir "package-registration-" $ \dir -> do - -- make absolute since @action@ will often change directory - abs_dir <- canonicalizePath dir - - let pkgConfDest = abs_dir "pkgConf" - action pkgConfDest - - readPkgConf "." pkgConfDest - where - pkgConfParseFailed :: String -> IO a - pkgConfParseFailed perror = - dieWithException verbosity $ PkgConfParseFailed perror - - readPkgConf :: FilePath -> FilePath -> IO InstalledPackageInfo - readPkgConf pkgConfDir pkgConfFile = do - pkgConfStr <- BS.readFile (pkgConfDir pkgConfFile) - (warns, ipkg) <- case Installed.parseInstalledPackageInfo pkgConfStr of - Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors - Right (warns, ipkg) -> return (warns, ipkg) - - unless (null warns) $ - warn verbosity $ - unlines warns - - return ipkg - ------------------------------------------------------------------------------- - --- * Utilities - ------------------------------------------------------------------------------- - -{- FOURMOLU_DISABLE -} -annotateFailureNoLog :: (SomeException -> BuildFailureReason) - -> IO a -> IO a -annotateFailureNoLog annotate action = - annotateFailure Nothing annotate action - -annotateFailure :: Maybe FilePath - -> (SomeException -> BuildFailureReason) - -> IO a -> IO a -annotateFailure mlogFile annotate action = - action `catches` - -- It's not just IOException and ExitCode we have to deal with, there's - -- lots, including exceptions from the hackage-security and tar packages. - -- So we take the strategy of catching everything except async exceptions. - [ -#if MIN_VERSION_base(4,7,0) - Handler $ \async -> throwIO (async :: SomeAsyncException) -#else - Handler $ \async -> throwIO (async :: AsyncException) -#endif - , Handler $ \other -> handler (other :: SomeException) - ] - where - handler :: Exception e => e -> IO a - handler = throwIO . BuildFailure mlogFile . annotate . toException diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding.hs.orig b/cabal-install/src/Distribution/Client/ProjectBuilding.hs.orig new file mode 100644 index 00000000000..2ffed160da1 --- /dev/null +++ b/cabal-install/src/Distribution/Client/ProjectBuilding.hs.orig @@ -0,0 +1,2345 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoMonoLocalBinds #-} + +module Distribution.Client.ProjectBuilding + ( -- * Dry run phase + + -- | What bits of the plan will we execute? The dry run does not change + -- anything but tells us what will need to be built. + rebuildTargetsDryRun + , improveInstallPlanWithUpToDatePackages + + -- ** Build status + + -- | This is the detailed status information we get from the dry run. + , BuildStatusMap + , BuildStatus (..) + , BuildStatusRebuild (..) + , BuildReason (..) + , MonitorChangedReason (..) + , buildStatusToString + + -- * Build phase + + -- | Now we actually execute the plan. + , rebuildTargets + + -- ** Build outcomes + + -- | This is the outcome for each package of executing the plan. + -- For each package, did the build succeed or fail? + , BuildOutcomes + , BuildOutcome + , BuildResult (..) + , BuildFailure (..) + , BuildFailureReason (..) + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.ProjectBuilding.Types +import Distribution.Client.ProjectConfig +import Distribution.Client.ProjectConfig.Types +import Distribution.Client.ProjectPlanning +import Distribution.Client.ProjectPlanning.Types +import Distribution.Client.Store + +import Distribution.Client.DistDirLayout +import Distribution.Client.FetchUtils +import Distribution.Client.GlobalFlags (RepoContext) +import Distribution.Client.InstallPlan + ( GenericInstallPlan + , GenericPlanPackage + , IsUnit + ) +import qualified Distribution.Client.InstallPlan as InstallPlan +import Distribution.Client.JobControl +import qualified Distribution.Client.Tar as Tar +import Distribution.Client.Types hiding + ( BuildFailure (..) + , BuildOutcome + , BuildOutcomes + , BuildResult (..) + ) + +import Distribution.Package +import Distribution.Simple.Compiler + ( Compiler + , PackageDB (..) + , jsemSupported + ) +import Distribution.Simple.Program +import qualified Distribution.Simple.Register as Cabal + +import Distribution.Compat.Graph (IsNode (..)) +import Distribution.Simple.Utils +import Distribution.Version + +import qualified Data.Map as Map +import qualified Data.Set as Set + +import qualified Text.PrettyPrint as Disp + +import Control.Exception (assert, bracket, handle) +import System.Directory (doesDirectoryExist, doesFileExist, renameDirectory) +import System.FilePath (makeRelative, takeDirectory, (<.>), ()) +import System.Semaphore (SemaphoreName (..)) + +import Distribution.Client.Errors +import Distribution.Simple.Flag (fromFlagOrDefault) + +import Distribution.Client.ProjectBuilding.PackageFileMonitor +import Distribution.Client.ProjectBuilding.UnpackedPackage (annotateFailureNoLog, buildAndInstallUnpackedPackage, buildInplaceUnpackedPackage) +import Distribution.Client.Utils (numberOfProcessors) + +------------------------------------------------------------------------------ + +-- * Overall building strategy. + +------------------------------------------------------------------------------ +-- +-- We start with an 'ElaboratedInstallPlan' that has already been improved by +-- reusing packages from the store, and pruned to include only the targets of +-- interest and their dependencies. So the remaining packages in the +-- 'InstallPlan.Configured' state are ones we either need to build or rebuild. +-- +-- First, we do a preliminary dry run phase where we work out which packages +-- we really need to (re)build, and for the ones we do need to build which +-- build phase to start at. +-- +-- We use this to improve the 'ElaboratedInstallPlan' again by changing +-- up-to-date 'InstallPlan.Configured' packages to 'InstallPlan.Installed' +-- so that the build phase will skip them. +-- +-- Then we execute the plan, that is actually build packages. The outcomes of +-- trying to build all the packages are collected and returned. +-- +-- We split things like this (dry run and execute) for a couple reasons. +-- Firstly we need to be able to do dry runs anyway, and these need to be +-- reasonably accurate in terms of letting users know what (and why) things +-- are going to be (re)built. +-- +-- Given that we need to be able to do dry runs, it would not be great if +-- we had to repeat all the same work when we do it for real. Not only is +-- it duplicate work, but it's duplicate code which is likely to get out of +-- sync. So we do things only once. We preserve info we discover in the dry +-- run phase and rely on it later when we build things for real. This also +-- somewhat simplifies the build phase. So this way the dry run can't so +-- easily drift out of sync with the real thing since we're relying on the +-- info it produces. +-- +-- An additional advantage is that it makes it easier to debug rebuild +-- errors (ie rebuilding too much or too little), since all the rebuild +-- decisions are made without making any state changes at the same time +-- (that would make it harder to reproduce the problem situation). +-- +-- Finally, we can use the dry run build status and the build outcomes to +-- give us some information on the overall status of packages in the project. +-- This includes limited information about the status of things that were +-- not actually in the subset of the plan that was used for the dry run or +-- execution phases. In particular we may know that some packages are now +-- definitely out of date. See "Distribution.Client.ProjectPlanOutput" for +-- details. + +------------------------------------------------------------------------------ + +-- * Dry run: what bits of the 'ElaboratedInstallPlan' will we execute? + +------------------------------------------------------------------------------ + +-- Refer to ProjectBuilding.Types for details of these important types: + +-- type BuildStatusMap = ... +-- data BuildStatus = ... +-- data BuildStatusRebuild = ... +-- data BuildReason = ... + +-- | Do the dry run pass. This is a prerequisite of 'rebuildTargets'. +-- +-- It gives us the 'BuildStatusMap'. This should be used with +-- 'improveInstallPlanWithUpToDatePackages' to give an improved version of +-- the 'ElaboratedInstallPlan' with packages switched to the +-- 'InstallPlan.Installed' state when we find that they're already up to date. +rebuildTargetsDryRun + :: DistDirLayout + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> IO BuildStatusMap +rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared = + -- Do the various checks to work out the 'BuildStatus' of each package + foldMInstallPlanDepOrder dryRunPkg + where + dryRunPkg + :: ElaboratedPlanPackage + -> [BuildStatus] + -> IO BuildStatus + dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus = + return BuildStatusPreExisting + dryRunPkg (InstallPlan.Installed _pkg) _depsBuildStatus = + return BuildStatusInstalled + dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do + mloc <- checkFetched (elabPkgSourceLocation pkg) + case mloc of + Nothing -> return BuildStatusDownload + Just (LocalUnpackedPackage srcdir) -> + -- For the case of a user-managed local dir, irrespective of the + -- build style, we build from that directory and put build + -- artifacts under the shared dist directory. + dryRunLocalPkg pkg depsBuildStatus srcdir + -- The rest cases are all tarball cases are, + -- and handled the same as each other though depending on the build style. + Just (LocalTarballPackage tarball) -> + dryRunTarballPkg pkg depsBuildStatus tarball + Just (RemoteTarballPackage _ tarball) -> + dryRunTarballPkg pkg depsBuildStatus tarball + Just (RepoTarballPackage _ _ tarball) -> + dryRunTarballPkg pkg depsBuildStatus tarball + Just (RemoteSourceRepoPackage _repo tarball) -> + dryRunTarballPkg pkg depsBuildStatus tarball + + dryRunTarballPkg + :: ElaboratedConfiguredPackage + -> [BuildStatus] + -> FilePath + -> IO BuildStatus + dryRunTarballPkg pkg depsBuildStatus tarball = + case elabBuildStyle pkg of + BuildAndInstall -> return (BuildStatusUnpack tarball) + BuildInplaceOnly{} -> do + -- TODO: [nice to have] use a proper file monitor rather + -- than this dir exists test + exists <- doesDirectoryExist srcdir + if exists + then dryRunLocalPkg pkg depsBuildStatus srcdir + else return (BuildStatusUnpack tarball) + where + srcdir :: FilePath + srcdir = distUnpackedSrcDirectory (packageId pkg) + + dryRunLocalPkg + :: ElaboratedConfiguredPackage + -> [BuildStatus] + -> FilePath + -> IO BuildStatus + dryRunLocalPkg pkg depsBuildStatus srcdir = do + -- Go and do lots of I/O, reading caches and probing files to work out + -- if anything has changed + change <- + checkPackageFileMonitorChanged + packageFileMonitor + pkg + srcdir + depsBuildStatus + case change of + -- It did change, giving us 'BuildStatusRebuild' info on why + Left rebuild -> + return (BuildStatusRebuild srcdir rebuild) + -- No changes, the package is up to date. Use the saved build results. + Right buildResult -> + return (BuildStatusUpToDate buildResult) + where + packageFileMonitor :: PackageFileMonitor + packageFileMonitor = + newPackageFileMonitor + shared + distDirLayout + (elabDistDirParams shared pkg) + +-- | A specialised traversal over the packages in an install plan. +-- +-- The packages are visited in dependency order, starting with packages with no +-- dependencies. The result for each package is accumulated into a 'Map' and +-- returned as the final result. In addition, when visiting a package, the +-- visiting function is passed the results for all the immediate package +-- dependencies. This can be used to propagate information from dependencies. +foldMInstallPlanDepOrder + :: forall m ipkg srcpkg b + . (Monad m, IsUnit ipkg, IsUnit srcpkg) + => ( GenericPlanPackage ipkg srcpkg + -> [b] + -> m b + ) + -> GenericInstallPlan ipkg srcpkg + -> m (Map UnitId b) +foldMInstallPlanDepOrder visit = + go Map.empty . InstallPlan.reverseTopologicalOrder + where + go + :: Map UnitId b + -> [GenericPlanPackage ipkg srcpkg] + -> m (Map UnitId b) + go !results [] = return results + go !results (pkg : pkgs) = do + -- we go in the right order so the results map has entries for all deps + let depresults :: [b] + depresults = + map + ( \ipkgid -> + let result = Map.findWithDefault (error "foldMInstallPlanDepOrder") ipkgid results + in result + ) + (InstallPlan.depends pkg) + result <- visit pkg depresults + let results' = Map.insert (nodeKey pkg) result results + go results' pkgs + +improveInstallPlanWithUpToDatePackages + :: BuildStatusMap + -> ElaboratedInstallPlan + -> ElaboratedInstallPlan +improveInstallPlanWithUpToDatePackages pkgsBuildStatus = + InstallPlan.installed canPackageBeImproved + where + canPackageBeImproved :: ElaboratedConfiguredPackage -> Bool + canPackageBeImproved pkg = + case Map.lookup (installedUnitId pkg) pkgsBuildStatus of + Just BuildStatusUpToDate{} -> True + Just _ -> False + Nothing -> + error $ + "improveInstallPlanWithUpToDatePackages: " + ++ prettyShow (packageId pkg) + ++ " not in status map" + +------------------------------------------------------------------------------ + +-- * Doing it: executing an 'ElaboratedInstallPlan' + +------------------------------------------------------------------------------ + +-- Refer to ProjectBuilding.Types for details of these important types: + +-- type BuildOutcomes = ... +-- type BuildOutcome = ... +-- data BuildResult = ... +-- data BuildFailure = ... +-- data BuildFailureReason = ... + +-- | Build things for real. +-- +-- It requires the 'BuildStatusMap' gathered by 'rebuildTargetsDryRun'. +rebuildTargets + :: Verbosity + -> ProjectConfig + -> DistDirLayout + -> StoreDirLayout + -> ElaboratedInstallPlan + -> ElaboratedSharedConfig + -> BuildStatusMap + -> BuildTimeSettings + -> IO BuildOutcomes +rebuildTargets + verbosity + ProjectConfig + { projectConfigBuildOnly = config + } + distDirLayout@DistDirLayout{..} + storeDirLayout + installPlan + sharedPackageConfig@ElaboratedSharedConfig + { pkgConfigCompiler = compiler + , pkgConfigCompilerProgs = progdb + } + pkgsBuildStatus + buildSettings@BuildTimeSettings + { buildSettingNumJobs + , buildSettingKeepGoing + } + | fromFlagOrDefault False (projectConfigOfflineMode config) && not (null packagesToDownload) = return offlineError + | otherwise = do + -- Concurrency control: create the job controller and concurrency limits + -- for downloading, building and installing. + mkJobControl <- case buildSettingNumJobs of + Serial -> newSerialJobControl + NumJobs n -> newParallelJobControl (fromMaybe numberOfProcessors n) + UseSem n -> + if jsemSupported compiler + then newSemaphoreJobControl n + else do + warn verbosity "-jsem is not supported by the selected compiler, falling back to normal parallelism control." + newParallelJobControl n + registerLock <- newLock -- serialise registration + cacheLock <- newLock -- serialise access to setup exe cache + -- TODO: [code cleanup] eliminate setup exe cache + info verbosity $ + "Executing install plan " + ++ case buildSettingNumJobs of + NumJobs n -> "in parallel using " ++ show n ++ " threads." + UseSem n -> "in parallel using a semaphore with " ++ show n ++ " slots." + Serial -> "serially." + + createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory + createDirectoryIfMissingVerbose verbosity True distTempDirectory + traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse + + bracket (pure mkJobControl) cleanupJobControl $ \jobControl -> do + -- Before traversing the install plan, preemptively find all packages that + -- will need to be downloaded and start downloading them. + asyncDownloadPackages + verbosity + withRepoCtx + installPlan + pkgsBuildStatus + $ \downloadMap -> + -- For each package in the plan, in dependency order, but in parallel... + InstallPlan.execute + mkJobControl + keepGoing + (BuildFailure Nothing . DependentFailed . packageId) + installPlan + $ \pkg -> + -- TODO: review exception handling + handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ do + let uid = installedUnitId pkg + pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus + + rebuildTarget + verbosity + distDirLayout + storeDirLayout + (jobControlSemaphore jobControl) + buildSettings + downloadMap + registerLock + cacheLock + sharedPackageConfig + installPlan + pkg + pkgBuildStatus + where + keepGoing = buildSettingKeepGoing + withRepoCtx = + projectConfigWithBuilderRepoContext + verbosity + buildSettings + packageDBsToUse = + -- all the package dbs we may need to create + (Set.toList . Set.fromList) + [ pkgdb + | InstallPlan.Configured elab <- InstallPlan.toList installPlan + , pkgdb <- + concat + [ elabBuildPackageDBStack elab + , elabRegisterPackageDBStack elab + , elabSetupPackageDBStack elab + ] + ] + + offlineError :: BuildOutcomes + offlineError = Map.fromList . map makeBuildOutcome $ packagesToDownload + where + makeBuildOutcome :: ElaboratedConfiguredPackage -> (UnitId, BuildOutcome) + makeBuildOutcome + ElaboratedConfiguredPackage + { elabUnitId + , elabPkgSourceId = PackageIdentifier{pkgName, pkgVersion} + } = + ( elabUnitId + , Left + ( BuildFailure + { buildFailureLogFile = Nothing + , buildFailureReason = GracefulFailure $ makeError pkgName pkgVersion + } + ) + ) + makeError :: PackageName -> Version -> String + makeError n v = + "--offline was specified, hence refusing to download the package: " + ++ unPackageName n + ++ " version " + ++ Disp.render (pretty v) + + packagesToDownload :: [ElaboratedConfiguredPackage] + packagesToDownload = + [ elab | InstallPlan.Configured elab <- InstallPlan.reverseTopologicalOrder installPlan, isRemote $ elabPkgSourceLocation elab + ] + where + isRemote :: PackageLocation a -> Bool + isRemote (RemoteTarballPackage _ _) = True + isRemote (RepoTarballPackage{}) = True + isRemote (RemoteSourceRepoPackage _ _) = True + isRemote _ = False + +-- | Create a package DB if it does not currently exist. Note that this action +-- is /not/ safe to run concurrently. +createPackageDBIfMissing + :: Verbosity + -> Compiler + -> ProgramDb + -> PackageDB + -> IO () +createPackageDBIfMissing + verbosity + compiler + progdb + (SpecificPackageDB dbPath) = do + exists <- Cabal.doesPackageDBExist dbPath + unless exists $ do + createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath) + Cabal.createPackageDB verbosity compiler progdb False dbPath +createPackageDBIfMissing _ _ _ _ = return () + +-- | Given all the context and resources, (re)build an individual package. +rebuildTarget + :: Verbosity + -> DistDirLayout + -> StoreDirLayout + -> Maybe SemaphoreName + -> BuildTimeSettings + -> AsyncFetchMap + -> Lock + -> Lock + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedReadyPackage + -> BuildStatus + -> IO BuildResult +rebuildTarget + verbosity + distDirLayout@DistDirLayout{distBuildDirectory} + storeDirLayout + semaphoreName + buildSettings + downloadMap + registerLock + cacheLock + sharedPackageConfig + plan + rpkg@(ReadyPackage pkg) + pkgBuildStatus + -- Technically, doing the --only-download filtering only in this function is + -- not perfect. We could also prune the plan at an earlier stage, like it's + -- done with --only-dependencies. But... + -- * the benefit would be minimal (practically just avoiding to print the + -- "requires build" parts of the plan) + -- * we currently don't have easy access to the BuildStatus of packages + -- in the pruning phase + -- * we still have to check it here to avoid performing successive phases + | buildSettingOnlyDownload buildSettings = do + case pkgBuildStatus of + BuildStatusDownload -> + void $ waitAsyncPackageDownload verbosity downloadMap pkg + _ -> return () + return $ BuildResult DocsNotTried TestsNotTried Nothing + | otherwise = + -- We rely on the 'BuildStatus' to decide which phase to start from: + case pkgBuildStatus of + BuildStatusDownload -> downloadPhase + BuildStatusUnpack tarball -> unpackTarballPhase tarball + BuildStatusRebuild srcdir status -> rebuildPhase status srcdir + -- TODO: perhaps re-nest the types to make these impossible + BuildStatusPreExisting{} -> unexpectedState + BuildStatusInstalled{} -> unexpectedState + BuildStatusUpToDate{} -> unexpectedState + where + unexpectedState = error "rebuildTarget: unexpected package status" + + downloadPhase :: IO BuildResult + downloadPhase = do + downsrcloc <- + annotateFailureNoLog DownloadFailed $ + waitAsyncPackageDownload verbosity downloadMap pkg + case downsrcloc of + DownloadedTarball tarball -> unpackTarballPhase tarball + -- TODO: [nice to have] git/darcs repos etc + + unpackTarballPhase :: FilePath -> IO BuildResult + unpackTarballPhase tarball = + withTarballLocalDirectory + verbosity + distDirLayout + tarball + (packageId pkg) + (elabDistDirParams sharedPackageConfig pkg) + (elabBuildStyle pkg) + (elabPkgDescriptionOverride pkg) + $ case elabBuildStyle pkg of + BuildAndInstall -> buildAndInstall + BuildInplaceOnly{} -> buildInplace buildStatus + where + buildStatus = BuildStatusConfigure MonitorFirstRun + + -- Note that this really is rebuild, not build. It can only happen for + -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages + -- would only start from download or unpack phases. + -- + rebuildPhase :: BuildStatusRebuild -> FilePath -> IO BuildResult + rebuildPhase buildStatus srcdir = + assert + (isInplaceBuildStyle $ elabBuildStyle pkg) + buildInplace + buildStatus + srcdir + builddir + where + builddir = + distBuildDirectory + (elabDistDirParams sharedPackageConfig pkg) + + buildAndInstall :: FilePath -> FilePath -> IO BuildResult + buildAndInstall srcdir builddir = + buildAndInstallUnpackedPackage + verbosity + distDirLayout + storeDirLayout + semaphoreName + buildSettings + registerLock + cacheLock + sharedPackageConfig + plan + rpkg + srcdir + builddir' + where + builddir' = makeRelative srcdir builddir + -- TODO: [nice to have] ^^ do this relative stuff better + + buildInplace :: BuildStatusRebuild -> FilePath -> FilePath -> IO BuildResult + buildInplace buildStatus srcdir builddir = + -- TODO: [nice to have] use a relative build dir rather than absolute + buildInplaceUnpackedPackage + verbosity + distDirLayout + semaphoreName + buildSettings + registerLock + cacheLock + sharedPackageConfig + plan + rpkg + buildStatus + srcdir + builddir + +-- TODO: [nice to have] do we need to use a with-style for the temp +-- files for downloading http packages, or are we going to cache them +-- persistently? + +-- | Given the current 'InstallPlan' and 'BuildStatusMap', select all the +-- packages we have to download and fork off an async action to download them. +-- We download them in dependency order so that the one's we'll need +-- first are the ones we will start downloading first. +-- +-- The body action is passed a map from those packages (identified by their +-- location) to a completion var for that package. So the body action should +-- lookup the location and use 'waitAsyncPackageDownload' to get the result. +asyncDownloadPackages + :: Verbosity + -> ((RepoContext -> IO a) -> IO a) + -> ElaboratedInstallPlan + -> BuildStatusMap + -> (AsyncFetchMap -> IO a) + -> IO a +asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body + | null pkgsToDownload = body Map.empty + | otherwise = withRepoCtx $ \repoctx -> + asyncFetchPackages + verbosity + repoctx + pkgsToDownload + body + where + pkgsToDownload :: [PackageLocation (Maybe FilePath)] + pkgsToDownload = + ordNub $ + [ elabPkgSourceLocation elab + | InstallPlan.Configured elab <- + InstallPlan.reverseTopologicalOrder installPlan + , let uid = installedUnitId elab + pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") uid pkgsBuildStatus + , BuildStatusDownload <- [pkgBuildStatus] + ] + +-- | Check if a package needs downloading, and if so expect to find a download +-- in progress in the given 'AsyncFetchMap' and wait on it to finish. +waitAsyncPackageDownload + :: Verbosity + -> AsyncFetchMap + -> ElaboratedConfiguredPackage + -> IO DownloadedSourceLocation +waitAsyncPackageDownload verbosity downloadMap elab = do + pkgloc <- + waitAsyncFetchPackage + verbosity + downloadMap + (elabPkgSourceLocation elab) + case downloadedSourceLocation pkgloc of + Just loc -> return loc + Nothing -> fail "waitAsyncPackageDownload: unexpected source location" + +data DownloadedSourceLocation = DownloadedTarball FilePath + +-- TODO: [nice to have] git/darcs repos etc + +downloadedSourceLocation + :: PackageLocation FilePath + -> Maybe DownloadedSourceLocation +downloadedSourceLocation pkgloc = + case pkgloc of + RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball) + RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball) + _ -> Nothing + +-- | Ensure that the package is unpacked in an appropriate directory, either +-- a temporary one or a persistent one under the shared dist directory. +withTarballLocalDirectory + :: Verbosity + -> DistDirLayout + -> FilePath + -> PackageId + -> DistDirParams + -> BuildStyle + -> Maybe CabalFileText + -> ( FilePath -- Source directory + -> FilePath -- Build directory + -> IO a + ) + -> IO a +withTarballLocalDirectory + verbosity + distDirLayout@DistDirLayout{..} + tarball + pkgid + dparams + buildstyle + pkgTextOverride + buildPkg = + case buildstyle of + -- In this case we make a temp dir (e.g. tmp/src2345/), unpack + -- the tarball to it (e.g. tmp/src2345/foo-1.0/), and for + -- compatibility we put the dist dir within it + -- (i.e. tmp/src2345/foo-1.0/dist/). + -- + -- Unfortunately, a few custom Setup.hs scripts do not respect + -- the --builddir flag and always look for it at ./dist/ so + -- this way we avoid breaking those packages + BuildAndInstall -> + let tmpdir = distTempDirectory + in withTempDirectory verbosity tmpdir "src" $ \unpackdir -> do + unpackPackageTarball + verbosity + tarball + unpackdir + pkgid + pkgTextOverride + let srcdir = unpackdir prettyShow pkgid + builddir = srcdir "dist" + buildPkg srcdir builddir + + -- In this case we make sure the tarball has been unpacked to the + -- appropriate location under the shared dist dir, and then build it + -- inplace there + BuildInplaceOnly{} -> do + let srcrootdir = distUnpackedSrcRootDirectory + srcdir = distUnpackedSrcDirectory pkgid + builddir = distBuildDirectory dparams + -- TODO: [nice to have] use a proper file monitor rather + -- than this dir exists test + exists <- doesDirectoryExist srcdir + unless exists $ do + createDirectoryIfMissingVerbose verbosity True srcrootdir + unpackPackageTarball + verbosity + tarball + srcrootdir + pkgid + pkgTextOverride + moveTarballShippedDistDirectory + verbosity + distDirLayout + srcrootdir + pkgid + dparams + buildPkg srcdir builddir + +unpackPackageTarball + :: Verbosity + -> FilePath + -> FilePath + -> PackageId + -> Maybe CabalFileText + -> IO () +unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride = + -- TODO: [nice to have] switch to tar package and catch tar exceptions + annotateFailureNoLog UnpackFailed $ do + -- Unpack the tarball + -- + info verbosity $ "Extracting " ++ tarball ++ " to " ++ parentdir ++ "..." + Tar.extractTarGzFile parentdir pkgsubdir tarball + + -- Sanity check + -- + exists <- doesFileExist cabalFile + unless exists $ + dieWithException verbosity $ + CabalFileNotFound cabalFile + + -- Overwrite the .cabal with the one from the index, when appropriate + -- + case pkgTextOverride of + Nothing -> return () + Just pkgtxt -> do + info verbosity $ + "Updating " + ++ prettyShow pkgname <.> "cabal" + ++ " with the latest revision from the index." + writeFileAtomic cabalFile pkgtxt + where + cabalFile :: FilePath + cabalFile = + parentdir + pkgsubdir + prettyShow pkgname + <.> "cabal" + pkgsubdir = prettyShow pkgid + pkgname = packageName pkgid + +-- | This is a bit of a hacky workaround. A number of packages ship +-- pre-processed .hs files in a dist directory inside the tarball. We don't +-- use the standard 'dist' location so unless we move this dist dir to the +-- right place then we'll miss the shipped pre-processed files. This hacky +-- approach to shipped pre-processed files ought to be replaced by a proper +-- system, though we'll still need to keep this hack for older packages. +moveTarballShippedDistDirectory + :: Verbosity + -> DistDirLayout + -> FilePath + -> PackageId + -> DistDirParams + -> IO () +moveTarballShippedDistDirectory + verbosity + DistDirLayout{distBuildDirectory} + parentdir + pkgid + dparams = do + distDirExists <- doesDirectoryExist tarballDistDir + when distDirExists $ do + debug verbosity $ + "Moving '" + ++ tarballDistDir + ++ "' to '" + ++ targetDistDir + ++ "'" + -- TODO: [nice to have] or perhaps better to copy, and use a file monitor + renameDirectory tarballDistDir targetDistDir + where + tarballDistDir = parentdir prettyShow pkgid "dist" + targetDistDir = distBuildDirectory dparams +<<<<<<< HEAD + +buildAndInstallUnpackedPackage + :: Verbosity + -> DistDirLayout + -> StoreDirLayout + -> Maybe SemaphoreName + -- ^ Whether to pass a semaphore to build process + -- this is different to BuildTimeSettings because the + -- name of the semaphore is created freshly each time. + -> BuildTimeSettings + -> Lock + -> Lock + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedReadyPackage + -> FilePath + -> FilePath + -> IO BuildResult +buildAndInstallUnpackedPackage + verbosity + distDirLayout@DistDirLayout{distTempDirectory} + storeDirLayout@StoreDirLayout + { storePackageDBStack + } + maybe_semaphore + BuildTimeSettings + { buildSettingNumJobs + , buildSettingLogFile + } + registerLock + cacheLock + pkgshared@ElaboratedSharedConfig + { pkgConfigPlatform = platform + , pkgConfigCompiler = compiler + , pkgConfigCompilerProgs = progdb + } + plan + rpkg@(ReadyPackage pkg) + srcdir + builddir = do + createDirectoryIfMissingVerbose verbosity True (srcdir builddir) + initLogFile + + -- TODO: [code cleanup] deal consistently with talking to older + -- Setup.hs versions, much like we do for ghc, with a proper + -- options type and rendering step which will also let us + -- call directly into the lib, rather than always going via + -- the lib's command line interface, which would also allow + -- passing data like installed packages, compiler, and + -- program db for a quicker configure. + + -- TODO: [required feature] docs and tests + -- TODO: [required feature] sudo re-exec + + -- Configure phase + noticeProgress ProgressStarting + + annotateFailure mlogFile ConfigureFailed $ + setup' configureCommand configureFlags configureArgs + + -- Build phase + noticeProgress ProgressBuilding + + annotateFailure mlogFile BuildFailed $ + setup buildCommand buildFlags + + -- Haddock phase + whenHaddock $ do + noticeProgress ProgressHaddock + annotateFailureNoLog HaddocksFailed $ + setup haddockCommand haddockFlags + + -- Install phase + noticeProgress ProgressInstalling + annotateFailure mlogFile InstallFailed $ do + let copyPkgFiles tmpDir = do + let tmpDirNormalised = normalise tmpDir + setup Cabal.copyCommand (copyFlags tmpDirNormalised) + -- 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 = + normalise $ + dropDrive (InstallDirs.prefix (elabInstallDirs pkg)) + entryDir = tmpDirNormalised prefix + + -- if there weren't anything to build, it might be that directory is not created + -- the @setup Cabal.copyCommand@ above might do nothing. + -- https://github.com/haskell/cabal/issues/4130 + createDirectoryIfMissingVerbose verbosity True entryDir + + let hashFileName = entryDir "cabal-hash.txt" + outPkgHashInputs = renderPackageHashInputs (packageHashInputs pkgshared pkg) + + info verbosity $ + "creating file with the inputs used to compute the package hash: " ++ hashFileName + + LBS.writeFile hashFileName outPkgHashInputs + + debug verbosity "Package hash inputs:" + traverse_ + (debug verbosity . ("> " ++)) + (lines $ LBS.Char8.unpack outPkgHashInputs) + + -- Ensure that there are no files in `tmpDir`, that are + -- not in `entryDir`. While this breaks the + -- prefix-relocatable property of the libraries, it is + -- necessary on macOS to stay under the load command limit + -- of the macOS mach-o linker. See also + -- @PackageHash.hashedInstalledPackageIdVeryShort@. + -- + -- We also normalise paths to ensure that there are no + -- different representations for the same path. Like / and + -- \\ on windows under msys. + otherFiles <- + filter (not . isPrefixOf entryDir) + <$> listFilesRecursive tmpDirNormalised + -- 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, otherFiles) + where + listFilesRecursive :: FilePath -> IO [FilePath] + listFilesRecursive path = do + files <- fmap (path ) <$> (listDirectory path) + allFiles <- for files $ \file -> do + isDir <- doesDirectoryExist file + if isDir + then listFilesRecursive file + else return [file] + return (concat allFiles) + + registerPkg + | not (elabRequiresRegistration pkg) = + debug verbosity $ + "registerPkg: elab does NOT require registration for " + ++ prettyShow uid + | 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 + 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 + testsResult = TestsNotTried + + noticeProgress ProgressCompleted + + return + BuildResult + { buildResultDocs = docsResult + , buildResultTests = testsResult + , buildResultLogFile = mlogFile + } + where + pkgid = packageId rpkg + uid = installedUnitId rpkg + compid = compilerId compiler + + dispname :: String + dispname = case elabPkgOrComp pkg of + ElabPackage _ -> + prettyShow pkgid + ++ " (all, legacy fallback)" + ElabComponent comp -> + prettyShow pkgid + ++ " (" + ++ maybe "custom" prettyShow (compComponentName comp) + ++ ")" + + noticeProgress :: ProgressPhase -> IO () + noticeProgress phase = + when (isParallelBuild buildSettingNumJobs) $ + progressMessage verbosity phase dispname + + whenHaddock action + | hasValidHaddockTargets pkg = action + | otherwise = return () + + configureCommand = Cabal.configureCommand defaultProgramDb + configureFlags v = + flip filterConfigureFlags v $ + setupHsConfigureFlags + plan + rpkg + pkgshared + verbosity + builddir + configureArgs _ = setupHsConfigureArgs pkg + + buildCommand = Cabal.buildCommand defaultProgramDb + comp_par_strat = case maybe_semaphore of + Just sem_name -> Cabal.Flag (getSemaphoreName sem_name) + _ -> Cabal.NoFlag + buildFlags _ = setupHsBuildFlags comp_par_strat pkg pkgshared verbosity builddir + + haddockCommand = Cabal.haddockCommand + haddockFlags _ = + setupHsHaddockFlags + pkg + pkgshared + verbosity + builddir + + generateInstalledPackageInfo :: IO InstalledPackageInfo + generateInstalledPackageInfo = + withTempInstalledPackageInfoFile + verbosity + distTempDirectory + $ \pkgConfDest -> do + let registerFlags _ = + setupHsRegisterFlags + pkg + pkgshared + verbosity + builddir + pkgConfDest + setup Cabal.registerCommand registerFlags + + copyFlags destdir _ = + setupHsCopyFlags + pkg + pkgshared + verbosity + builddir + destdir + + scriptOptions = + setupHsScriptOptions + rpkg + plan + pkgshared + distDirLayout + srcdir + builddir + (isParallelBuild buildSettingNumJobs) + cacheLock + + setup :: CommandUI flags -> (Version -> flags) -> IO () + setup cmd flags = setup' cmd flags (const []) + + setup' + :: CommandUI flags + -> (Version -> flags) + -> (Version -> [String]) + -> IO () + setup' cmd flags args = + withLogging $ \mLogFileHandle -> + setupWrapper + verbosity + scriptOptions + { useLoggingHandle = mLogFileHandle + , useExtraEnvOverrides = + dataDirsEnvironmentForPlan + distDirLayout + plan + } + (Just (elabPkgDescription pkg)) + cmd + flags + args + + mlogFile :: Maybe FilePath + mlogFile = + case buildSettingLogFile of + Nothing -> Nothing + Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid) + + initLogFile :: IO () + initLogFile = + case mlogFile of + Nothing -> return () + Just logFile -> do + createDirectoryIfMissing True (takeDirectory logFile) + exists <- doesFileExist logFile + when exists $ removeFile logFile + + withLogging :: (Maybe Handle -> IO r) -> IO r + withLogging action = + case mlogFile of + Nothing -> action Nothing + Just logFile -> withFile logFile AppendMode (action . Just) + +hasValidHaddockTargets :: ElaboratedConfiguredPackage -> Bool +hasValidHaddockTargets ElaboratedConfiguredPackage{..} + | not elabBuildHaddocks = False + | otherwise = any componentHasHaddocks components + where + components :: [ComponentTarget] + components = + elabBuildTargets + ++ elabTestTargets + ++ elabBenchTargets + ++ elabReplTarget + ++ elabHaddockTargets + + componentHasHaddocks :: ComponentTarget -> Bool + componentHasHaddocks (ComponentTarget name _) = + case name of + CLibName LMainLibName -> hasHaddocks + CLibName (LSubLibName _) -> elabHaddockInternal && hasHaddocks + CFLibName _ -> elabHaddockForeignLibs && hasHaddocks + CExeName _ -> elabHaddockExecutables && hasHaddocks + CTestName _ -> elabHaddockTestSuites && hasHaddocks + CBenchName _ -> elabHaddockBenchmarks && hasHaddocks + where + hasHaddocks = not (null (elabPkgDescription ^. componentModules name)) + +buildInplaceUnpackedPackage + :: Verbosity + -> DistDirLayout + -> Maybe SemaphoreName + -> BuildTimeSettings + -> Lock + -> Lock + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedReadyPackage + -> BuildStatusRebuild + -> FilePath + -> FilePath + -> IO BuildResult +buildInplaceUnpackedPackage + verbosity + distDirLayout@DistDirLayout + { distTempDirectory + , distPackageCacheDirectory + , distDirectory + , distHaddockOutputDir + } + maybe_semaphore + BuildTimeSettings{buildSettingNumJobs, buildSettingHaddockOpen} + registerLock + cacheLock + pkgshared@ElaboratedSharedConfig + { pkgConfigCompiler = compiler + , pkgConfigCompilerProgs = progdb + , pkgConfigPlatform = platform + } + plan + rpkg@(ReadyPackage pkg) + buildStatus + srcdir + builddir = do + -- TODO: [code cleanup] there is duplication between the + -- distdirlayout and the builddir here builddir is not + -- enough, we also need the per-package cachedir + createDirectoryIfMissingVerbose verbosity True builddir + createDirectoryIfMissingVerbose + verbosity + True + (distPackageCacheDirectory dparams) + + -- Configure phase + -- + whenReConfigure $ do + annotateFailureNoLog ConfigureFailed $ + setup configureCommand configureFlags configureArgs + invalidatePackageRegFileMonitor packageFileMonitor + updatePackageConfigFileMonitor packageFileMonitor srcdir pkg + + -- Build phase + -- + let docsResult = DocsNotTried + testsResult = TestsNotTried + + buildResult :: BuildResultMisc + buildResult = (docsResult, testsResult) + + whenRebuild $ do + timestamp <- beginUpdateFileMonitor + annotateFailureNoLog BuildFailed $ + setup buildCommand buildFlags buildArgs + + let listSimple = + execRebuild srcdir (needElaboratedConfiguredPackage pkg) + listSdist = + fmap (map monitorFileHashed) $ + allPackageSourceFiles verbosity srcdir + ifNullThen m m' = do + xs <- m + if null xs then m' else return xs + monitors <- case PD.buildType (elabPkgDescription pkg) of + Simple -> listSimple + -- If a Custom setup was used, AND the Cabal is recent + -- enough to have sdist --list-sources, use that to + -- determine the files that we need to track. This can + -- cause unnecessary rebuilding (for example, if README + -- is edited, we will try to rebuild) but there isn't + -- a more accurate Custom interface we can use to get + -- this info. We prefer not to use listSimple here + -- as it can miss extra source files that are considered + -- by the Custom setup. + _ + | elabSetupScriptCliVersion pkg >= mkVersion [1, 17] -> + -- However, sometimes sdist --list-sources will fail + -- and return an empty list. In that case, fall + -- back on the (inaccurate) simple tracking. + listSdist `ifNullThen` listSimple + | otherwise -> + listSimple + + let dep_monitors = + map monitorFileHashed $ + elabInplaceDependencyBuildCacheFiles + distDirLayout + pkgshared + plan + pkg + updatePackageBuildFileMonitor + packageFileMonitor + srcdir + timestamp + pkg + buildStatus + (monitors ++ dep_monitors) + buildResult + + -- PURPOSELY omitted: no copy! + + whenReRegister $ annotateFailureNoLog InstallFailed $ do + -- Register locally + mipkg <- + if elabRequiresRegistration pkg + then do + ipkg0 <- generateInstalledPackageInfo + -- 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. + let ipkg = ipkg0{Installed.installedUnitId = ipkgid} + criticalSection registerLock $ + Cabal.registerPackage + verbosity + compiler + progdb + (elabRegisterPackageDBStack pkg) + ipkg + Cabal.defaultRegisterOptions + return (Just ipkg) + else return Nothing + + updatePackageRegFileMonitor packageFileMonitor srcdir mipkg + + whenTest $ do + annotateFailureNoLog TestsFailed $ + setup testCommand testFlags testArgs + + whenBench $ + annotateFailureNoLog BenchFailed $ + setup benchCommand benchFlags benchArgs + + -- Repl phase + -- + whenRepl $ + annotateFailureNoLog ReplFailed $ + setupInteractive replCommand replFlags replArgs + + -- Haddock phase + whenHaddock $ + annotateFailureNoLog HaddocksFailed $ do + setup haddockCommand haddockFlags haddockArgs + let haddockTarget = elabHaddockForHackage pkg + when (haddockTarget == Cabal.ForHackage) $ do + let dest = distDirectory name <.> "tar.gz" + name = haddockDirName haddockTarget (elabPkgDescription pkg) + docDir = + distBuildDirectory distDirLayout dparams + "doc" + "html" + Tar.createTarGzFile dest docDir name + notice verbosity $ "Documentation tarball created: " ++ dest + + when (buildSettingHaddockOpen && haddockTarget /= Cabal.ForHackage) $ do + let dest = docDir "index.html" + name = haddockDirName haddockTarget (elabPkgDescription pkg) + docDir = case distHaddockOutputDir of + Nothing -> distBuildDirectory distDirLayout dparams "doc" "html" name + Just dir -> dir + exe <- findOpenProgramLocation platform + case exe of + Right open -> runProgramInvocation verbosity (simpleProgramInvocation open [dest]) + Left err -> dieWithException verbosity $ FindOpenProgramLocationErr err + + return + BuildResult + { buildResultDocs = docsResult + , buildResultTests = testsResult + , buildResultLogFile = Nothing + } + where + ipkgid = installedUnitId pkg + dparams = elabDistDirParams pkgshared pkg + + comp_par_strat = case maybe_semaphore of + Just sem_name -> Cabal.toFlag (getSemaphoreName sem_name) + _ -> Cabal.NoFlag + + packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams + + whenReConfigure action = case buildStatus of + BuildStatusConfigure _ -> action + _ -> return () + + whenRebuild action + | null (elabBuildTargets pkg) + , -- NB: we have to build the test/bench suite! + null (elabTestTargets pkg) + , null (elabBenchTargets pkg) = + return () + | otherwise = action + + whenTest action + | null (elabTestTargets pkg) = return () + | otherwise = action + + whenBench action + | null (elabBenchTargets pkg) = return () + | otherwise = action + + whenRepl action + | null (elabReplTarget pkg) = return () + | otherwise = action + + whenHaddock action + | hasValidHaddockTargets pkg = action + | otherwise = return () + + whenReRegister action = + case buildStatus of + -- We registered the package already + BuildStatusBuild (Just _) _ -> + info verbosity "whenReRegister: previously registered" + -- There is nothing to register + _ + | null (elabBuildTargets pkg) -> + info verbosity "whenReRegister: nothing to register" + | otherwise -> action + + configureCommand = Cabal.configureCommand defaultProgramDb + configureFlags v = + flip filterConfigureFlags v $ + setupHsConfigureFlags + plan + rpkg + pkgshared + verbosity + builddir + configureArgs _ = setupHsConfigureArgs pkg + + buildCommand = Cabal.buildCommand defaultProgramDb + buildFlags _ = + setupHsBuildFlags + comp_par_strat + pkg + pkgshared + verbosity + builddir + buildArgs _ = setupHsBuildArgs pkg + + testCommand = Cabal.testCommand -- defaultProgramDb + testFlags v = + flip filterTestFlags v $ + setupHsTestFlags + pkg + verbosity + builddir + testArgs _ = setupHsTestArgs pkg + + benchCommand = Cabal.benchmarkCommand + benchFlags _ = + setupHsBenchFlags + pkg + pkgshared + verbosity + builddir + benchArgs _ = setupHsBenchArgs pkg + + replCommand = Cabal.replCommand defaultProgramDb + replFlags _ = + setupHsReplFlags + pkg + pkgshared + verbosity + builddir + replArgs _ = setupHsReplArgs pkg + + haddockCommand = Cabal.haddockCommand + haddockFlags v = + flip filterHaddockFlags v $ + setupHsHaddockFlags + pkg + pkgshared + verbosity + builddir + haddockArgs v = + flip filterHaddockArgs v $ + setupHsHaddockArgs pkg + + scriptOptions = + setupHsScriptOptions + rpkg + plan + pkgshared + distDirLayout + srcdir + builddir + (isParallelBuild buildSettingNumJobs) + cacheLock + + setupInteractive + :: CommandUI flags + -> (Version -> flags) + -> (Version -> [String]) + -> IO () + setupInteractive cmd flags args = + setupWrapper + verbosity + scriptOptions{isInteractive = True} + (Just (elabPkgDescription pkg)) + cmd + flags + args + + setup + :: CommandUI flags + -> (Version -> flags) + -> (Version -> [String]) + -> IO () + setup cmd flags args = + setupWrapper + verbosity + scriptOptions + (Just (elabPkgDescription pkg)) + cmd + flags + args + + generateInstalledPackageInfo :: IO InstalledPackageInfo + generateInstalledPackageInfo = + withTempInstalledPackageInfoFile + verbosity + distTempDirectory + $ \pkgConfDest -> do + let registerFlags _ = + setupHsRegisterFlags + pkg + pkgshared + verbosity + builddir + pkgConfDest + setup Cabal.registerCommand registerFlags (const []) + +withTempInstalledPackageInfoFile + :: Verbosity + -> FilePath + -> (FilePath -> IO ()) + -> IO InstalledPackageInfo +withTempInstalledPackageInfoFile verbosity tempdir action = + withTempDirectory verbosity tempdir "package-registration-" $ \dir -> do + -- make absolute since @action@ will often change directory + abs_dir <- canonicalizePath dir + + let pkgConfDest = abs_dir "pkgConf" + action pkgConfDest + + readPkgConf "." pkgConfDest + where + pkgConfParseFailed :: String -> IO a + pkgConfParseFailed perror = + dieWithException verbosity $ PkgConfParseFailed perror + + readPkgConf :: FilePath -> FilePath -> IO InstalledPackageInfo + readPkgConf pkgConfDir pkgConfFile = do + pkgConfStr <- BS.readFile (pkgConfDir pkgConfFile) + (warns, ipkg) <- case Installed.parseInstalledPackageInfo pkgConfStr of + Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors + Right (warns, ipkg) -> return (warns, ipkg) + + unless (null warns) $ + warn verbosity $ + unlines warns + + return ipkg + +------------------------------------------------------------------------------ + +-- * Utilities + +------------------------------------------------------------------------------ + +{- FOURMOLU_DISABLE -} +annotateFailureNoLog :: (SomeException -> BuildFailureReason) + -> IO a -> IO a +annotateFailureNoLog annotate action = + annotateFailure Nothing annotate action + +annotateFailure :: Maybe FilePath + -> (SomeException -> BuildFailureReason) + -> IO a -> IO a +annotateFailure mlogFile annotate action = + action `catches` + -- It's not just IOException and ExitCode we have to deal with, there's + -- lots, including exceptions from the hackage-security and tar packages. + -- So we take the strategy of catching everything except async exceptions. + [ +#if MIN_VERSION_base(4,7,0) + Handler $ \async -> throwIO (async :: SomeAsyncException) +#else + Handler $ \async -> throwIO (async :: AsyncException) +#endif + , Handler $ \other -> handler (other :: SomeException) + ] + where + handler :: Exception e => e -> IO a + handler = throwIO . BuildFailure mlogFile . annotate . toException +||||||| parent of 531e5e250 (Refactor ProjectBuilding into Package Phases) + +buildAndInstallUnpackedPackage + :: Verbosity + -> DistDirLayout + -> StoreDirLayout + -> Maybe SemaphoreName + -- ^ Whether to pass a semaphore to build process + -- this is different to BuildTimeSettings because the + -- name of the semaphore is created freshly each time. + -> BuildTimeSettings + -> Lock + -> Lock + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedReadyPackage + -> FilePath + -> FilePath + -> IO BuildResult +buildAndInstallUnpackedPackage + verbosity + distDirLayout@DistDirLayout{distTempDirectory} + storeDirLayout@StoreDirLayout + { storePackageDBStack + } + maybe_semaphore + BuildTimeSettings + { buildSettingNumJobs + , buildSettingLogFile + } + registerLock + cacheLock + pkgshared@ElaboratedSharedConfig + { pkgConfigPlatform = platform + , pkgConfigCompiler = compiler + , pkgConfigCompilerProgs = progdb + } + plan + rpkg@(ReadyPackage pkg) + srcdir + builddir = do + createDirectoryIfMissingVerbose verbosity True (srcdir builddir) + initLogFile + + -- TODO: [code cleanup] deal consistently with talking to older + -- Setup.hs versions, much like we do for ghc, with a proper + -- options type and rendering step which will also let us + -- call directly into the lib, rather than always going via + -- the lib's command line interface, which would also allow + -- passing data like installed packages, compiler, and + -- program db for a quicker configure. + + -- TODO: [required feature] docs and tests + -- TODO: [required feature] sudo re-exec + + -- Configure phase + noticeProgress ProgressStarting + + annotateFailure mlogFile ConfigureFailed $ + setup' configureCommand configureFlags configureArgs + + -- Build phase + noticeProgress ProgressBuilding + + annotateFailure mlogFile BuildFailed $ + setup buildCommand buildFlags + + -- Haddock phase + whenHaddock $ do + noticeProgress ProgressHaddock + annotateFailureNoLog HaddocksFailed $ + setup haddockCommand haddockFlags + + -- Install phase + noticeProgress ProgressInstalling + annotateFailure mlogFile InstallFailed $ do + let copyPkgFiles tmpDir = do + let tmpDirNormalised = normalise tmpDir + setup Cabal.copyCommand (copyFlags tmpDirNormalised) + -- 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 = + normalise $ + dropDrive (InstallDirs.prefix (elabInstallDirs pkg)) + entryDir = tmpDirNormalised prefix + + -- if there weren't anything to build, it might be that directory is not created + -- the @setup Cabal.copyCommand@ above might do nothing. + -- https://github.com/haskell/cabal/issues/4130 + createDirectoryIfMissingVerbose verbosity True entryDir + + let hashFileName = entryDir "cabal-hash.txt" + outPkgHashInputs = renderPackageHashInputs (packageHashInputs pkgshared pkg) + + info verbosity $ + "creating file with the inputs used to compute the package hash: " ++ hashFileName + + LBS.writeFile hashFileName outPkgHashInputs + + debug verbosity "Package hash inputs:" + traverse_ + (debug verbosity . ("> " ++)) + (lines $ LBS.Char8.unpack outPkgHashInputs) + + -- Ensure that there are no files in `tmpDir`, that are + -- not in `entryDir`. While this breaks the + -- prefix-relocatable property of the libraries, it is + -- necessary on macOS to stay under the load command limit + -- of the macOS mach-o linker. See also + -- @PackageHash.hashedInstalledPackageIdVeryShort@. + -- + -- We also normalise paths to ensure that there are no + -- different representations for the same path. Like / and + -- \\ on windows under msys. + otherFiles <- + filter (not . isPrefixOf entryDir) + <$> listFilesRecursive tmpDirNormalised + -- 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, otherFiles) + where + listFilesRecursive :: FilePath -> IO [FilePath] + listFilesRecursive path = do + files <- fmap (path ) <$> (listDirectory path) + allFiles <- for files $ \file -> do + isDir <- doesDirectoryExist file + if isDir + then listFilesRecursive file + else return [file] + return (concat allFiles) + + registerPkg + | not (elabRequiresRegistration pkg) = + debug verbosity $ + "registerPkg: elab does NOT require registration for " + ++ prettyShow uid + | 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 + 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 + testsResult = TestsNotTried + + noticeProgress ProgressCompleted + + return + BuildResult + { buildResultDocs = docsResult + , buildResultTests = testsResult + , buildResultLogFile = mlogFile + } + where + pkgid = packageId rpkg + uid = installedUnitId rpkg + compid = compilerId compiler + + dispname :: String + dispname = case elabPkgOrComp pkg of + ElabPackage _ -> + prettyShow pkgid + ++ " (all, legacy fallback)" + ElabComponent comp -> + prettyShow pkgid + ++ " (" + ++ maybe "custom" prettyShow (compComponentName comp) + ++ ")" + + noticeProgress :: ProgressPhase -> IO () + noticeProgress phase = + when (isParallelBuild buildSettingNumJobs) $ + progressMessage verbosity phase dispname + + whenHaddock action + | hasValidHaddockTargets pkg = action + | otherwise = return () + + configureCommand = Cabal.configureCommand defaultProgramDb + configureFlags v = + flip filterConfigureFlags v $ + setupHsConfigureFlags + rpkg + pkgshared + verbosity + builddir + configureArgs _ = setupHsConfigureArgs pkg + + buildCommand = Cabal.buildCommand defaultProgramDb + comp_par_strat = case maybe_semaphore of + Just sem_name -> Cabal.Flag (getSemaphoreName sem_name) + _ -> Cabal.NoFlag + buildFlags _ = setupHsBuildFlags comp_par_strat pkg pkgshared verbosity builddir + + haddockCommand = Cabal.haddockCommand + haddockFlags _ = + setupHsHaddockFlags + pkg + pkgshared + verbosity + builddir + + generateInstalledPackageInfo :: IO InstalledPackageInfo + generateInstalledPackageInfo = + withTempInstalledPackageInfoFile + verbosity + distTempDirectory + $ \pkgConfDest -> do + let registerFlags _ = + setupHsRegisterFlags + pkg + pkgshared + verbosity + builddir + pkgConfDest + setup Cabal.registerCommand registerFlags + + copyFlags destdir _ = + setupHsCopyFlags + pkg + pkgshared + verbosity + builddir + destdir + + scriptOptions = + setupHsScriptOptions + rpkg + plan + pkgshared + distDirLayout + srcdir + builddir + (isParallelBuild buildSettingNumJobs) + cacheLock + + setup :: CommandUI flags -> (Version -> flags) -> IO () + setup cmd flags = setup' cmd flags (const []) + + setup' + :: CommandUI flags + -> (Version -> flags) + -> (Version -> [String]) + -> IO () + setup' cmd flags args = + withLogging $ \mLogFileHandle -> + setupWrapper + verbosity + scriptOptions + { useLoggingHandle = mLogFileHandle + , useExtraEnvOverrides = + dataDirsEnvironmentForPlan + distDirLayout + plan + } + (Just (elabPkgDescription pkg)) + cmd + flags + args + + mlogFile :: Maybe FilePath + mlogFile = + case buildSettingLogFile of + Nothing -> Nothing + Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid) + + initLogFile :: IO () + initLogFile = + case mlogFile of + Nothing -> return () + Just logFile -> do + createDirectoryIfMissing True (takeDirectory logFile) + exists <- doesFileExist logFile + when exists $ removeFile logFile + + withLogging :: (Maybe Handle -> IO r) -> IO r + withLogging action = + case mlogFile of + Nothing -> action Nothing + Just logFile -> withFile logFile AppendMode (action . Just) + +hasValidHaddockTargets :: ElaboratedConfiguredPackage -> Bool +hasValidHaddockTargets ElaboratedConfiguredPackage{..} + | not elabBuildHaddocks = False + | otherwise = any componentHasHaddocks components + where + components :: [ComponentTarget] + components = + elabBuildTargets + ++ elabTestTargets + ++ elabBenchTargets + ++ elabReplTarget + ++ elabHaddockTargets + + componentHasHaddocks :: ComponentTarget -> Bool + componentHasHaddocks (ComponentTarget name _) = + case name of + CLibName LMainLibName -> hasHaddocks + CLibName (LSubLibName _) -> elabHaddockInternal && hasHaddocks + CFLibName _ -> elabHaddockForeignLibs && hasHaddocks + CExeName _ -> elabHaddockExecutables && hasHaddocks + CTestName _ -> elabHaddockTestSuites && hasHaddocks + CBenchName _ -> elabHaddockBenchmarks && hasHaddocks + where + hasHaddocks = not (null (elabPkgDescription ^. componentModules name)) + +buildInplaceUnpackedPackage + :: Verbosity + -> DistDirLayout + -> Maybe SemaphoreName + -> BuildTimeSettings + -> Lock + -> Lock + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedReadyPackage + -> BuildStatusRebuild + -> FilePath + -> FilePath + -> IO BuildResult +buildInplaceUnpackedPackage + verbosity + distDirLayout@DistDirLayout + { distTempDirectory + , distPackageCacheDirectory + , distDirectory + , distHaddockOutputDir + } + maybe_semaphore + BuildTimeSettings{buildSettingNumJobs, buildSettingHaddockOpen} + registerLock + cacheLock + pkgshared@ElaboratedSharedConfig + { pkgConfigCompiler = compiler + , pkgConfigCompilerProgs = progdb + , pkgConfigPlatform = platform + } + plan + rpkg@(ReadyPackage pkg) + buildStatus + srcdir + builddir = do + -- TODO: [code cleanup] there is duplication between the + -- distdirlayout and the builddir here builddir is not + -- enough, we also need the per-package cachedir + createDirectoryIfMissingVerbose verbosity True builddir + createDirectoryIfMissingVerbose + verbosity + True + (distPackageCacheDirectory dparams) + + -- Configure phase + -- + whenReConfigure $ do + annotateFailureNoLog ConfigureFailed $ + setup configureCommand configureFlags configureArgs + invalidatePackageRegFileMonitor packageFileMonitor + updatePackageConfigFileMonitor packageFileMonitor srcdir pkg + + -- Build phase + -- + let docsResult = DocsNotTried + testsResult = TestsNotTried + + buildResult :: BuildResultMisc + buildResult = (docsResult, testsResult) + + whenRebuild $ do + timestamp <- beginUpdateFileMonitor + annotateFailureNoLog BuildFailed $ + setup buildCommand buildFlags buildArgs + + let listSimple = + execRebuild srcdir (needElaboratedConfiguredPackage pkg) + listSdist = + fmap (map monitorFileHashed) $ + allPackageSourceFiles verbosity srcdir + ifNullThen m m' = do + xs <- m + if null xs then m' else return xs + monitors <- case PD.buildType (elabPkgDescription pkg) of + Simple -> listSimple + -- If a Custom setup was used, AND the Cabal is recent + -- enough to have sdist --list-sources, use that to + -- determine the files that we need to track. This can + -- cause unnecessary rebuilding (for example, if README + -- is edited, we will try to rebuild) but there isn't + -- a more accurate Custom interface we can use to get + -- this info. We prefer not to use listSimple here + -- as it can miss extra source files that are considered + -- by the Custom setup. + _ + | elabSetupScriptCliVersion pkg >= mkVersion [1, 17] -> + -- However, sometimes sdist --list-sources will fail + -- and return an empty list. In that case, fall + -- back on the (inaccurate) simple tracking. + listSdist `ifNullThen` listSimple + | otherwise -> + listSimple + + let dep_monitors = + map monitorFileHashed $ + elabInplaceDependencyBuildCacheFiles + distDirLayout + pkgshared + plan + pkg + updatePackageBuildFileMonitor + packageFileMonitor + srcdir + timestamp + pkg + buildStatus + (monitors ++ dep_monitors) + buildResult + + -- PURPOSELY omitted: no copy! + + whenReRegister $ annotateFailureNoLog InstallFailed $ do + -- Register locally + mipkg <- + if elabRequiresRegistration pkg + then do + ipkg0 <- generateInstalledPackageInfo + -- 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. + let ipkg = ipkg0{Installed.installedUnitId = ipkgid} + criticalSection registerLock $ + Cabal.registerPackage + verbosity + compiler + progdb + (elabRegisterPackageDBStack pkg) + ipkg + Cabal.defaultRegisterOptions + return (Just ipkg) + else return Nothing + + updatePackageRegFileMonitor packageFileMonitor srcdir mipkg + + whenTest $ do + annotateFailureNoLog TestsFailed $ + setup testCommand testFlags testArgs + + whenBench $ + annotateFailureNoLog BenchFailed $ + setup benchCommand benchFlags benchArgs + + -- Repl phase + -- + whenRepl $ + annotateFailureNoLog ReplFailed $ + setupInteractive replCommand replFlags replArgs + + -- Haddock phase + whenHaddock $ + annotateFailureNoLog HaddocksFailed $ do + setup haddockCommand haddockFlags haddockArgs + let haddockTarget = elabHaddockForHackage pkg + when (haddockTarget == Cabal.ForHackage) $ do + let dest = distDirectory name <.> "tar.gz" + name = haddockDirName haddockTarget (elabPkgDescription pkg) + docDir = + distBuildDirectory distDirLayout dparams + "doc" + "html" + Tar.createTarGzFile dest docDir name + notice verbosity $ "Documentation tarball created: " ++ dest + + when (buildSettingHaddockOpen && haddockTarget /= Cabal.ForHackage) $ do + let dest = docDir "index.html" + name = haddockDirName haddockTarget (elabPkgDescription pkg) + docDir = case distHaddockOutputDir of + Nothing -> distBuildDirectory distDirLayout dparams "doc" "html" name + Just dir -> dir + exe <- findOpenProgramLocation platform + case exe of + Right open -> runProgramInvocation verbosity (simpleProgramInvocation open [dest]) + Left err -> dieWithException verbosity $ FindOpenProgramLocationErr err + + return + BuildResult + { buildResultDocs = docsResult + , buildResultTests = testsResult + , buildResultLogFile = Nothing + } + where + ipkgid = installedUnitId pkg + dparams = elabDistDirParams pkgshared pkg + + comp_par_strat = case maybe_semaphore of + Just sem_name -> Cabal.toFlag (getSemaphoreName sem_name) + _ -> Cabal.NoFlag + + packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams + + whenReConfigure action = case buildStatus of + BuildStatusConfigure _ -> action + _ -> return () + + whenRebuild action + | null (elabBuildTargets pkg) + , -- NB: we have to build the test/bench suite! + null (elabTestTargets pkg) + , null (elabBenchTargets pkg) = + return () + | otherwise = action + + whenTest action + | null (elabTestTargets pkg) = return () + | otherwise = action + + whenBench action + | null (elabBenchTargets pkg) = return () + | otherwise = action + + whenRepl action + | null (elabReplTarget pkg) = return () + | otherwise = action + + whenHaddock action + | hasValidHaddockTargets pkg = action + | otherwise = return () + + whenReRegister action = + case buildStatus of + -- We registered the package already + BuildStatusBuild (Just _) _ -> + info verbosity "whenReRegister: previously registered" + -- There is nothing to register + _ + | null (elabBuildTargets pkg) -> + info verbosity "whenReRegister: nothing to register" + | otherwise -> action + + configureCommand = Cabal.configureCommand defaultProgramDb + configureFlags v = + flip filterConfigureFlags v $ + setupHsConfigureFlags + rpkg + pkgshared + verbosity + builddir + configureArgs _ = setupHsConfigureArgs pkg + + buildCommand = Cabal.buildCommand defaultProgramDb + buildFlags _ = + setupHsBuildFlags + comp_par_strat + pkg + pkgshared + verbosity + builddir + buildArgs _ = setupHsBuildArgs pkg + + testCommand = Cabal.testCommand -- defaultProgramDb + testFlags v = + flip filterTestFlags v $ + setupHsTestFlags + pkg + pkgshared + verbosity + builddir + testArgs _ = setupHsTestArgs pkg + + benchCommand = Cabal.benchmarkCommand + benchFlags _ = + setupHsBenchFlags + pkg + pkgshared + verbosity + builddir + benchArgs _ = setupHsBenchArgs pkg + + replCommand = Cabal.replCommand defaultProgramDb + replFlags _ = + setupHsReplFlags + pkg + pkgshared + verbosity + builddir + replArgs _ = setupHsReplArgs pkg + + haddockCommand = Cabal.haddockCommand + haddockFlags v = + flip filterHaddockFlags v $ + setupHsHaddockFlags + pkg + pkgshared + verbosity + builddir + haddockArgs v = + flip filterHaddockArgs v $ + setupHsHaddockArgs pkg + + scriptOptions = + setupHsScriptOptions + rpkg + plan + pkgshared + distDirLayout + srcdir + builddir + (isParallelBuild buildSettingNumJobs) + cacheLock + + setupInteractive + :: CommandUI flags + -> (Version -> flags) + -> (Version -> [String]) + -> IO () + setupInteractive cmd flags args = + setupWrapper + verbosity + scriptOptions{isInteractive = True} + (Just (elabPkgDescription pkg)) + cmd + flags + args + + setup + :: CommandUI flags + -> (Version -> flags) + -> (Version -> [String]) + -> IO () + setup cmd flags args = + setupWrapper + verbosity + scriptOptions + (Just (elabPkgDescription pkg)) + cmd + flags + args + + generateInstalledPackageInfo :: IO InstalledPackageInfo + generateInstalledPackageInfo = + withTempInstalledPackageInfoFile + verbosity + distTempDirectory + $ \pkgConfDest -> do + let registerFlags _ = + setupHsRegisterFlags + pkg + pkgshared + verbosity + builddir + pkgConfDest + setup Cabal.registerCommand registerFlags (const []) + +withTempInstalledPackageInfoFile + :: Verbosity + -> FilePath + -> (FilePath -> IO ()) + -> IO InstalledPackageInfo +withTempInstalledPackageInfoFile verbosity tempdir action = + withTempDirectory verbosity tempdir "package-registration-" $ \dir -> do + -- make absolute since @action@ will often change directory + abs_dir <- canonicalizePath dir + + let pkgConfDest = abs_dir "pkgConf" + action pkgConfDest + + readPkgConf "." pkgConfDest + where + pkgConfParseFailed :: String -> IO a + pkgConfParseFailed perror = + dieWithException verbosity $ PkgConfParseFailed perror + + readPkgConf :: FilePath -> FilePath -> IO InstalledPackageInfo + readPkgConf pkgConfDir pkgConfFile = do + pkgConfStr <- BS.readFile (pkgConfDir pkgConfFile) + (warns, ipkg) <- case Installed.parseInstalledPackageInfo pkgConfStr of + Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors + Right (warns, ipkg) -> return (warns, ipkg) + + unless (null warns) $ + warn verbosity $ + unlines warns + + return ipkg + +------------------------------------------------------------------------------ + +-- * Utilities + +------------------------------------------------------------------------------ + +{- FOURMOLU_DISABLE -} +annotateFailureNoLog :: (SomeException -> BuildFailureReason) + -> IO a -> IO a +annotateFailureNoLog annotate action = + annotateFailure Nothing annotate action + +annotateFailure :: Maybe FilePath + -> (SomeException -> BuildFailureReason) + -> IO a -> IO a +annotateFailure mlogFile annotate action = + action `catches` + -- It's not just IOException and ExitCode we have to deal with, there's + -- lots, including exceptions from the hackage-security and tar packages. + -- So we take the strategy of catching everything except async exceptions. + [ +#if MIN_VERSION_base(4,7,0) + Handler $ \async -> throwIO (async :: SomeAsyncException) +#else + Handler $ \async -> throwIO (async :: AsyncException) +#endif + , Handler $ \other -> handler (other :: SomeException) + ] + where + handler :: Exception e => e -> IO a + handler = throwIO . BuildFailure mlogFile . annotate . toException +======= +>>>>>>> 531e5e250 (Refactor ProjectBuilding into Package Phases) diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs new file mode 100644 index 00000000000..b93064ea7be --- /dev/null +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/PackageFileMonitor.hs @@ -0,0 +1,294 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +module Distribution.Client.ProjectBuilding.PackageFileMonitor where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.ProjectBuilding.Types +import Distribution.Client.ProjectPlanning +import Distribution.Client.ProjectPlanning.Types +import Distribution.Client.RebuildMonad + +import Distribution.Client.DistDirLayout +import Distribution.Client.FileMonitor +import Distribution.Client.Types hiding + ( BuildFailure (..) + , BuildOutcome + , BuildOutcomes + , BuildResult (..) + ) + +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import Distribution.Simple.LocalBuildInfo + ( ComponentName (..) + ) + +import qualified Data.Set as Set +import Distribution.Client.Init.Types (removeExistingFile) + +----------------------------- +-- Package change detection +-- + +-- | As part of the dry run for local unpacked packages we have to check if the +-- package config or files have changed. That is the purpose of +-- 'PackageFileMonitor' and 'checkPackageFileMonitorChanged'. +-- +-- When a package is (re)built, the monitor must be updated to reflect the new +-- state of the package. Because we sometimes build without reconfiguring the +-- state updates are split into two, one for package config changes and one +-- for other changes. This is the purpose of 'updatePackageConfigFileMonitor' +-- and 'updatePackageBuildFileMonitor'. +data PackageFileMonitor = PackageFileMonitor + { pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage () + , pkgFileMonitorBuild :: FileMonitor (Set ComponentName) BuildResultMisc + , pkgFileMonitorReg :: FileMonitor () (Maybe InstalledPackageInfo) + } + +-- | This is all the components of the 'BuildResult' other than the +-- @['InstalledPackageInfo']@. +-- +-- We have to split up the 'BuildResult' components since they get produced +-- at different times (or rather, when different things change). +type BuildResultMisc = (DocsResult, TestsResult) + +newPackageFileMonitor + :: ElaboratedSharedConfig + -> DistDirLayout + -> DistDirParams + -> PackageFileMonitor +newPackageFileMonitor + shared + DistDirLayout{distPackageCacheFile} + dparams = + PackageFileMonitor + { pkgFileMonitorConfig = + FileMonitor + { fileMonitorCacheFile = distPackageCacheFile dparams "config" + , fileMonitorKeyValid = (==) `on` normaliseConfiguredPackage shared + , fileMonitorCheckIfOnlyValueChanged = False + } + , pkgFileMonitorBuild = + FileMonitor + { fileMonitorCacheFile = distPackageCacheFile dparams "build" + , fileMonitorKeyValid = \componentsToBuild componentsAlreadyBuilt -> + componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt + , fileMonitorCheckIfOnlyValueChanged = True + } + , pkgFileMonitorReg = + newFileMonitor (distPackageCacheFile dparams "registration") + } + +-- | Helper function for 'checkPackageFileMonitorChanged', +-- 'updatePackageConfigFileMonitor' and 'updatePackageBuildFileMonitor'. +-- +-- It selects the info from a 'ElaboratedConfiguredPackage' that are used by +-- the 'FileMonitor's (in the 'PackageFileMonitor') to detect value changes. +packageFileMonitorKeyValues + :: ElaboratedConfiguredPackage + -> (ElaboratedConfiguredPackage, Set ComponentName) +packageFileMonitorKeyValues elab = + (elab_config, buildComponents) + where + -- The first part is the value used to guard (re)configuring the package. + -- That is, if this value changes then we will reconfigure. + -- The ElaboratedConfiguredPackage consists mostly (but not entirely) of + -- information that affects the (re)configure step. But those parts that + -- do not affect the configure step need to be nulled out. Those parts are + -- the specific targets that we're going to build. + -- + + -- Additionally we null out the parts that don't affect the configure step because they're simply + -- about how tests or benchmarks are run + + -- TODO there may be more things to null here too, in the future. + + elab_config :: ElaboratedConfiguredPackage + elab_config = + elab + { elabBuildTargets = [] + , elabTestTargets = [] + , elabBenchTargets = [] + , elabReplTarget = [] + , elabHaddockTargets = [] + , elabBuildHaddocks = False + , elabTestMachineLog = Nothing + , elabTestHumanLog = Nothing + , elabTestShowDetails = Nothing + , elabTestKeepTix = False + , elabTestTestOptions = [] + , elabBenchmarkOptions = [] + } + + -- The second part is the value used to guard the build step. So this is + -- more or less the opposite of the first part, as it's just the info about + -- what targets we're going to build. + -- + buildComponents :: Set ComponentName + buildComponents = elabBuildTargetWholeComponents elab + +-- | Do all the checks on whether a package has changed and thus needs either +-- rebuilding or reconfiguring and rebuilding. +checkPackageFileMonitorChanged + :: PackageFileMonitor + -> ElaboratedConfiguredPackage + -> FilePath + -> [BuildStatus] + -> IO (Either BuildStatusRebuild BuildResult) +checkPackageFileMonitorChanged + PackageFileMonitor{..} + pkg + srcdir + depsBuildStatus = do + -- TODO: [nice to have] some debug-level message about file + -- changes, like rerunIfChanged + configChanged <- + checkFileMonitorChanged + pkgFileMonitorConfig + srcdir + pkgconfig + case configChanged of + MonitorChanged monitorReason -> + return (Left (BuildStatusConfigure monitorReason')) + where + monitorReason' = fmap (const ()) monitorReason + MonitorUnchanged () _ + -- The configChanged here includes the identity of the dependencies, + -- so depsBuildStatus is just needed for the changes in the content + -- of dependencies. + | any buildStatusRequiresBuild depsBuildStatus -> do + regChanged <- checkFileMonitorChanged pkgFileMonitorReg srcdir () + let mreg = changedToMaybe regChanged + return (Left (BuildStatusBuild mreg BuildReasonDepsRebuilt)) + | otherwise -> do + buildChanged <- + checkFileMonitorChanged + pkgFileMonitorBuild + srcdir + buildComponents + regChanged <- + checkFileMonitorChanged + pkgFileMonitorReg + srcdir + () + let mreg = changedToMaybe regChanged + case (buildChanged, regChanged) of + (MonitorChanged (MonitoredValueChanged prevBuildComponents), _) -> + return (Left (BuildStatusBuild mreg buildReason)) + where + buildReason = BuildReasonExtraTargets prevBuildComponents + (MonitorChanged monitorReason, _) -> + return (Left (BuildStatusBuild mreg buildReason)) + where + buildReason = BuildReasonFilesChanged monitorReason' + monitorReason' = fmap (const ()) monitorReason + (MonitorUnchanged _ _, MonitorChanged monitorReason) -> + -- this should only happen if the file is corrupt or been + -- manually deleted. We don't want to bother with another + -- phase just for this, so we'll reregister by doing a build. + return (Left (BuildStatusBuild Nothing buildReason)) + where + buildReason = BuildReasonFilesChanged monitorReason' + monitorReason' = fmap (const ()) monitorReason + (MonitorUnchanged _ _, MonitorUnchanged _ _) + | pkgHasEphemeralBuildTargets pkg -> + return (Left (BuildStatusBuild mreg buildReason)) + where + buildReason = BuildReasonEphemeralTargets + (MonitorUnchanged buildResult _, MonitorUnchanged _ _) -> + return $ + Right + BuildResult + { buildResultDocs = docsResult + , buildResultTests = testsResult + , buildResultLogFile = Nothing + } + where + (docsResult, testsResult) = buildResult + where + (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg + changedToMaybe :: MonitorChanged a b -> Maybe b + changedToMaybe (MonitorChanged _) = Nothing + changedToMaybe (MonitorUnchanged x _) = Just x + +updatePackageConfigFileMonitor + :: PackageFileMonitor + -> FilePath + -> ElaboratedConfiguredPackage + -> IO () +updatePackageConfigFileMonitor + PackageFileMonitor{pkgFileMonitorConfig} + srcdir + pkg = + updateFileMonitor + pkgFileMonitorConfig + srcdir + Nothing + [] + pkgconfig + () + where + (pkgconfig, _buildComponents) = packageFileMonitorKeyValues pkg + +updatePackageBuildFileMonitor + :: PackageFileMonitor + -> FilePath + -> MonitorTimestamp + -> ElaboratedConfiguredPackage + -> BuildStatusRebuild + -> [MonitorFilePath] + -> BuildResultMisc + -> IO () +updatePackageBuildFileMonitor + PackageFileMonitor{pkgFileMonitorBuild} + srcdir + timestamp + pkg + pkgBuildStatus + monitors + buildResult = + updateFileMonitor + pkgFileMonitorBuild + srcdir + (Just timestamp) + monitors + buildComponents' + buildResult + where + (_pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg + + -- If the only thing that's changed is that we're now building extra + -- components, then we can avoid later unnecessary rebuilds by saving the + -- total set of components that have been built, namely the union of the + -- existing ones plus the new ones. If files also changed this would be + -- the wrong thing to do. Note that we rely on the + -- fileMonitorCheckIfOnlyValueChanged = True mode to get this guarantee + -- that it's /only/ the value that changed not any files that changed. + buildComponents' = + case pkgBuildStatus of + BuildStatusBuild _ (BuildReasonExtraTargets prevBuildComponents) -> + buildComponents `Set.union` prevBuildComponents + _ -> buildComponents + +updatePackageRegFileMonitor + :: PackageFileMonitor + -> FilePath + -> Maybe InstalledPackageInfo + -> IO () +updatePackageRegFileMonitor + PackageFileMonitor{pkgFileMonitorReg} + srcdir + mipkg = + updateFileMonitor + pkgFileMonitorReg + srcdir + Nothing + [] + () + mipkg + +invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO () +invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} = + removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg) diff --git a/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs new file mode 100644 index 00000000000..f0ce968a78d --- /dev/null +++ b/cabal-install/src/Distribution/Client/ProjectBuilding/UnpackedPackage.hs @@ -0,0 +1,921 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +-- | This module exposes functions to build and register unpacked packages. +-- +-- Mainly, unpacked packages are either: +-- * Built and registered in-place +-- * Built and installed +-- +-- The two cases differ significantly for there to be a distinction. +-- For instance, we only care about file monitoring and re-building when dealing +-- with "inplace" registered packages, whereas for installed packages we don't. +module Distribution.Client.ProjectBuilding.UnpackedPackage + ( buildInplaceUnpackedPackage + , buildAndInstallUnpackedPackage + + -- ** Auxiliary definitions + , buildAndRegisterUnpackedPackage + , PackageBuildingPhase + + -- ** Utilities + , annotateFailure + , annotateFailureNoLog + ) where + +import Distribution.Client.Compat.Prelude +import Prelude () + +import Distribution.Client.PackageHash (renderPackageHashInputs) +import Distribution.Client.ProjectBuilding.Types +import Distribution.Client.ProjectConfig +import Distribution.Client.ProjectConfig.Types +import Distribution.Client.ProjectPlanning +import Distribution.Client.ProjectPlanning.Types +import Distribution.Client.RebuildMonad +import Distribution.Client.Store + +import Distribution.Client.DistDirLayout +import Distribution.Client.FileMonitor +import Distribution.Client.JobControl +import Distribution.Client.Setup + ( filterConfigureFlags + , filterHaddockArgs + , filterHaddockFlags + , filterTestFlags + ) +import Distribution.Client.SetupWrapper +import Distribution.Client.SourceFiles +import Distribution.Client.SrcDist (allPackageSourceFiles) +import qualified Distribution.Client.Tar as Tar +import Distribution.Client.Types hiding + ( BuildFailure (..) + , BuildOutcome + , BuildOutcomes + , BuildResult (..) + ) +import Distribution.Client.Utils + ( ProgressPhase (..) + , findOpenProgramLocation + , progressMessage + ) + +import Distribution.Compat.Lens +import Distribution.InstalledPackageInfo (InstalledPackageInfo) +import qualified Distribution.InstalledPackageInfo as Installed +import Distribution.Package +import qualified Distribution.PackageDescription as PD +import Distribution.Simple.BuildPaths (haddockDirName) +import Distribution.Simple.Command (CommandUI) +import Distribution.Simple.Compiler + ( PackageDBStack + , compilerId + ) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.Simple.LocalBuildInfo + ( ComponentName (..) + , LibraryName (..) + ) +import Distribution.Simple.Program +import qualified Distribution.Simple.Register as Cabal +import qualified Distribution.Simple.Setup as Cabal +import Distribution.Types.BuildType +import Distribution.Types.PackageDescription.Lens (componentModules) + +import Distribution.Simple.Utils +import Distribution.Version + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as LBS.Char8 +import qualified Data.List.NonEmpty as NE + +import Control.Exception (Handler (..), SomeAsyncException, assert, catches) +import System.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile) +import System.FilePath (dropDrive, normalise, takeDirectory, (<.>), ()) +import System.IO (Handle, IOMode (AppendMode), withFile) +import System.Semaphore (SemaphoreName (..)) + +import Distribution.Client.Errors +import Distribution.Compat.Directory (listDirectory) + +import Distribution.Client.ProjectBuilding.PackageFileMonitor + +-- | Each unpacked package is processed in the following phases: +-- +-- * Configure phase +-- * Build phase +-- * Install phase (copy + register) +-- * Register phase +-- * Test phase +-- * Bench phase +-- * Repl phase +-- * Haddock phase +-- +-- Depending on whether we are installing the package or building it inplace, +-- the phases will be carried out differently. For example, when installing, +-- the test, benchmark, and repl phase are ignored. +data PackageBuildingPhase + = PBConfigurePhase {runConfigure :: IO ()} + | PBBuildPhase {runBuild :: IO ()} + | PBHaddockPhase {runHaddock :: IO ()} + | PBInstallPhase + { runCopy :: FilePath -> IO () + , runRegister + :: PackageDBStack + -> Cabal.RegisterOptions + -> IO InstalledPackageInfo + } + | PBTestPhase {runTest :: IO ()} + | PBBenchPhase {runBench :: IO ()} + | PBReplPhase {runRepl :: IO ()} + +-- | Structures the phases of building and registering a package amongst others +-- (see t'PackageBuildingPhase'). Delegates logic specific to a certain +-- building style (notably, inplace vs install) to the delegate function that +-- receives as an argument t'PackageBuildingPhase') +buildAndRegisterUnpackedPackage + :: Verbosity + -> DistDirLayout + -> Maybe SemaphoreName + -- ^ Whether to pass a semaphore to build process + -- this is different to BuildTimeSettings because the + -- name of the semaphore is created freshly each time. + -> BuildTimeSettings + -> Lock + -> Lock + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedReadyPackage + -> FilePath + -> FilePath + -> (PackageBuildingPhase -> IO ()) + -> IO (Maybe FilePath) + -- ^ Returns the path to the /initialized/ log file configured in + -- t'BuildTimeSettings' ('buildSettingLogFile'), if one exists. +buildAndRegisterUnpackedPackage + verbosity + distDirLayout@DistDirLayout{distTempDirectory} + maybe_semaphore + BuildTimeSettings{buildSettingNumJobs, buildSettingLogFile} + registerLock + cacheLock + pkgshared@ElaboratedSharedConfig + { pkgConfigCompiler = compiler + , pkgConfigCompilerProgs = progdb + , pkgConfigPlatform = platform + } + plan + rpkg@(ReadyPackage pkg) + srcdir + builddir + delegate = do + initLogFile + + -- Configure phase + delegate $ + PBConfigurePhase $ + annotateFailure mlogFile ConfigureFailed $ + setup configureCommand configureFlags configureArgs + + -- Build phase + delegate $ + PBBuildPhase $ + annotateFailure mlogFile BuildFailed $ + setup buildCommand buildFlags buildArgs + + -- Haddock phase + whenHaddock $ + delegate $ + PBHaddockPhase $ + annotateFailure mlogFile HaddocksFailed $ do + setup haddockCommand haddockFlags haddockArgs + + -- Install phase + delegate $ + PBInstallPhase + { runCopy = \destdir -> + annotateFailure mlogFile InstallFailed $ + setup Cabal.copyCommand (copyFlags destdir) (const []) + , runRegister = \pkgDBStack registerOpts -> + annotateFailure mlogFile InstallFailed $ 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 + pkgDBStack + ipkg + registerOpts + return ipkg + } + + -- Test phase + whenTest $ + delegate $ + PBTestPhase $ + annotateFailure mlogFile TestsFailed $ + setup testCommand testFlags testArgs + + -- Bench phase + whenBench $ + delegate $ + PBBenchPhase $ + annotateFailure mlogFile BenchFailed $ + setup benchCommand benchFlags benchArgs + + -- Repl phase + whenRepl $ + delegate $ + PBReplPhase $ + annotateFailure mlogFile ReplFailed $ + setupInteractive replCommand replFlags replArgs + + return mlogFile + where + uid = installedUnitId rpkg + pkgid = packageId rpkg + + comp_par_strat = case maybe_semaphore of + Just sem_name -> Cabal.toFlag (getSemaphoreName sem_name) + _ -> Cabal.NoFlag + + whenTest action + | null (elabTestTargets pkg) = return () + | otherwise = action + + whenBench action + | null (elabBenchTargets pkg) = return () + | otherwise = action + + whenRepl action + | null (elabReplTarget pkg) = return () + | otherwise = action + + whenHaddock action + | hasValidHaddockTargets pkg = action + | otherwise = return () + + configureCommand = Cabal.configureCommand defaultProgramDb + configureFlags v = + flip filterConfigureFlags v $ + setupHsConfigureFlags + plan + rpkg + pkgshared + verbosity + builddir + configureArgs _ = setupHsConfigureArgs pkg + + buildCommand = Cabal.buildCommand defaultProgramDb + buildFlags _ = setupHsBuildFlags comp_par_strat pkg pkgshared verbosity builddir + buildArgs _ = setupHsBuildArgs pkg + + copyFlags destdir _ = + setupHsCopyFlags + pkg + pkgshared + verbosity + builddir + destdir + + testCommand = Cabal.testCommand -- defaultProgramDb + testFlags v = + flip filterTestFlags v $ + setupHsTestFlags + pkg + verbosity + builddir + testArgs _ = setupHsTestArgs pkg + + benchCommand = Cabal.benchmarkCommand + benchFlags _ = + setupHsBenchFlags + pkg + pkgshared + verbosity + builddir + benchArgs _ = setupHsBenchArgs pkg + + replCommand = Cabal.replCommand defaultProgramDb + replFlags _ = + setupHsReplFlags + pkg + pkgshared + verbosity + builddir + replArgs _ = setupHsReplArgs pkg + + haddockCommand = Cabal.haddockCommand + haddockFlags v = + flip filterHaddockFlags v $ + setupHsHaddockFlags + pkg + pkgshared + verbosity + builddir + haddockArgs v = + flip filterHaddockArgs v $ + setupHsHaddockArgs pkg + + scriptOptions = + setupHsScriptOptions + rpkg + plan + pkgshared + distDirLayout + srcdir + builddir + (isParallelBuild buildSettingNumJobs) + cacheLock + + setup + :: CommandUI flags + -> (Version -> flags) + -> (Version -> [String]) + -> IO () + setup cmd flags args = + withLogging $ \mLogFileHandle -> + setupWrapper + verbosity + scriptOptions + { useLoggingHandle = mLogFileHandle + , useExtraEnvOverrides = + dataDirsEnvironmentForPlan + distDirLayout + plan + } + (Just (elabPkgDescription pkg)) + cmd + flags + args + + setupInteractive + :: CommandUI flags + -> (Version -> flags) + -> (Version -> [String]) + -> IO () + setupInteractive cmd flags args = + setupWrapper + verbosity + scriptOptions{isInteractive = True} + (Just (elabPkgDescription pkg)) + cmd + flags + args + + generateInstalledPackageInfo :: IO InstalledPackageInfo + generateInstalledPackageInfo = + withTempInstalledPackageInfoFile + verbosity + distTempDirectory + $ \pkgConfDest -> do + let registerFlags _ = + setupHsRegisterFlags + pkg + pkgshared + verbosity + builddir + pkgConfDest + setup Cabal.registerCommand registerFlags (const []) + + mlogFile :: Maybe FilePath + mlogFile = + case buildSettingLogFile of + Nothing -> Nothing + Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid) + + initLogFile :: IO () + initLogFile = + case mlogFile of + Nothing -> return () + Just logFile -> do + createDirectoryIfMissing True (takeDirectory logFile) + exists <- doesFileExist logFile + when exists $ removeFile logFile + + withLogging :: (Maybe Handle -> IO r) -> IO r + withLogging action = + case mlogFile of + Nothing -> action Nothing + Just logFile -> withFile logFile AppendMode (action . Just) + +-------------------------------------------------------------------------------- + +-- * Build Inplace + +-------------------------------------------------------------------------------- + +buildInplaceUnpackedPackage + :: Verbosity + -> DistDirLayout + -> Maybe SemaphoreName + -> BuildTimeSettings + -> Lock + -> Lock + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedReadyPackage + -> BuildStatusRebuild + -> FilePath + -> FilePath + -> IO BuildResult +buildInplaceUnpackedPackage + verbosity + distDirLayout@DistDirLayout + { distPackageCacheDirectory + , distDirectory + , distHaddockOutputDir + } + maybe_semaphore + buildSettings@BuildTimeSettings{buildSettingHaddockOpen} + registerLock + cacheLock + pkgshared@ElaboratedSharedConfig{pkgConfigPlatform = platform} + plan + rpkg@(ReadyPackage pkg) + buildStatus + srcdir + builddir = do + -- TODO: [code cleanup] there is duplication between the + -- distdirlayout and the builddir here builddir is not + -- enough, we also need the per-package cachedir + createDirectoryIfMissingVerbose verbosity True builddir + createDirectoryIfMissingVerbose + verbosity + True + (distPackageCacheDirectory dparams) + + let docsResult = DocsNotTried + testsResult = TestsNotTried + + buildResult :: BuildResultMisc + buildResult = (docsResult, testsResult) + + mlogFile <- buildAndRegisterUnpackedPackage + verbosity + distDirLayout + maybe_semaphore + buildSettings + registerLock + cacheLock + pkgshared + plan + rpkg + srcdir + builddir + $ \case + PBConfigurePhase{runConfigure} -> do + whenReConfigure $ do + runConfigure + invalidatePackageRegFileMonitor packageFileMonitor + updatePackageConfigFileMonitor packageFileMonitor srcdir pkg + PBBuildPhase{runBuild} -> do + whenRebuild $ do + timestamp <- beginUpdateFileMonitor + runBuild + + let listSimple = + execRebuild srcdir (needElaboratedConfiguredPackage pkg) + listSdist = + fmap (map monitorFileHashed) $ + allPackageSourceFiles verbosity srcdir + ifNullThen m m' = do + xs <- m + if null xs then m' else return xs + monitors <- case PD.buildType (elabPkgDescription pkg) of + Simple -> listSimple + -- If a Custom setup was used, AND the Cabal is recent + -- enough to have sdist --list-sources, use that to + -- determine the files that we need to track. This can + -- cause unnecessary rebuilding (for example, if README + -- is edited, we will try to rebuild) but there isn't + -- a more accurate Custom interface we can use to get + -- this info. We prefer not to use listSimple here + -- as it can miss extra source files that are considered + -- by the Custom setup. + _ + | elabSetupScriptCliVersion pkg >= mkVersion [1, 17] -> + -- However, sometimes sdist --list-sources will fail + -- and return an empty list. In that case, fall + -- back on the (inaccurate) simple tracking. + listSdist `ifNullThen` listSimple + | otherwise -> + listSimple + + let dep_monitors = + map monitorFileHashed $ + elabInplaceDependencyBuildCacheFiles + distDirLayout + pkgshared + plan + pkg + updatePackageBuildFileMonitor + packageFileMonitor + srcdir + timestamp + pkg + buildStatus + (monitors ++ dep_monitors) + buildResult + PBHaddockPhase{runHaddock} -> do + runHaddock + let haddockTarget = elabHaddockForHackage pkg + when (haddockTarget == Cabal.ForHackage) $ do + let dest = distDirectory name <.> "tar.gz" + name = haddockDirName haddockTarget (elabPkgDescription pkg) + docDir = + distBuildDirectory distDirLayout dparams + "doc" + "html" + Tar.createTarGzFile dest docDir name + notice verbosity $ "Documentation tarball created: " ++ dest + + when (buildSettingHaddockOpen && haddockTarget /= Cabal.ForHackage) $ do + let dest = docDir "index.html" + name = haddockDirName haddockTarget (elabPkgDescription pkg) + docDir = case distHaddockOutputDir of + Nothing -> distBuildDirectory distDirLayout dparams "doc" "html" name + Just dir -> dir + exe <- findOpenProgramLocation platform + case exe of + Right open -> runProgramInvocation verbosity (simpleProgramInvocation open [dest]) + Left err -> dieWithException verbosity $ FindOpenProgramLocationErr err + PBInstallPhase{runCopy = _runCopy, runRegister} -> do + -- PURPOSELY omitted: no copy! + + whenReRegister $ do + -- Register locally + mipkg <- + if elabRequiresRegistration pkg + then do + ipkg <- + runRegister + (elabRegisterPackageDBStack pkg) + Cabal.defaultRegisterOptions + return (Just ipkg) + else return Nothing + + updatePackageRegFileMonitor packageFileMonitor srcdir mipkg + PBTestPhase{runTest} -> runTest + PBBenchPhase{runBench} -> runBench + PBReplPhase{runRepl} -> runRepl + + return + BuildResult + { buildResultDocs = docsResult + , buildResultTests = testsResult + , buildResultLogFile = mlogFile + } + where + dparams = elabDistDirParams pkgshared pkg + + packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams + + whenReConfigure action = case buildStatus of + BuildStatusConfigure _ -> action + _ -> return () + + whenRebuild action + | null (elabBuildTargets pkg) + , -- NB: we have to build the test/bench suite! + null (elabTestTargets pkg) + , null (elabBenchTargets pkg) = + return () + | otherwise = action + + whenReRegister action = + case buildStatus of + -- We registered the package already + BuildStatusBuild (Just _) _ -> + info verbosity "whenReRegister: previously registered" + -- There is nothing to register + _ + | null (elabBuildTargets pkg) -> + info verbosity "whenReRegister: nothing to register" + | otherwise -> action + +-------------------------------------------------------------------------------- + +-- * Build and Install + +-------------------------------------------------------------------------------- + +buildAndInstallUnpackedPackage + :: Verbosity + -> DistDirLayout + -> StoreDirLayout + -> Maybe SemaphoreName + -- ^ Whether to pass a semaphore to build process + -- this is different to BuildTimeSettings because the + -- name of the semaphore is created freshly each time. + -> BuildTimeSettings + -> Lock + -> Lock + -> ElaboratedSharedConfig + -> ElaboratedInstallPlan + -> ElaboratedReadyPackage + -> FilePath + -> FilePath + -> IO BuildResult +buildAndInstallUnpackedPackage + verbosity + distDirLayout + storeDirLayout@StoreDirLayout + { storePackageDBStack + } + maybe_semaphore + buildSettings@BuildTimeSettings{buildSettingNumJobs} + registerLock + cacheLock + pkgshared@ElaboratedSharedConfig{pkgConfigCompiler = compiler} + plan + rpkg@(ReadyPackage pkg) + srcdir + builddir = do + createDirectoryIfMissingVerbose verbosity True (srcdir builddir) + + -- TODO: [code cleanup] deal consistently with talking to older + -- Setup.hs versions, much like we do for ghc, with a proper + -- options type and rendering step which will also let us + -- call directly into the lib, rather than always going via + -- the lib's command line interface, which would also allow + -- passing data like installed packages, compiler, and + -- program db for a quicker configure. + + -- TODO: [required feature] docs and tests + -- TODO: [required feature] sudo re-exec + + mlogFile <- buildAndRegisterUnpackedPackage + verbosity + distDirLayout + maybe_semaphore + buildSettings + registerLock + cacheLock + pkgshared + plan + rpkg + srcdir + builddir + $ \case + PBConfigurePhase{runConfigure} -> do + noticeProgress ProgressStarting + runConfigure + PBBuildPhase{runBuild} -> do + noticeProgress ProgressBuilding + runBuild + PBHaddockPhase{runHaddock} -> do + noticeProgress ProgressHaddock + runHaddock + PBInstallPhase{runCopy, runRegister} -> do + noticeProgress ProgressInstalling + + let registerPkg + | not (elabRequiresRegistration pkg) = + debug verbosity $ + "registerPkg: elab does NOT require registration for " + ++ prettyShow uid + | otherwise = do + assert + ( elabRegisterPackageDBStack pkg + == storePackageDBStack compid + ) + (return ()) + _ <- + runRegister + (storePackageDBStack compid) + Cabal.defaultRegisterOptions + { Cabal.registerMultiInstance = True + , Cabal.registerSuppressFilesCheck = True + } + return () + + -- Actual installation + void $ + newStoreEntry + verbosity + storeDirLayout + compid + uid + (copyPkgFiles verbosity pkgshared pkg runCopy) + registerPkg + + -- No tests on install + PBTestPhase{} -> return () + -- No bench on install + PBBenchPhase{} -> return () + -- No repl on install + PBReplPhase{} -> return () + + -- 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 + testsResult = TestsNotTried + + noticeProgress ProgressCompleted + + return + BuildResult + { buildResultDocs = docsResult + , buildResultTests = testsResult + , buildResultLogFile = mlogFile + } + where + uid = installedUnitId rpkg + pkgid = packageId rpkg + compid = compilerId compiler + + dispname :: String + dispname = case elabPkgOrComp pkg of + ElabPackage _ -> + prettyShow pkgid + ++ " (all, legacy fallback)" + ElabComponent comp -> + prettyShow pkgid + ++ " (" + ++ maybe "custom" prettyShow (compComponentName comp) + ++ ")" + + noticeProgress :: ProgressPhase -> IO () + noticeProgress phase = + when (isParallelBuild buildSettingNumJobs) $ + progressMessage verbosity phase dispname + +-- | The copy part of the installation phase when doing build-and-install +copyPkgFiles + :: Verbosity + -> ElaboratedSharedConfig + -> ElaboratedConfiguredPackage + -> (FilePath -> IO ()) + -- ^ The 'runCopy' function which invokes ./Setup copy for the + -- given filepath + -> FilePath + -- ^ The temporary dir file path + -> IO (FilePath, [FilePath]) +copyPkgFiles verbosity pkgshared pkg runCopy tmpDir = do + let tmpDirNormalised = normalise tmpDir + runCopy tmpDirNormalised + -- 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 = + normalise $ + dropDrive (InstallDirs.prefix (elabInstallDirs pkg)) + entryDir = tmpDirNormalised prefix + + -- if there weren't anything to build, it might be that directory is not created + -- the @setup Cabal.copyCommand@ above might do nothing. + -- https://github.com/haskell/cabal/issues/4130 + createDirectoryIfMissingVerbose verbosity True entryDir + + let hashFileName = entryDir "cabal-hash.txt" + outPkgHashInputs = renderPackageHashInputs (packageHashInputs pkgshared pkg) + + info verbosity $ + "creating file with the inputs used to compute the package hash: " ++ hashFileName + + LBS.writeFile hashFileName outPkgHashInputs + + debug verbosity "Package hash inputs:" + traverse_ + (debug verbosity . ("> " ++)) + (lines $ LBS.Char8.unpack outPkgHashInputs) + + -- Ensure that there are no files in `tmpDir`, that are + -- not in `entryDir`. While this breaks the + -- prefix-relocatable property of the libraries, it is + -- necessary on macOS to stay under the load command limit + -- of the macOS mach-o linker. See also + -- @PackageHash.hashedInstalledPackageIdVeryShort@. + -- + -- We also normalise paths to ensure that there are no + -- different representations for the same path. Like / and + -- \\ on windows under msys. + otherFiles <- + filter (not . isPrefixOf entryDir) + <$> listFilesRecursive tmpDirNormalised + -- 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, otherFiles) + where + listFilesRecursive :: FilePath -> IO [FilePath] + listFilesRecursive path = do + files <- fmap (path ) <$> (listDirectory path) + allFiles <- for files $ \file -> do + isDir <- doesDirectoryExist file + if isDir + then listFilesRecursive file + else return [file] + return (concat allFiles) + +-------------------------------------------------------------------------------- + +-- * Exported Utils + +-------------------------------------------------------------------------------- + +{- FOURMOLU_DISABLE -} +annotateFailureNoLog :: (SomeException -> BuildFailureReason) + -> IO a -> IO a +annotateFailureNoLog annotate action = + annotateFailure Nothing annotate action + +annotateFailure :: Maybe FilePath + -> (SomeException -> BuildFailureReason) + -> IO a -> IO a +annotateFailure mlogFile annotate action = + action `catches` + -- It's not just IOException and ExitCode we have to deal with, there's + -- lots, including exceptions from the hackage-security and tar packages. + -- So we take the strategy of catching everything except async exceptions. + [ +#if MIN_VERSION_base(4,7,0) + Handler $ \async -> throwIO (async :: SomeAsyncException) +#else + Handler $ \async -> throwIO (async :: AsyncException) +#endif + , Handler $ \other -> handler (other :: SomeException) + ] + where + handler :: Exception e => e -> IO a + handler = throwIO . BuildFailure mlogFile . annotate . toException + +-------------------------------------------------------------------------------- +-- * Other Utils +-------------------------------------------------------------------------------- + +hasValidHaddockTargets :: ElaboratedConfiguredPackage -> Bool +hasValidHaddockTargets ElaboratedConfiguredPackage{..} + | not elabBuildHaddocks = False + | otherwise = any componentHasHaddocks components + where + components :: [ComponentTarget] + components = + elabBuildTargets + ++ elabTestTargets + ++ elabBenchTargets + ++ elabReplTarget + ++ elabHaddockTargets + + componentHasHaddocks :: ComponentTarget -> Bool + componentHasHaddocks (ComponentTarget name _) = + case name of + CLibName LMainLibName -> hasHaddocks + CLibName (LSubLibName _) -> elabHaddockInternal && hasHaddocks + CFLibName _ -> elabHaddockForeignLibs && hasHaddocks + CExeName _ -> elabHaddockExecutables && hasHaddocks + CTestName _ -> elabHaddockTestSuites && hasHaddocks + CBenchName _ -> elabHaddockBenchmarks && hasHaddocks + where + hasHaddocks = not (null (elabPkgDescription ^. componentModules name)) + +withTempInstalledPackageInfoFile + :: Verbosity + -> FilePath + -> (FilePath -> IO ()) + -> IO InstalledPackageInfo +withTempInstalledPackageInfoFile verbosity tempdir action = + withTempDirectory verbosity tempdir "package-registration-" $ \dir -> do + -- make absolute since @action@ will often change directory + abs_dir <- canonicalizePath dir + + let pkgConfDest = abs_dir "pkgConf" + action pkgConfDest + + readPkgConf "." pkgConfDest + where + pkgConfParseFailed :: String -> IO a + pkgConfParseFailed perror = + dieWithException verbosity $ PkgConfParseFailed perror + + readPkgConf :: FilePath -> FilePath -> IO InstalledPackageInfo + readPkgConf pkgConfDir pkgConfFile = do + pkgConfStr <- BS.readFile (pkgConfDir pkgConfFile) + (warns, ipkg) <- case Installed.parseInstalledPackageInfo pkgConfStr of + Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors + Right (warns, ipkg) -> return (warns, ipkg) + + unless (null warns) $ + warn verbosity $ + unlines warns + + return ipkg +