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

   1 {-# LANGUAGE BangPatterns #-}
   2 {-# LANGUAGE CPP #-}
   3 {-# LANGUAGE ConstraintKinds #-}
   4 {-# LANGUAGE NamedFieldPuns #-}
   5 {-# LANGUAGE RecordWildCards #-}
   6 {-# LANGUAGE ScopedTypeVariables #-}
   7 {-# LANGUAGE TypeFamilies #-}
   8 {-# LANGUAGE NoMonoLocalBinds #-}
   9
  10 module Distribution.Client.ProjectBuilding
  11   ( -- * Dry run phase
  12
  13     -- | What bits of the plan will we execute? The dry run does not change
  14     -- anything but tells us what will need to be built.
  15     rebuildTargetsDryRun
  16   , improveInstallPlanWithUpToDatePackages
  17
  18     -- ** Build status
  19
  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
  30     -- | Now we actually execute the plan.
  31   , rebuildTargets
  32
  33     -- ** Build outcomes
  34
  35     -- | This is the outcome for each package of executing the plan.
  36     -- For each package, did the build succeed or fail?
  37   , BuildOutcomes
  38   , BuildOutcome
  39   , BuildResult (..)
  40   , BuildFailure (..)
  41   , BuildFailureReason (..)
  42   ) where
  43
  44 import Distribution.Client.Compat.Prelude
  45 import Prelude ()
  46
  47 import Distribution.Client.ProjectBuilding.Types
  48 import Distribution.Client.ProjectConfig
  49 import Distribution.Client.ProjectConfig.Types
  50 import Distribution.Client.ProjectPlanning
  51 import Distribution.Client.ProjectPlanning.Types
  52 import Distribution.Client.Store
  53
  54 import Distribution.Client.DistDirLayout
  55 import Distribution.Client.FetchUtils
  56 import Distribution.Client.GlobalFlags (RepoContext)
  57 import Distribution.Client.InstallPlan
  58   ( GenericInstallPlan
  59   , GenericPlanPackage
  60   , IsUnit
  61   )
  62 import qualified Distribution.Client.InstallPlan as InstallPlan
  63 import Distribution.Client.JobControl
  64 import qualified Distribution.Client.Tar as Tar
  65 import Distribution.Client.Types hiding
  66   ( BuildFailure (..)
  67   , BuildOutcome
  68   , BuildOutcomes
  69   , BuildResult (..)
  70   )
  71
  72 import Distribution.Package
  73 import Distribution.Simple.Compiler
  74   ( Compiler
  75   , PackageDB (..)
  76   , jsemSupported
  77   )
  78 import Distribution.Simple.Program
  79 import qualified Distribution.Simple.Register as Cabal
  80
  81 import Distribution.Compat.Graph (IsNode (..))
  82 import Distribution.Simple.Utils
  83 import Distribution.Version
  84
  85 import qualified Data.Map as Map
  86 import qualified Data.Set as Set
  87
  88 import qualified Text.PrettyPrint as Disp
  89
  90 import Control.Exception (assert, bracket, handle)
  91 import System.Directory (doesDirectoryExist, doesFileExist, renameDirectory)
  92 import System.FilePath (makeRelative, takeDirectory, (<.>), (</>))
  93 import System.Semaphore (SemaphoreName (..))
  94
  95 import Distribution.Client.Errors
  96 import Distribution.Simple.Flag (fromFlagOrDefault)
  97
  98 import Distribution.Client.ProjectBuilding.PackageFileMonitor
  99 import Distribution.Client.ProjectBuilding.UnpackedPackage (annotateFailureNoLog, buildAndInstallUnpackedPackage, buildInplaceUnpackedPackage)
 100 import Distribution.Client.Utils (numberOfProcessors)
 101
 102 ------------------------------------------------------------------------------
 103
 104 -- * Overall building strategy.
 105
 106 ------------------------------------------------------------------------------
 107 --
 108 -- We start with an 'ElaboratedInstallPlan' that has already been improved by
 109 -- reusing packages from the store, and pruned to include only the targets of
 110 -- interest and their dependencies. So the remaining packages in the
 111 -- 'InstallPlan.Configured' state are ones we either need to build or rebuild.
 112 --
 113 -- First, we do a preliminary dry run phase where we work out which packages
 114 -- we really need to (re)build, and for the ones we do need to build which
 115 -- build phase to start at.
 116 --
 117 -- We use this to improve the 'ElaboratedInstallPlan' again by changing
 118 -- up-to-date 'InstallPlan.Configured' packages to 'InstallPlan.Installed'
 119 -- so that the build phase will skip them.
 120 --
 121 -- Then we execute the plan, that is actually build packages. The outcomes of
 122 -- trying to build all the packages are collected and returned.
 123 --
 124 -- We split things like this (dry run and execute) for a couple reasons.
 125 -- Firstly we need to be able to do dry runs anyway, and these need to be
 126 -- reasonably accurate in terms of letting users know what (and why) things
 127 -- are going to be (re)built.
 128 --
 129 -- Given that we need to be able to do dry runs, it would not be great if
 130 -- we had to repeat all the same work when we do it for real. Not only is
 131 -- it duplicate work, but it's duplicate code which is likely to get out of
 132 -- sync. So we do things only once. We preserve info we discover in the dry
 133 -- run phase and rely on it later when we build things for real. This also
 134 -- somewhat simplifies the build phase. So this way the dry run can't so
 135 -- easily drift out of sync with the real thing since we're relying on the
 136 -- info it produces.
 137 --
 138 -- An additional advantage is that it makes it easier to debug rebuild
 139 -- errors (ie rebuilding too much or too little), since all the rebuild
 140 -- decisions are made without making any state changes at the same time
 141 -- (that would make it harder to reproduce the problem situation).
 142 --
 143 -- Finally, we can use the dry run build status and the build outcomes to
 144 -- give us some information on the overall status of packages in the project.
 145 -- This includes limited information about the status of things that were
 146 -- not actually in the subset of the plan that was used for the dry run or
 147 -- execution phases. In particular we may know that some packages are now
 148 -- definitely out of date. See "Distribution.Client.ProjectPlanOutput" for
 149 -- details.
 150
 151 ------------------------------------------------------------------------------
 152
 153 -- * Dry run: what bits of the 'ElaboratedInstallPlan' will we execute?
 154
 155 ------------------------------------------------------------------------------
 156
 157 -- Refer to ProjectBuilding.Types for details of these important types:
 158
 159 -- type BuildStatusMap     = ...
 160 -- data BuildStatus        = ...
 161 -- data BuildStatusRebuild = ...
 162 -- data BuildReason        = ...
 163
 164 -- | Do the dry run pass. This is a prerequisite of 'rebuildTargets'.
 165 --
 166 -- It gives us the 'BuildStatusMap'. This should be used with
 167 -- 'improveInstallPlanWithUpToDatePackages' to give an improved version of
 168 -- the 'ElaboratedInstallPlan' with packages switched to the
 169 -- 'InstallPlan.Installed' state when we find that they're already up to date.
 170 rebuildTargetsDryRun
 171   :: DistDirLayout
 172   -> ElaboratedSharedConfig
 173   -> ElaboratedInstallPlan
 174   -> IO BuildStatusMap
 175 rebuildTargetsDryRun distDirLayout@DistDirLayout{..} shared =
 176   -- Do the various checks to work out the 'BuildStatus' of each package
 177   foldMInstallPlanDepOrder dryRunPkg
 178   where
 179     dryRunPkg
 180       :: ElaboratedPlanPackage
 181       -> [BuildStatus]
 182       -> IO BuildStatus
 183     dryRunPkg (InstallPlan.PreExisting _pkg) _depsBuildStatus =
 184       return BuildStatusPreExisting
 185     dryRunPkg (InstallPlan.Installed _pkg) _depsBuildStatus =
 186       return BuildStatusInstalled
 187     dryRunPkg (InstallPlan.Configured pkg) depsBuildStatus = do
 188       mloc <- checkFetched (elabPkgSourceLocation pkg)
 189       case mloc of
 190         Nothing -> return BuildStatusDownload
 191         Just (LocalUnpackedPackage srcdir) ->
 192           -- For the case of a user-managed local dir, irrespective of the
 193           -- build style, we build from that directory and put build
 194           -- artifacts under the shared dist directory.
 195           dryRunLocalPkg pkg depsBuildStatus srcdir
 196         -- The rest cases are all tarball cases are,
 197         -- and handled the same as each other though depending on the build style.
 198         Just (LocalTarballPackage tarball) ->
 199           dryRunTarballPkg pkg depsBuildStatus tarball
 200         Just (RemoteTarballPackage _ tarball) ->
 201           dryRunTarballPkg pkg depsBuildStatus tarball
 202         Just (RepoTarballPackage _ _ tarball) ->
 203           dryRunTarballPkg pkg depsBuildStatus tarball
 204         Just (RemoteSourceRepoPackage _repo tarball) ->
 205           dryRunTarballPkg pkg depsBuildStatus tarball
 206
 207     dryRunTarballPkg
 208       :: ElaboratedConfiguredPackage
 209       -> [BuildStatus]
 210       -> FilePath
 211       -> IO BuildStatus
 212     dryRunTarballPkg pkg depsBuildStatus tarball =
 213       case elabBuildStyle pkg of
 214         BuildAndInstall -> return (BuildStatusUnpack tarball)
 215         BuildInplaceOnly{} -> do
 216           -- TODO: [nice to have] use a proper file monitor rather
 217           -- than this dir exists test
 218           exists <- doesDirectoryExist srcdir
 219           if exists
 220             then dryRunLocalPkg pkg depsBuildStatus srcdir
 221             else return (BuildStatusUnpack tarball)
 222       where
 223         srcdir :: FilePath
 224         srcdir = distUnpackedSrcDirectory (packageId pkg)
 225
 226     dryRunLocalPkg
 227       :: ElaboratedConfiguredPackage
 228       -> [BuildStatus]
 229       -> FilePath
 230       -> IO BuildStatus
 231     dryRunLocalPkg pkg depsBuildStatus srcdir = do
 232       -- Go and do lots of I/O, reading caches and probing files to work out
 233       -- if anything has changed
 234       change <-
 235         checkPackageFileMonitorChanged
 236           packageFileMonitor
 237           pkg
 238           srcdir
 239           depsBuildStatus
 240       case change of
 241         -- It did change, giving us 'BuildStatusRebuild' info on why
 242         Left rebuild ->
 243           return (BuildStatusRebuild srcdir rebuild)
 244         -- No changes, the package is up to date. Use the saved build results.
 245         Right buildResult ->
 246           return (BuildStatusUpToDate buildResult)
 247       where
 248         packageFileMonitor :: PackageFileMonitor
 249         packageFileMonitor =
 250           newPackageFileMonitor
 251             shared
 252             distDirLayout
 253             (elabDistDirParams shared pkg)
 254
 255 -- | A specialised traversal over the packages in an install plan.
 256 --
 257 -- The packages are visited in dependency order, starting with packages with no
 258 -- dependencies. The result for each package is accumulated into a 'Map' and
 259 -- returned as the final result. In addition, when visiting a package, the
 260 -- visiting function is passed the results for all the immediate package
 261 -- dependencies. This can be used to propagate information from dependencies.
 262 foldMInstallPlanDepOrder
 263   :: forall m ipkg srcpkg b
 264    . (Monad m, IsUnit ipkg, IsUnit srcpkg)
 265   => ( GenericPlanPackage ipkg srcpkg
 266        -> [b]
 267        -> m b
 268      )
 269   -> GenericInstallPlan ipkg srcpkg
 270   -> m (Map UnitId b)
 271 foldMInstallPlanDepOrder visit =
 272   go Map.empty . InstallPlan.reverseTopologicalOrder
 273   where
 274     go
 275       :: Map UnitId b
 276       -> [GenericPlanPackage ipkg srcpkg]
 277       -> m (Map UnitId b)
 278     go !results [] = return results
 279     go !results (pkg : pkgs) = do
 280       -- we go in the right order so the results map has entries for all deps
 281       let depresults :: [b]
 282           depresults =
 283             map
 284               ( \ipkgid ->
 285                   let result = Map.findWithDefault (error "foldMInstallPlanDepOrder") ipkgid results
 286                    in result
 287               )
 288               (InstallPlan.depends pkg)
 289       result <- visit pkg depresults
 290       let results' = Map.insert (nodeKey pkg) result results
 291       go results' pkgs
 292
 293 improveInstallPlanWithUpToDatePackages
 294   :: BuildStatusMap
 295   -> ElaboratedInstallPlan
 296   -> ElaboratedInstallPlan
 297 improveInstallPlanWithUpToDatePackages pkgsBuildStatus =
 298   InstallPlan.installed canPackageBeImproved
 299   where
 300     canPackageBeImproved :: ElaboratedConfiguredPackage -> Bool
 301     canPackageBeImproved pkg =
 302       case Map.lookup (installedUnitId pkg) pkgsBuildStatus of
 303         Just BuildStatusUpToDate{} -> True
 304         Just _ -> False
 305         Nothing ->
 306           error $
 307             "improveInstallPlanWithUpToDatePackages: "
 308               ++ prettyShow (packageId pkg)
 309               ++ " not in status map"
 310
 311 ------------------------------------------------------------------------------
 312
 313 -- * Doing it: executing an 'ElaboratedInstallPlan'
 314
 315 ------------------------------------------------------------------------------
 316
 317 -- Refer to ProjectBuilding.Types for details of these important types:
 318
 319 -- type BuildOutcomes = ...
 320 -- type BuildOutcome  = ...
 321 -- data BuildResult   = ...
 322 -- data BuildFailure  = ...
 323 -- data BuildFailureReason = ...
 324
 325 -- | Build things for real.
 326 --
 327 -- It requires the 'BuildStatusMap' gathered by 'rebuildTargetsDryRun'.
 328 rebuildTargets
 329   :: Verbosity
 330   -> ProjectConfig
 331   -> DistDirLayout
 332   -> StoreDirLayout
 333   -> ElaboratedInstallPlan
 334   -> ElaboratedSharedConfig
 335   -> BuildStatusMap
 336   -> BuildTimeSettings
 337   -> IO BuildOutcomes
 338 rebuildTargets
 339   verbosity
 340   ProjectConfig
 341     { projectConfigBuildOnly = config
 342     }
 343   distDirLayout@DistDirLayout{..}
 344   storeDirLayout
 345   installPlan
 346   sharedPackageConfig@ElaboratedSharedConfig
 347     { pkgConfigCompiler = compiler
 348     , pkgConfigCompilerProgs = progdb
 349     }
 350   pkgsBuildStatus
 351   buildSettings@BuildTimeSettings
 352     { buildSettingNumJobs
 353     , buildSettingKeepGoing
 354     }
 355     | fromFlagOrDefault False (projectConfigOfflineMode config) && not (null packagesToDownload) = return offlineError
 356     | otherwise = do
 357         -- Concurrency control: create the job controller and concurrency limits
 358         -- for downloading, building and installing.
 359         mkJobControl <- case buildSettingNumJobs of
 360           Serial -> newSerialJobControl
 361           NumJobs n -> newParallelJobControl (fromMaybe numberOfProcessors n)
 362           UseSem n ->
 363             if jsemSupported compiler
 364               then newSemaphoreJobControl n
 365               else do
 366                 warn verbosity "-jsem is not supported by the selected compiler, falling back to normal parallelism control."
 367                 newParallelJobControl n
 368         registerLock <- newLock -- serialise registration
 369         cacheLock <- newLock -- serialise access to setup exe cache
 370         -- TODO: [code cleanup] eliminate setup exe cache
 371         info verbosity $
 372           "Executing install plan "
 373             ++ case buildSettingNumJobs of
 374               NumJobs n -> "in parallel using " ++ show n ++ " threads."
 375               UseSem n -> "in parallel using a semaphore with " ++ show n ++ " slots."
 376               Serial -> "serially."
 377
 378         createDirectoryIfMissingVerbose verbosity True distBuildRootDirectory
 379         createDirectoryIfMissingVerbose verbosity True distTempDirectory
 380         traverse_ (createPackageDBIfMissing verbosity compiler progdb) packageDBsToUse
 381
 382         bracket (pure mkJobControl) cleanupJobControl $ \jobControl -> do
 383           -- Before traversing the install plan, preemptively find all packages that
 384           -- will need to be downloaded and start downloading them.
 385           asyncDownloadPackages
 386             verbosity
 387             withRepoCtx
 388             installPlan
 389             pkgsBuildStatus
 390             $ \downloadMap ->
 391               -- For each package in the plan, in dependency order, but in parallel...
 392               InstallPlan.execute
 393                 mkJobControl
 394                 keepGoing
 395                 (BuildFailure Nothing . DependentFailed . packageId)
 396                 installPlan
 397                 $ \pkg ->
 398                   -- TODO: review exception handling
 399                   handle (\(e :: BuildFailure) -> return (Left e)) $ fmap Right $ do
 400                     let uid = installedUnitId pkg
 401                         pkgBuildStatus = Map.findWithDefault (error "rebuildTargets") uid pkgsBuildStatus
 402
 403                     rebuildTarget
 404                       verbosity
 405                       distDirLayout
 406                       storeDirLayout
 407                       (jobControlSemaphore jobControl)
 408                       buildSettings
 409                       downloadMap
 410                       registerLock
 411                       cacheLock
 412                       sharedPackageConfig
 413                       installPlan
 414                       pkg
 415                       pkgBuildStatus
 416     where
 417       keepGoing = buildSettingKeepGoing
 418       withRepoCtx =
 419         projectConfigWithBuilderRepoContext
 420           verbosity
 421           buildSettings
 422       packageDBsToUse =
 423         -- all the package dbs we may need to create
 424         (Set.toList . Set.fromList)
 425           [ pkgdb
 426           | InstallPlan.Configured elab <- InstallPlan.toList installPlan
 427           , pkgdb <-
 428               concat
 429                 [ elabBuildPackageDBStack elab
 430                 , elabRegisterPackageDBStack elab
 431                 , elabSetupPackageDBStack elab
 432                 ]
 433           ]
 434
 435       offlineError :: BuildOutcomes
 436       offlineError = Map.fromList . map makeBuildOutcome $ packagesToDownload
 437         where
 438           makeBuildOutcome :: ElaboratedConfiguredPackage -> (UnitId, BuildOutcome)
 439           makeBuildOutcome
 440             ElaboratedConfiguredPackage
 441               { elabUnitId
 442               , elabPkgSourceId = PackageIdentifier{pkgName, pkgVersion}
 443               } =
 444               ( elabUnitId
 445               , Left
 446                   ( BuildFailure
 447                       { buildFailureLogFile = Nothing
 448                       , buildFailureReason = GracefulFailure $ makeError pkgName pkgVersion
 449                       }
 450                   )
 451               )
 452           makeError :: PackageName -> Version -> String
 453           makeError n v =
 454             "--offline was specified, hence refusing to download the package: "
 455               ++ unPackageName n
 456               ++ " version "
 457               ++ Disp.render (pretty v)
 458
 459       packagesToDownload :: [ElaboratedConfiguredPackage]
 460       packagesToDownload =
 461         [ elab | InstallPlan.Configured elab <- InstallPlan.reverseTopologicalOrder installPlan, isRemote $ elabPkgSourceLocation elab
 462         ]
 463         where
 464           isRemote :: PackageLocation a -> Bool
 465           isRemote (RemoteTarballPackage _ _) = True
 466           isRemote (RepoTarballPackage{}) = True
 467           isRemote (RemoteSourceRepoPackage _ _) = True
 468           isRemote _ = False
 469
 470 -- | Create a package DB if it does not currently exist. Note that this action
 471 -- is /not/ safe to run concurrently.
 472 createPackageDBIfMissing
 473   :: Verbosity
 474   -> Compiler
 475   -> ProgramDb
 476   -> PackageDB
 477   -> IO ()
 478 createPackageDBIfMissing
 479   verbosity
 480   compiler
 481   progdb
 482   (SpecificPackageDB dbPath) = do
 483     exists <- Cabal.doesPackageDBExist dbPath
 484     unless exists $ do
 485       createDirectoryIfMissingVerbose verbosity True (takeDirectory dbPath)
 486       Cabal.createPackageDB verbosity compiler progdb False dbPath
 487 createPackageDBIfMissing _ _ _ _ = return ()
 488
 489 -- | Given all the context and resources, (re)build an individual package.
 490 rebuildTarget
 491   :: Verbosity
 492   -> DistDirLayout
 493   -> StoreDirLayout
 494   -> Maybe SemaphoreName
 495   -> BuildTimeSettings
 496   -> AsyncFetchMap
 497   -> Lock
 498   -> Lock
 499   -> ElaboratedSharedConfig
 500   -> ElaboratedInstallPlan
 501   -> ElaboratedReadyPackage
 502   -> BuildStatus
 503   -> IO BuildResult
 504 rebuildTarget
 505   verbosity
 506   distDirLayout@DistDirLayout{distBuildDirectory}
 507   storeDirLayout
 508   semaphoreName
 509   buildSettings
 510   downloadMap
 511   registerLock
 512   cacheLock
 513   sharedPackageConfig
 514   plan
 515   rpkg@(ReadyPackage pkg)
 516   pkgBuildStatus
 517     -- Technically, doing the --only-download filtering only in this function is
 518     -- not perfect. We could also prune the plan at an earlier stage, like it's
 519     -- done with --only-dependencies. But...
 520     --   * the benefit would be minimal (practically just avoiding to print the
 521     --     "requires build" parts of the plan)
 522     --   * we currently don't have easy access to the BuildStatus of packages
 523     --     in the pruning phase
 524     --   * we still have to check it here to avoid performing successive phases
 525     | buildSettingOnlyDownload buildSettings = do
 526         case pkgBuildStatus of
 527           BuildStatusDownload ->
 528             void $ waitAsyncPackageDownload verbosity downloadMap pkg
 529           _ -> return ()
 530         return $ BuildResult DocsNotTried TestsNotTried Nothing
 531     | otherwise =
 532         -- We rely on the 'BuildStatus' to decide which phase to start from:
 533         case pkgBuildStatus of
 534           BuildStatusDownload -> downloadPhase
 535           BuildStatusUnpack tarball -> unpackTarballPhase tarball
 536           BuildStatusRebuild srcdir status -> rebuildPhase status srcdir
 537           -- TODO: perhaps re-nest the types to make these impossible
 538           BuildStatusPreExisting{} -> unexpectedState
 539           BuildStatusInstalled{} -> unexpectedState
 540           BuildStatusUpToDate{} -> unexpectedState
 541     where
 542       unexpectedState = error "rebuildTarget: unexpected package status"
 543
 544       downloadPhase :: IO BuildResult
 545       downloadPhase = do
 546         downsrcloc <-
 547           annotateFailureNoLog DownloadFailed $
 548             waitAsyncPackageDownload verbosity downloadMap pkg
 549         case downsrcloc of
 550           DownloadedTarball tarball -> unpackTarballPhase tarball
 551       -- TODO: [nice to have] git/darcs repos etc
 552
 553       unpackTarballPhase :: FilePath -> IO BuildResult
 554       unpackTarballPhase tarball =
 555         withTarballLocalDirectory
 556           verbosity
 557           distDirLayout
 558           tarball
 559           (packageId pkg)
 560           (elabDistDirParams sharedPackageConfig pkg)
 561           (elabBuildStyle pkg)
 562           (elabPkgDescriptionOverride pkg)
 563           $ case elabBuildStyle pkg of
 564             BuildAndInstall -> buildAndInstall
 565             BuildInplaceOnly{} -> buildInplace buildStatus
 566               where
 567                 buildStatus = BuildStatusConfigure MonitorFirstRun
 568
 569       -- Note that this really is rebuild, not build. It can only happen for
 570       -- 'BuildInplaceOnly' style packages. 'BuildAndInstall' style packages
 571       -- would only start from download or unpack phases.
 572       --
 573       rebuildPhase :: BuildStatusRebuild -> FilePath -> IO BuildResult
 574       rebuildPhase buildStatus srcdir =
 575         assert
 576           (isInplaceBuildStyle $ elabBuildStyle pkg)
 577           buildInplace
 578           buildStatus
 579           srcdir
 580           builddir
 581         where
 582           builddir =
 583             distBuildDirectory
 584               (elabDistDirParams sharedPackageConfig pkg)
 585
 586       buildAndInstall :: FilePath -> FilePath -> IO BuildResult
 587       buildAndInstall srcdir builddir =
 588         buildAndInstallUnpackedPackage
 589           verbosity
 590           distDirLayout
 591           storeDirLayout
 592           semaphoreName
 593           buildSettings
 594           registerLock
 595           cacheLock
 596           sharedPackageConfig
 597           plan
 598           rpkg
 599           srcdir
 600           builddir'
 601         where
 602           builddir' = makeRelative srcdir builddir
 603       -- TODO: [nice to have] ^^ do this relative stuff better
 604
 605       buildInplace :: BuildStatusRebuild -> FilePath -> FilePath -> IO BuildResult
 606       buildInplace buildStatus srcdir builddir =
 607         -- TODO: [nice to have] use a relative build dir rather than absolute
 608         buildInplaceUnpackedPackage
 609           verbosity
 610           distDirLayout
 611           semaphoreName
 612           buildSettings
 613           registerLock
 614           cacheLock
 615           sharedPackageConfig
 616           plan
 617           rpkg
 618           buildStatus
 619           srcdir
 620           builddir
 621
 622 -- TODO: [nice to have] do we need to use a with-style for the temp
 623 -- files for downloading http packages, or are we going to cache them
 624 -- persistently?
 625
 626 -- | Given the current 'InstallPlan' and 'BuildStatusMap', select all the
 627 -- packages we have to download and fork off an async action to download them.
 628 -- We download them in dependency order so that the one's we'll need
 629 -- first are the ones we will start downloading first.
 630 --
 631 -- The body action is passed a map from those packages (identified by their
 632 -- location) to a completion var for that package. So the body action should
 633 -- lookup the location and use 'waitAsyncPackageDownload' to get the result.
 634 asyncDownloadPackages
 635   :: Verbosity
 636   -> ((RepoContext -> IO a) -> IO a)
 637   -> ElaboratedInstallPlan
 638   -> BuildStatusMap
 639   -> (AsyncFetchMap -> IO a)
 640   -> IO a
 641 asyncDownloadPackages verbosity withRepoCtx installPlan pkgsBuildStatus body
 642   | null pkgsToDownload = body Map.empty
 643   | otherwise = withRepoCtx $ \repoctx ->
 644       asyncFetchPackages
 645         verbosity
 646         repoctx
 647         pkgsToDownload
 648         body
 649   where
 650     pkgsToDownload :: [PackageLocation (Maybe FilePath)]
 651     pkgsToDownload =
 652       ordNub $
 653         [ elabPkgSourceLocation elab
 654         | InstallPlan.Configured elab <-
 655             InstallPlan.reverseTopologicalOrder installPlan
 656         , let uid = installedUnitId elab
 657               pkgBuildStatus = Map.findWithDefault (error "asyncDownloadPackages") uid pkgsBuildStatus
 658         , BuildStatusDownload <- [pkgBuildStatus]
 659         ]
 660
 661 -- | Check if a package needs downloading, and if so expect to find a download
 662 -- in progress in the given 'AsyncFetchMap' and wait on it to finish.
 663 waitAsyncPackageDownload
 664   :: Verbosity
 665   -> AsyncFetchMap
 666   -> ElaboratedConfiguredPackage
 667   -> IO DownloadedSourceLocation
 668 waitAsyncPackageDownload verbosity downloadMap elab = do
 669   pkgloc <-
 670     waitAsyncFetchPackage
 671       verbosity
 672       downloadMap
 673       (elabPkgSourceLocation elab)
 674   case downloadedSourceLocation pkgloc of
 675     Just loc -> return loc
 676     Nothing -> fail "waitAsyncPackageDownload: unexpected source location"
 677
 678 data DownloadedSourceLocation = DownloadedTarball FilePath
 679
 680 -- TODO: [nice to have] git/darcs repos etc
 681
 682 downloadedSourceLocation
 683   :: PackageLocation FilePath
 684   -> Maybe DownloadedSourceLocation
 685 downloadedSourceLocation pkgloc =
 686   case pkgloc of
 687     RemoteTarballPackage _ tarball -> Just (DownloadedTarball tarball)
 688     RepoTarballPackage _ _ tarball -> Just (DownloadedTarball tarball)
 689     _ -> Nothing
 690
 691 -- | Ensure that the package is unpacked in an appropriate directory, either
 692 -- a temporary one or a persistent one under the shared dist directory.
 693 withTarballLocalDirectory
 694   :: Verbosity
 695   -> DistDirLayout
 696   -> FilePath
 697   -> PackageId
 698   -> DistDirParams
 699   -> BuildStyle
 700   -> Maybe CabalFileText
 701   -> ( FilePath -- Source directory
 702        -> FilePath -- Build directory
 703        -> IO a
 704      )
 705   -> IO a
 706 withTarballLocalDirectory
 707   verbosity
 708   distDirLayout@DistDirLayout{..}
 709   tarball
 710   pkgid
 711   dparams
 712   buildstyle
 713   pkgTextOverride
 714   buildPkg =
 715     case buildstyle of
 716       -- In this case we make a temp dir (e.g. tmp/src2345/), unpack
 717       -- the tarball to it (e.g. tmp/src2345/foo-1.0/), and for
 718       -- compatibility we put the dist dir within it
 719       -- (i.e. tmp/src2345/foo-1.0/dist/).
 720       --
 721       -- Unfortunately, a few custom Setup.hs scripts do not respect
 722       -- the --builddir flag and always look for it at ./dist/ so
 723       -- this way we avoid breaking those packages
 724       BuildAndInstall ->
 725         let tmpdir = distTempDirectory
 726          in withTempDirectory verbosity tmpdir "src" $ \unpackdir -> do
 727               unpackPackageTarball
 728                 verbosity
 729                 tarball
 730                 unpackdir
 731                 pkgid
 732                 pkgTextOverride
 733               let srcdir = unpackdir </> prettyShow pkgid
 734                   builddir = srcdir </> "dist"
 735               buildPkg srcdir builddir
 736
 737       -- In this case we make sure the tarball has been unpacked to the
 738       -- appropriate location under the shared dist dir, and then build it
 739       -- inplace there
 740       BuildInplaceOnly{} -> do
 741         let srcrootdir = distUnpackedSrcRootDirectory
 742             srcdir = distUnpackedSrcDirectory pkgid
 743             builddir = distBuildDirectory dparams
 744         -- TODO: [nice to have] use a proper file monitor rather
 745         -- than this dir exists test
 746         exists <- doesDirectoryExist srcdir
 747         unless exists $ do
 748           createDirectoryIfMissingVerbose verbosity True srcrootdir
 749           unpackPackageTarball
 750             verbosity
 751             tarball
 752             srcrootdir
 753             pkgid
 754             pkgTextOverride
 755           moveTarballShippedDistDirectory
 756             verbosity
 757             distDirLayout
 758             srcrootdir
 759             pkgid
 760             dparams
 761         buildPkg srcdir builddir
 762
 763 unpackPackageTarball
 764   :: Verbosity
 765   -> FilePath
 766   -> FilePath
 767   -> PackageId
 768   -> Maybe CabalFileText
 769   -> IO ()
 770 unpackPackageTarball verbosity tarball parentdir pkgid pkgTextOverride =
 771   -- TODO: [nice to have] switch to tar package and catch tar exceptions
 772   annotateFailureNoLog UnpackFailed $ do
 773     -- Unpack the tarball
 774     --
 775     info verbosity $ "Extracting " ++ tarball ++ " to " ++ parentdir ++ "..."
 776     Tar.extractTarGzFile parentdir pkgsubdir tarball
 777
 778     -- Sanity check
 779     --
 780     exists <- doesFileExist cabalFile
 781     unless exists $
 782       dieWithException verbosity $
 783         CabalFileNotFound cabalFile
 784
 785     -- Overwrite the .cabal with the one from the index, when appropriate
 786     --
 787     case pkgTextOverride of
 788       Nothing -> return ()
 789       Just pkgtxt -> do
 790         info verbosity $
 791           "Updating "
 792             ++ prettyShow pkgname <.> "cabal"
 793             ++ " with the latest revision from the index."
 794         writeFileAtomic cabalFile pkgtxt
 795   where
 796     cabalFile :: FilePath
 797     cabalFile =
 798       parentdir
 799         </> pkgsubdir
 800         </> prettyShow pkgname
 801         <.> "cabal"
 802     pkgsubdir = prettyShow pkgid
 803     pkgname = packageName pkgid
 804
 805 -- | This is a bit of a hacky workaround. A number of packages ship
 806 -- pre-processed .hs files in a dist directory inside the tarball. We don't
 807 -- use the standard 'dist' location so unless we move this dist dir to the
 808 -- right place then we'll miss the shipped pre-processed files. This hacky
 809 -- approach to shipped pre-processed files ought to be replaced by a proper
 810 -- system, though we'll still need to keep this hack for older packages.
 811 moveTarballShippedDistDirectory
 812   :: Verbosity
 813   -> DistDirLayout
 814   -> FilePath
 815   -> PackageId
 816   -> DistDirParams
 817   -> IO ()
 818 moveTarballShippedDistDirectory
 819   verbosity
 820   DistDirLayout{distBuildDirectory}
 821   parentdir
 822   pkgid
 823   dparams = do
 824     distDirExists <- doesDirectoryExist tarballDistDir
 825     when distDirExists $ do
 826       debug verbosity $
 827         "Moving '"
 828           ++ tarballDistDir
 829           ++ "' to '"
 830           ++ targetDistDir
 831           ++ "'"
 832       -- TODO: [nice to have] or perhaps better to copy, and use a file monitor
 833       renameDirectory tarballDistDir targetDistDir
 834     where
 835       tarballDistDir = parentdir </> prettyShow pkgid </> "dist"
 836       targetDistDir = distBuildDirectory dparams