cabal-install/src/Distribution/Client/ProjectBuilding.hs

   1 {-# LANGUAGE BangPatterns        #-}
   2 {-# LANGUAGE CPP                 #-}
   3 {-# LANGUAGE ConstraintKinds     #-}
   4 {-# LANGUAGE NamedFieldPuns      #-}
   5 {-# LANGUAGE NoMonoLocalBinds    #-}
   6 {-# LANGUAGE RecordWildCards     #-}
   7 {-# LANGUAGE ScopedTypeVariables #-}
   8 {-# LANGUAGE TypeFamilies        #-}
   9
  10 -- |
  11 --
  12 module Distribution.Client.ProjectBuilding (
  13     -- * Dry run phase
  14     -- | What bits of the plan will we execute? The dry run does not change
  15     -- anything but tells us what will need to be built.
  16     rebuildTargetsDryRun,
  17     improveInstallPlanWithUpToDatePackages,
  18
  19     -- ** Build status
  20     -- | This is the detailed status information we get from the dry run.
  21     BuildStatusMap,
  22     BuildStatus(..),
  23     BuildStatusRebuild(..),
  24     BuildReason(..),
  25     MonitorChangedReason(..),
  26     buildStatusToString,
  27
  28     -- * Build phase
  29     -- | Now we actually execute the plan.
  30     rebuildTargets,
  31     -- ** Build outcomes
  32     -- | This is the outcome for each package of executing the plan.
  33     -- For each package, did the build succeed or fail?
  34     BuildOutcomes,
  35     BuildOutcome,
  36     BuildResult(..),
  37     BuildFailure(..),
  38     BuildFailureReason(..),
  39   ) where
  40
  41 import Distribution.Client.Compat.Prelude
  42 import Prelude ()
  43
  44 import           Distribution.Client.PackageHash (renderPackageHashInputs)
  45 import           Distribution.Client.RebuildMonad
  46 import           Distribution.Client.ProjectConfig
  47 import           Distribution.Client.ProjectPlanning
  48 import           Distribution.Client.ProjectPlanning.Types
  49 import           Distribution.Client.ProjectBuilding.Types
  50 import           Distribution.Client.Store
  51
  52 import           Distribution.Client.Types
  53                    hiding (BuildOutcomes, BuildOutcome,
  54                            BuildResult(..), BuildFailure(..))
  55 import           Distribution.Client.InstallPlan
  56                    ( GenericInstallPlan, GenericPlanPackage, IsUnit )
  57 import qualified Distribution.Client.InstallPlan as InstallPlan
  58 import           Distribution.Client.DistDirLayout
  59 import           Distribution.Client.FileMonitor
  60 import           Distribution.Client.SetupWrapper
  61 import           Distribution.Client.JobControl
  62 import           Distribution.Client.FetchUtils
  63 import           Distribution.Client.GlobalFlags (RepoContext)
  64 import qualified Distribution.Client.Tar as Tar
  65 import           Distribution.Client.Setup
  66                    ( filterConfigureFlags, filterHaddockArgs
  67                    , filterHaddockFlags, filterTestFlags )
  68 import           Distribution.Client.SourceFiles
  69 import           Distribution.Client.SrcDist (allPackageSourceFiles)
  70 import           Distribution.Client.Utils
  71                    ( ProgressPhase(..), findOpenProgramLocation, progressMessage, removeExistingFile )
  72
  73 import           Distribution.Compat.Lens
  74 import           Distribution.Package
  75 import qualified Distribution.PackageDescription as PD
  76 import           Distribution.InstalledPackageInfo (InstalledPackageInfo)
  77 import qualified Distribution.InstalledPackageInfo as Installed
  78 import           Distribution.Simple.BuildPaths (haddockDirName)
  79 import qualified Distribution.Simple.InstallDirs as InstallDirs
  80 import           Distribution.Types.BuildType
  81 import           Distribution.Types.PackageDescription.Lens (componentModules)
  82 import           Distribution.Simple.Program
  83 import qualified Distribution.Simple.Setup as Cabal
  84 import           Distribution.Simple.Command (CommandUI)
  85 import qualified Distribution.Simple.Register as Cabal
  86 import           Distribution.Simple.LocalBuildInfo
  87                    ( ComponentName(..), LibraryName(..) )
  88 import           Distribution.Simple.Compiler
  89                    ( Compiler, compilerId, PackageDB(..) )
  90
  91 import           Distribution.Simple.Utils
  92 import           Distribution.Version
  93 import           Distribution.Compat.Graph (IsNode(..))
  94
  95 import qualified Data.List.NonEmpty as NE
  96 import qualified Data.Map as Map
  97 import qualified Data.Set as Set
  98 import qualified Data.ByteString as BS
  99 import qualified Data.ByteString.Lazy as LBS
 100 import qualified Data.ByteString.Lazy.Char8 as LBS.Char8
 101
 102 import Control.Exception (Handler (..), SomeAsyncException, assert, catches, handle)
 103 import System.Directory  (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist, removeFile, renameDirectory)
 104 import System.FilePath   (dropDrive, makeRelative, normalise, takeDirectory, (<.>), (</>))
 105 import System.IO         (IOMode (AppendMode), Handle, withFile)
 106
 107 import Distribution.Compat.Directory (listDirectory)
 108
 109
 110 ------------------------------------------------------------------------------
 111 -- * Overall building strategy.
 112 ------------------------------------------------------------------------------
 113 --
 114 -- We start with an 'ElaboratedInstallPlan' that has already been improved by
 115 -- reusing packages from the store, and pruned to include only the targets of
 116 -- interest and their dependencies. So the remaining packages in the
 117 -- 'InstallPlan.Configured' state are ones we either need to build or rebuild.
 118 --
 119 -- First, we do a preliminary dry run phase where we work out which packages
 120 -- we really need to (re)build, and for the ones we do need to build which
 121 -- build phase to start at.
 122 --
 123 -- We use this to improve the 'ElaboratedInstallPlan' again by changing
 124 -- up-to-date 'InstallPlan.Configured' packages to 'InstallPlan.Installed'
 125 -- so that the build phase will skip them.
 126 --
 127 -- Then we execute the plan, that is actually build packages. The outcomes of
 128 -- trying to build all the packages are collected and returned.
 129 --
 130 -- We split things like this (dry run and execute) for a couple reasons.
 131 -- Firstly we need to be able to do dry runs anyway, and these need to be
 132 -- reasonably accurate in terms of letting users know what (and why) things
 133 -- are going to be (re)built.
 134 --
 135 -- Given that we need to be able to do dry runs, it would not be great if
 136 -- we had to repeat all the same work when we do it for real. Not only is
 137 -- it duplicate work, but it's duplicate code which is likely to get out of
 138 -- sync. So we do things only once. We preserve info we discover in the dry
 139 -- run phase and rely on it later when we build things for real. This also
 140 -- somewhat simplifies the build phase. So this way the dry run can't so
 141 -- easily drift out of sync with the real thing since we're relying on the
 142 -- info it produces.
 143 --
 144 -- An additional advantage is that it makes it easier to debug rebuild
 145 -- errors (ie rebuilding too much or too little), since all the rebuild
 146 -- decisions are made without making any state changes at the same time
 147 -- (that would make it harder to reproduce the problem situation).
 148 --
 149 -- Finally, we can use the dry run build status and the build outcomes to
 150 -- give us some information on the overall status of packages in the project.
 151 -- This includes limited information about the status of things that were
 152 -- not actually in the subset of the plan that was used for the dry run or
 153 -- execution phases. In particular we may know that some packages are now
 154 -- definitely out of date. See "Distribution.Client.ProjectPlanOutput" for
 155 -- details.
 156
 157
 158 ------------------------------------------------------------------------------
 159 -- * Dry run: what bits of the 'ElaboratedInstallPlan' will we execute?
 160 ------------------------------------------------------------------------------
 161
 162 -- Refer to ProjectBuilding.Types for details of these important types:
 163
 164 -- type BuildStatusMap     = ...
 165 -- data BuildStatus        = ...
 166 -- data BuildStatusRebuild = ...
 167 -- data BuildReason        = ...
 168
 169 -- | Do the dry run pass. This is a prerequisite of 'rebuildTargets'.
 170 --
 171 -- It gives us the 'BuildStatusMap'. This should be used with
 172 -- 'improveInstallPlanWithUpToDatePackages' to give an improved version of
 173 -- the 'ElaboratedInstallPlan' with packages switched to the
 174 -- 'InstallPlan.Installed' state when we find that they're already up to date.
 175 --
 176 rebuildTargetsDryRun :: DistDirLayout
 177                      -> ElaboratedSharedConfig
 178                      -> ElaboratedInstallPlan
 179                      -> IO BuildStatusMap
 180 rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared =
 181     -- Do the various checks to work out the 'BuildStatus' of each package
 182     foldMInstallPlanDepOrder dryRunPkg
 183   where
 184     dryRunPkg :: ElaboratedPlanPackage
 185               -> [BuildStatus]
 186               -> IO BuildStatus
 187     dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus =
 188       return BuildStatusPreExisting
 189
 190     dryRunPkg (InstallPlan.Installed _pkg) _depsBuildStatus =
 191       return BuildStatusInstalled
 192
 193     dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do
 194       mloc <- checkFetched (elabPkgSourceLocation pkg)
 195       case mloc of
 196         Nothing -> return BuildStatusDownload
 197
 198         Just (LocalUnpackedPackage srcdir) ->
 199           -- For the case of a user-managed local dir, irrespective of the
 200           -- build style, we build from that directory and put build
 201           -- artifacts under the shared dist directory.
 202           dryRunLocalPkg pkg depsBuildStatus srcdir
 203
 204         -- The rest cases are all tarball cases are,
 205         -- and handled the same as each other though depending on the build style.
 206         Just (LocalTarballPackage    tarball) ->
 207           dryRunTarballPkg pkg depsBuildStatus tarball
 208
 209         Just (RemoteTarballPackage _ tarball) ->
 210           dryRunTarballPkg pkg depsBuildStatus tarball
 211
 212         Just (RepoTarballPackage _ _ tarball) ->
 213           dryRunTarballPkg pkg depsBuildStatus tarball
 214
 215         Just (RemoteSourceRepoPackage _repo tarball) ->
 216           dryRunTarballPkg pkg depsBuildStatus tarball
 217
 218
 219     dryRunTarballPkg :: ElaboratedConfiguredPackage
 220                      -> [BuildStatus]
 221                      -> FilePath
 222                      -> IO BuildStatus
 223     dryRunTarballPkg pkg depsBuildStatus tarball =
 224       case elabBuildStyle pkg of
 225         BuildAndInstall  -> return (BuildStatusUnpack tarball)
 226         BuildInplaceOnly -> do
 227           -- TODO: [nice to have] use a proper file monitor rather
 228           -- than this dir exists test
 229           exists <- doesDirectoryExist srcdir
 230           if exists
 231             then dryRunLocalPkg pkg depsBuildStatus srcdir
 232             else return (BuildStatusUnpack tarball)
 233       where
 234         srcdir :: FilePath
 235         srcdir = distUnpackedSrcDirectory (packageId pkg)
 236
 237     dryRunLocalPkg :: ElaboratedConfiguredPackage
 238                    -> [BuildStatus]
 239                    -> FilePath
 240                    -> IO BuildStatus
 241     dryRunLocalPkg pkg depsBuildStatus srcdir = do
 242         -- Go and do lots of I/O, reading caches and probing files to work out
 243         -- if anything has changed
 244         change <- checkPackageFileMonitorChanged
 245                     packageFileMonitor pkg srcdir depsBuildStatus
 246         case change of
 247           -- It did change, giving us 'BuildStatusRebuild' info on why
 248           Left rebuild ->
 249             return (BuildStatusRebuild srcdir rebuild)
 250
 251           -- No changes, the package is up to date. Use the saved build results.
 252           Right buildResult ->
 253             return (BuildStatusUpToDate buildResult)
 254       where
 255         packageFileMonitor :: PackageFileMonitor
 256         packageFileMonitor =
 257           newPackageFileMonitor shared distDirLayout
 258           (elabDistDirParams shared pkg)
 259
 260
 261 -- | A specialised traversal over the packages in an install plan.
 262 --
 263 -- The packages are visited in dependency order, starting with packages with no
 264 -- dependencies. The result for each package is accumulated into a 'Map' and
 265 -- returned as the final result. In addition, when visiting a package, the
 266 -- visiting function is passed the results for all the immediate package
 267 -- dependencies. This can be used to propagate information from dependencies.
 268 --
 269 foldMInstallPlanDepOrder
 270   :: forall m ipkg srcpkg b.
 271      (Monad m, IsUnit ipkg, IsUnit srcpkg)
 272   => (GenericPlanPackage ipkg srcpkg ->
 273       [b] -> m b)
 274   -> GenericInstallPlan ipkg srcpkg
 275   -> m (Map UnitId b)
 276 foldMInstallPlanDepOrder visit =
 277     go Map.empty . InstallPlan.reverseTopologicalOrder
 278   where
 279     go :: Map UnitId b
 280        -> [GenericPlanPackage ipkg srcpkg]
 281        -> m (Map UnitId b)
 282     go !results [] = return results
 283
 284     go !results (pkg : pkgs) = do
 285       -- we go in the right order so the results map has entries for all deps
 286       let depresults :: [b]
 287           depresults =
 288             map (\ipkgid -> let result = Map.findWithDefault (error "foldMInstallPlanDepOrder") ipkgid results
 289                               in result)
 290                 (InstallPlan.depends pkg)
 291       result <- visit pkg depresults
 292       let results' = Map.insert (nodeKey pkg) result results
 293       go results' pkgs
 294
 295 improveInstallPlanWithUpToDatePackages :: BuildStatusMap
 296                                        -> ElaboratedInstallPlan
 297                                        -> ElaboratedInstallPlan
 298 improveInstallPlanWithUpToDatePackages pkgsBuildStatus =
 299     InstallPlan.installed canPackageBeImproved
 300   where
 301     canPackageBeImproved :: ElaboratedConfiguredPackage -> Bool
 302     canPackageBeImproved pkg =
 303       case Map.lookup (installedUnitId pkg) pkgsBuildStatus of
 304         Just BuildStatusUpToDate {} -> True
 305         Just _                      -> False
 306         Nothing -> error $ "improveInstallPlanWithUpToDatePackages: "
 307                         ++ prettyShow (packageId pkg) ++ " not in status map"
 308
 309
 310 -----------------------------
 311 -- Package change detection
 312 --
 313
 314 -- | As part of the dry run for local unpacked packages we have to check if the
 315 -- package config or files have changed. That is the purpose of
 316 -- 'PackageFileMonitor' and 'checkPackageFileMonitorChanged'.
 317 --
 318 -- When a package is (re)built, the monitor must be updated to reflect the new
 319 -- state of the package. Because we sometimes build without reconfiguring the
 320 -- state updates are split into two, one for package config changes and one
 321 -- for other changes. This is the purpose of 'updatePackageConfigFileMonitor'
 322 -- and 'updatePackageBuildFileMonitor'.
 323 --
 324 data PackageFileMonitor = PackageFileMonitor {
 325        pkgFileMonitorConfig :: FileMonitor ElaboratedConfiguredPackage (),
 326        pkgFileMonitorBuild  :: FileMonitor (Set ComponentName) BuildResultMisc,
 327        pkgFileMonitorReg    :: FileMonitor () (Maybe InstalledPackageInfo)
 328      }
 329
 330 -- | This is all the components of the 'BuildResult' other than the
 331 -- @['InstalledPackageInfo']@.
 332 --
 333 -- We have to split up the 'BuildResult' components since they get produced
 334 -- at different times (or rather, when different things change).
 335 --
 336 type BuildResultMisc = (DocsResult, TestsResult)
 337
 338 newPackageFileMonitor :: ElaboratedSharedConfig
 339                       -> DistDirLayout
 340                       -> DistDirParams
 341                       -> PackageFileMonitor
 342 newPackageFileMonitor shared
 343                       DistDirLayout{distPackageCacheFile}
 344                       dparams =
 345     PackageFileMonitor {
 346       pkgFileMonitorConfig =
 347         FileMonitor {
 348           fileMonitorCacheFile = distPackageCacheFile dparams "config",
 349           fileMonitorKeyValid = (==) `on` normaliseConfiguredPackage shared,
 350           fileMonitorCheckIfOnlyValueChanged = False
 351         },
 352
 353       pkgFileMonitorBuild =
 354         FileMonitor {
 355           fileMonitorCacheFile = distPackageCacheFile dparams "build",
 356           fileMonitorKeyValid  = \componentsToBuild componentsAlreadyBuilt ->
 357             componentsToBuild `Set.isSubsetOf` componentsAlreadyBuilt,
 358           fileMonitorCheckIfOnlyValueChanged = True
 359         },
 360
 361       pkgFileMonitorReg =
 362         newFileMonitor (distPackageCacheFile dparams "registration")
 363     }
 364
 365 -- | Helper function for 'checkPackageFileMonitorChanged',
 366 -- 'updatePackageConfigFileMonitor' and 'updatePackageBuildFileMonitor'.
 367 --
 368 -- It selects the info from a 'ElaboratedConfiguredPackage' that are used by
 369 -- the 'FileMonitor's (in the 'PackageFileMonitor') to detect value changes.
 370 --
 371 packageFileMonitorKeyValues :: ElaboratedConfiguredPackage
 372                             -> (ElaboratedConfiguredPackage, Set ComponentName)
 373 packageFileMonitorKeyValues elab =
 374     (elab_config, buildComponents)
 375   where
 376     -- The first part is the value used to guard (re)configuring the package.
 377     -- That is, if this value changes then we will reconfigure.
 378     -- The ElaboratedConfiguredPackage consists mostly (but not entirely) of
 379     -- information that affects the (re)configure step. But those parts that
 380     -- do not affect the configure step need to be nulled out. Those parts are
 381     -- the specific targets that we're going to build.
 382     --
 383
 384     -- Additionally we null out the parts that don't affect the configure step because they're simply
 385     -- about how tests or benchmarks are run
 386
 387     -- TODO there may be more things to null here too, in the future.
 388
 389     elab_config :: ElaboratedConfiguredPackage
 390     elab_config =
 391         elab {
 392             elabBuildTargets   = [],
 393             elabTestTargets    = [],
 394             elabBenchTargets   = [],
 395             elabReplTarget     = Nothing,
 396             elabHaddockTargets = [],
 397             elabBuildHaddocks  = False,
 398
 399             elabTestMachineLog   = Nothing,
 400             elabTestHumanLog     = Nothing,
 401             elabTestShowDetails  = Nothing,
 402             elabTestKeepTix      = False,
 403             elabTestTestOptions  = [],
 404             elabBenchmarkOptions = []
 405         }
 406
 407     -- The second part is the value used to guard the build step. So this is
 408     -- more or less the opposite of the first part, as it's just the info about
 409     -- what targets we're going to build.
 410     --
 411     buildComponents :: Set ComponentName
 412     buildComponents = elabBuildTargetWholeComponents elab
 413
 414 -- | Do all the checks on whether a package has changed and thus needs either
 415 -- rebuilding or reconfiguring and rebuilding.
 416 --
 417 checkPackageFileMonitorChanged :: PackageFileMonitor
 418                                -> ElaboratedConfiguredPackage
 419                                -> FilePath
 420                                -> [BuildStatus]
 421                                -> IO (Either BuildStatusRebuild BuildResult)
 422 checkPackageFileMonitorChanged PackageFileMonitor{..}
 423                                pkg srcdir depsBuildStatus = do
 424     --TODO: [nice to have] some debug-level message about file
 425     --changes, like rerunIfChanged
 426     configChanged <- checkFileMonitorChanged
 427                        pkgFileMonitorConfig srcdir pkgconfig
 428     case configChanged of
 429       MonitorChanged monitorReason ->
 430           return (Left (BuildStatusConfigure monitorReason'))
 431         where
 432           monitorReason' = fmap (const ()) monitorReason
 433
 434       MonitorUnchanged () _
 435           -- The configChanged here includes the identity of the dependencies,
 436           -- so depsBuildStatus is just needed for the changes in the content
 437           -- of dependencies.
 438         | any buildStatusRequiresBuild depsBuildStatus -> do
 439             regChanged <- checkFileMonitorChanged pkgFileMonitorReg srcdir ()
 440             let mreg = changedToMaybe regChanged
 441             return (Left (BuildStatusBuild mreg BuildReasonDepsRebuilt))
 442
 443         | otherwise -> do
 444             buildChanged  <- checkFileMonitorChanged
 445                                pkgFileMonitorBuild srcdir buildComponents
 446             regChanged    <- checkFileMonitorChanged
 447                                pkgFileMonitorReg srcdir ()
 448             let mreg = changedToMaybe regChanged
 449             case (buildChanged, regChanged) of
 450               (MonitorChanged (MonitoredValueChanged prevBuildComponents), _) ->
 451                   return (Left (BuildStatusBuild mreg buildReason))
 452                 where
 453                   buildReason = BuildReasonExtraTargets prevBuildComponents
 454
 455               (MonitorChanged monitorReason, _) ->
 456                   return (Left (BuildStatusBuild mreg buildReason))
 457                 where
 458                   buildReason    = BuildReasonFilesChanged monitorReason'
 459                   monitorReason' = fmap (const ()) monitorReason
 460
 461               (MonitorUnchanged _ _, MonitorChanged monitorReason) ->
 462                 -- this should only happen if the file is corrupt or been
 463                 -- manually deleted. We don't want to bother with another
 464                 -- phase just for this, so we'll reregister by doing a build.
 465                   return (Left (BuildStatusBuild Nothing buildReason))
 466                 where
 467                   buildReason    = BuildReasonFilesChanged monitorReason'
 468                   monitorReason' = fmap (const ()) monitorReason
 469
 470               (MonitorUnchanged _ _, MonitorUnchanged _ _)
 471                 | pkgHasEphemeralBuildTargets pkg ->
 472                   return (Left (BuildStatusBuild mreg buildReason))
 473                 where
 474                   buildReason = BuildReasonEphemeralTargets
 475
 476               (MonitorUnchanged buildResult _, MonitorUnchanged _ _) ->
 477                   return $ Right BuildResult {
 478                     buildResultDocs    = docsResult,
 479                     buildResultTests   = testsResult,
 480                     buildResultLogFile = Nothing
 481                   }
 482                 where
 483                   (docsResult, testsResult) = buildResult
 484   where
 485     (pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg
 486     changedToMaybe :: MonitorChanged a b -> Maybe b
 487     changedToMaybe (MonitorChanged     _) = Nothing
 488     changedToMaybe (MonitorUnchanged x _) = Just x
 489
 490
 491 updatePackageConfigFileMonitor :: PackageFileMonitor
 492                                -> FilePath
 493                                -> ElaboratedConfiguredPackage
 494                                -> IO ()
 495 updatePackageConfigFileMonitor PackageFileMonitor{pkgFileMonitorConfig}
 496                                srcdir pkg =
 497     updateFileMonitor pkgFileMonitorConfig srcdir Nothing
 498                       [] pkgconfig ()
 499   where
 500     (pkgconfig, _buildComponents) = packageFileMonitorKeyValues pkg
 501
 502 updatePackageBuildFileMonitor :: PackageFileMonitor
 503                               -> FilePath
 504                               -> MonitorTimestamp
 505                               -> ElaboratedConfiguredPackage
 506                               -> BuildStatusRebuild
 507                               -> [MonitorFilePath]
 508                               -> BuildResultMisc
 509                               -> IO ()
 510 updatePackageBuildFileMonitor PackageFileMonitor{pkgFileMonitorBuild}
 511                               srcdir timestamp pkg pkgBuildStatus
 512                               monitors buildResult =
 513     updateFileMonitor pkgFileMonitorBuild srcdir (Just timestamp)
 514                       monitors buildComponents' buildResult
 515   where
 516     (_pkgconfig, buildComponents) = packageFileMonitorKeyValues pkg
 517
 518     -- If the only thing that's changed is that we're now building extra
 519     -- components, then we can avoid later unnecessary rebuilds by saving the
 520     -- total set of components that have been built, namely the union of the
 521     -- existing ones plus the new ones. If files also changed this would be
 522     -- the wrong thing to do. Note that we rely on the
 523     -- fileMonitorCheckIfOnlyValueChanged = True mode to get this guarantee
 524     -- that it's /only/ the value that changed not any files that changed.
 525     buildComponents' =
 526       case pkgBuildStatus of
 527         BuildStatusBuild _ (BuildReasonExtraTargets prevBuildComponents)
 528           -> buildComponents `Set.union` prevBuildComponents
 529         _ -> buildComponents
 530
 531 updatePackageRegFileMonitor :: PackageFileMonitor
 532                             -> FilePath
 533                             -> Maybe InstalledPackageInfo
 534                             -> IO ()
 535 updatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg}
 536                             srcdir mipkg =
 537     updateFileMonitor pkgFileMonitorReg srcdir Nothing
 538                       [] () mipkg
 539
 540 invalidatePackageRegFileMonitor :: PackageFileMonitor -> IO ()
 541 invalidatePackageRegFileMonitor PackageFileMonitor{pkgFileMonitorReg} =
 542     removeExistingFile (fileMonitorCacheFile pkgFileMonitorReg)
 543
 544
 545 ------------------------------------------------------------------------------
 546 -- * Doing it: executing an 'ElaboratedInstallPlan'
 547 ------------------------------------------------------------------------------
 548
 549 -- Refer to ProjectBuilding.Types for details of these important types:
 550
 551 -- type BuildOutcomes = ...
 552 -- type BuildOutcome  = ...
 553 -- data BuildResult   = ...
 554 -- data BuildFailure  = ...
 555 -- data BuildFailureReason = ...
 556
 557 -- | Build things for real.
 558 --
 559 -- It requires the 'BuildStatusMap' gathered by 'rebuildTargetsDryRun'.
 560 --
 561 rebuildTargets :: Verbosity
 562                -> DistDirLayout
 563                -> StoreDirLayout
 564                -> ElaboratedInstallPlan
 565                -> ElaboratedSharedConfig
 566                -> BuildStatusMap
 567                -> BuildTimeSettings
 568                -> IO BuildOutcomes
 569 rebuildTargets verbosity
 570                distDirLayout@DistDirLayout{..}
 571                storeDirLayout
 572                installPlan
 573                sharedPackageConfig@ElaboratedSharedConfig {
 574                  pkgConfigCompiler      = compiler,
 575                  pkgConfigCompilerProgs = progdb
 576                }
 577                pkgsBuildStatus
 578                buildSettings@BuildTimeSettings{
 579                  buildSettingNumJobs,
 580                  buildSettingKeepGoing
 581                } = do
 582
 583     -- Concurrency control: create the job controller and concurrency limits
 584     -- for downloading, building and installing.
 585     jobControl    <- if isParallelBuild
 586                        then newParallelJobControl buildSettingNumJobs
 587                        else newSerialJobControl
 588     registerLock  <- newLock -- serialise registration
 589     cacheLock     <- newLock -- serialise access to setup exe cache
 590                              --TODO: [code cleanup] eliminate setup exe cache
 591
 592     debug verbosity $
 593         "Executing install plan "
 594      ++ if isParallelBuild
 595           then " in parallel using " ++ show buildSettingNumJobs ++ " threads."
 596           else " serially."
 597
 598     createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory
 599     createDirectoryIfMissingVerbose verbosity True distTempDirectory
 600     traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse
 601
 602     -- Before traversing the install plan, preemptively find all packages that
 603     -- will need to be downloaded and start downloading them.
 604     asyncDownloadPackages verbosity withRepoCtx
 605                           installPlan pkgsBuildStatus $ \downloadMap ->
 606
 607       -- For each package in the plan, in dependency order, but in parallel...
 608       InstallPlan.execute jobControl keepGoing
 609                           (BuildFailure Nothing . DependentFailed . packageId)
 610                           installPlan $ \pkg ->
 611         --TODO: review exception handling
 612         handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $
 613
 614         let uid = installedUnitId pkg
 615             pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus in
 616
 617         rebuildTarget
 618           verbosity
 619           distDirLayout
 620           storeDirLayout
 621           buildSettings downloadMap
 622           registerLock cacheLock
 623           sharedPackageConfig
 624           installPlan pkg
 625           pkgBuildStatus
 626   where
 627     isParallelBuild = buildSettingNumJobs >= 2
 628     keepGoing       = buildSettingKeepGoing
 629     withRepoCtx     = projectConfigWithBuilderRepoContext verbosity
 630                         buildSettings
 631     packageDBsToUse = -- all the package dbs we may need to create
 632       (Set.toList . Set.fromList)
 633         [ pkgdb
 634         | InstallPlan.Configured elab <- InstallPlan.toList installPlan
 635         , pkgdb <- concat [ elabBuildPackageDBStack elab
 636                           , elabRegisterPackageDBStack elab
 637                           , elabSetupPackageDBStack elab ]
 638         ]
 639
 640
 641 -- | Create a package DB if it does not currently exist. Note that this action
 642 -- is /not/ safe to run concurrently.
 643 --
 644 createPackageDBIfMissing :: Verbosity -> Compiler -> ProgramDb
 645                          -> PackageDB -> IO ()
 646 createPackageDBIfMissing verbosity compiler progdb
 647                          (SpecificPackageDB dbPath) = do
 648     exists <- Cabal.doesPackageDBExist dbPath
 649     unless exists $ do
 650       createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath)
 651       Cabal.createPackageDB verbosity compiler progdb False dbPath
 652 createPackageDBIfMissing _ _ _ _ = return ()
 653
 654
 655 -- | Given all the context and resources, (re)build an individual package.
 656 --
 657 rebuildTarget :: Verbosity
 658               -> DistDirLayout
 659               -> StoreDirLayout
 660               -> BuildTimeSettings
 661               -> AsyncFetchMap
 662               -> Lock -> Lock
 663               -> ElaboratedSharedConfig
 664               -> ElaboratedInstallPlan
 665               -> ElaboratedReadyPackage
 666               -> BuildStatus
 667               -> IO BuildResult
 668 rebuildTarget verbosity
 669               distDirLayout@DistDirLayout{distBuildDirectory}
 670               storeDirLayout
 671               buildSettings downloadMap
 672               registerLock cacheLock
 673               sharedPackageConfig
 674               plan rpkg@(ReadyPackage pkg)
 675               pkgBuildStatus
 676     -- Technically, doing the --only-download filtering only in this function is
 677     -- not perfect. We could also prune the plan at an earlier stage, like it's
 678     -- done with --only-dependencies. But...
 679     --   * the benefit would be minimal (practically just avoiding to print the
 680     --     "requires build" parts of the plan)
 681     --   * we currently don't have easy access to the BuildStatus of packages
 682     --     in the pruning phase
 683     --   * we still have to check it here to avoid performing successive phases
 684     | buildSettingOnlyDownload buildSettings = do
 685         case pkgBuildStatus of
 686           BuildStatusDownload ->
 687             void $ waitAsyncPackageDownload verbosity downloadMap pkg
 688           _ -> return ()
 689         return $ BuildResult DocsNotTried TestsNotTried Nothing
 690     | otherwise =
 691     -- We rely on the 'BuildStatus' to decide which phase to start from:
 692     case pkgBuildStatus of
 693       BuildStatusDownload              -> downloadPhase
 694       BuildStatusUnpack tarball        -> unpackTarballPhase tarball
 695       BuildStatusRebuild srcdir status -> rebuildPhase status srcdir
 696
 697       -- TODO: perhaps re-nest the types to make these impossible
 698       BuildStatusPreExisting {} -> unexpectedState
 699       BuildStatusInstalled   {} -> unexpectedState
 700       BuildStatusUpToDate    {} -> unexpectedState
 701   where
 702     unexpectedState = error "rebuildTarget: unexpected package status"
 703
 704     downloadPhase :: IO BuildResult
 705     downloadPhase = do
 706         downsrcloc <- annotateFailureNoLog DownloadFailed $
 707                         waitAsyncPackageDownload verbosity downloadMap pkg
 708         case downsrcloc of
 709           DownloadedTarball tarball -> unpackTarballPhase tarball
 710           --TODO: [nice to have] git/darcs repos etc
 711
 712
 713     unpackTarballPhase :: FilePath -> IO BuildResult
 714     unpackTarballPhase tarball =
 715         withTarballLocalDirectory
 716           verbosity distDirLayout tarball
 717           (packageId pkg) (elabDistDirParams sharedPackageConfig pkg)
 718           (elabBuildStyle pkg)
 719           (elabPkgDescriptionOverride pkg) $
 720
 721           case elabBuildStyle pkg of
 722             BuildAndInstall  -> buildAndInstall
 723             BuildInplaceOnly -> buildInplace buildStatus
 724               where
 725                 buildStatus = BuildStatusConfigure MonitorFirstRun
 726
 727     -- Note that this really is rebuild, not build. It can only happen for
 728     -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages
 729     -- would only start from download or unpack phases.
 730     --
 731     rebuildPhase :: BuildStatusRebuild -> FilePath -> IO BuildResult
 732     rebuildPhase buildStatus srcdir =
 733         assert (elabBuildStyle pkg == BuildInplaceOnly) $
 734
 735           buildInplace buildStatus srcdir builddir
 736       where
 737         builddir = distBuildDirectory
 738                    (elabDistDirParams sharedPackageConfig pkg)
 739
 740     buildAndInstall :: FilePath -> FilePath -> IO BuildResult
 741     buildAndInstall srcdir builddir =
 742         buildAndInstallUnpackedPackage
 743           verbosity distDirLayout storeDirLayout
 744           buildSettings registerLock cacheLock
 745           sharedPackageConfig
 746           plan rpkg
 747           srcdir builddir'
 748       where
 749         builddir' = makeRelative srcdir builddir
 750         --TODO: [nice to have] ^^ do this relative stuff better
 751
 752     buildInplace :: BuildStatusRebuild -> FilePath -> FilePath -> IO BuildResult
 753     buildInplace buildStatus srcdir builddir =
 754         --TODO: [nice to have] use a relative build dir rather than absolute
 755         buildInplaceUnpackedPackage
 756           verbosity distDirLayout
 757           buildSettings registerLock cacheLock
 758           sharedPackageConfig
 759           plan rpkg
 760           buildStatus
 761           srcdir builddir
 762
 763 -- TODO: [nice to have] do we need to use a with-style for the temp
 764 -- files for downloading http packages, or are we going to cache them
 765 -- persistently?
 766
 767 -- | Given the current 'InstallPlan' and 'BuildStatusMap', select all the
 768 -- packages we have to download and fork off an async action to download them.
 769 -- We download them in dependency order so that the one's we'll need
 770 -- first are the ones we will start downloading first.
 771 --
 772 -- The body action is passed a map from those packages (identified by their
 773 -- location) to a completion var for that package. So the body action should
 774 -- lookup the location and use 'waitAsyncPackageDownload' to get the result.
 775 --
 776 asyncDownloadPackages :: Verbosity
 777                       -> ((RepoContext -> IO a) -> IO a)
 778                       -> ElaboratedInstallPlan
 779                       -> BuildStatusMap
 780                       -> (AsyncFetchMap -> IO a)
 781                       -> IO a
 782 asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body
 783   | null pkgsToDownload = body Map.empty
 784   | otherwise           = withRepoCtx $ \repoctx ->
 785                             asyncFetchPackages verbosity repoctx
 786                                                pkgsToDownload body
 787   where
 788     pkgsToDownload :: [PackageLocation (Maybe FilePath)]
 789     pkgsToDownload =
 790       ordNub $
 791       [ elabPkgSourceLocation elab
 792       | InstallPlan.Configured elab
 793          <- InstallPlan.reverseTopologicalOrder installPlan
 794       , let uid = installedUnitId elab
 795             pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") uid pkgsBuildStatus
 796       , BuildStatusDownload <- [pkgBuildStatus]
 797       ]
 798
 799
 800 -- | Check if a package needs downloading, and if so expect to find a download
 801 -- in progress in the given 'AsyncFetchMap' and wait on it to finish.
 802 --
 803 waitAsyncPackageDownload :: Verbosity
 804                          -> AsyncFetchMap
 805                          -> ElaboratedConfiguredPackage
 806                          -> IO DownloadedSourceLocation
 807 waitAsyncPackageDownload verbosity downloadMap elab = do
 808     pkgloc <- waitAsyncFetchPackage verbosity downloadMap
 809                                     (elabPkgSourceLocation elab)
 810     case downloadedSourceLocation pkgloc of
 811       Just loc -> return loc
 812       Nothing  -> fail "waitAsyncPackageDownload: unexpected source location"
 813
 814 data DownloadedSourceLocation = DownloadedTarball FilePath
 815                               --TODO: [nice to have] git/darcs repos etc
 816
 817 downloadedSourceLocation :: PackageLocation FilePath
 818                          -> Maybe DownloadedSourceLocation
 819 downloadedSourceLocation pkgloc =
 820     case pkgloc of
 821       RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball)
 822       RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball)
 823       _                              -> Nothing
 824
 825
 826
 827
 828 -- | Ensure that the package is unpacked in an appropriate directory, either
 829 -- a temporary one or a persistent one under the shared dist directory.
 830 --
 831 withTarballLocalDirectory
 832   :: Verbosity
 833   -> DistDirLayout
 834   -> FilePath
 835   -> PackageId
 836   -> DistDirParams
 837   -> BuildStyle
 838   -> Maybe CabalFileText
 839   -> (FilePath -> -- Source directory
 840       FilePath -> -- Build directory
 841       IO a)
 842   -> IO a
 843 withTarballLocalDirectory verbosity distDirLayout@DistDirLayout{..}
 844                           tarball pkgid dparams buildstyle pkgTextOverride
 845                           buildPkg  =
 846       case buildstyle of
 847         -- In this case we make a temp dir (e.g. tmp/src2345/), unpack
 848         -- the tarball to it (e.g. tmp/src2345/foo-1.0/), and for
 849         -- compatibility we put the dist dir within it
 850         -- (i.e. tmp/src2345/foo-1.0/dist/).
 851         --
 852         -- Unfortunately, a few custom Setup.hs scripts do not respect
 853         -- the --builddir flag and always look for it at ./dist/ so
 854         -- this way we avoid breaking those packages
 855         BuildAndInstall ->
 856           let tmpdir = distTempDirectory in
 857           withTempDirectory verbosity tmpdir "src"   $ \unpackdir -> do
 858             unpackPackageTarball verbosity tarball unpackdir
 859                                  pkgid pkgTextOverride
 860             let srcdir   = unpackdir </> prettyShow pkgid
 861                 builddir = srcdir </> "dist"
 862             buildPkg srcdir builddir
 863
 864         -- In this case we make sure the tarball has been unpacked to the
 865         -- appropriate location under the shared dist dir, and then build it
 866         -- inplace there
 867         BuildInplaceOnly -> do
 868           let srcrootdir = distUnpackedSrcRootDirectory
 869               srcdir     = distUnpackedSrcDirectory pkgid
 870               builddir   = distBuildDirectory dparams
 871           -- TODO: [nice to have] use a proper file monitor rather
 872           -- than this dir exists test
 873           exists <- doesDirectoryExist srcdir
 874           unless exists $ do
 875             createDirectoryIfMissingVerbose verbosity True srcrootdir
 876             unpackPackageTarball verbosity tarball srcrootdir
 877                                  pkgid pkgTextOverride
 878             moveTarballShippedDistDirectory verbosity distDirLayout
 879                                             srcrootdir pkgid dparams
 880           buildPkg srcdir builddir
 881
 882
 883 unpackPackageTarball :: Verbosity -> FilePath -> FilePath
 884                      -> PackageId -> Maybe CabalFileText
 885                      -> IO ()
 886 unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride =
 887     --TODO: [nice to have] switch to tar package and catch tar exceptions
 888     annotateFailureNoLog UnpackFailed $ do
 889
 890       -- Unpack the tarball
 891       --
 892       info verbosity $ "Extracting " ++ tarball ++ " to " ++ parentdir ++ "..."
 893       Tar.extractTarGzFile parentdir pkgsubdir tarball
 894
 895       -- Sanity check
 896       --
 897       exists <- doesFileExist cabalFile
 898       unless exists $
 899         die' verbosity $
 900         "Package .cabal file not found in the tarball: " ++ cabalFile
 901
 902       -- Overwrite the .cabal with the one from the index, when appropriate
 903       --
 904       case pkgTextOverride of
 905         Nothing     -> return ()
 906         Just pkgtxt -> do
 907           info verbosity $ "Updating " ++ prettyShow pkgname <.> "cabal"
 908                         ++ " with the latest revision from the index."
 909           writeFileAtomic cabalFile pkgtxt
 910
 911   where
 912     cabalFile :: FilePath
 913     cabalFile = parentdir </> pkgsubdir
 914                           </> prettyShow pkgname <.> "cabal"
 915     pkgsubdir = prettyShow pkgid
 916     pkgname   = packageName pkgid
 917
 918
 919 -- | This is a bit of a hacky workaround. A number of packages ship
 920 -- pre-processed .hs files in a dist directory inside the tarball. We don't
 921 -- use the standard 'dist' location so unless we move this dist dir to the
 922 -- right place then we'll miss the shipped pre-processed files. This hacky
 923 -- approach to shipped pre-processed files ought to be replaced by a proper
 924 -- system, though we'll still need to keep this hack for older packages.
 925 --
 926 moveTarballShippedDistDirectory :: Verbosity -> DistDirLayout
 927                                 -> FilePath -> PackageId -> DistDirParams
 928                                 -> IO ()
 929 moveTarballShippedDistDirectory verbosity DistDirLayout{distBuildDirectory}
 930                                 parentdir pkgid dparams = do
 931     distDirExists <- doesDirectoryExist tarballDistDir
 932     when distDirExists $ do
 933       debug verbosity $ "Moving '" ++ tarballDistDir ++ "' to '"
 934                                    ++ targetDistDir ++ "'"
 935       --TODO: [nice to have] or perhaps better to copy, and use a file monitor
 936       renameDirectory tarballDistDir targetDistDir
 937   where
 938     tarballDistDir = parentdir </> prettyShow pkgid </> "dist"
 939     targetDistDir  = distBuildDirectory dparams
 940
 941
 942 buildAndInstallUnpackedPackage :: Verbosity
 943                                -> DistDirLayout
 944                                -> StoreDirLayout
 945                                -> BuildTimeSettings -> Lock -> Lock
 946                                -> ElaboratedSharedConfig
 947                                -> ElaboratedInstallPlan
 948                                -> ElaboratedReadyPackage
 949                                -> FilePath -> FilePath
 950                                -> IO BuildResult
 951 buildAndInstallUnpackedPackage verbosity
 952                                distDirLayout@DistDirLayout{distTempDirectory}
 953                                storeDirLayout@StoreDirLayout {
 954                                  storePackageDBStack
 955                                }
 956                                BuildTimeSettings {
 957                                  buildSettingNumJobs,
 958                                  buildSettingLogFile
 959                                }
 960                                registerLock cacheLock
 961                                pkgshared@ElaboratedSharedConfig {
 962                                  pkgConfigPlatform      = platform,
 963                                  pkgConfigCompiler      = compiler,
 964                                  pkgConfigCompilerProgs = progdb
 965                                }
 966                                plan rpkg@(ReadyPackage pkg)
 967                                srcdir builddir = do
 968
 969     createDirectoryIfMissingVerbose verbosity True (srcdir </> builddir)
 970     initLogFile
 971
 972     --TODO: [code cleanup] deal consistently with talking to older
 973     --      Setup.hs versions, much like we do for ghc, with a proper
 974     --      options type and rendering step which will also let us
 975     --      call directly into the lib, rather than always going via
 976     --      the lib's command line interface, which would also allow
 977     --      passing data like installed packages, compiler, and
 978     --      program db for a quicker configure.
 979
 980     --TODO: [required feature] docs and tests
 981     --TODO: [required feature] sudo re-exec
 982
 983     -- Configure phase
 984     noticeProgress ProgressStarting
 985
 986     annotateFailure mlogFile ConfigureFailed $
 987       setup' configureCommand configureFlags configureArgs
 988
 989     -- Build phase
 990     noticeProgress ProgressBuilding
 991
 992     annotateFailure mlogFile BuildFailed $
 993       setup buildCommand buildFlags
 994
 995     -- Haddock phase
 996     whenHaddock $ do
 997       noticeProgress ProgressHaddock
 998       annotateFailureNoLog HaddocksFailed $
 999         setup haddockCommand haddockFlags
1000
1001     -- Install phase
1002     noticeProgress ProgressInstalling
1003     annotateFailure mlogFile InstallFailed $ do
1004
1005       let copyPkgFiles tmpDir = do
1006             let tmpDirNormalised = normalise tmpDir
1007             setup Cabal.copyCommand (copyFlags tmpDirNormalised)
1008             -- Note that the copy command has put the files into
1009             -- @$tmpDir/$prefix@ so we need to return this dir so
1010             -- the store knows which dir will be the final store entry.
1011             let prefix   = normalise $
1012                            dropDrive (InstallDirs.prefix (elabInstallDirs pkg))
1013                 entryDir = tmpDirNormalised </> prefix
1014
1015             -- if there weren't anything to build, it might be that directory is not created
1016             -- the @setup Cabal.copyCommand@ above might do nothing.
1017             -- https://github.com/haskell/cabal/issues/4130
1018             createDirectoryIfMissingVerbose verbosity True entryDir
1019
1020             let hashFileName     = entryDir </> "cabal-hash.txt"
1021                 outPkgHashInputs = renderPackageHashInputs (packageHashInputs pkgshared pkg)
1022
1023             info verbosity $
1024               "creating file with the inputs used to compute the package hash: " ++ hashFileName
1025
1026             LBS.writeFile hashFileName outPkgHashInputs
1027
1028             debug verbosity "Package hash inputs:"
1029             traverse_
1030               (debug verbosity . ("> " ++))
1031               (lines $ LBS.Char8.unpack outPkgHashInputs)
1032
1033             -- Ensure that there are no files in `tmpDir`, that are
1034             -- not in `entryDir`. While this breaks the
1035             -- prefix-relocatable property of the libraries, it is
1036             -- necessary on macOS to stay under the load command limit
1037             -- of the macOS mach-o linker. See also
1038             -- @PackageHash.hashedInstalledPackageIdVeryShort@.
1039             --
1040             -- We also normalise paths to ensure that there are no
1041             -- different representations for the same path. Like / and
1042             -- \\ on windows under msys.
1043             otherFiles <- filter (not . isPrefixOf entryDir) <$>
1044                           listFilesRecursive tmpDirNormalised
1045             -- Here's where we could keep track of the installed files
1046             -- ourselves if we wanted to by making a manifest of the
1047             -- files in the tmp dir.
1048             return (entryDir, otherFiles)
1049             where
1050               listFilesRecursive :: FilePath -> IO [FilePath]
1051               listFilesRecursive path = do
1052                 files <- fmap (path </>) <$> (listDirectory path)
1053                 allFiles <- for files $ \file -> do
1054                   isDir <- doesDirectoryExist file
1055                   if isDir
1056                     then listFilesRecursive file
1057                     else return [file]
1058                 return (concat allFiles)
1059
1060           registerPkg
1061             | not (elabRequiresRegistration pkg) =
1062               debug verbosity $
1063                 "registerPkg: elab does NOT require registration for "
1064                 ++ prettyShow uid
1065             | otherwise = do
1066             -- We register ourselves rather than via Setup.hs. We need to
1067             -- grab and modify the InstalledPackageInfo. We decide what
1068             -- the installed package id is, not the build system.
1069             ipkg0 <- generateInstalledPackageInfo
1070             let ipkg = ipkg0 { Installed.installedUnitId = uid }
1071             assert (   elabRegisterPackageDBStack pkg
1072                     == storePackageDBStack compid) (return ())
1073             criticalSection registerLock $
1074               Cabal.registerPackage
1075                 verbosity compiler progdb
1076                 (storePackageDBStack compid) ipkg
1077                 Cabal.defaultRegisterOptions {
1078                   Cabal.registerMultiInstance      = True,
1079                   Cabal.registerSuppressFilesCheck = True
1080                 }
1081
1082
1083       -- Actual installation
1084       void $ newStoreEntry verbosity storeDirLayout
1085                            compid uid
1086                            copyPkgFiles registerPkg
1087
1088     --TODO: [nice to have] we currently rely on Setup.hs copy to do the right
1089     -- thing. Although we do copy into an image dir and do the move into the
1090     -- final location ourselves, perhaps we ought to do some sanity checks on
1091     -- the image dir first.
1092
1093     -- TODO: [required eventually] note that for nix-style
1094     -- installations it is not necessary to do the
1095     -- 'withWin32SelfUpgrade' dance, but it would be necessary for a
1096     -- shared bin dir.
1097
1098     --TODO: [required feature] docs and test phases
1099     let docsResult  = DocsNotTried
1100         testsResult = TestsNotTried
1101
1102     noticeProgress ProgressCompleted
1103
1104     return BuildResult {
1105        buildResultDocs    = docsResult,
1106        buildResultTests   = testsResult,
1107        buildResultLogFile = mlogFile
1108     }
1109
1110   where
1111     pkgid  = packageId rpkg
1112     uid    = installedUnitId rpkg
1113     compid = compilerId compiler
1114
1115     dispname :: String
1116     dispname = case elabPkgOrComp pkg of
1117         ElabPackage _ -> prettyShow pkgid
1118             ++ " (all, legacy fallback)"
1119         ElabComponent comp -> prettyShow pkgid
1120             ++ " (" ++ maybe "custom" prettyShow (compComponentName comp) ++ ")"
1121
1122     noticeProgress :: ProgressPhase -> IO ()
1123     noticeProgress phase = when isParallelBuild $
1124         progressMessage verbosity phase dispname
1125
1126     isParallelBuild = buildSettingNumJobs >= 2
1127
1128     whenHaddock action
1129       | hasValidHaddockTargets pkg = action
1130       | otherwise                  = return ()
1131
1132     configureCommand = Cabal.configureCommand defaultProgramDb
1133     configureFlags v = flip filterConfigureFlags v $
1134                        setupHsConfigureFlags rpkg pkgshared
1135                                              verbosity builddir
1136     configureArgs _  = setupHsConfigureArgs pkg
1137
1138     buildCommand     = Cabal.buildCommand defaultProgramDb
1139     buildFlags   _   = setupHsBuildFlags pkg pkgshared verbosity builddir
1140
1141     haddockCommand   = Cabal.haddockCommand
1142     haddockFlags _   = setupHsHaddockFlags pkg pkgshared
1143                                            verbosity builddir
1144
1145     generateInstalledPackageInfo :: IO InstalledPackageInfo
1146     generateInstalledPackageInfo =
1147       withTempInstalledPackageInfoFile
1148         verbosity distTempDirectory $ \pkgConfDest -> do
1149         let registerFlags _ = setupHsRegisterFlags
1150                                 pkg pkgshared
1151                                 verbosity builddir
1152                                 pkgConfDest
1153         setup Cabal.registerCommand registerFlags
1154
1155     copyFlags destdir _ = setupHsCopyFlags pkg pkgshared verbosity
1156                                            builddir destdir
1157
1158     scriptOptions = setupHsScriptOptions rpkg plan pkgshared
1159                                          distDirLayout srcdir builddir
1160                                          isParallelBuild cacheLock
1161
1162     setup :: CommandUI flags -> (Version -> flags) -> IO ()
1163     setup cmd flags = setup' cmd flags (const [])
1164
1165     setup' :: CommandUI flags -> (Version -> flags) -> (Version -> [String])
1166            -> IO ()
1167     setup' cmd flags args =
1168       withLogging $ \mLogFileHandle ->
1169         setupWrapper
1170           verbosity
1171           scriptOptions
1172             { useLoggingHandle     = mLogFileHandle
1173             , useExtraEnvOverrides = dataDirsEnvironmentForPlan
1174                                      distDirLayout plan }
1175           (Just (elabPkgDescription pkg))
1176           cmd flags args
1177
1178     mlogFile :: Maybe FilePath
1179     mlogFile =
1180       case buildSettingLogFile of
1181         Nothing        -> Nothing
1182         Just mkLogFile -> Just (mkLogFile compiler platform pkgid uid)
1183
1184     initLogFile :: IO ()
1185     initLogFile =
1186       case mlogFile of
1187         Nothing      -> return ()
1188         Just logFile -> do
1189           createDirectoryIfMissing True (takeDirectory logFile)
1190           exists <- doesFileExist logFile
1191           when exists $ removeFile logFile
1192
1193     withLogging :: (Maybe Handle -> IO r) -> IO r
1194     withLogging action =
1195       case mlogFile of
1196         Nothing      -> action Nothing
1197         Just logFile -> withFile logFile AppendMode (action . Just)
1198
1199
1200 hasValidHaddockTargets :: ElaboratedConfiguredPackage -> Bool
1201 hasValidHaddockTargets ElaboratedConfiguredPackage{..}
1202   | not elabBuildHaddocks = False
1203   | otherwise             = any componentHasHaddocks components
1204   where
1205     components :: [ComponentTarget]
1206     components = elabBuildTargets ++ elabTestTargets ++ elabBenchTargets
1207               ++ maybeToList elabReplTarget ++ elabHaddockTargets
1208
1209     componentHasHaddocks :: ComponentTarget -> Bool
1210     componentHasHaddocks (ComponentTarget name _) =
1211       case name of
1212         CLibName LMainLibName    ->                           hasHaddocks
1213         CLibName (LSubLibName _) -> elabHaddockInternal    && hasHaddocks
1214         CFLibName              _ -> elabHaddockForeignLibs && hasHaddocks
1215         CExeName               _ -> elabHaddockExecutables && hasHaddocks
1216         CTestName              _ -> elabHaddockTestSuites  && hasHaddocks
1217         CBenchName             _ -> elabHaddockBenchmarks  && hasHaddocks
1218       where
1219         hasHaddocks = not (null (elabPkgDescription ^. componentModules name))
1220
1221
1222 buildInplaceUnpackedPackage :: Verbosity
1223                             -> DistDirLayout
1224                             -> BuildTimeSettings -> Lock -> Lock
1225                             -> ElaboratedSharedConfig
1226                             -> ElaboratedInstallPlan
1227                             -> ElaboratedReadyPackage
1228                             -> BuildStatusRebuild
1229                             -> FilePath -> FilePath
1230                             -> IO BuildResult
1231 buildInplaceUnpackedPackage verbosity
1232                             distDirLayout@DistDirLayout {
1233                               distTempDirectory,
1234                               distPackageCacheDirectory,
1235                               distDirectory
1236                             }
1237                             BuildTimeSettings{buildSettingNumJobs, buildSettingHaddockOpen}
1238                             registerLock cacheLock
1239                             pkgshared@ElaboratedSharedConfig {
1240                               pkgConfigCompiler      = compiler,
1241                               pkgConfigCompilerProgs = progdb,
1242                               pkgConfigPlatform      = platform
1243                             }
1244                             plan
1245                             rpkg@(ReadyPackage pkg)
1246                             buildStatus
1247                             srcdir builddir = do
1248
1249         --TODO: [code cleanup] there is duplication between the
1250         --      distdirlayout and the builddir here builddir is not
1251         --      enough, we also need the per-package cachedir
1252         createDirectoryIfMissingVerbose verbosity True builddir
1253         createDirectoryIfMissingVerbose verbosity True
1254           (distPackageCacheDirectory dparams)
1255
1256         -- Configure phase
1257         --
1258         whenReConfigure $ do
1259           annotateFailureNoLog ConfigureFailed $
1260             setup configureCommand configureFlags configureArgs
1261           invalidatePackageRegFileMonitor packageFileMonitor
1262           updatePackageConfigFileMonitor packageFileMonitor srcdir pkg
1263
1264         -- Build phase
1265         --
1266         let docsResult  = DocsNotTried
1267             testsResult = TestsNotTried
1268
1269             buildResult :: BuildResultMisc
1270             buildResult = (docsResult, testsResult)
1271
1272         whenRebuild $ do
1273           timestamp <- beginUpdateFileMonitor
1274           annotateFailureNoLog BuildFailed $
1275             setup buildCommand buildFlags buildArgs
1276
1277           let listSimple =
1278                 execRebuild srcdir (needElaboratedConfiguredPackage pkg)
1279               listSdist =
1280                 fmap (map monitorFileHashed) $
1281                     allPackageSourceFiles verbosity srcdir
1282               ifNullThen m m' = do xs <- m
1283                                    if null xs then m' else return xs
1284           monitors <- case PD.buildType (elabPkgDescription pkg) of
1285             Simple -> listSimple
1286             -- If a Custom setup was used, AND the Cabal is recent
1287             -- enough to have sdist --list-sources, use that to
1288             -- determine the files that we need to track.  This can
1289             -- cause unnecessary rebuilding (for example, if README
1290             -- is edited, we will try to rebuild) but there isn't
1291             -- a more accurate Custom interface we can use to get
1292             -- this info.  We prefer not to use listSimple here
1293             -- as it can miss extra source files that are considered
1294             -- by the Custom setup.
1295             _ | elabSetupScriptCliVersion pkg >= mkVersion [1,17]
1296               -- However, sometimes sdist --list-sources will fail
1297               -- and return an empty list.  In that case, fall
1298               -- back on the (inaccurate) simple tracking.
1299               -> listSdist `ifNullThen` listSimple
1300               | otherwise
1301               -> listSimple
1302
1303           let dep_monitors = map monitorFileHashed
1304                            $ elabInplaceDependencyBuildCacheFiles
1305                                 distDirLayout pkgshared plan pkg
1306           updatePackageBuildFileMonitor packageFileMonitor srcdir timestamp
1307                                         pkg buildStatus
1308                                         (monitors ++ dep_monitors) buildResult
1309
1310         -- PURPOSELY omitted: no copy!
1311
1312         whenReRegister $ annotateFailureNoLog InstallFailed $ do
1313           -- Register locally
1314           mipkg <- if elabRequiresRegistration pkg
1315             then do
1316                 ipkg0 <- generateInstalledPackageInfo
1317                 -- We register ourselves rather than via Setup.hs. We need to
1318                 -- grab and modify the InstalledPackageInfo. We decide what
1319                 -- the installed package id is, not the build system.
1320                 let ipkg = ipkg0 { Installed.installedUnitId = ipkgid }
1321                 criticalSection registerLock $
1322                     Cabal.registerPackage verbosity compiler progdb
1323                                           (elabRegisterPackageDBStack pkg)
1324                                           ipkg Cabal.defaultRegisterOptions
1325                 return (Just ipkg)
1326
1327            else return Nothing
1328
1329           updatePackageRegFileMonitor packageFileMonitor srcdir mipkg
1330
1331         whenTest $ do
1332           annotateFailureNoLog TestsFailed $
1333             setup testCommand testFlags testArgs
1334
1335         whenBench $
1336           annotateFailureNoLog BenchFailed $
1337             setup benchCommand benchFlags benchArgs
1338
1339         -- Repl phase
1340         --
1341         whenRepl $
1342           annotateFailureNoLog ReplFailed $
1343           setupInteractive replCommand replFlags replArgs
1344
1345         -- Haddock phase
1346         whenHaddock $
1347           annotateFailureNoLog HaddocksFailed $ do
1348             setup haddockCommand haddockFlags haddockArgs
1349             let haddockTarget = elabHaddockForHackage pkg
1350             when (haddockTarget == Cabal.ForHackage) $ do
1351               let dest = distDirectory </> name <.> "tar.gz"
1352                   name = haddockDirName haddockTarget (elabPkgDescription pkg)
1353                   docDir = distBuildDirectory distDirLayout dparams
1354                            </> "doc" </> "html"
1355               Tar.createTarGzFile dest docDir name
1356               notice verbosity $ "Documentation tarball created: " ++ dest
1357
1358             when (buildSettingHaddockOpen && haddockTarget /= Cabal.ForHackage) $ do
1359               let dest = docDir </> name </> "index.html"
1360                   name = haddockDirName haddockTarget (elabPkgDescription pkg)
1361                   docDir = distBuildDirectory distDirLayout dparams
1362                            </> "doc" </> "html"
1363               exe <- findOpenProgramLocation platform
1364               case exe of
1365                 Right open -> runProgramInvocation verbosity (simpleProgramInvocation open [dest])
1366                 Left err -> die' verbosity err
1367
1368
1369         return BuildResult {
1370           buildResultDocs    = docsResult,
1371           buildResultTests   = testsResult,
1372           buildResultLogFile = Nothing
1373         }
1374
1375   where
1376     ipkgid  = installedUnitId pkg
1377     dparams = elabDistDirParams pkgshared pkg
1378
1379     isParallelBuild = buildSettingNumJobs >= 2
1380
1381     packageFileMonitor = newPackageFileMonitor pkgshared distDirLayout dparams
1382
1383     whenReConfigure action = case buildStatus of
1384       BuildStatusConfigure _ -> action
1385       _                      -> return ()
1386
1387     whenRebuild action
1388       | null (elabBuildTargets pkg)
1389       -- NB: we have to build the test/bench suite!
1390       , null (elabTestTargets pkg)
1391       , null (elabBenchTargets pkg) = return ()
1392       | otherwise                   = action
1393
1394     whenTest action
1395       | null (elabTestTargets pkg) = return ()
1396       | otherwise                  = action
1397
1398     whenBench action
1399       | null (elabBenchTargets pkg) = return ()
1400       | otherwise                   = action
1401
1402     whenRepl action
1403       | isNothing (elabReplTarget pkg) = return ()
1404       | otherwise                     = action
1405
1406     whenHaddock action
1407       | hasValidHaddockTargets pkg = action
1408       | otherwise                  = return ()
1409
1410     whenReRegister  action
1411       = case buildStatus of
1412           -- We registered the package already
1413           BuildStatusBuild (Just _) _     ->
1414             info verbosity "whenReRegister: previously registered"
1415           -- There is nothing to register
1416           _ | null (elabBuildTargets pkg) ->
1417               info verbosity "whenReRegister: nothing to register"
1418             | otherwise                   -> action
1419
1420     configureCommand = Cabal.configureCommand defaultProgramDb
1421     configureFlags v = flip filterConfigureFlags v $
1422                        setupHsConfigureFlags rpkg pkgshared
1423                                              verbosity builddir
1424     configureArgs _  = setupHsConfigureArgs pkg
1425
1426     buildCommand     = Cabal.buildCommand defaultProgramDb
1427     buildFlags   _   = setupHsBuildFlags pkg pkgshared
1428                                          verbosity builddir
1429     buildArgs     _  = setupHsBuildArgs  pkg
1430
1431     testCommand      = Cabal.testCommand -- defaultProgramDb
1432     testFlags      v = flip filterTestFlags v $
1433                        setupHsTestFlags pkg pkgshared
1434                                          verbosity builddir
1435     testArgs      _  = setupHsTestArgs  pkg
1436
1437     benchCommand     = Cabal.benchmarkCommand
1438     benchFlags    _  = setupHsBenchFlags pkg pkgshared
1439                                           verbosity builddir
1440     benchArgs     _  = setupHsBenchArgs  pkg
1441
1442     replCommand      = Cabal.replCommand defaultProgramDb
1443     replFlags _      = setupHsReplFlags pkg pkgshared
1444                                         verbosity builddir
1445     replArgs _       = setupHsReplArgs  pkg
1446
1447     haddockCommand   = Cabal.haddockCommand
1448     haddockFlags v   = flip filterHaddockFlags v $
1449                        setupHsHaddockFlags pkg pkgshared
1450                                            verbosity builddir
1451     haddockArgs    v = flip filterHaddockArgs v $
1452                        setupHsHaddockArgs pkg
1453
1454     scriptOptions    = setupHsScriptOptions rpkg plan pkgshared
1455                                             distDirLayout srcdir builddir
1456                                             isParallelBuild cacheLock
1457
1458     setupInteractive :: CommandUI flags
1459                      -> (Version -> flags) -> (Version -> [String]) -> IO ()
1460     setupInteractive cmd flags args =
1461       setupWrapper verbosity
1462                    scriptOptions { isInteractive = True }
1463                    (Just (elabPkgDescription pkg))
1464                    cmd flags args
1465
1466     setup :: CommandUI flags -> (Version -> flags) -> (Version -> [String])
1467           -> IO ()
1468     setup cmd flags args =
1469       setupWrapper verbosity
1470                    scriptOptions
1471                    (Just (elabPkgDescription pkg))
1472                    cmd flags args
1473
1474     generateInstalledPackageInfo :: IO InstalledPackageInfo
1475     generateInstalledPackageInfo =
1476       withTempInstalledPackageInfoFile
1477         verbosity distTempDirectory $ \pkgConfDest -> do
1478         let registerFlags _ = setupHsRegisterFlags
1479                                 pkg pkgshared
1480                                 verbosity builddir
1481                                 pkgConfDest
1482         setup Cabal.registerCommand registerFlags (const [])
1483
1484 withTempInstalledPackageInfoFile :: Verbosity -> FilePath
1485                                   -> (FilePath -> IO ())
1486                                   -> IO InstalledPackageInfo
1487 withTempInstalledPackageInfoFile verbosity tempdir action =
1488     withTempDirectory verbosity tempdir "package-registration-" $ \dir -> do
1489       -- make absolute since @action@ will often change directory
1490       abs_dir <- canonicalizePath dir
1491
1492       let pkgConfDest = abs_dir </> "pkgConf"
1493       action pkgConfDest
1494
1495       readPkgConf "." pkgConfDest
1496   where
1497     pkgConfParseFailed :: String -> IO a
1498     pkgConfParseFailed perror =
1499       die' verbosity $
1500       "Couldn't parse the output of 'setup register --gen-pkg-config':"
1501       ++ show perror
1502
1503     readPkgConf :: FilePath -> FilePath -> IO InstalledPackageInfo
1504     readPkgConf pkgConfDir pkgConfFile = do
1505       pkgConfStr <- BS.readFile (pkgConfDir </> pkgConfFile)
1506       (warns, ipkg) <- case Installed.parseInstalledPackageInfo pkgConfStr of
1507         Left perrors -> pkgConfParseFailed $ unlines $ NE.toList perrors
1508         Right (warns, ipkg) -> return (warns, ipkg)
1509
1510       unless (null warns) $
1511         warn verbosity $ unlines warns
1512
1513       return ipkg
1514
1515
1516 ------------------------------------------------------------------------------
1517 -- * Utilities
1518 ------------------------------------------------------------------------------
1519
1520 annotateFailureNoLog :: (SomeException -> BuildFailureReason)
1521                      -> IO a -> IO a
1522 annotateFailureNoLog annotate action =
1523   annotateFailure Nothing annotate action
1524
1525 annotateFailure :: Maybe FilePath
1526                 -> (SomeException -> BuildFailureReason)
1527                 -> IO a -> IO a
1528 annotateFailure mlogFile annotate action =
1529   action `catches`
1530     -- It's not just IOException and ExitCode we have to deal with, there's
1531     -- lots, including exceptions from the hackage-security and tar packages.
1532     -- So we take the strategy of catching everything except async exceptions.
1533     [
1534 #if MIN_VERSION_base(4,7,0)
1535       Handler $ \async -> throwIO (async :: SomeAsyncException)
1536 #else
1537       Handler $ \async -> throwIO (async :: AsyncException)
1538 #endif
1539     , Handler $ \other -> handler (other :: SomeException)
1540     ]
1541   where
1542     handler :: Exception e => e -> IO a
1543     handler = throwIO . BuildFailure mlogFile . annotate . toException